1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.org>
4 ;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
6 ;;; This file is part of GNU Guix.
8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
13 ;;; GNU Guix is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;;; GNU General Public License for more details.
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
21 (define-module (gnu system uuid)
22 #:use-module (srfi srfi-1)
23 #:use-module (srfi srfi-9)
24 #:use-module (rnrs bytevectors)
25 #:use-module (ice-9 match)
26 #:use-module (ice-9 vlist)
27 #:use-module (ice-9 regex)
28 #:use-module (ice-9 format)
51 ;; XXX: For lack of a better place.
57 ;;; Tools that lack a better place.
60 (define (sub-bytevector bv start size)
61 "Return a copy of the SIZE bytes of BV starting from offset START."
62 (let ((result (make-bytevector size)))
63 (bytevector-copy! bv start result 0 size)
66 (define (latin1->string bv terminator)
67 "Return a string of BV, a latin1 bytevector, or #f. TERMINATOR is a predicate
68 that takes a number and returns #t when a termination character is found."
69 (let ((bytes (take-while (negate terminator) (bytevector->u8-list bv))))
72 (list->string (map integer->char bytes)))))
79 (define-syntax %network-byte-order
80 (identifier-syntax (endianness big)))
82 (define (dce-uuid->string uuid)
83 "Convert UUID, a 16-byte bytevector, to its string representation, something
84 like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
85 ;; See <https://tools.ietf.org/html/rfc4122>.
86 (let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4))
87 (time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2))
88 (time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2))
89 (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
90 (node (bytevector-uint-ref uuid 10 %network-byte-order 6)))
91 (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
92 time-low time-mid time-hi clock-seq node)))
95 ;; The regexp of a UUID.
96 (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
98 (define (string->dce-uuid str)
99 "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
100 return its contents as a 16-byte bytevector. Return #f if STR is not a valid
101 UUID representation."
102 (and=> (regexp-exec %uuid-rx str)
104 (letrec-syntax ((hex->number
107 (string->number (match:substring match index)
111 ((_ bv index (number len) rest ...)
113 (bytevector-uint-set! bv index number
114 (endianness big) len)
115 (put! bv (+ index len) rest ...)))
118 (let ((time-low (hex->number 1))
119 (time-mid (hex->number 2))
120 (time-hi (hex->number 3))
121 (clock-seq (hex->number 4))
122 (node (hex->number 5))
123 (uuid (make-bytevector 16)))
125 (time-low 4) (time-mid 2) (time-hi 2)
126 (clock-seq 2) (node 6)))))))
133 ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.
135 (define %iso9660-uuid-rx
137 (make-regexp "^([[:digit:]]{4})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})$"))
138 (define (string->iso9660-uuid str)
139 "Parse STR as a ISO9660 UUID (which is really a timestamp - see /dev/disk/by-uuid).
140 Return its contents as a 16-byte bytevector. Return #f if STR is not a valid
141 ISO9660 UUID representation."
142 (and=> (regexp-exec %iso9660-uuid-rx str)
144 (letrec-syntax ((match-numerals
146 ((_ index (name rest ...) body)
147 (let ((name (match:substring match index)))
148 (match-numerals (+ 1 index) (rest ...) body)))
151 (match-numerals 1 (year month day hour minute second hundredths)
152 (string->utf8 (string-append year month day
153 hour minute second hundredths)))))))
154 (define (iso9660-uuid->string uuid)
155 "Given an UUID bytevector, return its timestamp string."
156 (define (digits->string bytes)
157 (latin1->string bytes (lambda (c) #f)))
158 (let* ((year (sub-bytevector uuid 0 4))
159 (month (sub-bytevector uuid 4 2))
160 (day (sub-bytevector uuid 6 2))
161 (hour (sub-bytevector uuid 8 2))
162 (minute (sub-bytevector uuid 10 2))
163 (second (sub-bytevector uuid 12 2))
164 (hundredths (sub-bytevector uuid 14 2))
165 (parts (list year month day hour minute second hundredths)))
166 (string-append (string-join (map digits->string parts) "-"))))
173 (define-syntax %fat-endianness
174 ;; Endianness of FAT32/FAT16 file systems.
175 (identifier-syntax (endianness little)))
177 (define (fat-uuid->string uuid)
178 "Convert FAT32/FAT16 UUID, a 4-byte bytevector, to its string representation."
179 (let ((high (bytevector-uint-ref uuid 0 %fat-endianness 2))
180 (low (bytevector-uint-ref uuid 2 %fat-endianness 2)))
181 (format #f "~:@(~4,'0x-~4,'0x~)" low high)))
184 (make-regexp "^([[:xdigit:]]{4})-([[:xdigit:]]{4})$"))
186 (define (string->fat-uuid str)
187 "Parse STR, which is in FAT32/FAT16 format, and return a bytevector or #f."
188 (match (regexp-exec %fat-uuid-rx str)
192 (uint-list->bytevector (list (string->number
193 (match:substring rx-match 2) 16)
195 (match:substring rx-match 1) 16))
204 (define-syntax %ntfs-endianness
205 ;; Endianness of NTFS file system.
206 (identifier-syntax (endianness little)))
208 (define (ntfs-uuid->string uuid)
209 "Convert NTFS UUID, a 8-byte bytevector, to its string representation."
210 (format #f "~{~:@(~x~)~}" (reverse (bytevector->u8-list uuid))))
212 (define %ntfs-uuid-rx
213 (make-regexp "^([[:xdigit:]]{16})$"))
215 (define (string->ntfs-uuid str)
216 "Parse STR, which is in NTFS format, and return a bytevector or #f."
217 (match (regexp-exec %ntfs-uuid-rx str)
224 (if (string=? str "")
226 (loop (string-drop str 2)
228 (string->number (string-take str 2) 16)
233 ;;; Generic interface.
236 (define string->ext2-uuid string->dce-uuid)
237 (define string->ext3-uuid string->dce-uuid)
238 (define string->ext4-uuid string->dce-uuid)
239 (define string->btrfs-uuid string->dce-uuid)
240 (define string->jfs-uuid string->dce-uuid)
242 (define-syntax vhashq
246 ((_ (key others ... => value) rest ...)
247 (vhash-consq key value
248 (vhashq (others ... => value) rest ...)))
249 ((_ (=> value) rest ...)
252 (define %uuid-parsers
254 ('dce 'ext2 'ext3 'ext4 'btrfs 'jfs 'luks => string->dce-uuid)
255 ('fat32 'fat16 'fat => string->fat-uuid)
256 ('ntfs => string->ntfs-uuid)
257 ('iso9660 => string->iso9660-uuid)))
259 (define %uuid-printers
261 ('dce 'ext2 'ext3 'ext4 'btrfs 'jfs 'luks => dce-uuid->string)
262 ('iso9660 => iso9660-uuid->string)
263 ('fat32 'fat16 'fat => fat-uuid->string)
264 ('ntfs => ntfs-uuid->string)))
266 (define* (string->uuid str #:optional (type 'dce))
267 "Parse STR as a UUID of the given TYPE. On success, return the
268 corresponding bytevector; otherwise return #f."
269 (match (vhash-assq type %uuid-parsers)
271 ((_ . (? procedure? parse)) (parse str))))
273 ;; High-level UUID representation that carries its type with it.
275 ;; This is necessary to serialize bytevectors with the right printer in some
276 ;; circumstances. For instance, GRUB "search --fs-uuid" command compares the
277 ;; string representation of UUIDs, not the raw bytes; thus, when emitting a
278 ;; GRUB 'search' command, we need to produce the right string representation
279 ;; (see <https://debbugs.gnu.org/cgi/bugreport.cgi?msg=52;att=0;bug=27735>).
280 (define-record-type <uuid>
283 (type uuid-type) ;'dce | 'iso9660 | ...
284 (bv uuid-bytevector))
286 (define* (bytevector->uuid bv #:optional (type 'dce))
287 "Return a UUID object make of BV and TYPE."
292 "Return the UUID object corresponding to the given UUID representation or
293 #f if the string could not be parsed."
294 (syntax-case s (quote)
295 ((_ str (quote type))
296 (and (string? (syntax->datum #'str))
297 (identifier? #'type))
298 ;; A literal string: do the conversion at expansion time.
299 (let ((bv (string->uuid (syntax->datum #'str)
300 (syntax->datum #'type))))
302 (syntax-violation 'uuid "invalid UUID" s))
303 #`(make-uuid 'type #,(datum->syntax s bv))))
305 (string? (syntax->datum #'str))
308 #'(let ((bv (string->uuid str 'dce)))
309 (and bv (make-uuid 'dce bv))))
311 #'(let ((bv (string->uuid str type)))
312 (and bv (make-uuid type bv)))))))
315 ;; Convert the given bytevector or UUID object, to the corresponding UUID
316 ;; string representation.
318 (((? bytevector? bv))
319 (uuid->string bv 'dce))
320 (((? bytevector? bv) type)
321 (match (vhash-assq type %uuid-printers)
323 ((_ . (? procedure? unparse)) (unparse bv))))
325 (uuid->string (uuid-bytevector uuid) (uuid-type uuid)))))
328 ;; Return true if A is equal to B, comparing only the actual bits.
330 (((? bytevector? a) (? bytevector? b))
332 (((? uuid? a) (? bytevector? b))
333 (bytevector=? (uuid-bytevector a) b))
334 (((? uuid? a) (? uuid? b))
335 (bytevector=? (uuid-bytevector a) (uuid-bytevector b)))
336 (((or (? uuid? a) (? bytevector? a)) (or (? uuid? b) (? bytevector? b)))