me
/
guix
Archived
1
0
Fork 0
Code

scripts: system: Accept <image> records as input. 

* guix/scripts/system.scm (system-derivation-for-action): Replace "os"
argument by "image". Remove "image-size", "image-type", "label" and
"volatile-root?"  arguments.
(perform-action): Ditto.
(process-action): Construct the <image> record and pass it to "perform-action"
procedure.
* tests/guix-system.sh: Adapt accordingly.
* gnu/system/images/hurd.scm: Return the default image.
* gnu/system/images/novena.scm: Ditto.
* gnu/system/images/pine64.scm: Ditto.
* gnu/system/images/pinebook-pro.scm Ditto.
master
Mathieu Othacehe 2021-01-20 10:56:08 +01:00
parent 4cce7610eb
commit 6e8cdf1d26
No known key found for this signature in database
GPG Key ID: 8354763531769CA6
6 changed files with 80 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
gnu/system/images/hurd.scm
View File

@ -111,3 +111,6 @@
(inherit (inherit
(os->image hurd-barebones-os #:type hurd-qcow2-image-type)) (os->image hurd-barebones-os #:type hurd-qcow2-image-type))
(name 'hurd-barebones.qcow2))) (name 'hurd-barebones.qcow2)))
;; Return the default image.
hurd-barebones-qcow2-image

3
gnu/system/images/novena.scm
View File

@ -59,3 +59,6 @@
(inherit (inherit
(os->image novena-barebones-os #:type novena-image-type)) (os->image novena-barebones-os #:type novena-image-type))
(name 'novena-barebones-raw-image))) (name 'novena-barebones-raw-image)))
;; Return the default image.
novena-barebones-raw-image

3
gnu/system/images/pine64.scm
View File

@ -64,3 +64,6 @@
(inherit (inherit
(os->image pine64-barebones-os #:type pine64-image-type)) (os->image pine64-barebones-os #:type pine64-image-type))
(name 'pine64-barebones-raw-image))) (name 'pine64-barebones-raw-image)))
;; Return the default image.
pine64-barebones-raw-image

3
gnu/system/images/pinebook-pro.scm
View File

@ -66,3 +66,6 @@
(inherit (inherit
(os->image pinebook-pro-barebones-os #:type pinebook-pro-image-type)) (os->image pinebook-pro-barebones-os #:type pinebook-pro-image-type))
(name 'pinebook-pro-barebones-raw-image))) (name 'pinebook-pro-barebones-raw-image)))
;; Return the default image.
pinebook-pro-barebones-raw-image

132
guix/scripts/system.scm
View File

@ -680,13 +680,15 @@ checking this by themselves in their 'check' procedure."
;;; Action. ;;; Action.
;;; ;;;
(define* (system-derivation-for-action os action (define* (system-derivation-for-action image action
#:key image-size image-type #:key
full-boot? container-shared-network? full-boot?
mappings label container-shared-network?
volatile-root?) mappings)
"Return as a monadic value the derivation for OS according to ACTION." "Return as a monadic value the derivation for IMAGE according to ACTION."
(mlet %store-monad ((target (current-target-system))) (mlet %store-monad ((target (current-target-system))
(os -> (image-operating-system image))
(image-size -> (image-size image)))
(case action (case action
((build init reconfigure) ((build init reconfigure)
(operating-system-derivation os)) (operating-system-derivation os))
@ -704,25 +706,11 @@ checking this by themselves in their 'check' procedure."
(* 70 (expt 2 20))) (* 70 (expt 2 20)))
#:mappings mappings)) #:mappings mappings))
((image disk-image vm-image) ((image disk-image vm-image)
(let* ((image-type (if (eq? action 'vm-image) (when (eq? action 'disk-image)
qcow2-image-type (warning (G_ "'disk-image' is deprecated: use 'image' instead~%")))
image-type)) (when (eq? action 'vm-image)
(base-image (os->image os #:type image-type)) (warning (G_ "'vm-image' is deprecated: use 'image' instead~%")))
(base-target (image-target base-image))) (lower-object (system-image image)))
(when (eq? action 'disk-image)
(warning (G_ "'disk-image' is deprecated: use 'image' instead~%")))
(when (eq? action 'vm-image)
(warning (G_ "'vm-image' is deprecated: use 'image' instead~%")))
(lower-object
(system-image
(image
(inherit (if label
(image-with-label base-image label)
base-image))
(target (or base-target target))
(size image-size)
(operating-system os)
(volatile-root? volatile-root?))))))
((docker-image) ((docker-image)
(system-docker-image os (system-docker-image os
#:shared-network? container-shared-network?))))) #:shared-network? container-shared-network?)))))
@ -768,7 +756,7 @@ and TARGET arguments."
(set! %load-compiled-path (lowered-gexp-load-compiled-path lowered)) (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered))
(return (primitive-eval (lowered-gexp-sexp lowered)))))) (return (primitive-eval (lowered-gexp-sexp lowered))))))
(define* (perform-action action os (define* (perform-action action image
#:key #:key
(validate-reconfigure ensure-forward-reconfigure) (validate-reconfigure ensure-forward-reconfigure)
save-provenance? save-provenance?
@ -776,16 +764,13 @@ and TARGET arguments."
install-bootloader? install-bootloader?
dry-run? derivations-only? dry-run? derivations-only?
use-substitutes? bootloader-target target use-substitutes? bootloader-target target
image-size image-type full-boot?
volatile-root? container-shared-network?
full-boot? label container-shared-network?
(mappings '()) (mappings '())
(gc-root #f)) (gc-root #f))
"Perform ACTION for OS. INSTALL-BOOTLOADER? specifies whether to install "Perform ACTION for IMAGE. INSTALL-BOOTLOADER? specifies whether to install
bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the
target root directory; IMAGE-SIZE is the size of the image to be built, for target root directory.
the 'image' action. IMAGE-TYPE is the type of image to be built. When
VOLATILE-ROOT? is #t, the root file system is mounted volatile.
FULL-BOOT? is used for the 'vm' action; it determines whether to FULL-BOOT? is used for the 'vm' action; it determines whether to
boot directly to the kernel or to the bootloader. CONTAINER-SHARED-NETWORK? boot directly to the kernel or to the bootloader. CONTAINER-SHARED-NETWORK?
@ -807,6 +792,9 @@ static checks."
'() '()
(map boot-parameters->menu-entry (profile-boot-parameters)))) (map boot-parameters->menu-entry (profile-boot-parameters))))
(define os
(image-operating-system image))
(define bootloader (define bootloader
(operating-system-bootloader os)) (operating-system-bootloader os))
@ -829,11 +817,7 @@ static checks."
(check-initrd-modules os))) (check-initrd-modules os)))
(mlet* %store-monad (mlet* %store-monad
((sys (system-derivation-for-action os action ((sys (system-derivation-for-action image action
#:label label
#:image-type image-type
#:image-size image-size
#:volatile-root? volatile-root?
#:full-boot? full-boot? #:full-boot? full-boot?
#:container-shared-network? container-shared-network? #:container-shared-network? container-shared-network?
#:mappings mappings)) #:mappings mappings))
@ -1169,9 +1153,9 @@ Some ACTIONS support additional ARGS.\n"))
ACTION must be one of the sub-commands that takes an operating system ACTION must be one of the sub-commands that takes an operating system
declaration as an argument (a file name.) OPTS is the raw alist of options declaration as an argument (a file name.) OPTS is the raw alist of options
resulting from command-line parsing." resulting from command-line parsing."
(define (ensure-operating-system file-or-exp obj) (define (ensure-operating-system-or-image file-or-exp obj)
(unless (operating-system? obj) (unless (or (operating-system? obj) (image? obj))
(leave (G_ "'~a' does not return an operating system~%") (leave (G_ "'~a' does not return an operating system or an image~%")
file-or-exp)) file-or-exp))
obj) obj)
@ -1185,27 +1169,47 @@ resulting from command-line parsing."
(expr (assoc-ref opts 'expression)) (expr (assoc-ref opts 'expression))
(system (assoc-ref opts 'system)) (system (assoc-ref opts 'system))
(target (assoc-ref opts 'target)) (target (assoc-ref opts 'target))
(transform (if save-provenance? (transform (lambda (obj)
(cut operating-system-with-provenance <> file) (if (and save-provenance? (operating-system? obj))
identity)) (operating-system-with-provenance obj file)
(os (transform obj)))
(ensure-operating-system (obj (transform
(or file expr) (ensure-operating-system-or-image
(cond (or file expr)
((and expr file) (cond
(leave ((and expr file)
(G_ "both file and expression cannot be specified~%"))) (leave
(expr (G_ "both file and expression cannot be specified~%")))
(read/eval expr)) (expr
(file (read/eval expr))
(load* file %user-module (file
#:on-error (assoc-ref opts 'on-error))) (load* file %user-module
(else #:on-error (assoc-ref opts 'on-error)))
(leave (G_ "no configuration specified~%"))))))) (else
(leave (G_ "no configuration specified~%")))))))
(dry? (assoc-ref opts 'dry-run?)) (dry? (assoc-ref opts 'dry-run?))
(bootloader? (assoc-ref opts 'install-bootloader?)) (bootloader? (assoc-ref opts 'install-bootloader?))
(label (assoc-ref opts 'label)) (label (assoc-ref opts 'label))
(image-type (lookup-image-type-by-name
(assoc-ref opts 'image-type)))
(image (let* ((image-type (if (eq? action 'vm-image)
qcow2-image-type
image-type))
(image-size (assoc-ref opts 'image-size))
(volatile? (assoc-ref opts 'volatile-root?))
(base-image (if (operating-system? obj)
(os->image obj
#:type image-type)
obj))
(base-target (image-target base-image)))
(image
(inherit (if label
(image-with-label base-image label)
base-image))
(target (or base-target target))
(size image-size)
(volatile-root? volatile?))))
(os (image-operating-system image))
(target-file (match args (target-file (match args
((first second) second) ((first second) second)
(_ #f))) (_ #f)))
@ -1241,7 +1245,7 @@ resulting from command-line parsing."
(warn-about-old-distro #:suggested-command (warn-about-old-distro #:suggested-command
"guix system reconfigure")) "guix system reconfigure"))
(perform-action action os (perform-action action image
#:dry-run? dry? #:dry-run? dry?
#:derivations-only? (assoc-ref opts #:derivations-only? (assoc-ref opts
'derivations-only?) 'derivations-only?)
@ -1250,11 +1254,6 @@ resulting from command-line parsing."
(assoc-ref opts 'skip-safety-checks?) (assoc-ref opts 'skip-safety-checks?)
#:validate-reconfigure #:validate-reconfigure
(assoc-ref opts 'validate-reconfigure) (assoc-ref opts 'validate-reconfigure)
#:image-type (lookup-image-type-by-name
(assoc-ref opts 'image-type))
#:image-size (assoc-ref opts 'image-size)
#:volatile-root?
(assoc-ref opts 'volatile-root?)
#:full-boot? (assoc-ref opts 'full-boot?) #:full-boot? (assoc-ref opts 'full-boot?)
#:container-shared-network? #:container-shared-network?
(assoc-ref opts 'container-shared-network?) (assoc-ref opts 'container-shared-network?)
@ -1264,7 +1263,6 @@ resulting from command-line parsing."
(_ #f)) (_ #f))
opts) opts)
#:install-bootloader? bootloader? #:install-bootloader? bootloader?
#:label label
#:target target-file #:target target-file
#:bootloader-target bootloader-target #:bootloader-target bootloader-target
#:gc-root (assoc-ref opts 'gc-root))))) #:gc-root (assoc-ref opts 'gc-root)))))

7
tests/guix-system.sh
View File

@ -337,12 +337,11 @@ for example in gnu/system/examples/*.tmpl; do
guix system -n disk-image $target "$example" guix system -n disk-image $target "$example"
done done
# Verify that the disk image types can be built. # Verify that the images can be built.
guix system -n vm gnu/system/examples/vm-image.tmpl guix system -n vm gnu/system/examples/vm-image.tmpl
guix system -n image gnu/system/images/pinebook-pro.scm
guix system -n image -t qcow2 gnu/system/examples/vm-image.tmpl guix system -n image -t qcow2 gnu/system/examples/vm-image.tmpl
# This invocation was taken care of in the loop above: guix system -n image -t iso9660 gnu/system/examples/bare-bones.tmpl
# guix system -n disk-image gnu/system/examples/bare-bones.tmpl
guix system -n disk-image -t iso9660 gnu/system/examples/bare-bones.tmpl
guix system -n docker-image gnu/system/examples/docker-image.tmpl guix system -n docker-image gnu/system/examples/docker-image.tmpl
# Verify that at least the raw image type is available. # Verify that at least the raw image type is available.