Subject: Lookup by UUID

From: [email-masked] (Ludovic Courtès)
Date: Thu, 20 Jul 2017 00:32:21 +0200

Hi!

Danny Milosavljevic <[email-masked]> skribis:

> I think it's a good interim solution.

Based on your feedback I’ve come up with the two attached patches.  I’ve
checked at the REPL that ‘operating-system-uuid’ gives reasonable
results for different ‘operating-system’ configs, and deterministic
results for a given config (OSes that are not ‘eq?’ but that are equal.)

On ext4 “guix system disk-image” produces an image that works like a
charm.

With iso9660, it works… by chance, because GRUB’s “search --fs-uuid”
fails.  Guess why?  Because it compares UUIDs as strings, and we format
it as a DCE UUID instead of an ISO UUID.  Sounds familiar no?  :-)

So that’s where we are.  Thoughts on how to address it?

Cheers,
Ludo’.

>From 00d49f0199dc51b02f2113c3669ea07f4461b102 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <[email-masked]>
Date: Thu, 20 Jul 2017 00:15:43 +0200
Subject: [PATCH] vm: Allow partitions to be initialized with a given UUID.

* gnu/build/vm.scm (<partition>)[uuid]: New field.
(create-ext-file-system): Add #:uuid and honor it.
(create-fat-file-system): Add #:uuid.
(format-partition): Add #:uuid and honor it.
(initialize-partition): Honor the 'uuid' field of PARTITION.
---
 gnu/build/vm.scm | 26 ++++++++++++++++----------
 1 file changed, 16 insertions(+), 10 deletions(-)

diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 727494ad9..8dfaf2789 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -163,6 +163,7 @@ the #:references-graphs parameter of 'derivation'."
   (size        partition-size)
   (file-system partition-file-system (default "ext4"))
   (label       partition-label (default #f))
+  (uuid        partition-uuid (default #f))
   (flags       partition-flags (default '()))
   (initializer partition-initializer (default (const #t))))
 
@@ -236,22 +237,26 @@ actual /dev name based on DEVICE."
 (define MS_BIND 4096)                             ; <sys/mounts.h> again!
 
 (define* (create-ext-file-system partition type
-                                 #:key label)
+                                 #:key label uuid)
   "Create an ext-family filesystem of TYPE on PARTITION.  If LABEL is true,
-use that as the volume name."
+use that as the volume name.  If UUID is true, use it as the partition UUID."
   (format #t "creating ~a partition...\n" type)
   (unless (zero? (apply system* (string-append "mkfs." type)
                         "-F" partition
-                        (if label
-                            `("-L" ,label)
-                            '())))
+                        `(,@(if label
+                                `("-L" ,label)
+                                '())
+                          ,@(if uuid
+                                `("-U" ,(uuid->string uuid))
+                                '()))))
     (error "failed to create partition")))
 
 (define* (create-fat-file-system partition
-                                 #:key label)
+                                 #:key label uuid)
   "Create a FAT filesystem on PARTITION.  The number of File Allocation Tables
 will be determined based on filesystem size.  If LABEL is true, use that as the
 volume name."
+  ;; FIXME: UUID is ignored!
   (format #t "creating FAT partition...\n")
   (unless (zero? (apply system* "mkfs.fat" partition
                         (if label
@@ -260,13 +265,13 @@ volume name."
     (error "failed to create FAT partition")))
 
 (define* (format-partition partition type
-                           #:key label)
+                           #:key label uuid)
   "Create a file system TYPE on PARTITION.  If LABEL is true, use that as the
 volume name."
   (cond ((string-prefix? "ext" type)
-         (create-ext-file-system partition type #:label label))
+         (create-ext-file-system partition type #:label label #:uuid uuid))
         ((or (string-prefix? "fat" type) (string= "vfat" type))
-         (create-fat-file-system partition #:label label))
+         (create-fat-file-system partition #:label label #:uuid uuid))
         (else (error "Unsupported file system."))))
 
 (define (initialize-partition partition)
@@ -275,7 +280,8 @@ it, run its initializer, and unmount it."
   (let ((target "/fs"))
    (format-partition (partition-device partition)
                      (partition-file-system partition)
-                     #:label (partition-label partition))
+                     #:label (partition-label partition)
+                     #:uuid (partition-uuid partition))
    (mkdir-p target)
    (mount (partition-device partition) target
           (partition-file-system partition))
-- 
2.13.2

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 6f979aee4..bd1e1b3e5 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -56,9 +56,12 @@
   #:use-module (gnu system file-systems)
   #:use-module (gnu system)
   #:use-module (gnu services)
+  #:use-module ((gnu build file-systems)
+                #:select (string->iso9660-uuid))
 
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
 
   #:export (expression->derivation-in-linux-vm
@@ -234,6 +237,7 @@ INPUTS is a list of inputs (as for packages)."
                      (disk-image-format "qcow2")
                      (file-system-type "ext4")
                      file-system-label
+                     file-system-uuid
                      os-drv
                      bootcfg-drv
                      bootloader
@@ -293,6 +297,7 @@ the image."
                   (partitions (list (partition
                                      (size root-size)
                                      (label #$file-system-label)
+                                     (uuid #$file-system-uuid)
                                      (file-system #$file-system-type)
                                      (flags '(boot))
                                      (initializer initialize))
@@ -330,6 +335,31 @@ the image."
 ;;; VM and disk images.
 ;;;
 
+(define* (operating-system-uuid os #:optional (type 'dce))
+  "Compute a deterministic \"UUID\" for OS, of the given TYPE (one of 'iso9660
+or 'dce)."
+  (if (eq? type 'iso9660)
+      (let ((pad (compose (cut string-pad <> 2 #\0)
+                          number->string))
+            (h   (hash (operating-system-services os) 3600)))
+        (string->iso9660-uuid
+         (string-append "1970-01-01-"
+                        (pad (hash (operating-system-host-name os) 24)) "-"
+                        (pad (quotient h 60)) "-"
+                        (pad (modulo h 60)) "-"
+                        (pad (hash (operating-system-file-systems os) 100)))))
+      (uint-list->bytevector
+       (list (hash file-system-type
+                   (expt 2 32))
+             (hash (operating-system-host-name os)
+                   (expt 2 32))
+             (hash (operating-system-services os)
+                   (expt 2 32))
+             (hash (operating-system-file-systems os)
+                   (expt 2 32)))
+       (endianness little)
+       4)))
+
 (define* (system-disk-image os
                             #:key
                             (name "disk-image")
@@ -346,12 +376,20 @@ to USB sticks meant to be read-only."
     (if (string=? "iso9660" file-system-type)
         string-upcase
         identity))
+
   (define root-label
-    ;; Volume name of the root file system.  Since we don't know which device
-    ;; will hold it, we use the volume name to find it (using the UUID would
-    ;; be even better, but somewhat less convenient.)
+    ;; Volume name of the root file system.
     (normalize-label "GuixSD_image"))
 
+  (define root-uuid
+    ;; 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
+    ;; different from the user's own file system UUIDs.
+    (operating-system-uuid os
+                           (if (string=? file-system-type "iso9660")
+                               'iso9660
+                               'dce)))
+
   (define file-systems-to-keep
     (remove (lambda (fs)
               (string=? (file-system-mount-point fs) "/"))
@@ -369,8 +407,8 @@ to USB sticks meant to be read-only."
               ;; Force our own root file system.
               (file-systems (cons (file-system
                                     (mount-point "/")
-                                    (device root-label)
-                                    (title 'label)
+                                    (device root-uuid)
+                                    (title 'uuid)
                                     (type file-system-type))
                                   file-systems-to-keep)))))
 
@@ -379,7 +417,7 @@ to USB sticks meant to be read-only."
       (if (string=? "iso9660" file-system-type)
           (iso9660-image #:name name
                          #:file-system-label root-label
-                         #:file-system-uuid #f
+                         #:file-system-uuid root-uuid
                          #:os-drv os-drv
                          #:bootcfg-drv bootcfg
                          #:bootloader (bootloader-configuration-bootloader
@@ -398,6 +436,7 @@ to USB sticks meant to be read-only."
                                              "ext4"
                                              file-system-type)
                       #:file-system-label root-label
+                      #:file-system-uuid root-uuid
                       #:copy-inputs? #t
                       #:register-closures? #t
                       #:inputs `(("system" ,os-drv)