Commit | Line | Data |
---|---|---|
e2f4b305 | 1 | ;;; GNU Guix --- Functional package management for GNU |
f8865db6 | 2 | ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> |
e2f4b305 LC |
3 | ;;; |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (gnu build file-systems) | |
20 | #:use-module (guix build utils) | |
6eb43907 | 21 | #:use-module (guix build bournish) |
2ff0da02 | 22 | #:use-module (guix build syscalls) |
e2f4b305 LC |
23 | #:use-module (rnrs io ports) |
24 | #:use-module (rnrs bytevectors) | |
25 | #:use-module (ice-9 match) | |
26 | #:use-module (ice-9 rdelim) | |
0ec5ee94 | 27 | #:use-module (ice-9 format) |
f8865db6 | 28 | #:use-module (ice-9 regex) |
e2f4b305 LC |
29 | #:use-module (system foreign) |
30 | #:autoload (system repl repl) (start-repl) | |
31 | #:use-module (srfi srfi-1) | |
32 | #:use-module (srfi srfi-26) | |
33 | #:export (disk-partitions | |
34 | partition-label-predicate | |
0ec5ee94 | 35 | partition-uuid-predicate |
a1ccefaa | 36 | partition-luks-uuid-predicate |
e2f4b305 | 37 | find-partition-by-label |
0ec5ee94 | 38 | find-partition-by-uuid |
a1ccefaa | 39 | find-partition-by-luks-uuid |
e2f4b305 LC |
40 | canonicalize-device-spec |
41 | ||
f8865db6 LC |
42 | uuid->string |
43 | string->uuid | |
44 | ||
e2f4b305 LC |
45 | bind-mount |
46 | ||
47 | mount-flags->bit-mask | |
48 | check-file-system | |
2ff0da02 LC |
49 | mount-file-system) |
50 | #:re-export (mount | |
51 | umount | |
52 | MS_BIND | |
53 | MS_MOVE | |
54 | MS_RDONLY)) | |
e2f4b305 LC |
55 | |
56 | ;;; Commentary: | |
57 | ;;; | |
58 | ;;; This modules provides tools to deal with disk partitions, and to mount and | |
59 | ;;; check file systems. | |
60 | ;;; | |
61 | ;;; Code: | |
62 | ||
85c3127f | 63 | ;; 'mount' is already defined in the statically linked Guile used for initial |
2ff0da02 LC |
64 | ;; RAM disks, in which case the bindings in (guix build syscalls) do not work |
65 | ;; (the FFI bindings do not work there). Override them in that case. | |
66 | (when (module-defined? the-scm-module 'mount) | |
67 | (set! mount (@ (guile) mount)) | |
68 | (set! umount (@ (guile) umount))) | |
e2f4b305 LC |
69 | |
70 | (define (bind-mount source target) | |
71 | "Bind-mount SOURCE at TARGET." | |
72 | (mount source target "" MS_BIND)) | |
73 | ||
a1ccefaa LC |
74 | \f |
75 | ;;; | |
76 | ;;; Ext2 file systems. | |
77 | ;;; | |
78 | ||
e2f4b305 LC |
79 | (define-syntax %ext2-endianness |
80 | ;; Endianness of ext2 file systems. | |
81 | (identifier-syntax (endianness little))) | |
82 | ||
83 | ;; Offset in bytes of interesting parts of an ext2 superblock. See | |
84 | ;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>. | |
85 | ;; TODO: Use "packed structs" from Guile-OpenGL or similar. | |
86 | (define-syntax %ext2-sblock-magic (identifier-syntax 56)) | |
87 | (define-syntax %ext2-sblock-creator-os (identifier-syntax 72)) | |
88 | (define-syntax %ext2-sblock-uuid (identifier-syntax 104)) | |
89 | (define-syntax %ext2-sblock-volume-name (identifier-syntax 120)) | |
90 | ||
91 | (define (read-ext2-superblock device) | |
92 | "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f | |
93 | if DEVICE does not contain an ext2 file system." | |
94 | (define %ext2-magic | |
95 | ;; The magic bytes that identify an ext2 file system. | |
96 | #xef53) | |
97 | ||
98 | (define superblock-size | |
99 | ;; Size of the interesting part of an ext2 superblock. | |
100 | 264) | |
101 | ||
102 | (define block | |
103 | ;; The superblock contents. | |
104 | (make-bytevector superblock-size)) | |
105 | ||
106 | (call-with-input-file device | |
107 | (lambda (port) | |
108 | (seek port 1024 SEEK_SET) | |
109 | ||
110 | ;; Note: work around <http://bugs.gnu.org/17466>. | |
111 | (and (eqv? superblock-size (get-bytevector-n! port block 0 | |
112 | superblock-size)) | |
113 | (let ((magic (bytevector-u16-ref block %ext2-sblock-magic | |
114 | %ext2-endianness))) | |
115 | (and (= magic %ext2-magic) | |
116 | block)))))) | |
117 | ||
118 | (define (ext2-superblock-uuid sblock) | |
119 | "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector." | |
120 | (let ((uuid (make-bytevector 16))) | |
121 | (bytevector-copy! sblock %ext2-sblock-uuid uuid 0 16) | |
122 | uuid)) | |
123 | ||
124 | (define (ext2-superblock-volume-name sblock) | |
125 | "Return the volume name of SBLOCK as a string of at most 16 characters, or | |
126 | #f if SBLOCK has no volume name." | |
127 | (let ((bv (make-bytevector 16))) | |
128 | (bytevector-copy! sblock %ext2-sblock-volume-name bv 0 16) | |
129 | ||
130 | ;; This is a Latin-1, nul-terminated string. | |
131 | (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv)))) | |
132 | (if (null? bytes) | |
133 | #f | |
134 | (list->string (map integer->char bytes)))))) | |
135 | ||
a1ccefaa LC |
136 | \f |
137 | ;;; | |
138 | ;;; LUKS encrypted devices. | |
139 | ;;; | |
140 | ||
141 | ;; The LUKS header format is described in "LUKS On-Disk Format Specification": | |
142 | ;; <http://wiki.cryptsetup.googlecode.com/git/LUKS-standard/>. We follow | |
143 | ;; version 1.2.1 of this document. | |
144 | ||
145 | (define-syntax %luks-endianness | |
146 | ;; Endianness of LUKS headers. | |
147 | (identifier-syntax (endianness big))) | |
148 | ||
149 | (define-syntax %luks-header-size | |
150 | ;; Size in bytes of the LUKS header, including key slots. | |
151 | (identifier-syntax 592)) | |
152 | ||
153 | (define %luks-magic | |
154 | ;; The 'LUKS_MAGIC' constant. | |
155 | (u8-list->bytevector (append (map char->integer (string->list "LUKS")) | |
156 | (list #xba #xbe)))) | |
157 | ||
158 | (define (sub-bytevector bv start size) | |
159 | "Return a copy of the SIZE bytes of BV starting from offset START." | |
160 | (let ((result (make-bytevector size))) | |
161 | (bytevector-copy! bv start result 0 size) | |
162 | result)) | |
163 | ||
164 | (define (read-luks-header file) | |
165 | "Read a LUKS header from FILE. Return the raw header on success, and #f if | |
166 | not valid header was found." | |
167 | (call-with-input-file file | |
168 | (lambda (port) | |
169 | (let ((header (make-bytevector %luks-header-size))) | |
170 | (match (get-bytevector-n! port header 0 (bytevector-length header)) | |
171 | ((? eof-object?) | |
172 | #f) | |
173 | ((? number? len) | |
174 | (and (= len (bytevector-length header)) | |
175 | (let ((magic (sub-bytevector header 0 6)) ;XXX: inefficient | |
176 | (version (bytevector-u16-ref header 6 %luks-endianness))) | |
177 | (and (bytevector=? magic %luks-magic) | |
178 | (= version 1) | |
179 | header))))))))) | |
180 | ||
181 | (define (luks-header-uuid header) | |
182 | "Return the LUKS UUID from HEADER, as a 16-byte bytevector." | |
183 | ;; 40 bytes are reserved for the UUID, but in practice, it contains the 36 | |
184 | ;; bytes of its ASCII representation. | |
185 | (let ((uuid (sub-bytevector header 168 36))) | |
186 | (string->uuid (utf8->string uuid)))) | |
187 | ||
188 | \f | |
189 | ;;; | |
190 | ;;; Partition lookup. | |
191 | ;;; | |
192 | ||
e2f4b305 LC |
193 | (define (disk-partitions) |
194 | "Return the list of device names corresponding to valid disk partitions." | |
195 | (define (partition? major minor) | |
196 | (let ((marker (format #f "/sys/dev/block/~a:~a/partition" major minor))) | |
197 | (catch 'system-error | |
198 | (lambda () | |
199 | (not (zero? (call-with-input-file marker read)))) | |
200 | (lambda args | |
201 | (if (= ENOENT (system-error-errno args)) | |
202 | #f | |
203 | (apply throw args)))))) | |
204 | ||
205 | (call-with-input-file "/proc/partitions" | |
206 | (lambda (port) | |
207 | ;; Skip the two header lines. | |
208 | (read-line port) | |
209 | (read-line port) | |
210 | ||
211 | ;; Read each subsequent line, and extract the last space-separated | |
212 | ;; field. | |
213 | (let loop ((parts '())) | |
214 | (let ((line (read-line port))) | |
215 | (if (eof-object? line) | |
216 | (reverse parts) | |
217 | (match (string-tokenize line) | |
218 | (((= string->number major) (= string->number minor) | |
219 | blocks name) | |
220 | (if (partition? major minor) | |
221 | (loop (cons name parts)) | |
222 | (loop parts)))))))))) | |
223 | ||
24473356 LC |
224 | (define (ENOENT-safe proc) |
225 | "Wrap the one-argument PROC such that ENOENT errors are caught and lead to a | |
226 | warning and #f as the result." | |
227 | (lambda (device) | |
228 | (catch 'system-error | |
229 | (lambda () | |
230 | (proc device)) | |
231 | (lambda args | |
232 | ;; When running on the hand-made /dev, | |
233 | ;; 'disk-partitions' could return partitions for which | |
234 | ;; we have no /dev node. Handle that gracefully. | |
235 | (if (= ENOENT (system-error-errno args)) | |
236 | (begin | |
237 | (format (current-error-port) | |
238 | "warning: device '~a' not found~%" device) | |
239 | #f) | |
240 | (apply throw args)))))) | |
241 | ||
a1ccefaa LC |
242 | (define (partition-predicate read field =) |
243 | "Return a predicate that returns true if the FIELD of partition header that | |
244 | was READ is = to the given value." | |
245 | (let ((read (ENOENT-safe read))) | |
246 | (lambda (expected) | |
247 | "Return a procedure that, when applied to a partition name such as \"sda1\", | |
0ec5ee94 | 248 | returns #t if that partition's volume name is LABEL." |
a1ccefaa LC |
249 | (lambda (part) |
250 | (let* ((device (string-append "/dev/" part)) | |
251 | (sblock (read device))) | |
252 | (and sblock | |
253 | (let ((actual (field sblock))) | |
254 | (and actual | |
255 | (= actual expected))))))))) | |
0ec5ee94 LC |
256 | |
257 | (define partition-label-predicate | |
a1ccefaa LC |
258 | (partition-predicate read-ext2-superblock |
259 | ext2-superblock-volume-name | |
260 | string=?)) | |
0ec5ee94 LC |
261 | |
262 | (define partition-uuid-predicate | |
a1ccefaa LC |
263 | (partition-predicate read-ext2-superblock |
264 | ext2-superblock-uuid | |
265 | bytevector=?)) | |
266 | ||
267 | (define partition-luks-uuid-predicate | |
268 | (partition-predicate read-luks-header | |
269 | luks-header-uuid | |
270 | bytevector=?)) | |
e2f4b305 LC |
271 | |
272 | (define (find-partition-by-label label) | |
273 | "Return the first partition found whose volume name is LABEL, or #f if none | |
274 | were found." | |
275 | (and=> (find (partition-label-predicate label) | |
276 | (disk-partitions)) | |
277 | (cut string-append "/dev/" <>))) | |
278 | ||
0ec5ee94 LC |
279 | (define (find-partition-by-uuid uuid) |
280 | "Return the first partition whose unique identifier is UUID (a bytevector), | |
281 | or #f if none was found." | |
282 | (and=> (find (partition-uuid-predicate uuid) | |
283 | (disk-partitions)) | |
284 | (cut string-append "/dev/" <>))) | |
285 | ||
a1ccefaa LC |
286 | (define (find-partition-by-luks-uuid uuid) |
287 | "Return the first LUKS partition whose unique identifier is UUID (a bytevector), | |
288 | or #f if none was found." | |
289 | (and=> (find (partition-luks-uuid-predicate uuid) | |
290 | (disk-partitions)) | |
291 | (cut string-append "/dev/" <>))) | |
292 | ||
f8865db6 LC |
293 | \f |
294 | ;;; | |
295 | ;;; UUIDs. | |
296 | ;;; | |
297 | ||
0ec5ee94 LC |
298 | (define-syntax %network-byte-order |
299 | (identifier-syntax (endianness big))) | |
300 | ||
301 | (define (uuid->string uuid) | |
302 | "Convert UUID, a 16-byte bytevector, to its string representation, something | |
303 | like \"6b700d61-5550-48a1-874c-a3d86998990e\"." | |
304 | ;; See <https://tools.ietf.org/html/rfc4122>. | |
305 | (let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4)) | |
306 | (time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2)) | |
307 | (time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2)) | |
308 | (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2)) | |
309 | (node (bytevector-uint-ref uuid 10 %network-byte-order 6))) | |
310 | (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x" | |
311 | time-low time-mid time-hi clock-seq node))) | |
312 | ||
f8865db6 LC |
313 | (define %uuid-rx |
314 | ;; The regexp of a UUID. | |
315 | (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$")) | |
316 | ||
317 | (define (string->uuid str) | |
318 | "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and | |
319 | return its contents as a 16-byte bytevector. Return #f if STR is not a valid | |
320 | UUID representation." | |
321 | (and=> (regexp-exec %uuid-rx str) | |
322 | (lambda (match) | |
323 | (letrec-syntax ((hex->number | |
324 | (syntax-rules () | |
325 | ((_ index) | |
326 | (string->number (match:substring match index) | |
327 | 16)))) | |
328 | (put! | |
329 | (syntax-rules () | |
330 | ((_ bv index (number len) rest ...) | |
331 | (begin | |
332 | (bytevector-uint-set! bv index number | |
333 | (endianness big) len) | |
334 | (put! bv (+ index len) rest ...))) | |
335 | ((_ bv index) | |
336 | bv)))) | |
337 | (let ((time-low (hex->number 1)) | |
338 | (time-mid (hex->number 2)) | |
339 | (time-hi (hex->number 3)) | |
340 | (clock-seq (hex->number 4)) | |
341 | (node (hex->number 5)) | |
342 | (uuid (make-bytevector 16))) | |
343 | (put! uuid 0 | |
344 | (time-low 4) (time-mid 2) (time-hi 2) | |
345 | (clock-seq 2) (node 6))))))) | |
346 | ||
347 | \f | |
e2f4b305 LC |
348 | (define* (canonicalize-device-spec spec #:optional (title 'any)) |
349 | "Return the device name corresponding to SPEC. TITLE is a symbol, one of | |
350 | the following: | |
351 | ||
352 | • 'device', in which case SPEC is known to designate a device node--e.g., | |
353 | \"/dev/sda1\"; | |
354 | • 'label', in which case SPEC is known to designate a partition label--e.g., | |
355 | \"my-root-part\"; | |
0ec5ee94 LC |
356 | • 'uuid', in which case SPEC must be a UUID (a 16-byte bytevector) |
357 | designating a partition; | |
e2f4b305 LC |
358 | • 'any', in which case SPEC can be anything. |
359 | " | |
360 | (define max-trials | |
361 | ;; Number of times we retry partition label resolution, 1 second per | |
362 | ;; trial. Note: somebody reported a delay of 16 seconds (!) before their | |
363 | ;; USB key would be detected by the kernel, so we must wait for at least | |
364 | ;; this long. | |
365 | 20) | |
366 | ||
367 | (define canonical-title | |
368 | ;; The realm of canonicalization. | |
369 | (if (eq? title 'any) | |
0ec5ee94 | 370 | (if (string? spec) |
f453f637 LC |
371 | ;; The "--root=SPEC" kernel command-line option always provides a |
372 | ;; string, but the string can represent a device, a UUID, or a | |
373 | ;; label. So check for all three. | |
374 | (cond ((string-prefix? "/" spec) 'device) | |
375 | ((string->uuid spec) 'uuid) | |
376 | (else 'label)) | |
0ec5ee94 | 377 | 'uuid) |
e2f4b305 LC |
378 | title)) |
379 | ||
0ec5ee94 LC |
380 | (define (resolve find-partition spec fmt) |
381 | (let loop ((count 0)) | |
382 | (let ((device (find-partition spec))) | |
383 | (or device | |
384 | ;; Some devices take a bit of time to appear, most notably USB | |
385 | ;; storage devices. Thus, wait for the device to appear. | |
386 | (if (> count max-trials) | |
387 | (error "failed to resolve partition" (fmt spec)) | |
388 | (begin | |
389 | (format #t "waiting for partition '~a' to appear...~%" | |
390 | (fmt spec)) | |
391 | (sleep 1) | |
392 | (loop (+ 1 count)))))))) | |
393 | ||
e2f4b305 LC |
394 | (case canonical-title |
395 | ((device) | |
396 | ;; Nothing to do. | |
397 | spec) | |
398 | ((label) | |
399 | ;; Resolve the label. | |
0ec5ee94 LC |
400 | (resolve find-partition-by-label spec identity)) |
401 | ((uuid) | |
f453f637 LC |
402 | (resolve find-partition-by-uuid |
403 | (if (string? spec) | |
404 | (string->uuid spec) | |
405 | spec) | |
406 | uuid->string)) | |
e2f4b305 LC |
407 | (else |
408 | (error "unknown device title" title)))) | |
409 | ||
410 | (define (check-file-system device type) | |
411 | "Run a file system check of TYPE on DEVICE." | |
412 | (define fsck | |
413 | (string-append "fsck." type)) | |
414 | ||
4359378a | 415 | (let ((status (system* fsck "-v" "-p" "-C" "0" device))) |
e2f4b305 LC |
416 | (match (status:exit-val status) |
417 | (0 | |
418 | #t) | |
419 | (1 | |
420 | (format (current-error-port) "'~a' corrected errors on ~a; continuing~%" | |
421 | fsck device)) | |
422 | (2 | |
423 | (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%" | |
424 | fsck device) | |
425 | (sleep 3) | |
426 | (reboot)) | |
427 | (code | |
6eb43907 LC |
428 | (format (current-error-port) "'~a' exited with code ~a on ~a; \ |
429 | spawning Bourne-like REPL~%" | |
e2f4b305 | 430 | fsck code device) |
6eb43907 | 431 | (start-repl %bournish-language))))) |
e2f4b305 LC |
432 | |
433 | (define (mount-flags->bit-mask flags) | |
434 | "Return the number suitable for the 'flags' argument of 'mount' that | |
435 | corresponds to the symbols listed in FLAGS." | |
436 | (let loop ((flags flags)) | |
437 | (match flags | |
438 | (('read-only rest ...) | |
439 | (logior MS_RDONLY (loop rest))) | |
440 | (('bind-mount rest ...) | |
441 | (logior MS_BIND (loop rest))) | |
442 | (('no-suid rest ...) | |
443 | (logior MS_NOSUID (loop rest))) | |
444 | (('no-dev rest ...) | |
445 | (logior MS_NODEV (loop rest))) | |
446 | (('no-exec rest ...) | |
447 | (logior MS_NOEXEC (loop rest))) | |
448 | (() | |
449 | 0)))) | |
450 | ||
8c812f2a DT |
451 | (define (regular-file? file-name) |
452 | "Return #t if FILE-NAME is a regular file." | |
453 | (eq? (stat:type (stat file-name)) 'regular)) | |
454 | ||
e2f4b305 LC |
455 | (define* (mount-file-system spec #:key (root "/root")) |
456 | "Mount the file system described by SPEC under ROOT. SPEC must have the | |
457 | form: | |
458 | ||
459 | (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?) | |
460 | ||
461 | DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; | |
462 | FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to | |
463 | run a file system check." | |
464 | (match spec | |
465 | ((source title mount-point type (flags ...) options check?) | |
466 | (let ((source (canonicalize-device-spec source title)) | |
b86fee78 LC |
467 | (mount-point (string-append root "/" mount-point)) |
468 | (flags (mount-flags->bit-mask flags))) | |
e2f4b305 LC |
469 | (when check? |
470 | (check-file-system source type)) | |
8c812f2a DT |
471 | |
472 | ;; Create the mount point. Most of the time this is a directory, but | |
473 | ;; in the case of a bind mount, a regular file may be needed. | |
474 | (if (and (= MS_BIND (logand flags MS_BIND)) | |
475 | (regular-file? source)) | |
78981bb9 | 476 | (unless (file-exists? mount-point) |
8c812f2a DT |
477 | (mkdir-p (dirname mount-point)) |
478 | (call-with-output-file mount-point (const #t))) | |
479 | (mkdir-p mount-point)) | |
480 | ||
5fd77f3f | 481 | (mount source mount-point type flags options) |
b86fee78 LC |
482 | |
483 | ;; For read-only bind mounts, an extra remount is needed, as per | |
484 | ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0. | |
485 | (when (and (= MS_BIND (logand flags MS_BIND)) | |
486 | (= MS_RDONLY (logand flags MS_RDONLY))) | |
5fd77f3f DT |
487 | (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY))) |
488 | (mount source mount-point type flags #f))))))) | |
e2f4b305 LC |
489 | |
490 | ;;; file-systems.scm ends here |