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