Commit | Line | Data |
---|---|---|
47cef4ec | 1 | ;;; GNU Guix --- Functional package management for GNU |
6c5790a2 | 2 | ;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
47cef4ec | 3 | ;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.org> |
e87471dc | 4 | ;;; Copyright © 2019, 2020 Tobias Geerinckx-Rice <me@tobias.gr> |
47cef4ec LC |
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) | |
9b336338 | 23 | #:use-module (srfi srfi-9) |
47cef4ec LC |
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 | |
9b336338 LC |
30 | uuid? |
31 | uuid-type | |
32 | uuid-bytevector | |
aed1f1b0 | 33 | uuid=? |
9b336338 LC |
34 | |
35 | bytevector->uuid | |
36 | ||
47cef4ec LC |
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 | |
e87471dc | 45 | string->bcachefs-uuid |
47cef4ec | 46 | string->btrfs-uuid |
03f66aea | 47 | string->fat-uuid |
43c4d27c | 48 | string->jfs-uuid |
675e5622 | 49 | string->ntfs-uuid |
47cef4ec LC |
50 | iso9660-uuid->string |
51 | ||
52 | ;; XXX: For lack of a better place. | |
53 | sub-bytevector | |
54 | latin1->string)) | |
55 | ||
56 | \f | |
57 | ;;; | |
58 | ;;; Tools that lack a better place. | |
59 | ;;; | |
60 | ||
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) | |
65 | result)) | |
66 | ||
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)))) | |
71 | (if (null? bytes) | |
72 | #f | |
73 | (list->string (map integer->char bytes))))) | |
74 | ||
75 | \f | |
76 | ;;; | |
77 | ;;; DCE UUIDs. | |
78 | ;;; | |
79 | ||
80 | (define-syntax %network-byte-order | |
81 | (identifier-syntax (endianness big))) | |
82 | ||
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))) | |
94 | ||
95 | (define %uuid-rx | |
96 | ;; The regexp of a UUID. | |
97 | (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$")) | |
98 | ||
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) | |
104 | (lambda (match) | |
105 | (letrec-syntax ((hex->number | |
106 | (syntax-rules () | |
107 | ((_ index) | |
108 | (string->number (match:substring match index) | |
109 | 16)))) | |
110 | (put! | |
111 | (syntax-rules () | |
112 | ((_ bv index (number len) rest ...) | |
113 | (begin | |
114 | (bytevector-uint-set! bv index number | |
115 | (endianness big) len) | |
116 | (put! bv (+ index len) rest ...))) | |
117 | ((_ bv index) | |
118 | bv)))) | |
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))) | |
125 | (put! uuid 0 | |
126 | (time-low 4) (time-mid 2) (time-hi 2) | |
127 | (clock-seq 2) (node 6))))))) | |
128 | ||
129 | \f | |
130 | ;;; | |
131 | ;;; ISO-9660. | |
132 | ;;; | |
133 | ||
134 | ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>. | |
135 | ||
136 | (define %iso9660-uuid-rx | |
137 | ;; Y m d H M S ss | |
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) | |
144 | (lambda (match) | |
145 | (letrec-syntax ((match-numerals | |
146 | (syntax-rules () | |
147 | ((_ index (name rest ...) body) | |
148 | (let ((name (match:substring match index))) | |
149 | (match-numerals (+ 1 index) (rest ...) body))) | |
150 | ((_ index () body) | |
151 | 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) "-")))) | |
168 | ||
169 | \f | |
170 | ;;; | |
03f66aea | 171 | ;;; FAT32/FAT16. |
47cef4ec LC |
172 | ;;; |
173 | ||
03f66aea LC |
174 | (define-syntax %fat-endianness |
175 | ;; Endianness of FAT32/FAT16 file systems. | |
47cef4ec LC |
176 | (identifier-syntax (endianness little))) |
177 | ||
03f66aea LC |
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))) | |
6c5790a2 | 182 | (format #f "~:@(~4,'0x-~4,'0x~)" low high))) |
47cef4ec | 183 | |
03f66aea | 184 | (define %fat-uuid-rx |
8a7d81a5 LC |
185 | (make-regexp "^([[:xdigit:]]{4})-([[:xdigit:]]{4})$")) |
186 | ||
03f66aea LC |
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) | |
8a7d81a5 LC |
190 | (#f |
191 | #f) | |
192 | (rx-match | |
193 | (uint-list->bytevector (list (string->number | |
194 | (match:substring rx-match 2) 16) | |
195 | (string->number | |
196 | (match:substring rx-match 1) 16)) | |
03f66aea | 197 | %fat-endianness |
8a7d81a5 LC |
198 | 2)))) |
199 | ||
47cef4ec | 200 | \f |
675e5622 MO |
201 | ;;; |
202 | ;;; NTFS. | |
203 | ;;; | |
204 | ||
205 | (define-syntax %ntfs-endianness | |
206 | ;; Endianness of NTFS file system. | |
207 | (identifier-syntax (endianness little))) | |
208 | ||
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)))) | |
212 | ||
213 | (define %ntfs-uuid-rx | |
214 | (make-regexp "^([[:xdigit:]]{16})$")) | |
215 | ||
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) | |
219 | (#f | |
220 | #f) | |
221 | (rx-match | |
222 | (u8-list->bytevector | |
223 | (let loop ((str str) | |
224 | (res '())) | |
225 | (if (string=? str "") | |
226 | res | |
227 | (loop (string-drop str 2) | |
228 | (cons | |
229 | (string->number (string-take str 2) 16) | |
230 | res)))))))) | |
231 | ||
232 | \f | |
47cef4ec LC |
233 | ;;; |
234 | ;;; Generic interface. | |
235 | ;;; | |
236 | ||
237 | (define string->ext2-uuid string->dce-uuid) | |
238 | (define string->ext3-uuid string->dce-uuid) | |
239 | (define string->ext4-uuid string->dce-uuid) | |
e87471dc | 240 | (define string->bcachefs-uuid string->dce-uuid) |
47cef4ec | 241 | (define string->btrfs-uuid string->dce-uuid) |
43c4d27c | 242 | (define string->jfs-uuid string->dce-uuid) |
47cef4ec LC |
243 | |
244 | (define-syntax vhashq | |
245 | (syntax-rules (=>) | |
246 | ((_) | |
247 | vlist-null) | |
248 | ((_ (key others ... => value) rest ...) | |
249 | (vhash-consq key value | |
250 | (vhashq (others ... => value) rest ...))) | |
251 | ((_ (=> value) rest ...) | |
252 | (vhashq rest ...)))) | |
253 | ||
254 | (define %uuid-parsers | |
255 | (vhashq | |
e87471dc | 256 | ('dce 'ext2 'ext3 'ext4 'bcachefs 'btrfs 'jfs 'luks => string->dce-uuid) |
03f66aea | 257 | ('fat32 'fat16 'fat => string->fat-uuid) |
675e5622 | 258 | ('ntfs => string->ntfs-uuid) |
47cef4ec LC |
259 | ('iso9660 => string->iso9660-uuid))) |
260 | ||
261 | (define %uuid-printers | |
262 | (vhashq | |
e87471dc | 263 | ('dce 'ext2 'ext3 'ext4 'bcachefs 'btrfs 'jfs 'luks => dce-uuid->string) |
47cef4ec | 264 | ('iso9660 => iso9660-uuid->string) |
675e5622 MO |
265 | ('fat32 'fat16 'fat => fat-uuid->string) |
266 | ('ntfs => ntfs-uuid->string))) | |
47cef4ec | 267 | |
ce094b46 | 268 | (define* (string->uuid str #:optional (type 'dce)) |
47cef4ec LC |
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) | |
272 | (#f #f) | |
273 | ((_ . (? procedure? parse)) (parse str)))) | |
274 | ||
9b336338 LC |
275 | ;; High-level UUID representation that carries its type with it. |
276 | ;; | |
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 | |
bf57e1c7 | 280 | ;; GRUB 'search' command, we need to produce the right string representation |
9b336338 LC |
281 | ;; (see <https://debbugs.gnu.org/cgi/bugreport.cgi?msg=52;att=0;bug=27735>). |
282 | (define-record-type <uuid> | |
283 | (make-uuid type bv) | |
284 | uuid? | |
285 | (type uuid-type) ;'dce | 'iso9660 | ... | |
286 | (bv uuid-bytevector)) | |
287 | ||
288 | (define* (bytevector->uuid bv #:optional (type 'dce)) | |
289 | "Return a UUID object make of BV and TYPE." | |
290 | (make-uuid type bv)) | |
47cef4ec LC |
291 | |
292 | (define-syntax uuid | |
293 | (lambda (s) | |
263c9941 LC |
294 | "Return the UUID object corresponding to the given UUID representation or |
295 | #f if the string could not be parsed." | |
ce094b46 LC |
296 | (syntax-case s (quote) |
297 | ((_ str (quote type)) | |
298 | (and (string? (syntax->datum #'str)) | |
299 | (identifier? #'type)) | |
47cef4ec | 300 | ;; A literal string: do the conversion at expansion time. |
ce094b46 LC |
301 | (let ((bv (string->uuid (syntax->datum #'str) |
302 | (syntax->datum #'type)))) | |
47cef4ec LC |
303 | (unless bv |
304 | (syntax-violation 'uuid "invalid UUID" s)) | |
ce094b46 LC |
305 | #`(make-uuid 'type #,(datum->syntax s bv)))) |
306 | ((_ str) | |
307 | (string? (syntax->datum #'str)) | |
308 | #'(uuid str 'dce)) | |
47cef4ec | 309 | ((_ str) |
263c9941 LC |
310 | #'(let ((bv (string->uuid str 'dce))) |
311 | (and bv (make-uuid 'dce bv)))) | |
ce094b46 | 312 | ((_ str type) |
263c9941 LC |
313 | #'(let ((bv (string->uuid str type))) |
314 | (and bv (make-uuid type bv))))))) | |
9b336338 LC |
315 | |
316 | (define uuid->string | |
317 | ;; Convert the given bytevector or UUID object, to the corresponding UUID | |
318 | ;; string representation. | |
319 | (match-lambda* | |
320 | (((? bytevector? bv)) | |
321 | (uuid->string bv 'dce)) | |
322 | (((? bytevector? bv) type) | |
323 | (match (vhash-assq type %uuid-printers) | |
324 | (#f #f) | |
325 | ((_ . (? procedure? unparse)) (unparse bv)))) | |
326 | (((? uuid? uuid)) | |
327 | (uuid->string (uuid-bytevector uuid) (uuid-type uuid))))) | |
aed1f1b0 LC |
328 | |
329 | (define uuid=? | |
330 | ;; Return true if A is equal to B, comparing only the actual bits. | |
331 | (match-lambda* | |
332 | (((? bytevector? a) (? bytevector? b)) | |
333 | (bytevector=? a 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))) | |
04a4af6d | 338 | (((or (? uuid? a) (? bytevector? a)) (or (? uuid? b) (? bytevector? b))) |
aed1f1b0 | 339 | (uuid=? b a)))) |