guix system: 'docker-image' honors '--network'.

[jackhill/guix/guix.git] / gnu / system / uuid.scm

diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm
index 1dd6a11..225959e 100644 (file)
--- a/gnu/system/uuid.scm
+++ b/gnu/system/uuid.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.org>
+;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +30,7 @@
             uuid?
             uuid-type
             uuid-bytevector
+            uuid=?
 
             bytevector->uuid
 
@@ -41,6 +43,8 @@
             string->ext3-uuid
             string->ext4-uuid
             string->btrfs-uuid
+            string->fat-uuid
+            string->jfs-uuid
             iso9660-uuid->string
 
             ;; XXX: For lack of a better place.
@@ -162,18 +166,34 @@ ISO9660 UUID representation."
 
 \f
 ;;;
-;;; FAT32.
+;;; FAT32/FAT16.
 ;;;
 
-(define-syntax %fat32-endianness
-  ;; Endianness of FAT file systems.
+(define-syntax %fat-endianness
+  ;; Endianness of FAT32/FAT16 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)))
+(define (fat-uuid->string uuid)
+  "Convert FAT32/FAT16 UUID, a 4-byte bytevector, to its string representation."
+  (let ((high  (bytevector-uint-ref uuid 0 %fat-endianness 2))
+        (low (bytevector-uint-ref uuid 2 %fat-endianness 2)))
+    (format #f "~:@(~4,'0x-~4,'0x~)" low high)))
+
+(define %fat-uuid-rx
+  (make-regexp "^([[:xdigit:]]{4})-([[:xdigit:]]{4})$"))
+
+(define (string->fat-uuid str)
+  "Parse STR, which is in FAT32/FAT16 format, and return a bytevector or #f."
+  (match (regexp-exec %fat-uuid-rx str)
+    (#f
+     #f)
+    (rx-match
+     (uint-list->bytevector (list (string->number
+                                   (match:substring rx-match 2) 16)
+                                  (string->number
+                                   (match:substring rx-match 1) 16))
+                            %fat-endianness
+                            2))))
 
 \f
 ;;;
@@ -184,6 +204,7 @@ ISO9660 UUID representation."
 (define string->ext3-uuid string->dce-uuid)
 (define string->ext4-uuid string->dce-uuid)
 (define string->btrfs-uuid string->dce-uuid)
+(define string->jfs-uuid string->dce-uuid)
 
 (define-syntax vhashq
   (syntax-rules (=>)
@@ -197,14 +218,15 @@ ISO9660 UUID representation."
 
 (define %uuid-parsers
   (vhashq
-   ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => string->dce-uuid)
+   ('dce 'ext2 'ext3 'ext4 'btrfs 'jfs 'luks => string->dce-uuid)
+   ('fat32 'fat16 'fat => string->fat-uuid)
    ('iso9660 => string->iso9660-uuid)))
 
 (define %uuid-printers
   (vhashq
-   ('dce 'ext2 'ext3 'ext4 'btrfs 'luks => dce-uuid->string)
+   ('dce 'ext2 'ext3 'ext4 'btrfs 'jfs 'luks => dce-uuid->string)
    ('iso9660 => iso9660-uuid->string)
-   ('fat32 'fat => fat32-uuid->string)))
+   ('fat32 'fat16 'fat => fat-uuid->string)))
 
 (define* (string->uuid str #:optional (type 'dce))
   "Parse STR as a UUID of the given TYPE.  On success, return the
@@ -218,7 +240,7 @@ corresponding bytevector; otherwise return #f."
 ;; 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
+;; GRUB 'search' command, we need to produce 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)
@@ -232,7 +254,8 @@ corresponding bytevector; otherwise return #f."
 
 (define-syntax uuid
   (lambda (s)
-    "Return the UUID object corresponding to the given UUID representation."
+    "Return the UUID object corresponding to the given UUID representation or
+#f if the string could not be parsed."
     (syntax-case s (quote)
       ((_ str (quote type))
        (and (string? (syntax->datum #'str))
@@ -247,9 +270,11 @@ corresponding bytevector; otherwise return #f."
        (string? (syntax->datum #'str))
        #'(uuid str 'dce))
       ((_ str)
-       #'(make-uuid 'dce (string->uuid str 'dce)))
+       #'(let ((bv (string->uuid str 'dce)))
+           (and bv (make-uuid 'dce bv))))
       ((_ str type)
-       #'(make-uuid type (string->uuid str type))))))
+       #'(let ((bv (string->uuid str type)))
+           (and bv (make-uuid type bv)))))))
 
 (define uuid->string
   ;; Convert the given bytevector or UUID object, to the corresponding UUID
@@ -263,3 +288,15 @@ corresponding bytevector; otherwise return #f."
        ((_ . (? procedure? unparse)) (unparse bv))))
     (((? uuid? uuid))
      (uuid->string (uuid-bytevector uuid) (uuid-type uuid)))))
+
+(define uuid=?
+  ;; Return true if A is equal to B, comparing only the actual bits.
+  (match-lambda*
+    (((? bytevector? a) (? bytevector? b))
+     (bytevector=? a b))
+    (((? uuid? a) (? bytevector? b))
+     (bytevector=? (uuid-bytevector a) b))
+    (((? uuid? a) (? uuid? b))
+     (bytevector=? (uuid-bytevector a) (uuid-bytevector b)))
+    ((a b)
+     (uuid=? b a))))