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.
This commit is contained in:
Ludovic Courtès
parent
943e1b975f
commit
47cef4ecad
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; Common file systems.
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
Loading…
Reference in New Issue