[bug#28377] [PATCH 00/10] Allow users to specify the UUID of disk images

[bug#28377] [PATCH 00/10] Allow users to specify the UUID of disk images

[Ludovic Courtès]

Hello!

This is a followup to
<https://debbugs.gnu.org/cgi/bugreport.cgi?bug=27735#31>: it’s about
making it possible to specify the UUID of the root partition of the disk
image.

To get there, this patch series does a few things:

  1. Give a 2nd argument to ‘uuid->string’ et al., which is the name of
     the UUID format.

  2. Move UUID-related code to (gnu system uuid).

  3. Introduce a <uuid> record type that ties together a bytevector and
     a symbol specifying the UUID type (DCE, ISO9660, etc.).  This
     allows ‘uuid->string’ to generate a string in the “right” format as
     expected by tools such as GRUB.

  4. Finally, generate a UUID for generated images.

Tested with both an ISO and an ext4/qcow2 image.

Feedback welcome!

Ludo’.

Ludovic Courtès (10):
  vm: Allow partitions to be initialized with a given UUID.
  file-systems: Add UUID type dictionaries.
  services: base: Import the closure of (gnu build file-systems).
  file-systems: Introduce (gnu system uuid).
  services: file-system: Use 'file-system->spec'.
  system: Introduce a disjoint UUID type.
  system: Serialize the UUID type in the "parameters" file.
  uuid: 'uuid' macro supports more UUID types.
  vm: Allow users to specify a UUID for the root partition.
  vm: Generate a UUID to identify the root file system.

 gnu/bootloader/grub.scm       |   4 +-
 gnu/build/file-systems.scm    | 130 +--------------------
 gnu/build/vm.scm              |  28 +++--
 gnu/local.mk                  |   1 +
 gnu/services/base.scm         |  15 +--
 gnu/system.scm                |  48 +++++---
 gnu/system/file-systems.scm   |  26 ++---
 gnu/system/mapped-devices.scm |   7 +-
 gnu/system/uuid.scm           | 265 ++++++++++++++++++++++++++++++++++++++++++
 gnu/system/vm.scm             |  63 ++++++++--
 10 files changed, 393 insertions(+), 194 deletions(-)
 create mode 100644 gnu/system/uuid.scm

-- 
2.14.1

[bug#28377] [PATCH 01/10] vm: Allow partitions to be initialized with a given UUID.

[Ludovic Courtès]

* 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.14.1

[bug#28377] [PATCH 02/10] file-systems: Add UUID type dictionaries.

[Ludovic Courtès]

* gnu/build/file-systems.scm (uuid->string): Rename to...
(dce-uuid->string): ... this.
(string->uuid): Rename to...
(string->dce-uuid): ... this.
(vhashq): New macro.
(%uuid-parsers, %uuid-printers): New variables.
(uuid->string, string->uuid): New procedures.
---
 gnu/build/file-systems.scm | 49 ++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 43 insertions(+), 6 deletions(-)

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 203fbdfff..fbaf15895 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -28,6 +28,7 @@
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 format)
   #:use-module (ice-9 regex)
+  #:use-module (ice-9 vlist)
   #:use-module (system foreign)
   #:autoload   (system repl repl) (start-repl)
   #:use-module (srfi srfi-1)
@@ -42,7 +43,9 @@
             canonicalize-device-spec
 
             uuid->string
+            dce-uuid->string
             string->uuid
+            string->dce-uuid
             string->iso9660-uuid
             string->ext2-uuid
             string->ext3-uuid
@@ -516,7 +519,7 @@ were found."
 (define-syntax %network-byte-order
   (identifier-syntax (endianness big)))
 
-(define (uuid->string uuid)
+(define (dce-uuid->string uuid)
   "Convert UUID, a 16-byte bytevector, to its string representation, something
 like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
   ;; See <https://tools.ietf.org/html/rfc4122>.
@@ -532,7 +535,7 @@ like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
   ;; The regexp of a UUID.
   (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
 
-(define (string->uuid str)
+(define (string->dce-uuid str)
   "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
 return its contents as a 16-byte bytevector.  Return #f if STR is not a valid
 UUID representation."
@@ -562,10 +565,44 @@ UUID representation."
                      (time-low 4) (time-mid 2) (time-hi 2)
                      (clock-seq 2) (node 6)))))))
 
-(define string->ext2-uuid string->uuid)
-(define string->ext3-uuid string->uuid)
-(define string->ext4-uuid string->uuid)
-(define string->btrfs-uuid string->uuid)
+(define string->ext2-uuid string->dce-uuid)
+(define string->ext3-uuid string->dce-uuid)
+(define string->ext4-uuid string->dce-uuid)
+(define string->btrfs-uuid string->dce-uuid)
+
+(define-syntax vhashq
+  (syntax-rules (=>)
+    ((_)
+     vlist-null)
+    ((_ (key others ... => value) rest ...)
+     (vhash-consq key value
+                  (vhashq (others ... => value) rest ...)))
+    ((_ (=> value) rest ...)
+     (vhashq rest ...))))
+
+(define %uuid-parsers
+  (vhashq
+   ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid)
+   ('iso9660 => string->iso9660-uuid)))
+
+(define %uuid-printers
+  (vhashq
+   ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => dce-uuid->string)
+   ('iso9660 => iso9660-uuid->string)
+   ('fat32 'fat => fat32-uuid->string)))
+
+(define* (string->uuid str #:key (type 'dce))
+  "Parse STR as a UUID of the given TYPE.  On success, return the
+corresponding bytevector; otherwise return #f."
+  (match (vhash-assq type %uuid-parsers)
+    (#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))))
 
 \f
 (define* (canonicalize-device-spec spec #:optional (title 'any))
-- 
2.14.1

[bug#28377] [PATCH 03/10] services: base: Import the closure of (gnu build file-systems).

[Ludovic Courtès]

* gnu/services/base.scm (file-system-shepherd-service): Use
'source-module-closure' in the 'with-imported-modules' form.
---
 gnu/services/base.scm | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 5001298ab..23ef2d4bf 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -47,6 +47,7 @@
                 #:select (mount-flags->bit-mask))
   #:use-module (guix gexp)
   #:use-module (guix records)
+  #:use-module (guix modules)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
@@ -286,8 +287,8 @@ FILE-SYSTEM."
         (dependencies (file-system-dependencies file-system))
         (packages (file-system-packages (list file-system))))
     (and (file-system-mount? file-system)
-         (with-imported-modules '((gnu build file-systems)
-                                  (guix build bournish))
+         (with-imported-modules (source-module-closure
+                                 '((gnu build file-systems)))
            (shepherd-service
             (provision (list (file-system->shepherd-service-name file-system)))
             (requirement `(root-file-system
-- 
2.14.1

[bug#28377] [PATCH 04/10] file-systems: Introduce (gnu system uuid).

[Ludovic Courtès]

* gnu/build/file-systems.scm (sub-bytevector)
(latin1->string, %fat32-endianness, fat32-uuid->string)
(%iso9660-uuid-rx, string->iso9660-uuid)
(iso9660-uuid->string, %network-byte-order)
(dce-uuid->string, %uuid-rx, string->dce-uuid)
(string->ext2-uuid, string->ext3-uuid, string->ext4-uuid)
(vhashq, %uuid-parsers, %uuid-printers, string->uuid)
(uuid->string): Move to...
* gnu/system/uuid.scm: ... here.  New file.
* gnu/system/file-systems.scm (uuid): Move to the above file.
* gnu/system/vm.scm: Adjust accordingly.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add uuid.scm.
---
 gnu/build/file-systems.scm  | 167 +-------------------------------
 gnu/build/vm.scm            |   2 +-
 gnu/local.mk                |   1 +
 gnu/system/file-systems.scm |  22 +----
 gnu/system/uuid.scm         | 227 ++++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 234 insertions(+), 185 deletions(-)
 create mode 100644 gnu/system/uuid.scm

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index fbaf15895..32885f1d2 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -19,6 +19,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu build file-systems)
+  #:use-module (gnu system uuid)
   #:use-module (guix build utils)
   #:use-module (guix build bournish)
   #:use-module (guix build syscalls)
@@ -26,9 +27,6 @@
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
-  #:use-module (ice-9 format)
-  #:use-module (ice-9 regex)
-  #:use-module (ice-9 vlist)
   #:use-module (system foreign)
   #:autoload   (system repl repl) (start-repl)
   #:use-module (srfi srfi-1)
@@ -42,17 +40,6 @@
             find-partition-by-luks-uuid
             canonicalize-device-spec
 
-            uuid->string
-            dce-uuid->string
-            string->uuid
-            string->dce-uuid
-            string->iso9660-uuid
-            string->ext2-uuid
-            string->ext3-uuid
-            string->ext4-uuid
-            string->btrfs-uuid
-            iso9660-uuid->string
-
             bind-mount
 
             mount-flags->bit-mask
@@ -98,20 +85,6 @@ takes a bytevector and returns #t when it's a valid superblock."
                      (and (magic? block)
                           block)))))))))
 
-(define (sub-bytevector bv start size)
-  "Return a copy of the SIZE bytes of BV starting from offset START."
-  (let ((result (make-bytevector size)))
-    (bytevector-copy! bv start result 0 size)
-    result))
-
-(define (latin1->string bv terminator)
-  "Return a string of BV, a latin1 bytevector, or #f.  TERMINATOR is a predicate
-that takes a number and returns #t when a termination character is found."
-    (let ((bytes (take-while (negate terminator) (bytevector->u8-list bv))))
-      (if (null? bytes)
-          #f
-          (list->string (map integer->char bytes)))))
-
 (define null-terminated-latin1->string
   (cut latin1->string <> zero?))
 
@@ -199,10 +172,6 @@ if DEVICE does not contain a btrfs file system."
 
 ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-107.pdf>.
 
-(define-syntax %fat32-endianness
-  ;; Endianness of fat file systems.
-  (identifier-syntax (endianness little)))
-
 (define (fat32-superblock? sblock)
   "Return #t when SBLOCK is a fat32 superblock."
   (bytevector=? (sub-bytevector sblock 82 8)
@@ -217,12 +186,6 @@ if DEVICE does not contain a btrfs file system."
   "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
   (sub-bytevector sblock 67 4))
 
-(define (fat32-uuid->string uuid)
-  "Convert fat32 UUID, a 4-byte bytevector, to its string representation."
-  (let ((high  (bytevector-uint-ref uuid 0 %fat32-endianness 2))
-        (low (bytevector-uint-ref uuid 2 %fat32-endianness 2)))
-    (format #f "~:@(~x-~x~)" low high)))
-
 (define (fat32-superblock-volume-name sblock)
   "Return the volume name of SBLOCK as a string of at most 11 characters, or
 #f if SBLOCK has no volume name.  The volume name is a latin1 string.
@@ -244,27 +207,6 @@ Trailing spaces are trimmed."
 
 ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.
 
-(define %iso9660-uuid-rx
-  ;;                   Y                m                d                H                M                S                ss
-  (make-regexp "^([[:digit:]]{4})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})$"))
-
-(define (string->iso9660-uuid str)
-  "Parse STR as a ISO9660 UUID (which is really a timestamp - see /dev/disk/by-uuid).
-Return its contents as a 16-byte bytevector.  Return #f if STR is not a valid
-ISO9660 UUID representation."
-  (and=> (regexp-exec %iso9660-uuid-rx str)
-         (lambda (match)
-           (letrec-syntax ((match-numerals
-                            (syntax-rules ()
-                              ((_ index (name rest ...) body)
-                               (let ((name (match:substring match index)))
-                                 (match-numerals (+ 1 index) (rest ...) body)))
-                              ((_ index () body)
-                               body))))
-            (match-numerals 1 (year month day hour minute second hundredths)
-              (string->utf8 (string-append year month day
-                                           hour minute second hundredths)))))))
-
 (define (iso9660-superblock? sblock)
   "Return #t when SBLOCK is an iso9660 volume descriptor."
   (bytevector=? (sub-bytevector sblock 1 6)
@@ -311,20 +253,6 @@ SBLOCK as a bytevector.  If that's not set, returns the creation time."
                    modification-time)))
     (sub-bytevector time 0 16))) ; strips GMT offset.
 
-(define (iso9660-uuid->string uuid)
-  "Given an UUID bytevector, return its timestamp string."
-  (define (digits->string bytes)
-    (latin1->string bytes (lambda (c) #f)))
-  (let* ((year (sub-bytevector uuid 0 4))
-         (month (sub-bytevector uuid 4 2))
-         (day (sub-bytevector uuid 6 2))
-         (hour (sub-bytevector uuid 8 2))
-         (minute (sub-bytevector uuid 10 2))
-         (second (sub-bytevector uuid 12 2))
-         (hundredths (sub-bytevector uuid 14 2))
-         (parts (list year month day hour minute second hundredths)))
-    (string-append (string-join (map digits->string parts) "-"))))
-
 (define (iso9660-superblock-volume-name sblock)
   "Return the volume name of SBLOCK as a string.  The volume name is an ASCII
 string.  Trailing spaces are trimmed."
@@ -512,99 +440,6 @@ were found."
   (find-partition luks-partition-uuid-predicate))
 
 \f
-;;;
-;;; UUIDs.
-;;;
-
-(define-syntax %network-byte-order
-  (identifier-syntax (endianness big)))
-
-(define (dce-uuid->string uuid)
-  "Convert UUID, a 16-byte bytevector, to its string representation, something
-like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
-  ;; See <https://tools.ietf.org/html/rfc4122>.
-  (let ((time-low  (bytevector-uint-ref uuid 0 %network-byte-order 4))
-        (time-mid  (bytevector-uint-ref uuid 4 %network-byte-order 2))
-        (time-hi   (bytevector-uint-ref uuid 6 %network-byte-order 2))
-        (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
-        (node      (bytevector-uint-ref uuid 10 %network-byte-order 6)))
-    (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
-            time-low time-mid time-hi clock-seq node)))
-
-(define %uuid-rx
-  ;; The regexp of a UUID.
-  (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
-
-(define (string->dce-uuid str)
-  "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
-return its contents as a 16-byte bytevector.  Return #f if STR is not a valid
-UUID representation."
-  (and=> (regexp-exec %uuid-rx str)
-         (lambda (match)
-           (letrec-syntax ((hex->number
-                            (syntax-rules ()
-                              ((_ index)
-                               (string->number (match:substring match index)
-                                               16))))
-                           (put!
-                            (syntax-rules ()
-                              ((_ bv index (number len) rest ...)
-                               (begin
-                                 (bytevector-uint-set! bv index number
-                                                       (endianness big) len)
-                                 (put! bv (+ index len) rest ...)))
-                              ((_ bv index)
-                               bv))))
-             (let ((time-low  (hex->number 1))
-                   (time-mid  (hex->number 2))
-                   (time-hi   (hex->number 3))
-                   (clock-seq (hex->number 4))
-                   (node      (hex->number 5))
-                   (uuid      (make-bytevector 16)))
-               (put! uuid 0
-                     (time-low 4) (time-mid 2) (time-hi 2)
-                     (clock-seq 2) (node 6)))))))
-
-(define string->ext2-uuid string->dce-uuid)
-(define string->ext3-uuid string->dce-uuid)
-(define string->ext4-uuid string->dce-uuid)
-(define string->btrfs-uuid string->dce-uuid)
-
-(define-syntax vhashq
-  (syntax-rules (=>)
-    ((_)
-     vlist-null)
-    ((_ (key others ... => value) rest ...)
-     (vhash-consq key value
-                  (vhashq (others ... => value) rest ...)))
-    ((_ (=> value) rest ...)
-     (vhashq rest ...))))
-
-(define %uuid-parsers
-  (vhashq
-   ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid)
-   ('iso9660 => string->iso9660-uuid)))
-
-(define %uuid-printers
-  (vhashq
-   ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => dce-uuid->string)
-   ('iso9660 => iso9660-uuid->string)
-   ('fat32 'fat => fat32-uuid->string)))
-
-(define* (string->uuid str #:key (type 'dce))
-  "Parse STR as a UUID of the given TYPE.  On success, return the
-corresponding bytevector; otherwise return #f."
-  (match (vhash-assq type %uuid-parsers)
-    (#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))))
-
-\f
 (define* (canonicalize-device-spec spec #:optional (title 'any))
   "Return the device name corresponding to SPEC.  TITLE is a symbol, one of
 the following:
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 8dfaf2789..4298eebd7 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -26,7 +26,7 @@
   #:use-module (guix build syscalls)
   #:use-module (gnu build linux-boot)
   #:use-module (gnu build install)
-  #:use-module (gnu build file-systems)
+  #:use-module (gnu system uuid)
   #:use-module (guix records)
   #:use-module ((guix combinators) #:select (fold2))
   #:use-module (ice-9 format)
diff --git a/gnu/local.mk b/gnu/local.mk
index 643a88db8..6d75ba319 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -468,6 +468,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/system/nss.scm				\
   %D%/system/pam.scm				\
   %D%/system/shadow.scm				\
+  %D%/system/uuid.scm				\
   %D%/system/vm.scm				\
 						\
   %D%/build/activation.scm			\
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index bbac23fbd..dd30559d7 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -20,9 +20,10 @@
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (guix records)
-  #:use-module ((gnu build file-systems)
-                #:select (string->uuid uuid->string))
-  #:re-export (string->uuid
+  #:use-module ((gnu system uuid)
+                #:select (uuid string->uuid uuid->string))
+  #:re-export (uuid                               ;backward compatibility
+               string->uuid
                uuid->string)
   #:export (<file-system>
             file-system
@@ -44,7 +45,6 @@
             file-system->spec
             spec->file-system
             specification->file-system-mapping
-            uuid
 
             %fuse-control-file-system
             %binary-format-file-system
@@ -186,20 +186,6 @@ TARGET in the other system."
          (target spec)
          (writable? writable?)))))
 
-(define-syntax uuid
-  (lambda (s)
-    "Return the bytevector corresponding to the given UUID representation."
-    (syntax-case s ()
-      ((_ str)
-       (string? (syntax->datum #'str))
-       ;; A literal string: do the conversion at expansion time.
-       (let ((bv (string->uuid (syntax->datum #'str))))
-         (unless bv
-           (syntax-violation 'uuid "invalid UUID" s))
-         (datum->syntax #'str bv)))
-      ((_ str)
-       #'(string->uuid str)))))
-
 \f
 ;;;
 ;;; Common file systems.
diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm
new file mode 100644
index 000000000..64dad5a37
--- /dev/null
+++ b/gnu/system/uuid.scm
@@ -0,0 +1,227 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu system uuid)
+  #:use-module (srfi srfi-1)
+  #: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->string
+            dce-uuid->string
+            string->uuid
+            string->dce-uuid
+            string->iso9660-uuid
+            string->ext2-uuid
+            string->ext3-uuid
+            string->ext4-uuid
+            string->btrfs-uuid
+            iso9660-uuid->string
+
+            ;; XXX: For lack of a better place.
+            sub-bytevector
+            latin1->string))
+
+\f
+;;;
+;;; Tools that lack a better place.
+;;;
+
+(define (sub-bytevector bv start size)
+  "Return a copy of the SIZE bytes of BV starting from offset START."
+  (let ((result (make-bytevector size)))
+    (bytevector-copy! bv start result 0 size)
+    result))
+
+(define (latin1->string bv terminator)
+  "Return a string of BV, a latin1 bytevector, or #f.  TERMINATOR is a predicate
+that takes a number and returns #t when a termination character is found."
+    (let ((bytes (take-while (negate terminator) (bytevector->u8-list bv))))
+      (if (null? bytes)
+          #f
+          (list->string (map integer->char bytes)))))
+
+\f
+;;;
+;;; DCE UUIDs.
+;;;
+
+(define-syntax %network-byte-order
+  (identifier-syntax (endianness big)))
+
+(define (dce-uuid->string uuid)
+  "Convert UUID, a 16-byte bytevector, to its string representation, something
+like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
+  ;; See <https://tools.ietf.org/html/rfc4122>.
+  (let ((time-low  (bytevector-uint-ref uuid 0 %network-byte-order 4))
+        (time-mid  (bytevector-uint-ref uuid 4 %network-byte-order 2))
+        (time-hi   (bytevector-uint-ref uuid 6 %network-byte-order 2))
+        (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
+        (node      (bytevector-uint-ref uuid 10 %network-byte-order 6)))
+    (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
+            time-low time-mid time-hi clock-seq node)))
+
+(define %uuid-rx
+  ;; The regexp of a UUID.
+  (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
+
+(define (string->dce-uuid str)
+  "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
+return its contents as a 16-byte bytevector.  Return #f if STR is not a valid
+UUID representation."
+  (and=> (regexp-exec %uuid-rx str)
+         (lambda (match)
+           (letrec-syntax ((hex->number
+                            (syntax-rules ()
+                              ((_ index)
+                               (string->number (match:substring match index)
+                                               16))))
+                           (put!
+                            (syntax-rules ()
+                              ((_ bv index (number len) rest ...)
+                               (begin
+                                 (bytevector-uint-set! bv index number
+                                                       (endianness big) len)
+                                 (put! bv (+ index len) rest ...)))
+                              ((_ bv index)
+                               bv))))
+             (let ((time-low  (hex->number 1))
+                   (time-mid  (hex->number 2))
+                   (time-hi   (hex->number 3))
+                   (clock-seq (hex->number 4))
+                   (node      (hex->number 5))
+                   (uuid      (make-bytevector 16)))
+               (put! uuid 0
+                     (time-low 4) (time-mid 2) (time-hi 2)
+                     (clock-seq 2) (node 6)))))))
+
+\f
+;;;
+;;; ISO-9660.
+;;;
+
+;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.
+
+(define %iso9660-uuid-rx
+  ;;                   Y                m                d                H                M                S                ss
+  (make-regexp "^([[:digit:]]{4})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})$"))
+(define (string->iso9660-uuid str)
+  "Parse STR as a ISO9660 UUID (which is really a timestamp - see /dev/disk/by-uuid).
+Return its contents as a 16-byte bytevector.  Return #f if STR is not a valid
+ISO9660 UUID representation."
+  (and=> (regexp-exec %iso9660-uuid-rx str)
+         (lambda (match)
+           (letrec-syntax ((match-numerals
+                            (syntax-rules ()
+                              ((_ index (name rest ...) body)
+                               (let ((name (match:substring match index)))
+                                 (match-numerals (+ 1 index) (rest ...) body)))
+                              ((_ index () body)
+                               body))))
+            (match-numerals 1 (year month day hour minute second hundredths)
+              (string->utf8 (string-append year month day
+                                           hour minute second hundredths)))))))
+(define (iso9660-uuid->string uuid)
+  "Given an UUID bytevector, return its timestamp string."
+  (define (digits->string bytes)
+    (latin1->string bytes (lambda (c) #f)))
+  (let* ((year (sub-bytevector uuid 0 4))
+         (month (sub-bytevector uuid 4 2))
+         (day (sub-bytevector uuid 6 2))
+         (hour (sub-bytevector uuid 8 2))
+         (minute (sub-bytevector uuid 10 2))
+         (second (sub-bytevector uuid 12 2))
+         (hundredths (sub-bytevector uuid 14 2))
+         (parts (list year month day hour minute second hundredths)))
+    (string-append (string-join (map digits->string parts) "-"))))
+
+\f
+;;;
+;;; FAT32.
+;;;
+
+(define-syntax %fat32-endianness
+  ;; Endianness of FAT file systems.
+  (identifier-syntax (endianness little)))
+
+(define (fat32-uuid->string uuid)
+  "Convert fat32 UUID, a 4-byte bytevector, to its string representation."
+  (let ((high  (bytevector-uint-ref uuid 0 %fat32-endianness 2))
+        (low (bytevector-uint-ref uuid 2 %fat32-endianness 2)))
+    (format #f "~:@(~x-~x~)" low high)))
+
+\f
+;;;
+;;; Generic interface.
+;;;
+
+(define string->ext2-uuid string->dce-uuid)
+(define string->ext3-uuid string->dce-uuid)
+(define string->ext4-uuid string->dce-uuid)
+(define string->btrfs-uuid string->dce-uuid)
+
+(define-syntax vhashq
+  (syntax-rules (=>)
+    ((_)
+     vlist-null)
+    ((_ (key others ... => value) rest ...)
+     (vhash-consq key value
+                  (vhashq (others ... => value) rest ...)))
+    ((_ (=> value) rest ...)
+     (vhashq rest ...))))
+
+(define %uuid-parsers
+  (vhashq
+   ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid)
+   ('iso9660 => string->iso9660-uuid)))
+
+(define %uuid-printers
+  (vhashq
+   ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => dce-uuid->string)
+   ('iso9660 => iso9660-uuid->string)
+   ('fat32 'fat => fat32-uuid->string)))
+
+(define* (string->uuid str #:key (type 'dce))
+  "Parse STR as a UUID of the given TYPE.  On success, return the
+corresponding bytevector; otherwise return #f."
+  (match (vhash-assq type %uuid-parsers)
+    (#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))))
+
+(define-syntax uuid
+  (lambda (s)
+    "Return the bytevector corresponding to the given UUID representation."
+    (syntax-case s ()
+      ((_ str)
+       (string? (syntax->datum #'str))
+       ;; A literal string: do the conversion at expansion time.
+       (let ((bv (string->uuid (syntax->datum #'str))))
+         (unless bv
+           (syntax-violation 'uuid "invalid UUID" s))
+         (datum->syntax #'str bv)))
+      ((_ str)
+       #'(string->uuid str)))))
-- 
2.14.1

[bug#28377] [PATCH 05/10] services: file-system: Use 'file-system->spec'.

[Ludovic Courtès]

* gnu/services/base.scm (file-system-shepherd-service): Use
'file-system->spec' instead of in-line code.
---
 gnu/services/base.scm | 10 ++--------
 1 file changed, 2 insertions(+), 8 deletions(-)

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 23ef2d4bf..b8feb725d 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -29,6 +29,7 @@
   #:use-module (gnu services networking)
   #:use-module (gnu system pam)
   #:use-module (gnu system shadow)                ; 'user-account', etc.
+  #:use-module (gnu system uuid)
   #:use-module (gnu system file-systems)          ; 'file-system', etc.
   #:use-module (gnu system mapped-devices)
   #:use-module ((gnu system linux-initrd)
@@ -277,12 +278,6 @@ FILE-SYSTEM."
   "Return the shepherd service for @var{file-system}, or @code{#f} if
 @var{file-system} is not auto-mounted upon boot."
   (let ((target  (file-system-mount-point file-system))
-        (device  (file-system-device file-system))
-        (type    (file-system-type file-system))
-        (title   (file-system-title file-system))
-        (flags   (file-system-flags file-system))
-        (options (file-system-options file-system))
-        (check?  (file-system-check? file-system))
         (create? (file-system-create-mount-point? file-system))
         (dependencies (file-system-dependencies file-system))
         (packages (file-system-packages (list file-system))))
@@ -311,8 +306,7 @@ FILE-SYSTEM."
                                                                 '#$packages))))
                            (lambda ()
                              (mount-file-system
-                              `(#$device #$title #$target #$type #$flags
-                                         #$options #$check?)
+                              '#$(file-system->spec file-system)
                               #:root "/"))
                            (lambda ()
                              (setenv "PATH" $PATH)))
-- 
2.14.1

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

[Ludovic Courtès]

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

[bug#28377] [PATCH 07/10] system: Serialize the UUID type in the "parameters" file.

[Ludovic Courtès]

* gnu/system.scm (read-boot-parameters)[device->sexp]: New procedure.
Use it for 'root-device' and 'store-device'.
(device->sexp): Serialize the UUID type in addition to its bytevector.
---
 gnu/system.scm | 18 ++++++++++++------
 1 file changed, 12 insertions(+), 6 deletions(-)

diff --git a/gnu/system.scm b/gnu/system.scm
index a8d2a8131..6f795d629 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -234,6 +234,15 @@ directly by the user."
 (define (read-boot-parameters port)
   "Read boot parameters from PORT and return the corresponding
 <boot-parameters> object or #f if the format is unrecognized."
+  (define device-sexp->device
+    (match-lambda
+      (('uuid (? symbol? type) (? bytevector? bv))
+       (bytevector->uuid bv type))
+      ((? bytevector? bv)                         ;old format
+       (bytevector->uuid bv 'dce))
+      ((? string? device)
+       device)))
+
   (match (read port)
     (('boot-parameters ('version 0)
                        ('label label) ('root-device root)
@@ -241,7 +250,7 @@ directly by the user."
                        rest ...)
      (boot-parameters
       (label label)
-      (root-device root)
+      (root-device (device->sexp root))
 
       (bootloader-name
        (match (assq 'bootloader-name rest)
@@ -269,10 +278,8 @@ directly by the user."
 
       (store-device
        (match (assq 'store rest)
-         (('store ('device (? bytevector? bv)) _ ...)
-          (bytevector->uuid bv))
          (('store ('device device) _ ...)
-          device)
+          (device-sexp->device device))
          (_                                       ;the old format
           ;; Root might be a device path like "/dev/sda1", which is not a
           ;; suitable GRUB device identifier.
@@ -925,8 +932,7 @@ kernel arguments for that derivation to <boot-parameters>."
   "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))
+     `(uuid ,(uuid-type uuid) ,(uuid-bytevector uuid)))
     (_
      device)))
 
-- 
2.14.1

[bug#28377] [PATCH 08/10] uuid: 'uuid' macro supports more UUID types.

[Ludovic Courtès]

* gnu/system/uuid.scm (string->uuid): Turn 'type' into an optional
argument.
(uuid): Add clauses to allow for an optional 'type' parameter.
---
 gnu/system/uuid.scm | 22 ++++++++++++++--------
 1 file changed, 14 insertions(+), 8 deletions(-)

diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm
index 60626ebb1..1dd6a1133 100644
--- a/gnu/system/uuid.scm
+++ b/gnu/system/uuid.scm
@@ -206,7 +206,7 @@ ISO9660 UUID representation."
    ('iso9660 => iso9660-uuid->string)
    ('fat32 'fat => fat32-uuid->string)))
 
-(define* (string->uuid str #:key (type 'dce))
+(define* (string->uuid str #:optional (type 'dce))
   "Parse STR as a UUID of the given TYPE.  On success, return the
 corresponding bytevector; otherwise return #f."
   (match (vhash-assq type %uuid-parsers)
@@ -233,17 +233,23 @@ corresponding bytevector; otherwise return #f."
 (define-syntax uuid
   (lambda (s)
     "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))
+    (syntax-case s (quote)
+      ((_ str (quote type))
+       (and (string? (syntax->datum #'str))
+            (identifier? #'type))
        ;; A literal string: do the conversion at expansion time.
-       (let ((bv (string->uuid (syntax->datum #'str))))
+       (let ((bv (string->uuid (syntax->datum #'str)
+                               (syntax->datum #'type))))
          (unless bv
            (syntax-violation 'uuid "invalid UUID" s))
-         #`(make-uuid 'dce #,(datum->syntax #'str bv))))
+         #`(make-uuid 'type #,(datum->syntax s bv))))
       ((_ str)
-       #'(make-uuid 'dce (string->uuid str))))))
+       (string? (syntax->datum #'str))
+       #'(uuid str 'dce))
+      ((_ str)
+       #'(make-uuid 'dce (string->uuid str 'dce)))
+      ((_ str type)
+       #'(make-uuid type (string->uuid str type))))))
 
 (define uuid->string
   ;; Convert the given bytevector or UUID object, to the corresponding UUID
-- 
2.14.1

[bug#28377] [PATCH 09/10] vm: Allow users to specify a UUID for the root partition.

[Ludovic Courtès]

* gnu/system/vm.scm (qemu-image): Add #:file-system-uuid parameter; pass
it as the 'uuid' field of the root partition.
---
 gnu/system/vm.scm | 8 +++++++-
 1 file changed, 7 insertions(+), 1 deletion(-)

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 1807946cb..73d830bf0 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -240,6 +240,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
@@ -249,7 +250,10 @@ INPUTS is a list of inputs (as for packages)."
   "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
 'qcow2' or 'raw'), with a root partition of type FILE-SYSTEM-TYPE.
 Optionally, FILE-SYSTEM-LABEL can be specified as the volume name for the root
-partition.  The returned image is a full disk image that runs OS-DERIVATION,
+partition; likewise FILE-SYSTEM-UUID, if true, is the UUID of the root
+partition (a UUID object).
+
+The returned image is a full disk image that runs OS-DERIVATION,
 with a GRUB installation that uses GRUB-CONFIGURATION as its configuration
 file (GRUB-CONFIGURATION must be the name of a file in the VM.)
 
@@ -299,6 +303,8 @@ the image."
                   (partitions (list (partition
                                      (size root-size)
                                      (label #$file-system-label)
+                                     (uuid #$(and=> file-system-uuid
+                                                    uuid-bytevector))
                                      (file-system #$file-system-type)
                                      (flags '(boot))
                                      (initializer initialize))
-- 
2.14.1

[bug#28377] [PATCH 10/10] vm: Generate a UUID to identify the root file system.

[Ludovic Courtès]

This makes collisions less likely than when using a label to look up the
partition.  See <https://bugs.gnu.org/27735>.

* gnu/system/vm.scm (operating-system-uuid): New procedure.
(system-disk-image): Define 'root-uuid' and use it for the root file
system.  Pass it to 'iso9660-image' and 'qemu-image'.
---
 gnu/system/vm.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 45 insertions(+), 6 deletions(-)

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 73d830bf0..d947fd605 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -61,6 +61,7 @@
 
   #: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
@@ -342,6 +343,35 @@ the image."
 ;;; VM and disk images.
 ;;;
 
+(define* (operating-system-uuid os #:optional (type 'dce))
+  "Compute UUID object with a deterministic \"UUID\" for OS, of the given
+TYPE (one of 'iso9660 or 'dce).  Return a UUID object."
+  (if (eq? type 'iso9660)
+      (let ((pad (compose (cut string-pad <> 2 #\0)
+                          number->string))
+            (h   (hash (operating-system-services os) 3600)))
+        (bytevector->uuid
+         (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))))
+         'iso9660))
+      (bytevector->uuid
+       (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)
+       type)))
+
 (define* (system-disk-image os
                             #:key
                             (name "disk-image")
@@ -358,12 +388,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) "/"))
@@ -387,8 +425,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)))))
 
@@ -397,7 +435,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
@@ -413,6 +451,7 @@ to USB sticks meant to be read-only."
                       #:disk-image-format "raw"
                       #:file-system-type file-system-type
                       #:file-system-label root-label
+                      #:file-system-uuid root-uuid
                       #:copy-inputs? #t
                       #:register-closures? #t
                       #:inputs `(("system" ,os-drv)
-- 
2.14.1

[bug#28377] [PATCH 02/10] file-systems: Add UUID type dictionaries.

[Danny Milosavljevic]

> +(define %uuid-parsers
> +  (vhashq
> +   ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid)
> +   ('iso9660 => string->iso9660-uuid)))

No fat32?

Otherwise LGTM!

[bug#28377] [PATCH 03/10] services: base: Import the closure of (gnu build file-systems).

[Danny Milosavljevic]

LGTM!

[bug#28377] [PATCH 04/10] file-systems: Introduce (gnu system uuid).

[Danny Milosavljevic]

LGTM!

[bug#28377] [PATCH 05/10] services: file-system: Use 'file-system->spec'.

[Danny Milosavljevic]

LGTM!

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

[Danny Milosavljevic]

> +(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.

Yes :)

Otherwise LGTM!

[bug#28377] [PATCH 07/10] system: Serialize the UUID type in the "parameters" file.

[Danny Milosavljevic]

> -     ;; TODO: Preserve the type of UUID.
> -     (uuid-bytevector uuid))
> +     `(uuid ,(uuid-type uuid) ,(uuid-bytevector uuid)))

Ah okay.

LGTM!

[bug#28377] [PATCH 02/10] file-systems: Add UUID type dictionaries.

[Ludovic Courtès]

Hi Danny,

Danny Milosavljevic <dannym@scratchpost.org> skribis:

>> +(define %uuid-parsers
>> +  (vhashq
>> +   ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid)
>> +   ('iso9660 => string->iso9660-uuid)))
>
> No fat32?

Yes, because we don’t have a FAT32 parser currently, only a printer
(‘fat32-uuid->string’).

> Otherwise LGTM!

Thanks for reviewing this!

Ludo’.

[bug#28377] [PATCH 09/10] vm: Allow users to specify a UUID for the root partition.

[Danny Milosavljevic]

On Thu,  7 Sep 2017 00:17:55 +0200
Ludovic Courtès <ludo@gnu.org> wrote:

> +partition; likewise FILE-SYSTEM-UUID, if true, is the UUID of the root

                                            ^^^ ??      ^^^^^^ which is it? 

Probably meant "not #f".

Otherwise LGTM!

[bug#28377] [PATCH 10/10] vm: Generate a UUID to identify the root file system.

[Danny Milosavljevic]

LGTM!

bug#28377: [PATCH 09/10] vm: Allow users to specify a UUID for the root partition.

[Ludovic Courtès]

Danny Milosavljevic <dannym@scratchpost.org> skribis:

> On Thu,  7 Sep 2017 00:17:55 +0200
> Ludovic Courtès <ludo@gnu.org> wrote:
>
>> +partition; likewise FILE-SYSTEM-UUID, if true, is the UUID of the root
>
>                                             ^^^ ??      ^^^^^^ which is it? 
>
> Probably meant "not #f".

Yes.  In Scheme only #f is false; any other value is true.

I’ve replaced “is the UUID…” by “specifies the UUID…”, which is
hopefully clearer.

I’ve now pushed the whole series.  Thanks for reviewing!

Ludo’.