>From a6d4cb90825b9e45c0baeaeaa653c57a9100b21a Mon Sep 17 00:00:00 2001
From: Julien Lepiller <julien@lepiller.eu>
Date: Sat, 29 Aug 2020 15:34:56 +0200
Subject: [PATCH 1/2] guix: system: Add `--label' option.

* guix/scripts/system.scm (%options): Add `--label'.
---
 guix/scripts/system.scm | 24 ++++++++++++++++++++----
 1 file changed, 20 insertions(+), 4 deletions(-)

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index f6d20382b6..c9cee2e2a2 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -662,7 +662,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)
@@ -688,7 +688,14 @@ checking this by themselves in their 'check' procedure."
        (image
         (inherit base-image)
         (size image-size)
-        (operating-system os)))))
+        (operating-system os)
+        (partitions (match (image-partitions base-image)
+                      ((boot others ...)
+                       (cons
+                         ((@ (gnu image) partition)
+                           (inherit boot)
+                           (label (or label (partition-label boot))))
+                         others))))))))
     ((docker-image)
      (system-docker-image os #:shared-network? container-shared-network?))))
 
@@ -741,7 +748,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))
@@ -795,6 +802,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?
@@ -942,6 +950,8 @@ Some ACTIONS support additional ARGS.\n"))
       --image-size=SIZE  for 'vm-image', produce an image of SIZE"))
   (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_ "
@@ -1008,6 +1018,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)))
@@ -1065,7 +1078,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."
@@ -1119,6 +1133,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)))
@@ -1169,6 +1184,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)))))
-- 
2.28.0