01/03: guix: system: Add `--label' option.

[guix-commits]

roptat pushed a commit to branch master
in repository guix.

commit 036f23f053ee6bd34c6d387debb4a9166561dd02
Author: Julien Lepiller <julien@lepiller.eu>
AuthorDate: Sat Aug 29 15:34:56 2020 +0200

    guix: system: Add `--label' option.
    
    * guix/scripts/system.scm (%options): Add `--label'.
    (system-derivation-for-action): Take a #:label key to set volume ID.
    (perform-action): Take a #:label key.
    (%default-options): Add default label value.
    (process-action): Pass label value from command-line to perform-action.
    * gnu/system/image.scm (image-with-label): New procedure.
---
 doc/guix.texi           |  4 +++-
 gnu/system/image.scm    | 17 ++++++++++++++++-
 guix/scripts/system.scm | 18 ++++++++++++++----
 3 files changed, 33 insertions(+), 6 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 6206a93..56b1cd8 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -28836,7 +28836,9 @@ the @option{--image-size} option is ignored in the case 
of
 @code{docker-image}.
 
 You can specify the root file system type by using the
-@option{--file-system-type} option.  It defaults to @code{ext4}.
+@option{--file-system-type} option.  It defaults to @code{ext4}.  When its
+value is @code{iso9660}, the @option{--label} option can be used to specify
+a volume ID with @code{disk-image}.
 
 When using @code{vm-image}, the returned image is in qcow2 format, which
 the QEMU emulator can efficiently use. @xref{Running Guix in a VM},
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index c1a718d..733f2bf 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -63,7 +63,8 @@
             iso9660-image
 
             find-image
-            system-image))
+            system-image
+            image-with-label))
 
 
 ;;;
@@ -407,6 +408,20 @@ used in the image. "
                                #:references-graphs ,inputs
                                #:substitutable? ,substitutable?))))
 
+(define (image-with-label base-image label)
+  "The volume ID of an ISO is the label of the first partition.  This procedure
+returns an image record where the first partition's label is set to <label>."
+  (image
+    (inherit base-image)
+    (partitions
+      (match (image-partitions base-image)
+        ((boot others ...)
+         (cons
+           (partition
+             (inherit boot)
+             (label label))
+           others))))))
+
 
 ;;
 ;; Image creation.
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 3222a53..b75b0e5 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -6,6 +6,7 @@
 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2019 Christopher Baines <mail@cbaines.net>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
+;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -667,7 +668,7 @@ checking this by themselves in their 'check' procedure."
 (define* (system-derivation-for-action os base-image action
                                        #:key image-size file-system-type
                                        full-boot? container-shared-network?
-                                       mappings)
+                                       mappings label)
   "Return as a monadic value the derivation for OS according to ACTION."
   (case action
     ((build init reconfigure)
@@ -691,7 +692,7 @@ checking this by themselves in their 'check' procedure."
      (lower-object
       (system-image
        (image
-        (inherit base-image)
+        (inherit (if label (image-with-label base-image label) base-image))
         (size image-size)
         (operating-system os)))))
     ((docker-image)
@@ -746,7 +747,7 @@ and TARGET arguments."
                          install-bootloader?
                          dry-run? derivations-only?
                          use-substitutes? bootloader-target target
-                         image-size file-system-type full-boot?
+                         image-size file-system-type full-boot? label
                          container-shared-network?
                          (mappings '())
                          (gc-root #f))
@@ -800,6 +801,7 @@ static checks."
       ((target*   (current-target-system))
        (image ->  (find-image file-system-type target*))
        (sys       (system-derivation-for-action os image action
+                                                #:label label
                                                 #:file-system-type 
file-system-type
                                                 #:image-size image-size
                                                 #:full-boot? full-boot?
@@ -950,6 +952,8 @@ Some ACTIONS support additional ARGS.\n"))
   (display (G_ "
       --no-bootloader    for 'init', do not install a bootloader"))
   (display (G_ "
+      --label=LABEL      for 'disk-image', label disk image with LABEL"))
+  (display (G_ "
       --save-provenance  save provenance information"))
   (display (G_ "
       --share=SPEC       for 'vm', share host file system according to SPEC"))
@@ -1015,6 +1019,9 @@ Some ACTIONS support additional ARGS.\n"))
          (option '("no-bootloader" "no-grub") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'install-bootloader? #f result)))
+         (option '("label") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'label arg result)))
          (option '("full-boot") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'full-boot? #t result)))
@@ -1072,7 +1079,8 @@ Some ACTIONS support additional ARGS.\n"))
     (validate-reconfigure . ,ensure-forward-reconfigure)
     (file-system-type . "ext4")
     (image-size . guess)
-    (install-bootloader? . #t)))
+    (install-bootloader? . #t)
+    (label . #f)))
 
 (define (verbosity-level opts)
   "Return the verbosity level based on OPTS, the alist of parsed options."
@@ -1126,6 +1134,7 @@ resulting from command-line parsing."
 
          (dry?        (assoc-ref opts 'dry-run?))
          (bootloader? (assoc-ref opts 'install-bootloader?))
+         (label       (assoc-ref opts 'label))
          (target-file (match args
                         ((first second) second)
                         (_ #f)))
@@ -1176,6 +1185,7 @@ 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)))))