all messages for Guix-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
* [bug#46017] [PATCH 0/2] scripts: system: Accept <image> records as input.
@ 2021-01-21 11:37 Mathieu Othacehe
  2021-01-21 11:42 ` [bug#46017] [PATCH 1/2] image: Export image? procedure Mathieu Othacehe
  2021-01-21 11:52 ` [bug#46017] [PATCH v2] " Mathieu Othacehe
  0 siblings, 2 replies; 4+ messages in thread
From: Mathieu Othacehe @ 2021-01-21 11:37 UTC (permalink / raw)
  To: 46017; +Cc: Mathieu Othacehe

Hello,

Here is a patch adding support for <image> records as input of "guix system
image" command. This has been discussed here:
https://issues.guix.gnu.org/45933.

It would be nice to also provide some documentation about that feature. I have
delayed it because I felt the API was not stable enough. Maybe now is the
time. Joshua is proposing a Cookbook patch that could be a first step. Then,
I'll try to provide a proper description of the <image> record and the
associated commands in the documentation.

Thanks,

Mathieu

Mathieu Othacehe (2):
  image: Export image? procedure.
  scripts: system: Accept <image> records as input.

 gnu/image.scm                      |   1 +
 gnu/system/images/hurd.scm         |   3 +
 gnu/system/images/novena.scm       |   3 +
 gnu/system/images/pine64.scm       |   3 +
 gnu/system/images/pinebook-pro.scm |   3 +
 guix/scripts/system.scm            | 128 ++++++++++++++---------------
 tests/guix-system.sh               |   7 +-
 7 files changed, 80 insertions(+), 68 deletions(-)

-- 
2.29.2





^ permalink raw reply	[flat|nested] 4+ messages in thread

* [bug#46017] [PATCH 1/2] image: Export image? procedure.
  2021-01-21 11:37 [bug#46017] [PATCH 0/2] scripts: system: Accept <image> records as input Mathieu Othacehe
@ 2021-01-21 11:42 ` Mathieu Othacehe
  2021-01-21 11:43   ` [bug#46017] [PATCH 2/2] scripts: system: Accept <image> records as input Mathieu Othacehe
  2021-01-21 11:52 ` [bug#46017] [PATCH v2] " Mathieu Othacehe
  1 sibling, 1 reply; 4+ messages in thread
From: Mathieu Othacehe @ 2021-01-21 11:42 UTC (permalink / raw)
  To: 46017; +Cc: Mathieu Othacehe

* gnu/image.scm (image?): Export it.
---
 gnu/image.scm | 1 +
 1 file changed, 1 insertion(+)

diff --git a/gnu/image.scm b/gnu/image.scm
index a60d83b175..75d489490d 100644
--- a/gnu/image.scm
+++ b/gnu/image.scm
@@ -31,6 +31,7 @@
             partition-initializer
 
             image
+            image?
             image-name
             image-format
             image-target
-- 
2.29.2





^ permalink raw reply related	[flat|nested] 4+ messages in thread

* [bug#46017] [PATCH 2/2] scripts: system: Accept <image> records as input.
  2021-01-21 11:42 ` [bug#46017] [PATCH 1/2] image: Export image? procedure Mathieu Othacehe
@ 2021-01-21 11:43   ` Mathieu Othacehe
  0 siblings, 0 replies; 4+ messages in thread
From: Mathieu Othacehe @ 2021-01-21 11:43 UTC (permalink / raw)
  To: 46017; +Cc: Mathieu Othacehe

* guix/scripts/system.scm (system-derivation-for-action): Replace "os"
argument by "image". Remove "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.
---
 gnu/system/images/hurd.scm         |   3 +
 gnu/system/images/novena.scm       |   3 +
 gnu/system/images/pine64.scm       |   3 +
 gnu/system/images/pinebook-pro.scm |   3 +
 guix/scripts/system.scm            | 128 ++++++++++++++---------------
 tests/guix-system.sh               |   7 +-
 6 files changed, 79 insertions(+), 68 deletions(-)

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..ae904b3fd6 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -680,13 +680,14 @@ 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
+                                       image-size 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)))
     (case action
       ((build init reconfigure)
        (operating-system-derivation os))
@@ -704,25 +705,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 +755,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 +763,14 @@ 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?
+                         image-size 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.
+the 'image' action.
 
 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,8 @@ static checks."
       (check-initrd-modules os)))
 
   (mlet* %store-monad
-      ((sys       (system-derivation-for-action os action
-                                                #:label label
-                                                #:image-type image-type
+      ((sys       (system-derivation-for-action image action
                                                 #:image-size image-size
-                                                #:volatile-root? volatile-root?
                                                 #:full-boot? full-boot?
                                                 #:container-shared-network? container-shared-network?
                                                 #:mappings mappings))
@@ -1168,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)
 
@@ -1184,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)))
@@ -1240,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?)
@@ -1249,11 +1254,7 @@ 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 +1264,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





^ permalink raw reply related	[flat|nested] 4+ messages in thread

* [bug#46017] [PATCH v2] scripts: system: Accept <image> records as input.
  2021-01-21 11:37 [bug#46017] [PATCH 0/2] scripts: system: Accept <image> records as input Mathieu Othacehe
  2021-01-21 11:42 ` [bug#46017] [PATCH 1/2] image: Export image? procedure Mathieu Othacehe
@ 2021-01-21 11:52 ` Mathieu Othacehe
  1 sibling, 0 replies; 4+ messages in thread
From: Mathieu Othacehe @ 2021-01-21 11:52 UTC (permalink / raw)
  To: 46017; +Cc: Mathieu Othacehe

* 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.
---
Hello,

Here's a v2 that's also removing the "image-size" argument.

Thanks,

Mathieu

 gnu/system/images/hurd.scm         |   3 +
 gnu/system/images/novena.scm       |   3 +
 gnu/system/images/pine64.scm       |   3 +
 gnu/system/images/pinebook-pro.scm |   3 +
 guix/scripts/system.scm            | 132 ++++++++++++++---------------
 tests/guix-system.sh               |   7 +-
 6 files changed, 80 insertions(+), 71 deletions(-)

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





^ permalink raw reply related	[flat|nested] 4+ messages in thread

end of thread, other threads:[~2021-01-21 11:53 UTC | newest]

Thread overview: 4+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-01-21 11:37 [bug#46017] [PATCH 0/2] scripts: system: Accept <image> records as input Mathieu Othacehe
2021-01-21 11:42 ` [bug#46017] [PATCH 1/2] image: Export image? procedure Mathieu Othacehe
2021-01-21 11:43   ` [bug#46017] [PATCH 2/2] scripts: system: Accept <image> records as input Mathieu Othacehe
2021-01-21 11:52 ` [bug#46017] [PATCH v2] " Mathieu Othacehe

Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/guix.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.