branch wip-disk-image updated: image: Fix label and uuid handling.

[guix-commits]

This is an automated email from the git hooks/post-receive script.

mothacehe pushed a commit to branch wip-disk-image
in repository guix.

The following commit(s) were added to refs/heads/wip-disk-image by this push:
     new eeab1a4  image: Fix label and uuid handling.
eeab1a4 is described below

commit eeab1a4aece8636beb2e4c4373ab4915be42e3d9
Author: Mathieu Othacehe <address@hidden>
AuthorDate: Sun Apr 26 19:42:00 2020 +0200

    image: Fix label and uuid handling.
---
 gnu/build/disk-image.scm |   8 ++--
 gnu/image.scm            |   1 +
 gnu/system/image.scm     | 109 +++++++++++++++++++++++++++--------------------
 3 files changed, 69 insertions(+), 49 deletions(-)

diff --git a/gnu/build/disk-image.scm b/gnu/build/disk-image.scm
index 0dcc4a8..26653aa 100644
--- a/gnu/build/disk-image.scm
+++ b/gnu/build/disk-image.scm
@@ -40,10 +40,11 @@
 
 (define (sexp->partition sexp)
   (match sexp
-    ((size file-system label)
+    ((size file-system label uuid)
      (partition (size size)
                 (file-system file-system)
-                (label label)))))
+                (label label)
+                (uuid uuid)))))
 
 (define (size-in-kib size)
   (number->string
@@ -56,9 +57,10 @@
                           #:key (owner 0))
   (let ((size (partition-size partition))
         (label (partition-label partition))
+        (uuid (partition-uuid partition))
         (options "lazy_itable_init=1,lazy_journal_init=1"))
     (invoke "mke2fs" "-t" "ext4" "-d" root
-            "-L" label
+            "-L" label "-U" (uuid->string uuid)
             "-E" (format #f "root_owner=~a:~a,~a"
                          owner owner options)
             target
diff --git a/gnu/image.scm b/gnu/image.scm
index 040546e..fdada40 100644
--- a/gnu/image.scm
+++ b/gnu/image.scm
@@ -25,6 +25,7 @@
             partition-size
             partition-file-system
             partition-label
+            partition-uuid
             partition-flags
             partition-initializer
 
diff --git a/gnu/system/image.scm b/gnu/system/image.scm
index 467506b..ca63487 100644
--- a/gnu/system/image.scm
+++ b/gnu/system/image.scm
@@ -41,7 +41,8 @@
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:use-module (gnu packages linux)
   #:use-module (gnu packages mtools)
-  #:use-module ((srfi srfi-1) #:select (append-map remove find))
+  #:use-module ((srfi srfi-1) #:prefix scm:)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
@@ -84,20 +85,18 @@
 
 (define iso9660-image
   (image
-   (format 'iso9660)))
+   (format 'iso9660)
+   (partitions
+    (list (partition
+           (size 'guess)
+           (label "GUIX_IMAGE")
+           (flags '(boot)))))))
 
 
 ;;
 ;; Helpers.
 ;;
 
-(define (root-label image)
-  (let ((label "Guix_image")
-        (format (image-format image)))
-    (if (eq? format 'iso9660)
-        (string-upcase label)
-        label)))
-
 (define (root-uuid image)
   ;; UUID of the root file system, computed in a deterministic fashion.
   ;; This is what we use to locate the root file system so it has to be
@@ -119,16 +118,19 @@
 (define (partition->gexp partition)
   #~'(#$@(list (partition-size partition))
       #$(partition-file-system partition)
-      #$(partition-label partition)))
+      #$(partition-label partition)
+      #$(and=> (partition-uuid partition)
+               uuid-bytevector)))
 
 (define gcrypt-sqlite3&co
   ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
-  (append-map (lambda (package)
-                (cons package
-                      (match (package-transitive-propagated-inputs package)
-                        (((labels packages) ...)
-                         packages))))
-              (list guile-gcrypt guile-sqlite3)))
+  (scm:append-map
+   (lambda (package)
+     (cons package
+           (match (package-transitive-propagated-inputs package)
+             (((labels packages) ...)
+              packages))))
+   (list guile-gcrypt guile-sqlite3)))
 
 (define-syntax-rule (with-imported-modules* exp ...)
   (with-extensions gcrypt-sqlite3&co
@@ -153,8 +155,6 @@
 (define* (system-disk-image image
                             #:key
                             (name "disk-image")
-                            label
-                            uuid
                             bootcfg
                             bootloader
                             register-closures?
@@ -261,9 +261,9 @@ image ~a {
 
 (define (has-guix-service-type? os)
   "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
-  (not (not (find (lambda (service)
-                     (eq? (service-kind service) guix-service-type))
-                   (operating-system-services os)))))
+  (not (not (scm:find (lambda (service)
+                        (eq? (service-kind service) guix-service-type))
+                      (operating-system-services os)))))
 
 (define* (system-iso9660-image image
                                #:key
@@ -276,6 +276,16 @@ image ~a {
                                (inputs '())
                                (grub-mkrescue-environment '())
                                (substitutable? #t))
+  (define root-label
+    (match (image-partitions image)
+      ((partition)
+       (partition-label partition))))
+
+  (define root-uuid
+    (match (image-partitions image)
+      ((partition)
+       (uuid-bytevector (partition-uuid partition)))))
+
   (let* ((os (image-operating-system image))
          (bootloader (bootloader-package bootloader))
          (schema (local-file (search-path %load-path
@@ -314,9 +324,8 @@ image ~a {
                                  #:references-graphs '#$graph
                                  #:register-closures? #$register-closures?
                                  #:compression? #f
-                                 #:volume-id #$label
-                                 #:volume-uuid #$(and=> uuid
-                                                        uuid-bytevector))))))
+                                 #:volume-id #$root-label
+                                 #:volume-uuid #$root-uuid)))))
     (gexp->derivation name builder
                       #:references-graphs inputs)))
 
@@ -325,22 +334,33 @@ image ~a {
 ;; Image creation.
 ;;
 
-(define (image->root-file-system image)
-  (define (find-root-partition)
-    (let ((partitions (image-partitions image)))
-      (find (lambda (partition)
-              (member 'boot (partition-flags partition)))
-            partitions)))
+(define (root-partition? partition)
+  (member 'boot (partition-flags partition)))
 
+(define (find-root-partition image)
+  (scm:find root-partition? (image-partitions image)))
+
+(define (image->root-file-system image)
   (let ((format (image-format image)))
     (if (eq? format 'iso9660)
         "iso9660"
-        (partition-file-system (find-root-partition)))))
-
-(define-syntax-rule (image-with-os base-image os)
-  (image
-   (inherit base-image)
-   (operating-system os)))
+        (partition-file-system (find-root-partition image)))))
+
+(define* (image-with-os base-image os
+                        #:key uuid)
+  (let*-values (((partitions) (image-partitions base-image))
+                ((root-partition other-partitions)
+                 (scm:partition root-partition? partitions)))
+    (image
+     (inherit base-image)
+     (operating-system os)
+     (partitions
+      (if uuid
+          (cons (partition
+                 (inherit (car root-partition))
+                 (uuid uuid))
+                other-partitions)
+          partitions)))))
 
 (define* (system-image image
                        #:key
@@ -348,9 +368,10 @@ image ~a {
   (let* ((image-os (image-operating-system image))
          (format (image-format image))
          (file-systems-to-keep
-          (remove (lambda (fs)
-                    (string=? (file-system-mount-point fs) "/"))
-                  (operating-system-file-systems image-os)))
+          (scm:remove
+           (lambda (fs)
+             (string=? (file-system-mount-point fs) "/"))
+           (operating-system-file-systems image-os)))
          (root-file-system-type (image->root-file-system image))
          (os (operating-system
                (inherit image-os)
@@ -363,7 +384,7 @@ image ~a {
                                (bootloader-configuration
                                 (inherit
                                  (operating-system-bootloader image-os))
-                                 (bootloader grub-mkrescue-bootloader))
+                                (bootloader grub-mkrescue-bootloader))
                                (operating-system-bootloader image-os)))
                (file-systems (cons (file-system
                                      (mount-point "/")
@@ -371,7 +392,6 @@ image ~a {
                                      (type root-file-system-type))
                                    file-systems-to-keep))))
          (uuid (root-uuid image))
-         (label (root-label image))
          (os (operating-system
                (inherit os)
                (file-systems (cons (file-system
@@ -379,7 +399,8 @@ image ~a {
                                      (device uuid)
                                      (type root-file-system-type))
                                    file-systems-to-keep))))
-         (image* (image-with-os image os))
+         (image* (image-with-os image os
+                                #:uuid uuid))
          (register-closures? (has-guix-service-type? os))
          (bootcfg (operating-system-bootcfg os))
          (bootloader (bootloader-configuration-bootloader
@@ -387,8 +408,6 @@ image ~a {
     (case (image-format image)
       ((disk-image)
        (system-disk-image image*
-                          #:label label
-                          #:uuid uuid
                           #:bootcfg bootcfg
                           #:bootloader bootloader
                           #:register-closures? register-closures?
@@ -397,8 +416,6 @@ image ~a {
                           #:substitutable? substitutable?))
       ((iso9660)
        (system-iso9660-image image*
-                             #:label label
-                             #:uuid uuid
                              #:bootcfg bootcfg
                              #:bootloader bootloader
                              #:register-closures? register-closures?