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.

1 files changed, 65 insertions, 67 deletions

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index ead20a071e..e3cf99acc6 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))
@@ -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)))))