[bug#28377] [PATCH 06/10] system: Introduce a disjoint UUID type.

["Ludovic Courtès" <ludo@gnu.org>]

Conceptually a UUID is just a bytevector.  However, there's software out
there such as GRUB that relies on the string representation of different
UUID types (e.g., the string representation of DCE UUIDs differs from
that of ISO-9660 UUIDs, even if they are actually bytevectors of the
same length).  This new <uuid> record type allows us to preserve
information about the type of UUID so we can eventually convert it to a
string using the right representation.

* gnu/system/uuid.scm (<uuid>): New record type.
(bytevector->uuid): New procedure.
(uuid): Return calls to 'make-uuid'.
(uuid->string): Rewrite using 'match-lambda*' to accept a single 'uuid?'
argument.
* gnu/bootloader/grub.scm (grub-root-search): Check for 'uuid?' instead
of 'bytevector?'.
* gnu/system.scm (bootable-kernel-arguments): Check whether ROOT-DEVICE
is 'uuid?'.
(read-boot-parameters): Use 'bytevector->uuid' when the
store device is a bytevector.
(read-boot-parameters-file): Check for 'uuid?' instead of 'bytevector?'.
(device->sexp): New procedure.
(operating-system-boot-parameters-file): Use it for 'root-device' and
'store'.
(operating-system-bootcfg): Remove conditional in definition of
'root-device'.
* gnu/system/file-systems.scm (file-system->spec): Check for 'uuid?' on
DEVICE and take its bytevector.
* gnu/system/mapped-devices.scm (open-luks-device): Likewise.
* gnu/system/vm.scm (iso9660-image): Call 'uuid-bytevector' for the
 #:volume-uuid argument.
---
 gnu/bootloader/grub.scm       |  4 ++--
 gnu/system.scm                | 38 ++++++++++++++++++++++++----------
 gnu/system/file-systems.scm   |  8 +++++---
 gnu/system/mapped-devices.scm |  7 +++++--
 gnu/system/uuid.scm           | 48 +++++++++++++++++++++++++++++++++++--------
 gnu/system/vm.scm             |  4 +++-
 6 files changed, 82 insertions(+), 27 deletions(-)

diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index a9f0875f3..96e53c5c2 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -30,7 +30,7 @@
   #:use-module (gnu artwork)
   #:use-module (gnu system)
   #:use-module (gnu bootloader)
-  #:use-module (gnu system file-systems)
+  #:use-module (gnu system uuid)
   #:autoload   (gnu packages bootloaders) (grub)
   #:autoload   (gnu packages compression) (gzip)
   #:autoload   (gnu packages gtk) (guile-cairo guile-rsvg)
@@ -300,7 +300,7 @@ code."
       (match device
         ;; Preferably refer to DEVICE by its UUID or label.  This is more
         ;; efficient and less ambiguous, see <http://bugs.gnu.org/22281>.
-        ((? bytevector? uuid)
+        ((? uuid? uuid)
          (format #f "search --fs-uuid --set ~a"
                  (uuid->string device)))
         ((? string? label)
diff --git a/gnu/system.scm b/gnu/system.scm
index 6b35e3c0c..a8d2a8131 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -54,6 +54,7 @@
   #:use-module (gnu system locale)
   #:use-module (gnu system pam)
   #:use-module (gnu system linux-initrd)
+  #:use-module (gnu system uuid)
   #:use-module (gnu system file-systems)
   #:use-module (gnu system mapped-devices)
   #:use-module (ice-9 match)
@@ -128,7 +129,14 @@
 (define (bootable-kernel-arguments kernel-arguments system.drv root-device)
   "Prepend extra arguments to KERNEL-ARGUMENTS that allow SYSTEM.DRV to be
 booted from ROOT-DEVICE"
-  (cons* (string-append "--root=" root-device)
+  (cons* (string-append "--root="
+                        (if (uuid? root-device)
+
+                            ;; Note: Always use the DCE format because that's
+                            ;; what (gnu build linux-boot) expects for the
+                            ;; '--root' kernel command-line option.
+                            (uuid->string (uuid-bytevector root-device) 'dce)
+                            root-device))
          #~(string-append "--system=" #$system.drv)
          #~(string-append "--load=" #$system.drv "/boot")
          kernel-arguments))
@@ -261,6 +269,8 @@ directly by the user."
 
       (store-device
        (match (assq 'store rest)
+         (('store ('device (? bytevector? bv)) _ ...)
+          (bytevector->uuid bv))
          (('store ('device device) _ ...)
           device)
          (_                                       ;the old format
@@ -289,16 +299,12 @@ The object has its kernel-arguments extended in order to make it bootable."
   (let* ((file (string-append system "/parameters"))
          (params (call-with-input-file file read-boot-parameters))
          (root (boot-parameters-root-device params))
-         (root-device (if (bytevector? root)
-                          (uuid->string root)
-                          root))
          (kernel-arguments (boot-parameters-kernel-arguments params)))
     (if params
       (boot-parameters
         (inherit params)
         (kernel-arguments (bootable-kernel-arguments kernel-arguments
-                                                     system
-                                                     root-device)))
+                                                     system root)))
       #f)))
 
 (define (boot-parameters->menu-entry conf)
@@ -875,9 +881,7 @@ listed in OS.  The C library expects to find it under
   (mlet* %store-monad
       ((system      (operating-system-derivation os))
        (root-fs ->  (operating-system-root-file-system os))
-       (root-device -> (if (eq? 'uuid (file-system-title root-fs))
-                           (uuid->string (file-system-device root-fs))
-                           (file-system-device root-fs)))
+       (root-device -> (file-system-device root-fs))
        (params (operating-system-boot-parameters os system root-device))
        (entry -> (boot-parameters->menu-entry params))
        (bootloader-conf -> (operating-system-bootloader os)))
@@ -917,6 +921,15 @@ kernel arguments for that derivation to <boot-parameters>."
              (store-device (fs->boot-device store))
              (store-mount-point (file-system-mount-point store))))))
 
+(define (device->sexp device)
+  "Serialize DEVICE as an sexp (really, as an object with a read syntax.)"
+  (match device
+    ((? uuid? uuid)
+     ;; TODO: Preserve the type of UUID.
+     (uuid-bytevector uuid))
+    (_
+     device)))
+
 (define* (operating-system-boot-parameters-file os #:optional (system.drv #f))
    "Return a file that describes the boot parameters of OS.  The primary use of
 this file is the reconstruction of GRUB menu entries for old configurations.
@@ -934,14 +947,17 @@ being stored into the \"parameters\" file)."
                  #~(boot-parameters
                     (version 0)
                     (label #$(boot-parameters-label params))
-                    (root-device #$(boot-parameters-root-device params))
+                    (root-device
+                     #$(device->sexp
+                        (boot-parameters-root-device params)))
                     (kernel #$(boot-parameters-kernel params))
                     (kernel-arguments
                      #$(boot-parameters-kernel-arguments params))
                     (initrd #$(boot-parameters-initrd params))
                     (bootloader-name #$(boot-parameters-bootloader-name params))
                     (store
-                     (device #$(boot-parameters-store-device params))
+                     (device
+                      #$(device->sexp (boot-parameters-store-device params)))
                      (mount-point #$(boot-parameters-store-mount-point params))))
                  #:set-load-path? #f)))
 
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index dd30559d7..52f16676f 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -20,8 +20,7 @@
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (guix records)
-  #:use-module ((gnu system uuid)
-                #:select (uuid string->uuid uuid->string))
+  #:use-module (gnu system uuid)
   #:re-export (uuid                               ;backward compatibility
                string->uuid
                uuid->string)
@@ -157,7 +156,10 @@ store--e.g., if FS is the root file system."
 initrd code."
   (match fs
     (($ <file-system> device title mount-point type flags options _ _ check?)
-     (list device title mount-point type flags options check?))))
+     (list (if (uuid? device)
+               (uuid-bytevector device)
+               device)
+           title mount-point type flags options check?))))
 
 (define (spec->file-system sexp)
   "Deserialize SEXP, a list, to the corresponding <file-system> object."
diff --git a/gnu/system/mapped-devices.scm b/gnu/system/mapped-devices.scm
index 18b9f5b4b..17cf6b716 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2017 Mark H Weaver <mhw@netris.org>
 ;;;
@@ -24,6 +24,7 @@
   #:use-module (guix modules)
   #:use-module (gnu services)
   #:use-module (gnu services shepherd)
+  #:use-module (gnu system uuid)
   #:autoload   (gnu packages cryptsetup) (cryptsetup-static)
   #:autoload   (gnu packages linux) (mdadm-static)
   #:use-module (srfi srfi-1)
@@ -99,7 +100,9 @@
 'cryptsetup'."
   (with-imported-modules (source-module-closure
                           '((gnu build file-systems)))
-    #~(let ((source #$source))
+    #~(let ((source #$(if (uuid? source)
+                          (uuid-bytevector source)
+                          source)))
         ;; XXX: 'use-modules' should be at the top level.
         (use-modules (rnrs bytevectors)           ;bytevector?
                      ((gnu build file-systems)
diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm
index 64dad5a37..60626ebb1 100644
--- a/gnu/system/uuid.scm
+++ b/gnu/system/uuid.scm
@@ -19,12 +19,19 @@
 
 (define-module (gnu system uuid)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 format)
   #:export (uuid
+            uuid?
+            uuid-type
+            uuid-bytevector
+
+            bytevector->uuid
+
             uuid->string
             dce-uuid->string
             string->uuid
@@ -206,15 +213,27 @@ corresponding bytevector; otherwise return #f."
     (#f #f)
     ((_ . (? procedure? parse)) (parse str))))
 
-(define* (uuid->string bv #:key (type 'dce))
-  "Convert BV, a bytevector, to the UUID string representation for TYPE."
-  (match (vhash-assq type %uuid-printers)
-    (#f #f)
-    ((_ . (? procedure? unparse)) (unparse bv))))
+;; High-level UUID representation that carries its type with it.
+;;
+;; This is necessary to serialize bytevectors with the right printer in some
+;; circumstances.  For instance, GRUB "search --fs-uuid" command compares the
+;; string representation of UUIDs, not the raw bytes; thus, when emitting a
+;; GRUB 'search' command, we need to procedure the right string representation
+;; (see <https://debbugs.gnu.org/cgi/bugreport.cgi?msg=52;att=0;bug=27735>).
+(define-record-type <uuid>
+  (make-uuid type bv)
+  uuid?
+  (type  uuid-type)                               ;'dce | 'iso9660 | ...
+  (bv    uuid-bytevector))
+
+(define* (bytevector->uuid bv #:optional (type 'dce))
+  "Return a UUID object make of BV and TYPE."
+  (make-uuid type bv))
 
 (define-syntax uuid
   (lambda (s)
-    "Return the bytevector corresponding to the given UUID representation."
+    "Return the UUID object corresponding to the given UUID representation."
+    ;; TODO: Extend to types other than DCE.
     (syntax-case s ()
       ((_ str)
        (string? (syntax->datum #'str))
@@ -222,6 +241,19 @@ corresponding bytevector; otherwise return #f."
        (let ((bv (string->uuid (syntax->datum #'str))))
          (unless bv
            (syntax-violation 'uuid "invalid UUID" s))
-         (datum->syntax #'str bv)))
+         #`(make-uuid 'dce #,(datum->syntax #'str bv))))
       ((_ str)
-       #'(string->uuid str)))))
+       #'(make-uuid 'dce (string->uuid str))))))
+
+(define uuid->string
+  ;; Convert the given bytevector or UUID object, to the corresponding UUID
+  ;; string representation.
+  (match-lambda*
+    (((? bytevector? bv))
+     (uuid->string bv 'dce))
+    (((? bytevector? bv) type)
+     (match (vhash-assq type %uuid-printers)
+       (#f #f)
+       ((_ . (? procedure? unparse)) (unparse bv))))
+    (((? uuid? uuid))
+     (uuid->string (uuid-bytevector uuid) (uuid-type uuid)))))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index b3da11876..1807946cb 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -57,6 +57,7 @@
   #:use-module (gnu system file-systems)
   #:use-module (gnu system)
   #:use-module (gnu services)
+  #:use-module (gnu system uuid)
 
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
@@ -223,7 +224,8 @@ INPUTS is a list of inputs (as for packages)."
                                #$os-drv
                                "/xchg/guixsd.iso"
                                #:volume-id #$file-system-label
-                               #:volume-uuid #$file-system-uuid)
+                               #:volume-uuid #$(and=> file-system-uuid
+                                                      uuid-bytevector))
            (reboot))))
    #:system system
    #:make-disk-image? #f
-- 
2.14.1