infra/nonguix
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

* nongnu/system/install.scm

Browse Source 
Refactored %channels-file creation to make build-image cleaner.

* nongnu/system/build-image.scm
Refactored make-tmp-channel to use mkstemp! and improved %channels-file.
Improved readability of build-image function.
This commit is contained in:
AAaronson 2021-05-04 15:09:56 +00:00
parent 12d6628ba3
commit f9227ab655
2 changed files with 41 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
nongnu/system/build-image.scm
View File

@ -1,7 +1,9 @@
#!/usr/bin/env -S guile \\ #!/usr/bin/env -S guile \\
-e build-image -s -e build-image -s
!# ;; Guile uses a meta switch '\' which env requires escaping to passthru. !#
;; See: https://pingus.seul.org/~grumbel/tmp/guile-1.6.0/guile_10.html#SEC27 ; Guile uses a meta switch '\' which env requires escaping to passthru.
; See: https://pingus.seul.org/~grumbel/tmp/guile-1.6.0/guile_10.html#SEC27
;;; Copyright © 2021 Kyle Cassidy <123_kbc@pm.me> ;;; Copyright © 2021 Kyle Cassidy <123_kbc@pm.me>
;;; ;;;
@ -21,6 +23,8 @@
;; Generate a bootable image with: ;; Generate a bootable image with:
;; $ chmod +x build-image.scm && ./build-image.scm ;; $ chmod +x build-image.scm && ./build-image.scm
(use-modules (ice-9 pretty-print))
; Searches through Scheme file for 'define and 'define* expressions ; Searches through Scheme file for 'define and 'define* expressions
; such as (define <name> ... ) or (define (<name> ...) ...) ; such as (define <name> ... ) or (define (<name> ...) ...)
(define (search-for-define scheme-file define-name) (define (search-for-define scheme-file define-name)
@ -37,47 +41,41 @@
exp) exp)
(#t (next (read port)))))))) (#t (next (read port))))))))
; Writes channel-list to a tmpfile ; Writes channel-list to a temp file
; 'use-module is assumed to be needed, does not do anything if not used. TODO: remove assumption. (define (make-temp-channel channel-list)
; TODO: get mkstemp! to work (result of using it was a blank file) (let ((port (mkstemp! (string-copy "/tmp/guix-channel-XXXXXX") "a")))
(define (make-tmp-channel channel-list) (map (lambda (_) (pretty-print _ port))
(let loop ((tmpath (string-append "/tmp/guix-channel" channel-list)
(number->string (random 1000000))))) (force-output port)
(cond ((file-exists? tmpath) (port-filename port)))
(loop (string-append "/tmp/guix-channel"
(number->string (random 1000000)))))
(#t (call-with-output-file tmpath
(lambda (port)
(write '(use-modules (guix ci)) port)
(write channel-list port)))
tmpath))))
; Main function called when run at command line. ; Main function called when run at command line.
; Parses "nongnu/system/install.scm" for channel definition ; Parses "nongnu/system/install.scm" for channel definition
; (current-filename) used to locate in same dir as this file ; (current-filename) used to locate in same dir as this file
; Creates tmpfile containing channel definition ; Creates a temp file containing channel definition
; Performs a guix pull using tmpfile as channel file ; Performs a guix pull using temp file as channel file
; Deletes tmpfile ; Deletes temp file
; Builds image (currently iso only) ; Builds image (currently iso only)
; supports "--uncompressed" command line argument ; supports "--uncompressed" command line argument
; If "--roll-back" is used as an argument, reverts guix pull ; If "--roll-back" is used as an argument, reverts guix pull
; Returns #t if exit-code is 0, else returns #f ; Returns #t if exit-code is 0, else returns #f
(define (build-image args) (define (build-image args)
(let* ((image-type 'iso) ; todo: parse args for supported image types (let* ((image-type 'iso) ; TODO: parse args for supported image types
(image-label "nonguix-install") (image-label "nonguix-install")
(channel-define-name '%channels)
(config-dir (dirname (current-filename))) (config-dir (dirname (current-filename)))
(config-file-name "install.scm") (config-file-name "install.scm")
(install-config (string-append config-dir (install-config (string-append config-dir
file-name-separator-string file-name-separator-string
config-file-name)) config-file-name))
(name-to-search 'nonguix-channels) ; lookup in install-config
(channels (caddr (search-for-define (channels (caddr (search-for-define
install-config install-config
channel-define-name))) name-to-search)))
(tmp-channel-file-path (make-tmp-channel (cadr channels))) (temp-channel-file-path (make-temp-channel (cadr channels)))
(exit-code #f)) (exit-code #f))
(system* "guix" "pull" (string-append "--channels=" tmp-channel-file-path)) (system* "guix" "pull" (string-append "--channels=" temp-channel-file-path))
(delete-file tmp-channel-file-path) (delete-file temp-channel-file-path)
(cond ((equal? image-type 'iso) (cond ((equal? image-type 'iso)
(let ((image-link (string-append config-dir (let ((image-link (string-append config-dir
file-name-separator-string file-name-separator-string
@ -93,6 +91,8 @@
(string-append "--label=" image-label) (string-append "--label=" image-label)
(string-append "--root=" image-link) (string-append "--root=" image-link)
install-config))))) install-config)))))
(and (member "--roll-back" args) (and (member "--roll-back" args)
(system* "guix" "pull" "--roll-back")) (system* "guix" "pull" "--roll-back"))
(equal? exit-code 0))) (equal? exit-code 0)))

34
nongnu/system/install.scm
View File

@ -27,30 +27,28 @@
#:use-module (ice-9 pretty-print) #:use-module (ice-9 pretty-print)
#:export (installation-os-nonfree)) #:export (installation-os-nonfree))
; List of guix channels for the "/etc/skel/.config/guix/channels.scm" file. ; Guix channel for the "/etc/skel/.config/guix/channels.scm" file.
; %default-guix-channel is configured to pull package definitions from ; %default-guix-channel is configured to pull package definitions from
; the Guix substitute server, to save compiling during a guix pull. ; the Guix substitute server, to save compiling during a guix pull.
(define %channels (define nonguix-channels
'(list (channel '((use-modules (guix ci)) ; required for channel-with-substitutes-available
(name 'nonguix) (list (channel
(url "https://gitlab.com/nonguix/nonguix") (name 'nonguix)
(introduction (url "https://gitlab.com/nonguix/nonguix")
(make-channel-introduction (introduction
"897c1a470da759236cc11798f4e0a5f7d4d59fbc" (make-channel-introduction
(openpgp-fingerprint "897c1a470da759236cc11798f4e0a5f7d4d59fbc"
"2A39 3FFF 68F4 EF7A 3D29 12AF 6F51 20A0 22FB B2D5")))) (openpgp-fingerprint
(channel-with-substitutes-available "2A39 3FFF 68F4 EF7A 3D29 12AF 6F51 20A0 22FB B2D5"))))
%default-guix-channel (channel-with-substitutes-available
"https://ci.guix.gnu.org"))) %default-guix-channel
"https://ci.guix.gnu.org"))))
; Create the plain-file definition of "channels.scm" to add to the install. ; Create the plain-file definition of "channels.scm" to add to the install.
(define %channels-file (define %channels-file
(let ((port (open-output-string))) (let ((port (open-output-string)))
(pretty-print '(use-modules (map (lambda (_) (pretty-print _ port))
(guix ci)) ; for channel-with-substitutes-availabe nonguix-channels)
port)
(pretty-print %channels
port)
(plain-file "channels.scm" (plain-file "channels.scm"
(get-output-string port)))) (get-output-string port))))