;;; 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.
;;;
(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
+ uuid=?
+
+ bytevector->uuid
+
uuid->string
dce-uuid->string
string->uuid
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.
\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
;;;
(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 (=>)
(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 #: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)
(#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 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)
+ 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."
- (syntax-case s ()
- ((_ str)
- (string? (syntax->datum #'str))
+ "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))
+ (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))
- (datum->syntax #'str bv)))
+ #`(make-uuid 'type #,(datum->syntax s bv))))
+ ((_ str)
+ (string? (syntax->datum #'str))
+ #'(uuid str 'dce))
((_ str)
- #'(string->uuid str)))))
+ #'(let ((bv (string->uuid str 'dce)))
+ (and bv (make-uuid 'dce bv))))
+ ((_ 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
+ ;; 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)))))
+
+(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))))
HCoop / jackhill / guix / guix.git / blobdiff