From a8e1247d7d758a0c32d54f8277f40a05711555b8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sat, 19 Aug 2017 23:55:10 +0200
Subject: [PATCH] file-systems: Add UUID type dictionaries.

* 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 203fbdfffb..fbaf158951 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))))
 
 
 (define* (canonicalize-device-spec spec #:optional (title 'any))