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