Toggle diff (285 lines)
diff --git a/gnu/system/images/hurd.scm b/gnu/system/images/hurd.scm
index 4417952c5d..eac5b7f7e6 100644
--- a/gnu/system/images/hurd.scm
+++ b/gnu/system/images/hurd.scm
@@ -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
diff --git a/gnu/system/images/novena.scm b/gnu/system/images/novena.scm
index dfaf2c60ee..1cd724ff88 100644
--- a/gnu/system/images/novena.scm
+++ b/gnu/system/images/novena.scm
@@ -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
diff --git a/gnu/system/images/pine64.scm b/gnu/system/images/pine64.scm
index 63b31399a5..613acd5cfd 100644
--- a/gnu/system/images/pine64.scm
+++ b/gnu/system/images/pine64.scm
@@ -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
diff --git a/gnu/system/images/pinebook-pro.scm b/gnu/system/images/pinebook-pro.scm
index 22997fd742..b56a7ea409 100644
--- a/gnu/system/images/pinebook-pro.scm
+++ b/gnu/system/images/pinebook-pro.scm
@@ -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
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 9b75ac2fd0..f4743c64ea 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -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))
@@ -1168,9 +1152,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)
@@ -1184,27 +1168,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)))
@@ -1240,7 +1244,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?)
@@ -1249,11 +1253,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?)
@@ -1263,7 +1262,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)))))
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index ddbdd0edcd..ce4030bc59 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -333,12 +333,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.
--
2.29.2
