1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2015, 2016 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 (read-superblock device offset size magic?)
76 "Read a superblock of SIZE from OFFSET and DEVICE. Return the raw
77 superblock on success, and #f if no valid superblock was found. MAGIC?
78 takes a bytevector and returns #t when it's a valid superblock."
79 (call-with-input-file device
81 (seek port offset SEEK_SET)
83 (let ((block (make-bytevector size)))
84 (match (get-bytevector-n! port block 0 (bytevector-length block))
88 (and (= len (bytevector-length block))
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)
98 (define (null-terminated-latin1->string bv)
99 "Return the volume name of SBLOCK as a string of at most 256 characters, or
100 #f if SBLOCK has no volume name."
101 ;; This is a Latin-1, nul-terminated string.
102 (let ((bytes (take-while (negate zero?) (bytevector->u8-list bv))))
105 (list->string (map integer->char bytes)))))
109 ;;; Ext2 file systems.
112 ;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
113 ;; TODO: Use "packed structs" from Guile-OpenGL or similar.
115 (define-syntax %ext2-endianness
116 ;; Endianness of ext2 file systems.
117 (identifier-syntax (endianness little)))
119 (define (ext2-superblock? sblock)
120 "Return #t when SBLOCK is an ext2 superblock."
121 (let ((magic (bytevector-u16-ref sblock 56 %ext2-endianness)))
124 (define (read-ext2-superblock device)
125 "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
126 if DEVICE does not contain an ext2 file system."
127 (read-superblock device 1024 264 ext2-superblock?))
129 (define (ext2-superblock-uuid sblock)
130 "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
131 (sub-bytevector sblock 104 16))
133 (define (ext2-superblock-volume-name sblock)
134 "Return the volume name of SBLOCK as a string of at most 16 characters, or
135 #f if SBLOCK has no volume name."
136 (null-terminated-latin1->string (sub-bytevector sblock 120 16)))
138 (define (check-ext2-file-system device)
139 "Return the health of an ext2 file system on DEVICE."
140 (match (status:exit-val
141 (system* "e2fsck" "-v" "-p" "-C" "0" device))
143 (1 'errors-corrected)
149 ;;; Btrfs file systems.
152 ;; <https://btrfs.wiki.kernel.org/index.php/On-disk_Format#Superblock>.
154 (define-syntax %btrfs-endianness
155 ;; Endianness of btrfs file systems.
156 (identifier-syntax (endianness little)))
158 (define (btrfs-superblock? sblock)
159 "Return #t when SBLOCK is a btrfs superblock."
160 (bytevector=? (sub-bytevector sblock 64 8)
161 (string->utf8 "_BHRfS_M")))
163 (define (read-btrfs-superblock device)
164 "Return the raw contents of DEVICE's btrfs superblock as a bytevector, or #f
165 if DEVICE does not contain a btrfs file system."
166 (read-superblock device 65536 4096 btrfs-superblock?))
168 (define (btrfs-superblock-uuid sblock)
169 "Return the UUID of a btrfs superblock SBLOCK as a 16-byte bytevector."
170 (sub-bytevector sblock 32 16))
172 (define (btrfs-superblock-volume-name sblock)
173 "Return the volume name of SBLOCK as a string of at most 256 characters, or
174 #f if SBLOCK has no volume name."
175 (null-terminated-latin1->string (sub-bytevector sblock 299 256)))
177 (define (check-btrfs-file-system device)
178 "Return the health of a btrfs file system on DEVICE."
179 (match (status:exit-val
180 (system* "btrfs" "device" "scan"))
186 ;;; LUKS encrypted devices.
189 ;; The LUKS header format is described in "LUKS On-Disk Format Specification":
190 ;; <https://gitlab.com/cryptsetup/cryptsetup/wikis/Specification>. We follow
191 ;; version 1.2.1 of this document.
193 (define-syntax %luks-endianness
194 ;; Endianness of LUKS headers.
195 (identifier-syntax (endianness big)))
197 (define (luks-superblock? sblock)
198 "Return #t when SBLOCK is a luks superblock."
200 ;; The 'LUKS_MAGIC' constant.
201 (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
203 (let ((magic (sub-bytevector sblock 0 6))
204 (version (bytevector-u16-ref sblock 6 %luks-endianness)))
205 (and (bytevector=? magic %luks-magic)
208 (define (read-luks-header file)
209 "Read a LUKS header from FILE. Return the raw header on success, and #f if
210 not valid header was found."
211 ;; Size in bytes of the LUKS header, including key slots.
212 (read-superblock file 0 592 luks-superblock?))
214 (define (luks-header-uuid header)
215 "Return the LUKS UUID from HEADER, as a 16-byte bytevector."
216 ;; 40 bytes are reserved for the UUID, but in practice, it contains the 36
217 ;; bytes of its ASCII representation.
218 (let ((uuid (sub-bytevector header 168 36)))
219 (string->uuid (utf8->string uuid))))
223 ;;; Partition lookup.
226 (define (disk-partitions)
227 "Return the list of device names corresponding to valid disk partitions."
228 (define (last-character str)
229 (string-ref str (- (string-length str) 1)))
231 (define (partition? name major minor)
232 ;; Select device names that end in a digit, like libblkid's 'probe_all'
233 ;; function does. Checking for "/sys/dev/block/MAJOR:MINOR/partition"
234 ;; doesn't work for partitions coming from mapped devices.
235 (and (char-set-contains? char-set:digit (last-character name))
236 (> major 2))) ;ignore RAM disks and floppy disks
238 (call-with-input-file "/proc/partitions"
240 ;; Skip the two header lines.
244 ;; Read each subsequent line, and extract the last space-separated
246 (let loop ((parts '()))
247 (let ((line (read-line port)))
248 (if (eof-object? line)
250 (match (string-tokenize line)
251 (((= string->number major) (= string->number minor)
253 (if (partition? name major minor)
254 (loop (cons name parts))
255 (loop parts))))))))))
257 (define (ENOENT-safe proc)
258 "Wrap the one-argument PROC such that ENOENT errors are caught and lead to a
259 warning and #f as the result."
265 ;; When running on the hand-made /dev,
266 ;; 'disk-partitions' could return partitions for which
267 ;; we have no /dev node. Handle that gracefully.
268 (let ((errno (system-error-errno args)))
269 (cond ((= ENOENT errno)
270 (format (current-error-port)
271 "warning: device '~a' not found~%" device)
273 ((= ENOMEDIUM errno) ;for removable media
276 (apply throw args))))))))
278 (define (partition-field-reader read field)
279 "Return a procedure that takes a device and returns the value of a FIELD in
280 the partition superblock or #f."
281 (let ((read (ENOENT-safe read)))
283 (let ((sblock (read device)))
287 (define (read-partition-field device partition-field-readers)
288 "Returns the value of a FIELD in the partition superblock of DEVICE or #f. It
289 takes a list of PARTITION-FIELD-READERS and returns the result of the first
290 partition field reader that returned a value."
291 (match (filter-map (cut apply <> (list device)) partition-field-readers)
295 (define %partition-label-readers
296 (list (partition-field-reader read-ext2-superblock
297 ext2-superblock-volume-name)
298 (partition-field-reader read-btrfs-superblock
299 btrfs-superblock-volume-name)))
301 (define %partition-uuid-readers
302 (list (partition-field-reader read-ext2-superblock
303 ext2-superblock-uuid)
304 (partition-field-reader read-btrfs-superblock
305 btrfs-superblock-uuid)))
307 (define read-partition-label
308 (cut read-partition-field <> %partition-label-readers))
310 (define read-partition-uuid
311 (cut read-partition-field <> %partition-uuid-readers))
313 (define (partition-predicate reader =)
314 "Return a predicate that returns true if the FIELD of partition header that
315 was READ is = to the given value."
318 (let ((actual (reader device)))
320 (= actual expected))))))
322 (define partition-label-predicate
323 (partition-predicate read-partition-label string=?))
325 (define partition-uuid-predicate
326 (partition-predicate read-partition-uuid bytevector=?))
328 (define luks-partition-uuid-predicate
330 (partition-field-reader read-luks-header luks-header-uuid)
333 (define (find-partition predicate)
334 "Return the first partition found that matches PREDICATE, or #f if none
337 (find (predicate expected)
338 (map (cut string-append "/dev/" <>)
339 (disk-partitions)))))
341 (define find-partition-by-label
342 (find-partition partition-label-predicate))
344 (define find-partition-by-uuid
345 (find-partition partition-uuid-predicate))
347 (define find-partition-by-luks-uuid
348 (find-partition luks-partition-uuid-predicate))
355 (define-syntax %network-byte-order
356 (identifier-syntax (endianness big)))
358 (define (uuid->string uuid)
359 "Convert UUID, a 16-byte bytevector, to its string representation, something
360 like \"6b700d61-5550-48a1-874c-a3d86998990e\"."
361 ;; See <https://tools.ietf.org/html/rfc4122>.
362 (let ((time-low (bytevector-uint-ref uuid 0 %network-byte-order 4))
363 (time-mid (bytevector-uint-ref uuid 4 %network-byte-order 2))
364 (time-hi (bytevector-uint-ref uuid 6 %network-byte-order 2))
365 (clock-seq (bytevector-uint-ref uuid 8 %network-byte-order 2))
366 (node (bytevector-uint-ref uuid 10 %network-byte-order 6)))
367 (format #f "~8,'0x-~4,'0x-~4,'0x-~4,'0x-~12,'0x"
368 time-low time-mid time-hi clock-seq node)))
371 ;; The regexp of a UUID.
372 (make-regexp "^([[:xdigit:]]{8})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{4})-([[:xdigit:]]{12})$"))
374 (define (string->uuid str)
375 "Parse STR as a DCE UUID (see <https://tools.ietf.org/html/rfc4122>) and
376 return its contents as a 16-byte bytevector. Return #f if STR is not a valid
377 UUID representation."
378 (and=> (regexp-exec %uuid-rx str)
380 (letrec-syntax ((hex->number
383 (string->number (match:substring match index)
387 ((_ bv index (number len) rest ...)
389 (bytevector-uint-set! bv index number
390 (endianness big) len)
391 (put! bv (+ index len) rest ...)))
394 (let ((time-low (hex->number 1))
395 (time-mid (hex->number 2))
396 (time-hi (hex->number 3))
397 (clock-seq (hex->number 4))
398 (node (hex->number 5))
399 (uuid (make-bytevector 16)))
401 (time-low 4) (time-mid 2) (time-hi 2)
402 (clock-seq 2) (node 6)))))))
405 (define* (canonicalize-device-spec spec #:optional (title 'any))
406 "Return the device name corresponding to SPEC. TITLE is a symbol, one of
409 • 'device', in which case SPEC is known to designate a device node--e.g.,
411 • 'label', in which case SPEC is known to designate a partition label--e.g.,
413 • 'uuid', in which case SPEC must be a UUID (a 16-byte bytevector)
414 designating a partition;
415 • 'any', in which case SPEC can be anything.
418 ;; Number of times we retry partition label resolution, 1 second per
419 ;; trial. Note: somebody reported a delay of 16 seconds (!) before their
420 ;; USB key would be detected by the kernel, so we must wait for at least
424 (define canonical-title
425 ;; The realm of canonicalization.
428 ;; The "--root=SPEC" kernel command-line option always provides a
429 ;; string, but the string can represent a device, a UUID, or a
430 ;; label. So check for all three.
431 (cond ((string-prefix? "/" spec) 'device)
432 ((string->uuid spec) 'uuid)
437 (define (resolve find-partition spec fmt)
438 (let loop ((count 0))
439 (let ((device (find-partition spec)))
441 ;; Some devices take a bit of time to appear, most notably USB
442 ;; storage devices. Thus, wait for the device to appear.
443 (if (> count max-trials)
444 (error "failed to resolve partition" (fmt spec))
446 (format #t "waiting for partition '~a' to appear...~%"
449 (loop (+ 1 count))))))))
451 (case canonical-title
456 ;; Resolve the label.
457 (resolve find-partition-by-label spec identity))
459 (resolve find-partition-by-uuid
465 (error "unknown device title" title))))
467 (define (check-file-system device type)
468 "Run a file system check of TYPE on DEVICE."
469 (define check-procedure
471 ((string-prefix? "ext" type) check-ext2-file-system)
472 ((string-prefix? "btrfs" type) check-btrfs-file-system)
476 (match (check-procedure device)
480 (format (current-error-port)
481 "File system check corrected errors on ~a; continuing~%"
484 (format (current-error-port)
485 "File system check corrected errors on ~a; rebooting~%"
490 (format (current-error-port)
491 "File system check on ~a failed; spawning Bourne-like REPL~%"
493 (start-repl %bournish-language)))
494 (format (current-error-port)
495 "No file system check procedure for ~a; skipping~%"
498 (define (mount-flags->bit-mask flags)
499 "Return the number suitable for the 'flags' argument of 'mount' that
500 corresponds to the symbols listed in FLAGS."
501 (let loop ((flags flags))
503 (('read-only rest ...)
504 (logior MS_RDONLY (loop rest)))
505 (('bind-mount rest ...)
506 (logior MS_BIND (loop rest)))
508 (logior MS_NOSUID (loop rest)))
510 (logior MS_NODEV (loop rest)))
512 (logior MS_NOEXEC (loop rest)))
516 (define (regular-file? file-name)
517 "Return #t if FILE-NAME is a regular file."
518 (eq? (stat:type (stat file-name)) 'regular))
520 (define* (mount-file-system spec #:key (root "/root"))
521 "Mount the file system described by SPEC under ROOT. SPEC must have the
524 (DEVICE TITLE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?)
526 DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
527 FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to
528 run a file system check."
530 (define (mount-nfs source mount-point type flags options)
531 (let* ((idx (string-rindex source #\:))
532 (host-part (string-take source idx))
533 ;; Strip [] from around host if present
534 (host (match (string-split host-part (string->char-set "[]"))
537 (aa (match (getaddrinfo host "nfs") ((x . _) x)))
538 (sa (addrinfo:addr aa))
539 (inet-addr (inet-ntop (sockaddr:fam sa)
540 (sockaddr:addr sa))))
542 ;; Mounting an NFS file system requires passing the address
543 ;; of the server in the addr= option
544 (mount source mount-point type flags
545 (string-append "addr="
548 (string-append "," options)
551 ((source title mount-point type (flags ...) options check?)
552 (let ((source (canonicalize-device-spec source title))
553 (mount-point (string-append root "/" mount-point))
554 (flags (mount-flags->bit-mask flags)))
556 (check-file-system source type))
558 ;; Create the mount point. Most of the time this is a directory, but
559 ;; in the case of a bind mount, a regular file may be needed.
560 (if (and (= MS_BIND (logand flags MS_BIND))
561 (regular-file? source))
562 (unless (file-exists? mount-point)
563 (mkdir-p (dirname mount-point))
564 (call-with-output-file mount-point (const #t)))
565 (mkdir-p mount-point))
568 ((string-prefix? "nfs" type)
569 (mount-nfs source mount-point type flags options))
571 (mount source mount-point type flags options)))
573 ;; For read-only bind mounts, an extra remount is needed, as per
574 ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
575 (when (and (= MS_BIND (logand flags MS_BIND))
576 (= MS_RDONLY (logand flags MS_RDONLY)))
577 (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
578 (mount source mount-point type flags #f)))))))
580 ;;; file-systems.scm ends here