1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
5 ;;; This file is part of GNU Guix.
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.
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.
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/>.
20 (define-module (gnu build file-systems)
21 #:use-module (guix build utils)
22 #:use-module (guix build bournish)
23 #:use-module (guix build syscalls)
24 #:use-module (rnrs io ports)
25 #:use-module (rnrs bytevectors)
26 #:use-module (ice-9 match)
27 #:use-module (ice-9 rdelim)
28 #:use-module (ice-9 format)
29 #:use-module (ice-9 regex)
30 #:use-module (system foreign)
31 #:autoload (system repl repl) (start-repl)
32 #:use-module (srfi srfi-1)
33 #:use-module (srfi srfi-26)
34 #:export (disk-partitions
35 partition-label-predicate
36 partition-uuid-predicate
37 partition-luks-uuid-predicate
38 find-partition-by-label
39 find-partition-by-uuid
40 find-partition-by-luks-uuid
41 canonicalize-device-spec
59 ;;; This modules provides tools to deal with disk partitions, and to mount and
60 ;;; check file systems.
64 ;; 'mount' is already defined in the statically linked Guile used for initial
65 ;; RAM disks, in which case the bindings in (guix build syscalls) do not work
66 ;; (the FFI bindings do not work there). Override them in that case.
67 (when (module-defined? the-scm-module 'mount)
68 (set! mount (@ (guile) mount))
69 (set! umount (@ (guile) umount)))
71 (define (bind-mount source target)
72 "Bind-mount SOURCE at TARGET."
73 (mount source target "" MS_BIND))
75 (define (seek* fd/port offset whence)
76 "Like 'seek' but return -1 instead of throwing to 'system-error' upon
77 EINVAL. This makes it easier to catch cases like OFFSET being too large for
81 (seek fd/port offset whence))
83 (if (= EINVAL (system-error-errno args))
85 (apply throw args)))))
87 (define (read-superblock device offset size magic?)
88 "Read a superblock of SIZE from OFFSET and DEVICE. Return the raw
89 superblock on success, and #f if no valid superblock was found. MAGIC?
90 takes a bytevector and returns #t when it's a valid superblock."
91 (call-with-input-file device
93 (and (= offset (seek* port offset SEEK_SET))
94 (let ((block (make-bytevector size)))
95 (match (get-bytevector-n! port block 0 (bytevector-length block))
99 (and (= len (bytevector-length block))
103 (define (sub-bytevector bv start size)
104 "Return a copy of the SIZE bytes of BV starting from offset START."
105 (let ((result (make-bytevector size)))
106 (bytevector-copy! bv start result 0 size)
109 (define (null-terminated-latin1->string bv)
110 "Return the volume name of SBLOCK as a string of at most 256 characters, or
111 #f if SBLOCK has no volume name."
112 ;; This is a Latin-1, nul-terminated string.
113 (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
116 (list->string (map integer->char bytes)))))
120 ;;; Ext2 file systems.
123 ;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
124 ;; TODO: Use "packed structs" from Guile-OpenGL or similar.
126 (define-syntax %ext2-endianness
127 ;; Endianness of ext2 file systems.
128 (identifier-syntax (endianness little)))
130 (define (ext2-superblock? sblock)
131 "Return #t when SBLOCK is an ext2 superblock."
132 (let ((magic (bytevector-u16-ref sblock 56 %ext2-endianness)))
135 (define (read-ext2-superblock device)
136 "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
137 if DEVICE does not contain an ext2 file system."
138 (read-superblock device 1024 264 ext2-superblock?))
140 (define (ext2-superblock-uuid sblock)
141 "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
142 (sub-bytevector sblock 104 16))
144 (define (ext2-superblock-volume-name sblock)
145 "Return the volume name of SBLOCK as a string of at most 16 characters, or
146 #f if SBLOCK has no volume name."
147 (null-terminated-latin1->string (sub-bytevector sblock 120 16)))
149 (define (check-ext2-file-system device)
150 "Return the health of an ext2 file system on DEVICE."
151 (match (status:exit-val
152 (system* "e2fsck" "-v" "-p" "-C" "0" device))
154 (1 'errors-corrected)
160 ;;; Btrfs file systems.
163 ;; <https://btrfs.wiki.kernel.org/index.php/On-disk_Format#Superblock>.
165 (define-syntax %btrfs-endianness
166 ;; Endianness of btrfs file systems.
167 (identifier-syntax (endianness little)))
169 (define (btrfs-superblock? sblock)
170 "Return #t when SBLOCK is a btrfs superblock."
171 (bytevector=? (sub-bytevector sblock 64 8)
172 (string->utf8 "_BHRfS_M")))
174 (define (read-btrfs-superblock device)
175 "Return the raw contents of DEVICE's btrfs superblock as a bytevector, or #f
176 if DEVICE does not contain a btrfs file system."
177 (read-superblock device 65536 4096 btrfs-superblock?))
179 (define (btrfs-superblock-uuid sblock)
180 "Return the UUID of a btrfs superblock SBLOCK as a 16-byte bytevector."
181 (sub-bytevector sblock 32 16))
183 (define (btrfs-superblock-volume-name sblock)
184 "Return the volume name of SBLOCK as a string of at most 256 characters, or
185 #f if SBLOCK has no volume name."
186 (null-terminated-latin1->string (sub-bytevector sblock 299 256)))
188 (define (check-btrfs-file-system device)
189 "Return the health of a btrfs file system on DEVICE."
190 (match (status:exit-val
191 (system* "btrfs" "device" "scan"))
197 ;;; LUKS encrypted devices.
200 ;; The LUKS header format is described in "LUKS On-Disk Format Specification":
201 ;; <https://gitlab.com/cryptsetup/cryptsetup/wikis/Specification>. We follow
202 ;; version 1.2.1 of this document.
204 (define-syntax %luks-endianness
205 ;; Endianness of LUKS headers.
206 (identifier-syntax (endianness big)))
208 (define (luks-superblock? sblock)
209 "Return #t when SBLOCK is a luks superblock."
211 ;; The 'LUKS_MAGIC' constant.
212 (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
214 (let ((magic (sub-bytevector sblock 0 6))
215 (version (bytevector-u16-ref sblock 6 %luks-endianness)))
216 (and (bytevector=? magic %luks-magic)
219 (define (read-luks-header file)
220 "Read a LUKS header from FILE. Return the raw header on success, and #f if
221 not valid header was found."
222 ;; Size in bytes of the LUKS header, including key slots.
223 (read-superblock file 0 592 luks-superblock?))
225 (define (luks-header-uuid header)
226 "Return the LUKS UUID from HEADER, as a 16-byte bytevector."
227 ;; 40 bytes are reserved for the UUID, but in practice, it contains the 36
228 ;; bytes of its ASCII representation.
229 (let ((uuid (sub-bytevector header 168 36)))
230 (string->uuid (utf8->string uuid))))
234 ;;; Partition lookup.
237 (define (disk-partitions)
238 "Return the list of device names corresponding to valid disk partitions."
239 (define (last-character str)
240 (string-ref str (- (string-length str) 1)))
242 (define (partition? name major minor)
243 ;; Select device names that end in a digit, like libblkid's 'probe_all'
244 ;; function does. Checking for "/sys/dev/block/MAJOR:MINOR/partition"
245 ;; doesn't work for partitions coming from mapped devices.
246 (and (char-set-contains? char-set:digit (last-character name))
247 (> major 2))) ;ignore RAM disks and floppy disks
249 (call-with-input-file "/proc/partitions"
251 ;; Skip the two header lines.
255 ;; Read each subsequent line, and extract the last space-separated
257 (let loop ((parts '()))
258 (let ((line (read-line port)))
259 (if (eof-object? line)
261 (match (string-tokenize line)
262 (((= string->number major) (= string->number minor)
264 (if (partition? name major minor)
265 (loop (cons name parts))
266 (loop parts))))))))))
268 (define (ENOENT-safe proc)
269 "Wrap the one-argument PROC such that ENOENT errors are caught and lead to a
270 warning and #f as the result."
276 ;; When running on the hand-made /dev,
277 ;; 'disk-partitions' could return partitions for which
278 ;; we have no /dev node. Handle that gracefully.
279 (let ((errno (system-error-errno args)))
280 (cond ((= ENOENT errno)
281 (format (current-error-port)
282 "warning: device '~a' not found~%" device)
284 ((= ENOMEDIUM errno) ;for removable media
287 (apply throw args))))))))
289 (define (partition-field-reader read field)
290 "Return a procedure that takes a device and returns the value of a FIELD in
291 the partition superblock or #f."
292 (let ((read (ENOENT-safe read)))
294 (let ((sblock (read device)))
298 (define (read-partition-field device partition-field-readers)
299 "Returns the value of a FIELD in the partition superblock of DEVICE or #f. It
300 takes a list of PARTITION-FIELD-READERS and returns the result of the first
301 partition field reader that returned a value."
302 (match (filter-map (cut apply <> (list device)) partition-field-readers)
306 (define %partition-label-readers
307 (list (partition-field-reader read-ext2-superblock
308 ext2-superblock-volume-name)
309 (partition-field-reader read-btrfs-superblock
310 btrfs-superblock-volume-name)))
312 (define %partition-uuid-readers
313 (list (partition-field-reader read-ext2-superblock
314 ext2-superblock-uuid)
315 (partition-field-reader read-btrfs-superblock
316 btrfs-superblock-uuid)))
318 (define read-partition-label
319 (cut read-partition-field <> %partition-label-readers))
321 (define read-partition-uuid
322 (cut read-partition-field <> %partition-uuid-readers))
324 (define (partition-predicate reader =)
325 "Return a predicate that returns true if the FIELD of partition header that
326 was READ is = to the given value."
329 (let ((actual (reader device)))
331 (= actual expected))))))
333 (define partition-label-predicate
334 (partition-predicate read-partition-label string=?))
336 (define partition-uuid-predicate
337 (partition-predicate read-partition-uuid bytevector=?))
339 (define luks-partition-uuid-predicate
341 (partition-field-reader read-luks-header luks-header-uuid)
344 (define (find-partition predicate)
345 "Return the first partition found that matches PREDICATE, or #f if none
348 (find (predicate expected)
349 (map (cut string-append "/dev/" <>)
350 (disk-partitions)))))
352 (define find-partition-by-label
353 (find-partition partition-label-predicate))
355 (define find-partition-by-uuid
356 (find-partition partition-uuid-predicate))
358 (define find-partition-by-luks-uuid
359 (find-partition luks-partition-uuid-predicate))
366 (define-syntax %network-byte-order
367 (identifier-syntax (endianness big)))
369 (define (uuid->string uuid)
370 "Convert UUID, a 16-byte bytevector, to its string representation, something
371 like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
372 ;; See <https://tools.ietf.org/html/rfc4122>.
373 (let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4))
374 (time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2))
375 (time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2))
376 (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
377 (node (bytevector-uint-ref uuid 10 %network-byte-order 6)))
378 (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
379 time-low time-mid time-hi clock-seq node)))
382 ;; The regexp of a UUID.
383 (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
385 (define (string->uuid str)
386 "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
387 return its contents as a 16-byte bytevector. Return #f if STR is not a valid
388 UUID representation."
389 (and=> (regexp-exec %uuid-rx str)
391 (letrec-syntax ((hex->number
394 (string->number (match:substring match index)
398 ((_ bv index (number len) rest ...)
400 (bytevector-uint-set! bv index number
401 (endianness big) len)
402 (put! bv (+ index len) rest ...)))
405 (let ((time-low (hex->number 1))
406 (time-mid (hex->number 2))
407 (time-hi (hex->number 3))
408 (clock-seq (hex->number 4))
409 (node (hex->number 5))
410 (uuid (make-bytevector 16)))
412 (time-low 4) (time-mid 2) (time-hi 2)
413 (clock-seq 2) (node 6)))))))
416 (define* (canonicalize-device-spec spec #:optional (title 'any))
417 "Return the device name corresponding to SPEC. TITLE is a symbol, one of
420 • 'device', in which case SPEC is known to designate a device node--e.g.,
422 • 'label', in which case SPEC is known to designate a partition label--e.g.,
424 • 'uuid', in which case SPEC must be a UUID (a 16-byte bytevector)
425 designating a partition;
426 • 'any', in which case SPEC can be anything.
429 ;; Number of times we retry partition label resolution, 1 second per
430 ;; trial. Note: somebody reported a delay of 16 seconds (!) before their
431 ;; USB key would be detected by the kernel, so we must wait for at least
435 (define canonical-title
436 ;; The realm of canonicalization.
439 ;; The "--root=SPEC" kernel command-line option always provides a
440 ;; string, but the string can represent a device, a UUID, or a
441 ;; label. So check for all three.
442 (cond ((string-prefix? "/" spec) 'device)
443 ((string->uuid spec) 'uuid)
448 (define (resolve find-partition spec fmt)
449 (let loop ((count 0))
450 (let ((device (find-partition spec)))
452 ;; Some devices take a bit of time to appear, most notably USB
453 ;; storage devices. Thus, wait for the device to appear.
454 (if (> count max-trials)
455 (error "failed to resolve partition" (fmt spec))
457 (format #t "waiting for partition '~a' to appear...~%"
460 (loop (+ 1 count))))))))
462 (case canonical-title
467 ;; Resolve the label.
468 (resolve find-partition-by-label spec identity))
470 (resolve find-partition-by-uuid
476 (error "unknown device title" title))))
478 (define (check-file-system device type)
479 "Run a file system check of TYPE on DEVICE."
480 (define check-procedure
482 ((string-prefix? "ext" type) check-ext2-file-system)
483 ((string-prefix? "btrfs" type) check-btrfs-file-system)
487 (match (check-procedure device)
491 (format (current-error-port)
492 "File system check corrected errors on ~a; continuing~%"
495 (format (current-error-port)
496 "File system check corrected errors on ~a; rebooting~%"
501 (format (current-error-port)
502 "File system check on ~a failed; spawning Bourne-like REPL~%"
504 (start-repl %bournish-language)))
505 (format (current-error-port)
506 "No file system check procedure for ~a; skipping~%"
509 (define (mount-flags->bit-mask flags)
510 "Return the number suitable for the 'flags' argument of 'mount' that
511 corresponds to the symbols listed in FLAGS."
512 (let loop ((flags flags))
514 (('read-only rest ...)
515 (logior MS_RDONLY (loop rest)))
516 (('bind-mount rest ...)
517 (logior MS_BIND (loop rest)))
519 (logior MS_NOSUID (loop rest)))
521 (logior MS_NODEV (loop rest)))
523 (logior MS_NOEXEC (loop rest)))
527 (define (regular-file? file-name)
528 "Return #t if FILE-NAME is a regular file."
529 (eq? (stat:type (stat file-name)) 'regular))
531 (define* (mount-file-system spec #:key (root "/root"))
532 "Mount the file system described by SPEC under ROOT. SPEC must have the
535 (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
537 DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
538 FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
539 run a file system check."
541 (define (mount-nfs source mount-point type flags options)
542 (let* ((idx (string-rindex source #\:))
543 (host-part (string-take source idx))
544 ;; Strip [] from around host if present
545 (host (match (string-split host-part (string->char-set "[]"))
548 (aa (match (getaddrinfo host "nfs") ((x . _) x)))
549 (sa (addrinfo:addr aa))
550 (inet-addr (inet-ntop (sockaddr:fam sa)
551 (sockaddr:addr sa))))
553 ;; Mounting an NFS file system requires passing the address
554 ;; of the server in the addr= option
555 (mount source mount-point type flags
556 (string-append "addr="
559 (string-append "," options)
562 ((source title mount-point type (flags ...) options check?)
563 (let ((source (canonicalize-device-spec source title))
564 (mount-point (string-append root "/" mount-point))
565 (flags (mount-flags->bit-mask flags)))
567 (check-file-system source type))
569 ;; Create the mount point. Most of the time this is a directory, but
570 ;; in the case of a bind mount, a regular file may be needed.
571 (if (and (= MS_BIND (logand flags MS_BIND))
572 (regular-file? source))
573 (unless (file-exists? mount-point)
574 (mkdir-p (dirname mount-point))
575 (call-with-output-file mount-point (const #t)))
576 (mkdir-p mount-point))
579 ((string-prefix? "nfs" type)
580 (mount-nfs source mount-point type flags options))
582 (mount source mount-point type flags options)))
584 ;; For read-only bind mounts, an extra remount is needed, as per
585 ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
586 (when (and (= MS_BIND (logand flags MS_BIND))
587 (= MS_RDONLY (logand flags MS_RDONLY)))
588 (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
589 (mount source mount-point type flags #f)))))))
591 ;;; file-systems.scm ends here