Commit | Line | Data |
---|---|---|
e2f4b305 | 1 | ;;; GNU Guix --- Functional package management for GNU |
2fe4ceee | 2 | ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> |
ab4e939c | 3 | ;;; Copyright © 2016, 2017 David Craven <david@craven.ch> |
a5e13c3b | 4 | ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> |
e2f4b305 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 build file-systems) | |
22 | #:use-module (guix build utils) | |
6eb43907 | 23 | #:use-module (guix build bournish) |
2ff0da02 | 24 | #:use-module (guix build syscalls) |
e2f4b305 LC |
25 | #:use-module (rnrs io ports) |
26 | #:use-module (rnrs bytevectors) | |
27 | #:use-module (ice-9 match) | |
28 | #:use-module (ice-9 rdelim) | |
0ec5ee94 | 29 | #:use-module (ice-9 format) |
f8865db6 | 30 | #:use-module (ice-9 regex) |
e2f4b305 LC |
31 | #:use-module (system foreign) |
32 | #:autoload (system repl repl) (start-repl) | |
33 | #:use-module (srfi srfi-1) | |
34 | #:use-module (srfi srfi-26) | |
35 | #:export (disk-partitions | |
36 | partition-label-predicate | |
0ec5ee94 | 37 | partition-uuid-predicate |
a1ccefaa | 38 | partition-luks-uuid-predicate |
e2f4b305 | 39 | find-partition-by-label |
0ec5ee94 | 40 | find-partition-by-uuid |
a1ccefaa | 41 | find-partition-by-luks-uuid |
e2f4b305 LC |
42 | canonicalize-device-spec |
43 | ||
f8865db6 LC |
44 | uuid->string |
45 | string->uuid | |
46 | ||
e2f4b305 LC |
47 | bind-mount |
48 | ||
49 | mount-flags->bit-mask | |
50 | check-file-system | |
a5e13c3b | 51 | mount-file-system)) |
e2f4b305 LC |
52 | |
53 | ;;; Commentary: | |
54 | ;;; | |
55 | ;;; This modules provides tools to deal with disk partitions, and to mount and | |
56 | ;;; check file systems. | |
57 | ;;; | |
58 | ;;; Code: | |
59 | ||
e2f4b305 LC |
60 | (define (bind-mount source target) |
61 | "Bind-mount SOURCE at TARGET." | |
62 | (mount source target "" MS_BIND)) | |
63 | ||
2fe4ceee LC |
64 | (define (seek* fd/port offset whence) |
65 | "Like 'seek' but return -1 instead of throwing to 'system-error' upon | |
66 | EINVAL. This makes it easier to catch cases like OFFSET being too large for | |
67 | FD/PORT." | |
68 | (catch 'system-error | |
69 | (lambda () | |
70 | (seek fd/port offset whence)) | |
71 | (lambda args | |
72 | (if (= EINVAL (system-error-errno args)) | |
73 | -1 | |
74 | (apply throw args))))) | |
75 | ||
974e02da DC |
76 | (define (read-superblock device offset size magic?) |
77 | "Read a superblock of SIZE from OFFSET and DEVICE. Return the raw | |
78 | superblock on success, and #f if no valid superblock was found. MAGIC? | |
79 | takes a bytevector and returns #t when it's a valid superblock." | |
80 | (call-with-input-file device | |
81 | (lambda (port) | |
2fe4ceee LC |
82 | (and (= offset (seek* port offset SEEK_SET)) |
83 | (let ((block (make-bytevector size))) | |
84 | (match (get-bytevector-n! port block 0 (bytevector-length block)) | |
85 | ((? eof-object?) | |
86 | #f) | |
87 | ((? number? len) | |
88 | (and (= len (bytevector-length block)) | |
89 | (and (magic? block) | |
90 | block))))))))) | |
974e02da DC |
91 | |
92 | (define (sub-bytevector bv start size) | |
93 | "Return a copy of the SIZE bytes of BV starting from offset START." | |
94 | (let ((result (make-bytevector size))) | |
95 | (bytevector-copy! bv start result 0 size) | |
96 | result)) | |
97 | ||
b0377e58 DC |
98 | (define (latin1->string bv terminator) |
99 | "Return a string of BV, a latin1 bytevector, or #f. TERMINATOR is a predicate | |
100 | that takes a number and returns #t when a termination character is found." | |
101 | (let ((bytes (take-while (negate terminator) (bytevector->u8-list bv)))) | |
974e02da DC |
102 | (if (null? bytes) |
103 | #f | |
104 | (list->string (map integer->char bytes))))) | |
105 | ||
b0377e58 DC |
106 | (define null-terminated-latin1->string |
107 | (cut latin1->string <> zero?)) | |
108 | ||
a1ccefaa LC |
109 | \f |
110 | ;;; | |
111 | ;;; Ext2 file systems. | |
112 | ;;; | |
113 | ||
974e02da DC |
114 | ;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>. |
115 | ;; TODO: Use "packed structs" from Guile-OpenGL or similar. | |
116 | ||
e2f4b305 LC |
117 | (define-syntax %ext2-endianness |
118 | ;; Endianness of ext2 file systems. | |
119 | (identifier-syntax (endianness little))) | |
120 | ||
974e02da DC |
121 | (define (ext2-superblock? sblock) |
122 | "Return #t when SBLOCK is an ext2 superblock." | |
123 | (let ((magic (bytevector-u16-ref sblock 56 %ext2-endianness))) | |
124 | (= magic #xef53))) | |
e2f4b305 LC |
125 | |
126 | (define (read-ext2-superblock device) | |
127 | "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f | |
128 | if DEVICE does not contain an ext2 file system." | |
974e02da | 129 | (read-superblock device 1024 264 ext2-superblock?)) |
e2f4b305 LC |
130 | |
131 | (define (ext2-superblock-uuid sblock) | |
132 | "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector." | |
974e02da | 133 | (sub-bytevector sblock 104 16)) |
e2f4b305 LC |
134 | |
135 | (define (ext2-superblock-volume-name sblock) | |
136 | "Return the volume name of SBLOCK as a string of at most 16 characters, or | |
137 | #f if SBLOCK has no volume name." | |
974e02da | 138 | (null-terminated-latin1->string (sub-bytevector sblock 120 16))) |
e2f4b305 | 139 | |
26905ec8 DC |
140 | (define (check-ext2-file-system device) |
141 | "Return the health of an ext2 file system on DEVICE." | |
142 | (match (status:exit-val | |
143 | (system* "e2fsck" "-v" "-p" "-C" "0" device)) | |
144 | (0 'pass) | |
145 | (1 'errors-corrected) | |
146 | (2 'reboot-required) | |
147 | (_ 'fatal-error))) | |
e2f4b305 | 148 | |
a1ccefaa | 149 | \f |
b1a505ba DC |
150 | ;;; |
151 | ;;; Btrfs file systems. | |
152 | ;;; | |
153 | ||
154 | ;; <https://btrfs.wiki.kernel.org/index.php/On-disk_Format#Superblock>. | |
155 | ||
156 | (define-syntax %btrfs-endianness | |
157 | ;; Endianness of btrfs file systems. | |
158 | (identifier-syntax (endianness little))) | |
159 | ||
160 | (define (btrfs-superblock? sblock) | |
161 | "Return #t when SBLOCK is a btrfs superblock." | |
162 | (bytevector=? (sub-bytevector sblock 64 8) | |
163 | (string->utf8 "_BHRfS_M"))) | |
164 | ||
165 | (define (read-btrfs-superblock device) | |
166 | "Return the raw contents of DEVICE's btrfs superblock as a bytevector, or #f | |
167 | if DEVICE does not contain a btrfs file system." | |
168 | (read-superblock device 65536 4096 btrfs-superblock?)) | |
169 | ||
170 | (define (btrfs-superblock-uuid sblock) | |
171 | "Return the UUID of a btrfs superblock SBLOCK as a 16-byte bytevector." | |
172 | (sub-bytevector sblock 32 16)) | |
173 | ||
174 | (define (btrfs-superblock-volume-name sblock) | |
175 | "Return the volume name of SBLOCK as a string of at most 256 characters, or | |
176 | #f if SBLOCK has no volume name." | |
177 | (null-terminated-latin1->string (sub-bytevector sblock 299 256))) | |
178 | ||
179 | (define (check-btrfs-file-system device) | |
180 | "Return the health of a btrfs file system on DEVICE." | |
181 | (match (status:exit-val | |
182 | (system* "btrfs" "device" "scan")) | |
183 | (0 'pass) | |
184 | (_ 'fatal-error))) | |
185 | ||
186 | \f | |
b0377e58 DC |
187 | ;;; |
188 | ;;; FAT32 file systems. | |
189 | ;;; | |
190 | ||
191 | ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-107.pdf>. | |
192 | ||
193 | (define-syntax %fat32-endianness | |
194 | ;; Endianness of fat file systems. | |
195 | (identifier-syntax (endianness little))) | |
196 | ||
197 | (define (fat32-superblock? sblock) | |
198 | "Return #t when SBLOCK is a fat32 superblock." | |
199 | (bytevector=? (sub-bytevector sblock 82 8) | |
200 | (string->utf8 "FAT32 "))) | |
201 | ||
202 | (define (read-fat32-superblock device) | |
203 | "Return the raw contents of DEVICE's fat32 superblock as a bytevector, or | |
204 | #f if DEVICE does not contain a fat32 file system." | |
205 | (read-superblock device 0 90 fat32-superblock?)) | |
206 | ||
207 | (define (fat32-superblock-uuid sblock) | |
208 | "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector." | |
209 | (sub-bytevector sblock 67 4)) | |
210 | ||
211 | (define (fat32-uuid->string uuid) | |
212 | "Convert fat32 UUID, a 4-byte bytevector, to its string representation." | |
213 | (let ((high (bytevector-uint-ref uuid 0 %fat32-endianness 2)) | |
214 | (low (bytevector-uint-ref uuid 2 %fat32-endianness 2))) | |
215 | (format #f "~:@(~x-~x~)" low high))) | |
216 | ||
217 | (define (fat32-superblock-volume-name sblock) | |
218 | "Return the volume name of SBLOCK as a string of at most 11 characters, or | |
219 | #f if SBLOCK has no volume name. The volume name is a latin1 string. | |
220 | Trailing spaces are trimmed." | |
221 | (string-trim-right (latin1->string (sub-bytevector sblock 71 11) (lambda (c) #f)) #\space)) | |
222 | ||
223 | (define (check-fat32-file-system device) | |
224 | "Return the health of a fat file system on DEVICE." | |
225 | (match (status:exit-val | |
226 | (system* "fsck.vfat" "-v" "-a" device)) | |
227 | (0 'pass) | |
228 | (1 'errors-corrected) | |
229 | (_ 'fatal-error))) | |
230 | ||
231 | \f | |
06110559 DM |
232 | ;;; |
233 | ;;; ISO9660 file systems. | |
234 | ;;; | |
235 | ||
236 | ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>. | |
237 | ||
238 | (define (iso9660-superblock? sblock) | |
3dba9b37 | 239 | "Return #t when SBLOCK is an iso9660 volume descriptor." |
06110559 DM |
240 | (bytevector=? (sub-bytevector sblock 1 6) |
241 | ;; Note: "\x01" is the volume descriptor format version | |
242 | (string->utf8 "CD001\x01"))) | |
243 | ||
244 | (define (read-iso9660-primary-volume-descriptor device offset) | |
245 | "Find and read the first primary volume descriptor, starting at OFFSET. | |
246 | Return #f if not found." | |
247 | (let* ((sblock (read-superblock device offset 2048 iso9660-superblock?)) | |
203a9455 DM |
248 | (type-code (if sblock |
249 | (bytevector-u8-ref sblock 0) | |
250 | (error (format #f | |
251 | "Could not read ISO9660 primary | |
252 | volume descriptor from ~s" | |
253 | device))))) | |
06110559 DM |
254 | (match type-code |
255 | (255 #f) ; Volume Descriptor Set Terminator. | |
256 | (1 sblock) ; Primary Volume Descriptor | |
257 | (_ (read-iso9660-primary-volume-descriptor device (+ offset 2048)))))) | |
258 | ||
259 | (define (read-iso9660-superblock device) | |
3dba9b37 DM |
260 | "Return the raw contents of DEVICE's iso9660 primary volume descriptor |
261 | as a bytevector, or #f if DEVICE does not contain an iso9660 file system." | |
06110559 | 262 | ;; Start reading at sector 16. |
fb03f44b DM |
263 | ;; Since we are not sure that the device contains an ISO9660 filesystem, |
264 | ;; we have to find that out first. | |
265 | (if (read-superblock device (* 2048 16) 2048 iso9660-superblock?) | |
266 | (read-iso9660-primary-volume-descriptor device (* 2048 16)) | |
267 | #f)) ; Device does not contain an iso9660 filesystem. | |
06110559 DM |
268 | |
269 | (define (iso9660-superblock-uuid sblock) | |
3dba9b37 DM |
270 | "Return the modification time of an iso9660 primary volume descriptor |
271 | SBLOCK as a bytevector." | |
06110559 DM |
272 | ;; Drops GMT offset for compatibility with Grub, blkid and /dev/disk/by-uuid. |
273 | ;; Compare Grub: "2014-12-02-19-30-23-00". | |
274 | ;; Compare blkid result: "2014-12-02-19-30-23-00". | |
275 | ;; Compare /dev/disk/by-uuid entry: "2014-12-02-19-30-23-00". | |
276 | (sub-bytevector sblock 830 16)) | |
277 | ||
278 | (define (iso9660-uuid->string uuid) | |
279 | "Given an UUID bytevector, return its timestamp string." | |
280 | (define (digits->string bytes) | |
281 | (latin1->string bytes (lambda (c) #f))) | |
282 | (let* ((year (sub-bytevector uuid 0 4)) | |
283 | (month (sub-bytevector uuid 4 2)) | |
284 | (day (sub-bytevector uuid 6 2)) | |
285 | (hour (sub-bytevector uuid 8 2)) | |
286 | (minute (sub-bytevector uuid 10 2)) | |
287 | (second (sub-bytevector uuid 12 2)) | |
288 | (hundredths (sub-bytevector uuid 14 2)) | |
289 | (parts (list year month day hour minute second hundredths))) | |
290 | (string-append (string-join (map digits->string parts))))) | |
291 | ||
292 | (define (iso9660-superblock-volume-name sblock) | |
293 | "Return the volume name of SBLOCK as a string. The volume name is an ASCII | |
294 | string. Trailing spaces are trimmed." | |
cdc701ea | 295 | ;; Note: Valid characters are of the set "[0-9][A-Z]_" (ECMA-119 Appendix A) |
06110559 DM |
296 | (string-trim-right (latin1->string (sub-bytevector sblock 40 32) |
297 | (lambda (c) #f)) #\space)) | |
298 | ||
299 | \f | |
a1ccefaa LC |
300 | ;;; |
301 | ;;; LUKS encrypted devices. | |
302 | ;;; | |
303 | ||
304 | ;; The LUKS header format is described in "LUKS On-Disk Format Specification": | |
de975de3 | 305 | ;; <https://gitlab.com/cryptsetup/cryptsetup/wikis/Specification>. We follow |
a1ccefaa LC |
306 | ;; version 1.2.1 of this document. |
307 | ||
308 | (define-syntax %luks-endianness | |
309 | ;; Endianness of LUKS headers. | |
310 | (identifier-syntax (endianness big))) | |
311 | ||
974e02da DC |
312 | (define (luks-superblock? sblock) |
313 | "Return #t when SBLOCK is a luks superblock." | |
314 | (define %luks-magic | |
315 | ;; The 'LUKS_MAGIC' constant. | |
316 | (u8-list->bytevector (append (map char->integer (string->list "LUKS")) | |
317 | (list #xba #xbe)))) | |
318 | (let ((magic (sub-bytevector sblock 0 6)) | |
319 | (version (bytevector-u16-ref sblock 6 %luks-endianness))) | |
320 | (and (bytevector=? magic %luks-magic) | |
321 | (= version 1)))) | |
a1ccefaa LC |
322 | |
323 | (define (read-luks-header file) | |
324 | "Read a LUKS header from FILE. Return the raw header on success, and #f if | |
325 | not valid header was found." | |
974e02da DC |
326 | ;; Size in bytes of the LUKS header, including key slots. |
327 | (read-superblock file 0 592 luks-superblock?)) | |
a1ccefaa LC |
328 | |
329 | (define (luks-header-uuid header) | |
330 | "Return the LUKS UUID from HEADER, as a 16-byte bytevector." | |
331 | ;; 40 bytes are reserved for the UUID, but in practice, it contains the 36 | |
332 | ;; bytes of its ASCII representation. | |
333 | (let ((uuid (sub-bytevector header 168 36))) | |
334 | (string->uuid (utf8->string uuid)))) | |
335 | ||
336 | \f | |
337 | ;;; | |
338 | ;;; Partition lookup. | |
339 | ;;; | |
340 | ||
e2f4b305 LC |
341 | (define (disk-partitions) |
342 | "Return the list of device names corresponding to valid disk partitions." | |
49baaff4 LC |
343 | (define (last-character str) |
344 | (string-ref str (- (string-length str) 1))) | |
345 | ||
346 | (define (partition? name major minor) | |
347 | ;; Select device names that end in a digit, like libblkid's 'probe_all' | |
348 | ;; function does. Checking for "/sys/dev/block/MAJOR:MINOR/partition" | |
349 | ;; doesn't work for partitions coming from mapped devices. | |
350 | (and (char-set-contains? char-set:digit (last-character name)) | |
351 | (> major 2))) ;ignore RAM disks and floppy disks | |
e2f4b305 LC |
352 | |
353 | (call-with-input-file "/proc/partitions" | |
354 | (lambda (port) | |
355 | ;; Skip the two header lines. | |
356 | (read-line port) | |
357 | (read-line port) | |
358 | ||
359 | ;; Read each subsequent line, and extract the last space-separated | |
360 | ;; field. | |
361 | (let loop ((parts '())) | |
362 | (let ((line (read-line port))) | |
363 | (if (eof-object? line) | |
364 | (reverse parts) | |
365 | (match (string-tokenize line) | |
366 | (((= string->number major) (= string->number minor) | |
367 | blocks name) | |
49baaff4 | 368 | (if (partition? name major minor) |
e2f4b305 LC |
369 | (loop (cons name parts)) |
370 | (loop parts)))))))))) | |
371 | ||
24473356 LC |
372 | (define (ENOENT-safe proc) |
373 | "Wrap the one-argument PROC such that ENOENT errors are caught and lead to a | |
374 | warning and #f as the result." | |
375 | (lambda (device) | |
376 | (catch 'system-error | |
377 | (lambda () | |
378 | (proc device)) | |
379 | (lambda args | |
380 | ;; When running on the hand-made /dev, | |
381 | ;; 'disk-partitions' could return partitions for which | |
382 | ;; we have no /dev node. Handle that gracefully. | |
49baaff4 LC |
383 | (let ((errno (system-error-errno args))) |
384 | (cond ((= ENOENT errno) | |
385 | (format (current-error-port) | |
386 | "warning: device '~a' not found~%" device) | |
387 | #f) | |
388 | ((= ENOMEDIUM errno) ;for removable media | |
389 | #f) | |
390 | (else | |
391 | (apply throw args)))))))) | |
24473356 | 392 | |
ab4e939c DC |
393 | (define (partition-field-reader read field) |
394 | "Return a procedure that takes a device and returns the value of a FIELD in | |
395 | the partition superblock or #f." | |
396 | (let ((read (ENOENT-safe read))) | |
397 | (lambda (device) | |
398 | (let ((sblock (read device))) | |
399 | (and sblock | |
400 | (field sblock)))))) | |
401 | ||
402 | (define (read-partition-field device partition-field-readers) | |
403 | "Returns the value of a FIELD in the partition superblock of DEVICE or #f. It | |
404 | takes a list of PARTITION-FIELD-READERS and returns the result of the first | |
405 | partition field reader that returned a value." | |
406 | (match (filter-map (cut apply <> (list device)) partition-field-readers) | |
407 | ((field . _) field) | |
408 | (_ #f))) | |
409 | ||
410 | (define %partition-label-readers | |
06110559 DM |
411 | (list (partition-field-reader read-iso9660-superblock |
412 | iso9660-superblock-volume-name) | |
413 | (partition-field-reader read-ext2-superblock | |
b1a505ba DC |
414 | ext2-superblock-volume-name) |
415 | (partition-field-reader read-btrfs-superblock | |
b0377e58 DC |
416 | btrfs-superblock-volume-name) |
417 | (partition-field-reader read-fat32-superblock | |
418 | fat32-superblock-volume-name))) | |
ab4e939c DC |
419 | |
420 | (define %partition-uuid-readers | |
06110559 DM |
421 | (list (partition-field-reader read-iso9660-superblock |
422 | iso9660-superblock-uuid) | |
423 | (partition-field-reader read-ext2-superblock | |
b1a505ba DC |
424 | ext2-superblock-uuid) |
425 | (partition-field-reader read-btrfs-superblock | |
b0377e58 DC |
426 | btrfs-superblock-uuid) |
427 | (partition-field-reader read-fat32-superblock | |
428 | fat32-superblock-uuid))) | |
ab4e939c DC |
429 | |
430 | (define read-partition-label | |
431 | (cut read-partition-field <> %partition-label-readers)) | |
432 | ||
433 | (define read-partition-uuid | |
434 | (cut read-partition-field <> %partition-uuid-readers)) | |
435 | ||
436 | (define (partition-predicate reader =) | |
a1ccefaa LC |
437 | "Return a predicate that returns true if the FIELD of partition header that |
438 | was READ is = to the given value." | |
ab4e939c DC |
439 | (lambda (expected) |
440 | (lambda (device) | |
441 | (let ((actual (reader device))) | |
442 | (and actual | |
443 | (= actual expected)))))) | |
0ec5ee94 LC |
444 | |
445 | (define partition-label-predicate | |
ab4e939c | 446 | (partition-predicate read-partition-label string=?)) |
0ec5ee94 LC |
447 | |
448 | (define partition-uuid-predicate | |
ab4e939c | 449 | (partition-predicate read-partition-uuid bytevector=?)) |
a1ccefaa | 450 | |
974e02da | 451 | (define luks-partition-uuid-predicate |
ab4e939c DC |
452 | (partition-predicate |
453 | (partition-field-reader read-luks-header luks-header-uuid) | |
454 | bytevector=?)) | |
e2f4b305 | 455 | |
ab4e939c DC |
456 | (define (find-partition predicate) |
457 | "Return the first partition found that matches PREDICATE, or #f if none | |
e2f4b305 | 458 | were found." |
ab4e939c DC |
459 | (lambda (expected) |
460 | (find (predicate expected) | |
461 | (map (cut string-append "/dev/" <>) | |
462 | (disk-partitions))))) | |
463 | ||
464 | (define find-partition-by-label | |
465 | (find-partition partition-label-predicate)) | |
466 | ||
467 | (define find-partition-by-uuid | |
468 | (find-partition partition-uuid-predicate)) | |
469 | ||
470 | (define find-partition-by-luks-uuid | |
471 | (find-partition luks-partition-uuid-predicate)) | |
a1ccefaa | 472 | |
f8865db6 LC |
473 | \f |
474 | ;;; | |
475 | ;;; UUIDs. | |
476 | ;;; | |
477 | ||
0ec5ee94 LC |
478 | (define-syntax %network-byte-order |
479 | (identifier-syntax (endianness big))) | |
480 | ||
481 | (define (uuid->string uuid) | |
482 | "Convert UUID, a 16-byte bytevector, to its string representation, something | |
483 | like \"6b700d61-5550-48a1-874c-a3d86998990e\"." | |
484 | ;; See <https://tools.ietf.org/html/rfc4122>. | |
485 | (let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4)) | |
486 | (time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2)) | |
487 | (time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2)) | |
488 | (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2)) | |
489 | (node (bytevector-uint-ref uuid 10 %network-byte-order 6))) | |
490 | (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x" | |
491 | time-low time-mid time-hi clock-seq node))) | |
492 | ||
f8865db6 LC |
493 | (define %uuid-rx |
494 | ;; The regexp of a UUID. | |
495 | (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$")) | |
496 | ||
497 | (define (string->uuid str) | |
498 | "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and | |
499 | return its contents as a 16-byte bytevector. Return #f if STR is not a valid | |
500 | UUID representation." | |
501 | (and=> (regexp-exec %uuid-rx str) | |
502 | (lambda (match) | |
503 | (letrec-syntax ((hex->number | |
504 | (syntax-rules () | |
505 | ((_ index) | |
506 | (string->number (match:substring match index) | |
507 | 16)))) | |
508 | (put! | |
509 | (syntax-rules () | |
510 | ((_ bv index (number len) rest ...) | |
511 | (begin | |
512 | (bytevector-uint-set! bv index number | |
513 | (endianness big) len) | |
514 | (put! bv (+ index len) rest ...))) | |
515 | ((_ bv index) | |
516 | bv)))) | |
517 | (let ((time-low (hex->number 1)) | |
518 | (time-mid (hex->number 2)) | |
519 | (time-hi (hex->number 3)) | |
520 | (clock-seq (hex->number 4)) | |
521 | (node (hex->number 5)) | |
522 | (uuid (make-bytevector 16))) | |
523 | (put! uuid 0 | |
524 | (time-low 4) (time-mid 2) (time-hi 2) | |
525 | (clock-seq 2) (node 6))))))) | |
526 | ||
527 | \f | |
e2f4b305 LC |
528 | (define* (canonicalize-device-spec spec #:optional (title 'any)) |
529 | "Return the device name corresponding to SPEC. TITLE is a symbol, one of | |
530 | the following: | |
531 | ||
532 | • 'device', in which case SPEC is known to designate a device node--e.g., | |
533 | \"/dev/sda1\"; | |
534 | • 'label', in which case SPEC is known to designate a partition label--e.g., | |
535 | \"my-root-part\"; | |
0ec5ee94 LC |
536 | • 'uuid', in which case SPEC must be a UUID (a 16-byte bytevector) |
537 | designating a partition; | |
e2f4b305 LC |
538 | • 'any', in which case SPEC can be anything. |
539 | " | |
540 | (define max-trials | |
541 | ;; Number of times we retry partition label resolution, 1 second per | |
542 | ;; trial. Note: somebody reported a delay of 16 seconds (!) before their | |
543 | ;; USB key would be detected by the kernel, so we must wait for at least | |
544 | ;; this long. | |
545 | 20) | |
546 | ||
547 | (define canonical-title | |
548 | ;; The realm of canonicalization. | |
549 | (if (eq? title 'any) | |
0ec5ee94 | 550 | (if (string? spec) |
f453f637 LC |
551 | ;; The "--root=SPEC" kernel command-line option always provides a |
552 | ;; string, but the string can represent a device, a UUID, or a | |
553 | ;; label. So check for all three. | |
554 | (cond ((string-prefix? "/" spec) 'device) | |
555 | ((string->uuid spec) 'uuid) | |
556 | (else 'label)) | |
0ec5ee94 | 557 | 'uuid) |
e2f4b305 LC |
558 | title)) |
559 | ||
0ec5ee94 LC |
560 | (define (resolve find-partition spec fmt) |
561 | (let loop ((count 0)) | |
562 | (let ((device (find-partition spec))) | |
563 | (or device | |
564 | ;; Some devices take a bit of time to appear, most notably USB | |
565 | ;; storage devices. Thus, wait for the device to appear. | |
566 | (if (> count max-trials) | |
567 | (error "failed to resolve partition" (fmt spec)) | |
568 | (begin | |
569 | (format #t "waiting for partition '~a' to appear...~%" | |
570 | (fmt spec)) | |
571 | (sleep 1) | |
572 | (loop (+ 1 count)))))))) | |
573 | ||
e2f4b305 LC |
574 | (case canonical-title |
575 | ((device) | |
576 | ;; Nothing to do. | |
577 | spec) | |
578 | ((label) | |
579 | ;; Resolve the label. | |
0ec5ee94 LC |
580 | (resolve find-partition-by-label spec identity)) |
581 | ((uuid) | |
f453f637 LC |
582 | (resolve find-partition-by-uuid |
583 | (if (string? spec) | |
584 | (string->uuid spec) | |
585 | spec) | |
586 | uuid->string)) | |
e2f4b305 LC |
587 | (else |
588 | (error "unknown device title" title)))) | |
589 | ||
590 | (define (check-file-system device type) | |
591 | "Run a file system check of TYPE on DEVICE." | |
26905ec8 DC |
592 | (define check-procedure |
593 | (cond | |
594 | ((string-prefix? "ext" type) check-ext2-file-system) | |
b1a505ba | 595 | ((string-prefix? "btrfs" type) check-btrfs-file-system) |
b0377e58 | 596 | ((string-suffix? "fat" type) check-fat32-file-system) |
26905ec8 DC |
597 | (else #f))) |
598 | ||
599 | (if check-procedure | |
600 | (match (check-procedure device) | |
601 | ('pass | |
602 | #t) | |
603 | ('errors-corrected | |
604 | (format (current-error-port) | |
605 | "File system check corrected errors on ~a; continuing~%" | |
606 | device)) | |
607 | ('reboot-required | |
608 | (format (current-error-port) | |
609 | "File system check corrected errors on ~a; rebooting~%" | |
610 | device) | |
611 | (sleep 3) | |
612 | (reboot)) | |
613 | ('fatal-error | |
614 | (format (current-error-port) | |
615 | "File system check on ~a failed; spawning Bourne-like REPL~%" | |
616 | device) | |
617 | (start-repl %bournish-language))) | |
618 | (format (current-error-port) | |
619 | "No file system check procedure for ~a; skipping~%" | |
620 | device))) | |
e2f4b305 LC |
621 | |
622 | (define (mount-flags->bit-mask flags) | |
623 | "Return the number suitable for the 'flags' argument of 'mount' that | |
624 | corresponds to the symbols listed in FLAGS." | |
625 | (let loop ((flags flags)) | |
626 | (match flags | |
627 | (('read-only rest ...) | |
628 | (logior MS_RDONLY (loop rest))) | |
629 | (('bind-mount rest ...) | |
630 | (logior MS_BIND (loop rest))) | |
631 | (('no-suid rest ...) | |
632 | (logior MS_NOSUID (loop rest))) | |
633 | (('no-dev rest ...) | |
634 | (logior MS_NODEV (loop rest))) | |
635 | (('no-exec rest ...) | |
636 | (logior MS_NOEXEC (loop rest))) | |
637 | (() | |
638 | 0)))) | |
639 | ||
640 | (define* (mount-file-system spec #:key (root "/root")) | |
641 | "Mount the file system described by SPEC under ROOT. SPEC must have the | |
642 | form: | |
643 | ||
644 | (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?) | |
645 | ||
646 | DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; | |
647 | FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to | |
648 | run a file system check." | |
0c85db79 JD |
649 | |
650 | (define (mount-nfs source mount-point type flags options) | |
651 | (let* ((idx (string-rindex source #\:)) | |
652 | (host-part (string-take source idx)) | |
653 | ;; Strip [] from around host if present | |
654 | (host (match (string-split host-part (string->char-set "[]")) | |
655 | (("" h "") h) | |
656 | ((h) h))) | |
657 | (aa (match (getaddrinfo host "nfs") ((x . _) x))) | |
658 | (sa (addrinfo:addr aa)) | |
659 | (inet-addr (inet-ntop (sockaddr:fam sa) | |
660 | (sockaddr:addr sa)))) | |
661 | ||
662 | ;; Mounting an NFS file system requires passing the address | |
663 | ;; of the server in the addr= option | |
664 | (mount source mount-point type flags | |
665 | (string-append "addr=" | |
666 | inet-addr | |
667 | (if options | |
668 | (string-append "," options) | |
669 | ""))))) | |
e2f4b305 LC |
670 | (match spec |
671 | ((source title mount-point type (flags ...) options check?) | |
672 | (let ((source (canonicalize-device-spec source title)) | |
b86fee78 LC |
673 | (mount-point (string-append root "/" mount-point)) |
674 | (flags (mount-flags->bit-mask flags))) | |
e2f4b305 LC |
675 | (when check? |
676 | (check-file-system source type)) | |
8c812f2a DT |
677 | |
678 | ;; Create the mount point. Most of the time this is a directory, but | |
bb5cad4e | 679 | ;; in the case of a bind mount, a regular file or socket may be needed. |
8c812f2a | 680 | (if (and (= MS_BIND (logand flags MS_BIND)) |
bb5cad4e | 681 | (not (file-is-directory? source))) |
78981bb9 | 682 | (unless (file-exists? mount-point) |
8c812f2a DT |
683 | (mkdir-p (dirname mount-point)) |
684 | (call-with-output-file mount-point (const #t))) | |
685 | (mkdir-p mount-point)) | |
686 | ||
0c85db79 JD |
687 | (cond |
688 | ((string-prefix? "nfs" type) | |
689 | (mount-nfs source mount-point type flags options)) | |
690 | (else | |
691 | (mount source mount-point type flags options))) | |
b86fee78 LC |
692 | |
693 | ;; For read-only bind mounts, an extra remount is needed, as per | |
694 | ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0. | |
695 | (when (and (= MS_BIND (logand flags MS_BIND)) | |
696 | (= MS_RDONLY (logand flags MS_RDONLY))) | |
5fd77f3f DT |
697 | (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY))) |
698 | (mount source mount-point type flags #f))))))) | |
e2f4b305 LC |
699 | |
700 | ;;; file-systems.scm ends here |