projects/guix·blob javascript-team · refs

344 lines · 12.2 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <[email protected]>
3;;; Copyright © 2017 Danny Milosavljevic <[email protected]>
4;;; Copyright © 2019–2020, 2024 Tobias Geerinckx-Rice <[email protected]>
5;;;
6;;; This file is part of GNU Guix.
7;;;
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.
12;;;
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.
17;;;
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/>.
20
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)
29 #:export (uuid
30 uuid?
31 uuid-type
32 uuid-bytevector
33 uuid=?
34
35 bytevector->uuid
36
37 uuid->string
38 dce-uuid->string
39 string->uuid
40 string->dce-uuid
41 string->iso9660-uuid
42 string->ext2-uuid
43 string->ext3-uuid
44 string->ext4-uuid
45 string->bcachefs-uuid
46 string->btrfs-uuid
47 string->fat-uuid
48 string->jfs-uuid
49 string->ntfs-uuid
50 string->xfs-uuid
51 iso9660-uuid->string
52
53 ;; XXX: For lack of a better place.
54 sub-bytevector
55 latin1->string))
56
57
58;;;
59;;; Tools that lack a better place.
60;;;
61
62(define (sub-bytevector bv start size)
63 "Return a copy of the SIZE bytes of BV starting from offset START."
64 (let ((result (make-bytevector size)))
65 (bytevector-copy! bv start result 0 size)
66 result))
67
68(define (latin1->string bv terminator)
69 "Return a string of BV, a latin1 bytevector, or #f. TERMINATOR is a predicate
70that takes a number and returns #t when a termination character is found."
71 (let ((bytes (take-while (negate terminator) (bytevector->u8-list bv))))
72 (if (null? bytes)
73 #f
74 (list->string (map integer->char bytes)))))
75
76
77;;;
78;;; DCE UUIDs.
79;;;
80
81(define-syntax %network-byte-order
82 (identifier-syntax (endianness big)))
83
84(define (dce-uuid->string uuid)
85 "Convert UUID, a 16-byte bytevector, to its string representation, something
86like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
87 ;; See <https://tools.ietf.org/html/rfc4122>.
88 (let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4))
89 (time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2))
90 (time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2))
91 (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
92 (node (bytevector-uint-ref uuid 10 %network-byte-order 6)))
93 (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
94 time-low time-mid time-hi clock-seq node)))
95
96(define %uuid-rx
97 ;; The regexp of a UUID.
98 (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
99
100(define (string->dce-uuid str)
101 "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
102return its contents as a 16-byte bytevector. Return #f if STR is not a valid
103UUID representation."
104 (and=> (regexp-exec %uuid-rx str)
105 (lambda (match)
106 (letrec-syntax ((hex->number
107 (syntax-rules ()
108 ((_ index)
109 (string->number (match:substring match index)
110 16))))
111 (put!
112 (syntax-rules ()
113 ((_ bv index (number len) rest ...)
114 (begin
115 (bytevector-uint-set! bv index number
116 (endianness big) len)
117 (put! bv (+ index len) rest ...)))
118 ((_ bv index)
119 bv))))
120 (let ((time-low (hex->number 1))
121 (time-mid (hex->number 2))
122 (time-hi (hex->number 3))
123 (clock-seq (hex->number 4))
124 (node (hex->number 5))
125 (uuid (make-bytevector 16)))
126 (put! uuid 0
127 (time-low 4) (time-mid 2) (time-hi 2)
128 (clock-seq 2) (node 6)))))))
129
130
131;;;
132;;; ISO-9660.
133;;;
134
135;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.
136
137(define %iso9660-uuid-rx
138 ;; Y m d H M S ss
139 (make-regexp "^([[:digit:]]{4})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})-([[:digit:]]{2})$"))
140(define (string->iso9660-uuid str)
141 "Parse STR as a ISO9660 UUID (which is really a timestamp - see /dev/disk/by-uuid).
142Return its contents as a 16-byte bytevector. Return #f if STR is not a valid
143ISO9660 UUID representation."
144 (and=> (regexp-exec %iso9660-uuid-rx str)
145 (lambda (match)
146 (letrec-syntax ((match-numerals
147 (syntax-rules ()
148 ((_ index (name rest ...) body)
149 (let ((name (match:substring match index)))
150 (match-numerals (+ 1 index) (rest ...) body)))
151 ((_ index () body)
152 body))))
153 (match-numerals 1 (year month day hour minute second hundredths)
154 (string->utf8 (string-append year month day
155 hour minute second hundredths)))))))
156(define (iso9660-uuid->string uuid)
157 "Given an UUID bytevector, return its timestamp string."
158 (define (digits->string bytes)
159 (latin1->string bytes (lambda (c) #f)))
160 (let* ((year (sub-bytevector uuid 0 4))
161 (month (sub-bytevector uuid 4 2))
162 (day (sub-bytevector uuid 6 2))
163 (hour (sub-bytevector uuid 8 2))
164 (minute (sub-bytevector uuid 10 2))
165 (second (sub-bytevector uuid 12 2))
166 (hundredths (sub-bytevector uuid 14 2))
167 (parts (list year month day hour minute second hundredths)))
168 (string-append (string-join (map digits->string parts) "-"))))
169
170
171;;;
172;;; exFAT/FAT32/FAT16.
173;;;
174
175(define-syntax %fat-endianness
176 ;; Endianness of FAT32/FAT16 file systems.
177 (identifier-syntax (endianness little)))
178
179(define (fat-uuid->string uuid)
180 "Convert FAT32/FAT16 UUID, a 4-byte bytevector, to its string representation."
181 (let ((high (bytevector-uint-ref uuid 0 %fat-endianness 2))
182 (low (bytevector-uint-ref uuid 2 %fat-endianness 2)))
183 (format #f "~:@(~4,'0x-~4,'0x~)" low high)))
184
185(define %fat-uuid-rx
186 (make-regexp "^([[:xdigit:]]{4})-([[:xdigit:]]{4})$"))
187
188(define (string->fat-uuid str)
189 "Parse STR, which is in FAT32/FAT16 format, and return a bytevector or #f."
190 (match (regexp-exec %fat-uuid-rx str)
191 (#f
192 #f)
193 (rx-match
194 (uint-list->bytevector (list (string->number
195 (match:substring rx-match 2) 16)
196 (string->number
197 (match:substring rx-match 1) 16))
198 %fat-endianness
199 2))))
200
201
202;;;
203;;; NTFS.
204;;;
205
206(define-syntax %ntfs-endianness
207 ;; Endianness of NTFS file system.
208 (identifier-syntax (endianness little)))
209
210(define (ntfs-uuid->string uuid)
211 "Convert NTFS UUID, a 8-byte bytevector, to its string representation."
212 (format #f "~{~:@(~2,'0x~)~}" (reverse (bytevector->u8-list uuid))))
213
214(define %ntfs-uuid-rx
215 (make-regexp "^([[:xdigit:]]{16})$"))
216
217(define (string->ntfs-uuid str)
218 "Parse STR, which is in NTFS format, and return a bytevector or #f."
219 (match (regexp-exec %ntfs-uuid-rx str)
220 (#f
221 #f)
222 (rx-match
223 (u8-list->bytevector
224 (let loop ((str str)
225 (res '()))
226 (if (string=? str "")
227 res
228 (loop (string-drop str 2)
229 (cons
230 (string->number (string-take str 2) 16)
231 res))))))))
232
233
234;;;
235;;; Generic interface.
236;;;
237
238(define string->ext2-uuid string->dce-uuid)
239(define string->ext3-uuid string->dce-uuid)
240(define string->ext4-uuid string->dce-uuid)
241(define string->bcachefs-uuid string->dce-uuid)
242(define string->btrfs-uuid string->dce-uuid)
243(define string->f2fs-uuid string->dce-uuid)
244(define string->jfs-uuid string->dce-uuid)
245(define string->xfs-uuid string->dce-uuid)
246
247(define-syntax vhashq
248 (syntax-rules (=>)
249 ((_)
250 vlist-null)
251 ((_ (key others ... => value) rest ...)
252 (vhash-consq key value
253 (vhashq (others ... => value) rest ...)))
254 ((_ (=> value) rest ...)
255 (vhashq rest ...))))
256
257(define %uuid-parsers
258 (vhashq
259 ('dce 'ext2 'ext3 'ext4 'bcachefs 'btrfs 'f2fs 'jfs 'xfs 'luks
260 => string->dce-uuid)
261 ('exfat 'fat32 'fat16 'fat => string->fat-uuid)
262 ('ntfs => string->ntfs-uuid)
263 ('iso9660 => string->iso9660-uuid)))
264
265(define %uuid-printers
266 (vhashq
267 ('dce 'ext2 'ext3 'ext4 'bcachefs 'btrfs 'f2fs 'jfs 'xfs 'luks
268 => dce-uuid->string)
269 ('iso9660 => iso9660-uuid->string)
270 ('exfat 'fat32 'fat16 'fat => fat-uuid->string)
271 ('ntfs => ntfs-uuid->string)))
272
273(define* (string->uuid str #:optional (type 'dce))
274 "Parse STR as a UUID of the given TYPE. On success, return the
275corresponding bytevector; otherwise return #f."
276 (match (vhash-assq type %uuid-parsers)
277 (#f #f)
278 ((_ . (? procedure? parse)) (parse str))))
279
280;; High-level UUID representation that carries its type with it.
281;;
282;; This is necessary to serialize bytevectors with the right printer in some
283;; circumstances. For instance, GRUB "search --fs-uuid" command compares the
284;; string representation of UUIDs, not the raw bytes; thus, when emitting a
285;; GRUB 'search' command, we need to produce the right string representation
286;; (see <https://debbugs.gnu.org/cgi/bugreport.cgi?msg=52;att=0;bug=27735>).
287(define-record-type <uuid>
288 (make-uuid type bv)
289 uuid?
290 (type uuid-type) ;'dce | 'iso9660 | ...
291 (bv uuid-bytevector))
292
293(define* (bytevector->uuid bv #:optional (type 'dce))
294 "Return a UUID object make of BV and TYPE."
295 (make-uuid type bv))
296
297(define-syntax uuid
298 (lambda (s)
299 "Return the UUID object corresponding to the given UUID representation or
300#f if the string could not be parsed."
301 (syntax-case s (quote)
302 ((_ str (quote type))
303 (and (string? (syntax->datum #'str))
304 (identifier? #'type))
305 ;; A literal string: do the conversion at expansion time.
306 (let ((bv (string->uuid (syntax->datum #'str)
307 (syntax->datum #'type))))
308 (unless bv
309 (syntax-violation 'uuid "invalid UUID" s))
310 #`(make-uuid 'type #,(datum->syntax s bv))))
311 ((_ str)
312 (string? (syntax->datum #'str))
313 #'(uuid str 'dce))
314 ((_ str)
315 #'(let ((bv (string->uuid str 'dce)))
316 (and bv (make-uuid 'dce bv))))
317 ((_ str type)
318 #'(let ((bv (string->uuid str type)))
319 (and bv (make-uuid type bv)))))))
320
321(define uuid->string
322 ;; Convert the given bytevector or UUID object, to the corresponding UUID
323 ;; string representation.
324 (match-lambda*
325 (((? bytevector? bv))
326 (uuid->string bv 'dce))
327 (((? bytevector? bv) type)
328 (match (vhash-assq type %uuid-printers)
329 (#f #f)
330 ((_ . (? procedure? unparse)) (unparse bv))))
331 (((? uuid? uuid))
332 (uuid->string (uuid-bytevector uuid) (uuid-type uuid)))))
333
334(define uuid=?
335 ;; Return true if A is equal to B, comparing only the actual bits.
336 (match-lambda*
337 (((? bytevector? a) (? bytevector? b))
338 (bytevector=? a b))
339 (((? uuid? a) (? bytevector? b))
340 (bytevector=? (uuid-bytevector a) b))
341 (((? uuid? a) (? uuid? b))
342 (bytevector=? (uuid-bytevector a) (uuid-bytevector b)))
343 (((or (? uuid? a) (? bytevector? a)) (or (? uuid? b) (? bytevector? b)))
344 (uuid=? b a))))