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