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