file-systems: Introduce (gnu system uuid).

* 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

@@ -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."
@@ -511,99 +439,6 @@ were found."
 (define find-partition-by-luks-uuid
   (find-partition luks-partition-uuid-predicate))
 
-
-;;;
-;;; 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))))
-
 
 (define* (canonicalize-device-spec spec #:optional (title 'any))
   "Return the device name corresponding to SPEC.  TITLE is a symbol, one of

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)

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			\

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)
+  #:use-module ((gnu system uuid)
-                #:select (string->uuid uuid->string))
+                #:select (uuid string->uuid uuid->string))
-  #:re-export (string->uuid
+  #: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)))))
-
 
 ;;;
 ;;; Common file systems.

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))
+
+
+;;;
+;;; 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)))))
+
+
+;;;
+;;; 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)))))))
+
+
+;;;
+;;; 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) "-"))))
+
+
+;;;
+;;; 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)))
+
+
+;;;
+;;; 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)))))