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.
This commit is contained in:
Mathieu Othacehe
parent
4cce7610eb
commit
6e8cdf1d26
@ -111,3 +111,6 @@
|
||||
(inherit
|
||||
(os->image hurd-barebones-os #:type hurd-qcow2-image-type))
|
||||
(name 'hurd-barebones.qcow2)))
|
||||
|
||||
;; Return the default image.
|
||||
hurd-barebones-qcow2-image
|
||||
|
||||
@ -59,3 +59,6 @@
|
||||
(inherit
|
||||
(os->image novena-barebones-os #:type novena-image-type))
|
||||
(name 'novena-barebones-raw-image)))
|
||||
|
||||
;; Return the default image.
|
||||
novena-barebones-raw-image
|
||||
|
||||
@ -64,3 +64,6 @@
|
||||
(inherit
|
||||
(os->image pine64-barebones-os #:type pine64-image-type))
|
||||
(name 'pine64-barebones-raw-image)))
|
||||
|
||||
;; Return the default image.
|
||||
pine64-barebones-raw-image
|
||||
|
||||
@ -66,3 +66,6 @@
|
||||
(inherit
|
||||
(os->image pinebook-pro-barebones-os #:type pinebook-pro-image-type))
|
||||
(name 'pinebook-pro-barebones-raw-image)))
|
||||
|
||||
;; Return the default image.
|
||||
pinebook-pro-barebones-raw-image
|
||||
|
||||
@ -680,13 +680,15 @@ checking this by themselves in their 'check' procedure."
|
||||
;;; Action.
|
||||
;;;
|
||||
|
||||
(define* (system-derivation-for-action os action
|
||||
#:key image-size image-type
|
||||
full-boot? container-shared-network?
|
||||
mappings label
|
||||
volatile-root?)
|
||||
"Return as a monadic value the derivation for OS according to ACTION."
|
||||
(mlet %store-monad ((target (current-target-system)))
|
||||
(define* (system-derivation-for-action image action
|
||||
#:key
|
||||
full-boot?
|
||||
container-shared-network?
|
||||
mappings)
|
||||
"Return as a monadic value the derivation for IMAGE according to ACTION."
|
||||
(mlet %store-monad ((target (current-target-system))
|
||||
(os -> (image-operating-system image))
|
||||
(image-size -> (image-size image)))
|
||||
(case action
|
||||
((build init reconfigure)
|
||||
(operating-system-derivation os))
|
||||
@ -704,25 +706,11 @@ checking this by themselves in their 'check' procedure."
|
||||
(* 70 (expt 2 20)))
|
||||
#:mappings mappings))
|
||||
((image disk-image vm-image)
|
||||
(let* ((image-type (if (eq? action 'vm-image)
|
||||
qcow2-image-type
|
||||
image-type))
|
||||
(base-image (os->image os #:type image-type))
|
||||
(base-target (image-target base-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?))))))
|
||||
(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)))
|
||||
((docker-image)
|
||||
(system-docker-image os
|
||||
#:shared-network? container-shared-network?)))))
|
||||
@ -768,7 +756,7 @@ and TARGET arguments."
|
||||
(set! %load-compiled-path (lowered-gexp-load-compiled-path lowered))
|
||||
(return (primitive-eval (lowered-gexp-sexp lowered))))))
|
||||
|
||||
(define* (perform-action action os
|
||||
(define* (perform-action action image
|
||||
#:key
|
||||
(validate-reconfigure ensure-forward-reconfigure)
|
||||
save-provenance?
|
||||
@ -776,16 +764,13 @@ and TARGET arguments."
|
||||
install-bootloader?
|
||||
dry-run? derivations-only?
|
||||
use-substitutes? bootloader-target target
|
||||
image-size image-type
|
||||
volatile-root?
|
||||
full-boot? label container-shared-network?
|
||||
full-boot?
|
||||
container-shared-network?
|
||||
(mappings '())
|
||||
(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
|
||||
target root directory; IMAGE-SIZE is the size of the image to be built, for
|
||||
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.
|
||||
target root directory.
|
||||
|
||||
FULL-BOOT? is used for the 'vm' action; it determines whether to
|
||||
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))))
|
||||
|
||||
(define os
|
||||
(image-operating-system image))
|
||||
|
||||
(define bootloader
|
||||
(operating-system-bootloader os))
|
||||
|
||||
@ -829,11 +817,7 @@ static checks."
|
||||
(check-initrd-modules os)))
|
||||
|
||||
(mlet* %store-monad
|
||||
((sys (system-derivation-for-action os action
|
||||
#:label label
|
||||
#:image-type image-type
|
||||
#:image-size image-size
|
||||
#:volatile-root? volatile-root?
|
||||
((sys (system-derivation-for-action image action
|
||||
#:full-boot? full-boot?
|
||||
#:container-shared-network? container-shared-network?
|
||||
#: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
|
||||
declaration as an argument (a file name.) OPTS is the raw alist of options
|
||||
resulting from command-line parsing."
|
||||
(define (ensure-operating-system file-or-exp obj)
|
||||
(unless (operating-system? obj)
|
||||
(leave (G_ "'~a' does not return an operating system~%")
|
||||
(define (ensure-operating-system-or-image file-or-exp obj)
|
||||
(unless (or (operating-system? obj) (image? obj))
|
||||
(leave (G_ "'~a' does not return an operating system or an image~%")
|
||||
file-or-exp))
|
||||
obj)
|
||||
|
||||
@ -1185,27 +1169,47 @@ resulting from command-line parsing."
|
||||
(expr (assoc-ref opts 'expression))
|
||||
(system (assoc-ref opts 'system))
|
||||
(target (assoc-ref opts 'target))
|
||||
(transform (if save-provenance?
|
||||
(cut operating-system-with-provenance <> file)
|
||||
identity))
|
||||
(os (transform
|
||||
(ensure-operating-system
|
||||
(or file expr)
|
||||
(cond
|
||||
((and expr file)
|
||||
(leave
|
||||
(G_ "both file and expression cannot be specified~%")))
|
||||
(expr
|
||||
(read/eval expr))
|
||||
(file
|
||||
(load* file %user-module
|
||||
#:on-error (assoc-ref opts 'on-error)))
|
||||
(else
|
||||
(leave (G_ "no configuration specified~%")))))))
|
||||
|
||||
(transform (lambda (obj)
|
||||
(if (and save-provenance? (operating-system? obj))
|
||||
(operating-system-with-provenance obj file)
|
||||
obj)))
|
||||
(obj (transform
|
||||
(ensure-operating-system-or-image
|
||||
(or file expr)
|
||||
(cond
|
||||
((and expr file)
|
||||
(leave
|
||||
(G_ "both file and expression cannot be specified~%")))
|
||||
(expr
|
||||
(read/eval expr))
|
||||
(file
|
||||
(load* file %user-module
|
||||
#:on-error (assoc-ref opts 'on-error)))
|
||||
(else
|
||||
(leave (G_ "no configuration specified~%")))))))
|
||||
(dry? (assoc-ref opts 'dry-run?))
|
||||
(bootloader? (assoc-ref opts 'install-bootloader?))
|
||||
(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
|
||||
((first second) second)
|
||||
(_ #f)))
|
||||
@ -1241,7 +1245,7 @@ resulting from command-line parsing."
|
||||
(warn-about-old-distro #:suggested-command
|
||||
"guix system reconfigure"))
|
||||
|
||||
(perform-action action os
|
||||
(perform-action action image
|
||||
#:dry-run? dry?
|
||||
#:derivations-only? (assoc-ref opts
|
||||
'derivations-only?)
|
||||
@ -1250,11 +1254,6 @@ resulting from command-line parsing."
|
||||
(assoc-ref opts 'skip-safety-checks?)
|
||||
#: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?)
|
||||
#:container-shared-network?
|
||||
(assoc-ref opts 'container-shared-network?)
|
||||
@ -1264,7 +1263,6 @@ resulting from command-line parsing."
|
||||
(_ #f))
|
||||
opts)
|
||||
#:install-bootloader? bootloader?
|
||||
#:label label
|
||||
#:target target-file
|
||||
#:bootloader-target bootloader-target
|
||||
#:gc-root (assoc-ref opts 'gc-root)))))
|
||||
|
||||
@ -337,12 +337,11 @@ for example in gnu/system/examples/*.tmpl; do
|
||||
guix system -n disk-image $target "$example"
|
||||
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 image gnu/system/images/pinebook-pro.scm
|
||||
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 disk-image gnu/system/examples/bare-bones.tmpl
|
||||
guix system -n disk-image -t iso9660 gnu/system/examples/bare-bones.tmpl
|
||||
guix system -n image -t iso9660 gnu/system/examples/bare-bones.tmpl
|
||||
guix system -n docker-image gnu/system/examples/docker-image.tmpl
|
||||
|
||||
# Verify that at least the raw image type is available.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user