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, 2020 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)
52 ;; XXX: For lack of a better place.
58 ;;; Tools that lack a better place.
61 (define (sub-bytevector bv start size)
62 "Return a copy of the SIZE bytes of BV starting from offset START."
63 (let ((result (make-bytevector size)))
64 (bytevector-copy! bv start result 0 size)
67 (define (latin1->string bv terminator)
68 "Return a string of BV, a latin1 bytevector, or #f. TERMINATOR is a predicate
69 that takes a number and returns #t when a termination character is found."
70 (let ((bytes (take-while (negate terminator) (bytevector->u8-list bv))))
73 (list->string (map integer->char bytes)))))
80 (define-syntax %network-byte-order
81 (identifier-syntax (endianness big)))
83 (define (dce-uuid->string uuid)
84 "Convert UUID, a 16-byte bytevector, to its string representation, something
85 like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
86 ;; See <https://tools.ietf.org/html/rfc4122>.
87 (let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4))
88 (time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2))
89 (time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2))
90 (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
91 (node (bytevector-uint-ref uuid 10 %network-byte-order 6)))
92 (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
93 time-low time-mid time-hi clock-seq node)))
96 ;; The regexp of a UUID.
97 (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
99 (define (string->dce-uuid str)
100 "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
101 return its contents as a 16-byte bytevector. Return #f if STR is not a valid
102 UUID representation."
103 (and=> (regexp-exec %uuid-rx str)
105 (letrec-syntax ((hex->number
108 (string->number (match:substring match index)
112 ((_ bv index (number len) rest ...)
114 (bytevector-uint-set! bv index number
115 (endianness big) len)
116 (put! bv (+ index len) rest ...)))
119 (let ((time-low (hex->number 1))
120 (time-mid (hex->number 2))
121 (time-hi (hex->number 3))
122 (clock-seq (hex->number 4))
123 (node (hex->number 5))
124 (uuid (make-bytevector 16)))
126 (time-low 4) (time-mid 2) (time-hi 2)
127 (clock-seq 2) (node 6)))))))
134 ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.
136 (define %iso9660-uuid-rx
138 (make-regexp "^([[:digit:]]{4})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})$"))
139 (define (string->iso9660-uuid str)
140 "Parse STR as a ISO9660 UUID (which is really a timestamp - see /dev/disk/by-uuid).
141 Return its contents as a 16-byte bytevector. Return #f if STR is not a valid
142 ISO9660 UUID representation."
143 (and=> (regexp-exec %iso9660-uuid-rx str)
145 (letrec-syntax ((match-numerals
147 ((_ index (name rest ...) body)
148 (let ((name (match:substring match index)))
149 (match-numerals (+ 1 index) (rest ...) body)))
152 (match-numerals 1 (year month day hour minute second hundredths)
153 (string->utf8 (string-append year month day
154 hour minute second hundredths)))))))
155 (define (iso9660-uuid->string uuid)
156 "Given an UUID bytevector, return its timestamp string."
157 (define (digits->string bytes)
158 (latin1->string bytes (lambda (c) #f)))
159 (let* ((year (sub-bytevector uuid 0 4))
160 (month (sub-bytevector uuid 4 2))
161 (day (sub-bytevector uuid 6 2))
162 (hour (sub-bytevector uuid 8 2))
163 (minute (sub-bytevector uuid 10 2))
164 (second (sub-bytevector uuid 12 2))
165 (hundredths (sub-bytevector uuid 14 2))
166 (parts (list year month day hour minute second hundredths)))
167 (string-append (string-join (map digits->string parts) "-"))))
174 (define-syntax %fat-endianness
175 ;; Endianness of FAT32/FAT16 file systems.
176 (identifier-syntax (endianness little)))
178 (define (fat-uuid->string uuid)
179 "Convert FAT32/FAT16 UUID, a 4-byte bytevector, to its string representation."
180 (let ((high (bytevector-uint-ref uuid 0 %fat-endianness 2))
181 (low (bytevector-uint-ref uuid 2 %fat-endianness 2)))
182 (format #f "~:@(~4,'0x-~4,'0x~)" low high)))
185 (make-regexp "^([[:xdigit:]]{4})-([[:xdigit:]]{4})$"))
187 (define (string->fat-uuid str)
188 "Parse STR, which is in FAT32/FAT16 format, and return a bytevector or #f."
189 (match (regexp-exec %fat-uuid-rx str)
193 (uint-list->bytevector (list (string->number
194 (match:substring rx-match 2) 16)
196 (match:substring rx-match 1) 16))
205 (define-syntax %ntfs-endianness
206 ;; Endianness of NTFS file system.
207 (identifier-syntax (endianness little)))
209 (define (ntfs-uuid->string uuid)
210 "Convert NTFS UUID, a 8-byte bytevector, to its string representation."
211 (format #f "~{~:@(~x~)~}" (reverse (bytevector->u8-list uuid))))
213 (define %ntfs-uuid-rx
214 (make-regexp "^([[:xdigit:]]{16})$"))
216 (define (string->ntfs-uuid str)
217 "Parse STR, which is in NTFS format, and return a bytevector or #f."
218 (match (regexp-exec %ntfs-uuid-rx str)
225 (if (string=? str "")
227 (loop (string-drop str 2)
229 (string->number (string-take str 2) 16)
234 ;;; Generic interface.
237 (define string->ext2-uuid string->dce-uuid)
238 (define string->ext3-uuid string->dce-uuid)
239 (define string->ext4-uuid string->dce-uuid)
240 (define string->bcachefs-uuid string->dce-uuid)
241 (define string->btrfs-uuid string->dce-uuid)
242 (define string->jfs-uuid string->dce-uuid)
244 (define-syntax vhashq
248 ((_ (key others ... => value) rest ...)
249 (vhash-consq key value
250 (vhashq (others ... => value) rest ...)))
251 ((_ (=> value) rest ...)
254 (define %uuid-parsers
256 ('dce 'ext2 'ext3 'ext4 'bcachefs 'btrfs 'jfs 'luks => string->dce-uuid)
257 ('fat32 'fat16 'fat => string->fat-uuid)
258 ('ntfs => string->ntfs-uuid)
259 ('iso9660 => string->iso9660-uuid)))
261 (define %uuid-printers
263 ('dce 'ext2 'ext3 'ext4 'bcachefs 'btrfs 'jfs 'luks => dce-uuid->string)
264 ('iso9660 => iso9660-uuid->string)
265 ('fat32 'fat16 'fat => fat-uuid->string)
266 ('ntfs => ntfs-uuid->string)))
268 (define* (string->uuid str #:optional (type 'dce))
269 "Parse STR as a UUID of the given TYPE. On success, return the
270 corresponding bytevector; otherwise return #f."
271 (match (vhash-assq type %uuid-parsers)
273 ((_ . (? procedure? parse)) (parse str))))
275 ;; High-level UUID representation that carries its type with it.
277 ;; This is necessary to serialize bytevectors with the right printer in some
278 ;; circumstances. For instance, GRUB "search --fs-uuid" command compares the
279 ;; string representation of UUIDs, not the raw bytes; thus, when emitting a
280 ;; GRUB 'search' command, we need to produce the right string representation
281 ;; (see <https://debbugs.gnu.org/cgi/bugreport.cgi?msg=52;att=0;bug=27735>).
282 (define-record-type <uuid>
285 (type uuid-type) ;'dce | 'iso9660 | ...
286 (bv uuid-bytevector))
288 (define* (bytevector->uuid bv #:optional (type 'dce))
289 "Return a UUID object make of BV and TYPE."
294 "Return the UUID object corresponding to the given UUID representation or
295 #f if the string could not be parsed."
296 (syntax-case s (quote)
297 ((_ str (quote type))
298 (and (string? (syntax->datum #'str))
299 (identifier? #'type))
300 ;; A literal string: do the conversion at expansion time.
301 (let ((bv (string->uuid (syntax->datum #'str)
302 (syntax->datum #'type))))
304 (syntax-violation 'uuid "invalid UUID" s))
305 #`(make-uuid 'type #,(datum->syntax s bv))))
307 (string? (syntax->datum #'str))
310 #'(let ((bv (string->uuid str 'dce)))
311 (and bv (make-uuid 'dce bv))))
313 #'(let ((bv (string->uuid str type)))
314 (and bv (make-uuid type bv)))))))
317 ;; Convert the given bytevector or UUID object, to the corresponding UUID
318 ;; string representation.
320 (((? bytevector? bv))
321 (uuid->string bv 'dce))
322 (((? bytevector? bv) type)
323 (match (vhash-assq type %uuid-printers)
325 ((_ . (? procedure? unparse)) (unparse bv))))
327 (uuid->string (uuid-bytevector uuid) (uuid-type uuid)))))
330 ;; Return true if A is equal to B, comparing only the actual bits.
332 (((? bytevector? a) (? bytevector? b))
334 (((? uuid? a) (? bytevector? b))
335 (bytevector=? (uuid-bytevector a) b))
336 (((? uuid? a) (? uuid? b))
337 (bytevector=? (uuid-bytevector a) (uuid-bytevector b)))
338 (((or (? uuid? a) (? bytevector? a)) (or (? uuid? b) (? bytevector? b)))