1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
4 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
5 ;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net>
6 ;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
7 ;;; Copyright © 2019 David C. Trudgian <dave@trudgian.net>
8 ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
10 ;;; This file is part of GNU Guix.
12 ;;; GNU Guix is free software; you can redistribute it and/or modify it
13 ;;; under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 3 of the License, or (at
15 ;;; your option) any later version.
17 ;;; GNU Guix is distributed in the hope that it will be useful, but
18 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
25 (define-module (gnu build file-systems)
26 #:use-module (gnu system uuid)
27 #:use-module (gnu system file-systems)
28 #:use-module (guix build utils)
29 #:use-module (guix build bournish)
30 #:use-module ((guix build syscalls)
31 #:hide (file-system-type))
32 #:use-module (rnrs io ports)
33 #:use-module (rnrs bytevectors)
34 #:use-module (ice-9 match)
35 #:use-module (ice-9 rdelim)
36 #:use-module (system foreign)
37 #:autoload (system repl repl) (start-repl)
38 #:use-module (srfi srfi-1)
39 #:use-module (srfi srfi-26)
40 #:export (disk-partitions
41 partition-label-predicate
42 partition-uuid-predicate
43 partition-luks-uuid-predicate
44 find-partition-by-label
45 find-partition-by-uuid
46 find-partition-by-luks-uuid
47 canonicalize-device-spec
51 read-luks-partition-uuid
61 ;;; This modules provides tools to deal with disk partitions, and to mount and
62 ;;; check file systems.
66 (define (bind-mount source target)
67 "Bind-mount SOURCE at TARGET."
68 (mount source target "" MS_BIND))
70 (define (seek* fd/port offset whence)
71 "Like 'seek' but return -1 instead of throwing to 'system-error' upon
72 EINVAL. This makes it easier to catch cases like OFFSET being too large for
76 (seek fd/port offset whence))
78 (if (= EINVAL (system-error-errno args))
80 (apply throw args)))))
82 (define (read-superblock device offset size magic?)
83 "Read a superblock of SIZE from OFFSET and DEVICE. Return the raw
84 superblock on success, and #f if no valid superblock was found. MAGIC?
85 takes a bytevector and returns #t when it's a valid superblock."
86 (call-with-input-file device
88 (and (= offset (seek* port offset SEEK_SET))
89 (let ((block (make-bytevector size)))
90 (match (get-bytevector-n! port block 0 (bytevector-length block))
94 (and (= len (bytevector-length block))
98 (define null-terminated-latin1->string
99 (cut latin1->string <> zero?))
103 ;;; Ext2 file systems.
106 ;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
107 ;; TODO: Use "packed structs" from Guile-OpenGL or similar.
109 (define-syntax %ext2-endianness
110 ;; Endianness of ext2 file systems.
111 (identifier-syntax (endianness little)))
113 (define (ext2-superblock? sblock)
114 "Return #t when SBLOCK is an ext2 superblock."
115 (let ((magic (bytevector-u16-ref sblock 56 %ext2-endianness)))
118 (define (read-ext2-superblock device)
119 "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
120 if DEVICE does not contain an ext2 file system."
121 (read-superblock device 1024 264 ext2-superblock?))
123 (define (ext2-superblock-uuid sblock)
124 "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
125 (sub-bytevector sblock 104 16))
127 (define (ext2-superblock-volume-name sblock)
128 "Return the volume name of SBLOCK as a string of at most 16 characters, or
129 #f if SBLOCK has no volume name."
130 (null-terminated-latin1->string (sub-bytevector sblock 120 16)))
132 (define (check-ext2-file-system device)
133 "Return the health of an ext2 file system on DEVICE."
134 (match (status:exit-val
135 (system* "e2fsck" "-v" "-p" "-C" "0" device))
137 (1 'errors-corrected)
143 ;;; Btrfs file systems.
146 ;; <https://btrfs.wiki.kernel.org/index.php/On-disk_Format#Superblock>.
148 (define-syntax %btrfs-endianness
149 ;; Endianness of btrfs file systems.
150 (identifier-syntax (endianness little)))
152 (define (btrfs-superblock? sblock)
153 "Return #t when SBLOCK is a btrfs superblock."
154 (bytevector=? (sub-bytevector sblock 64 8)
155 (string->utf8 "_BHRfS_M")))
157 (define (read-btrfs-superblock device)
158 "Return the raw contents of DEVICE's btrfs superblock as a bytevector, or #f
159 if DEVICE does not contain a btrfs file system."
160 (read-superblock device 65536 4096 btrfs-superblock?))
162 (define (btrfs-superblock-uuid sblock)
163 "Return the UUID of a btrfs superblock SBLOCK as a 16-byte bytevector."
164 (sub-bytevector sblock 32 16))
166 (define (btrfs-superblock-volume-name sblock)
167 "Return the volume name of SBLOCK as a string of at most 256 characters, or
168 #f if SBLOCK has no volume name."
169 (null-terminated-latin1->string (sub-bytevector sblock 299 256)))
171 (define (check-btrfs-file-system device)
172 "Return the health of a btrfs file system on DEVICE."
173 (match (status:exit-val
174 (system* "btrfs" "device" "scan"))
180 ;;; FAT32 file systems.
183 ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-107.pdf>.
185 (define (fat32-superblock? sblock)
186 "Return #t when SBLOCK is a fat32 superblock."
187 (bytevector=? (sub-bytevector sblock 82 8)
188 (string->utf8 "FAT32 ")))
190 (define (read-fat32-superblock device)
191 "Return the raw contents of DEVICE's fat32 superblock as a bytevector, or
192 #f if DEVICE does not contain a fat32 file system."
193 (read-superblock device 0 90 fat32-superblock?))
195 (define (fat32-superblock-uuid sblock)
196 "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
197 (sub-bytevector sblock 67 4))
199 (define (fat32-superblock-volume-name sblock)
200 "Return the volume name of SBLOCK as a string of at most 11 characters, or
201 #f if SBLOCK has no volume name. The volume name is a latin1 string.
202 Trailing spaces are trimmed."
203 (string-trim-right (latin1->string (sub-bytevector sblock 71 11) (lambda (c) #f)) #\space))
205 (define (check-fat-file-system device)
206 "Return the health of a fat file system on DEVICE."
207 (match (status:exit-val
208 (system* "fsck.vfat" "-v" "-a" device))
210 (1 'errors-corrected)
215 ;;; FAT16 file systems.
218 (define (fat16-superblock? sblock)
219 "Return #t when SBLOCK is a fat16 boot record."
220 (bytevector=? (sub-bytevector sblock 54 8)
221 (string->utf8 "FAT16 ")))
223 (define (read-fat16-superblock device)
224 "Return the raw contents of DEVICE's fat16 superblock as a bytevector, or
225 #f if DEVICE does not contain a fat16 file system."
226 (read-superblock device 0 62 fat16-superblock?))
228 (define (fat16-superblock-uuid sblock)
229 "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
230 (sub-bytevector sblock 39 4))
232 (define (fat16-superblock-volume-name sblock)
233 "Return the volume name of SBLOCK as a string of at most 11 characters, or
234 #f if SBLOCK has no volume name. The volume name is a latin1 string.
235 Trailing spaces are trimmed."
236 (string-trim-right (latin1->string (sub-bytevector sblock 43 11)
242 ;;; ISO9660 file systems.
245 ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.
247 (define (iso9660-superblock? sblock)
248 "Return #t when SBLOCK is an iso9660 volume descriptor."
249 (bytevector=? (sub-bytevector sblock 1 6)
250 ;; Note: "\x01" is the volume descriptor format version
251 (string->utf8 "CD001\x01")))
253 (define (read-iso9660-primary-volume-descriptor device offset)
254 "Find and read the first primary volume descriptor, starting at OFFSET.
255 Return #f if not found."
256 (let* ((sblock (read-superblock device offset 2048 iso9660-superblock?))
257 (type-code (if sblock
258 (bytevector-u8-ref sblock 0)
260 "Could not read ISO9660 primary
261 volume descriptor from ~s"
264 (255 #f) ; Volume Descriptor Set Terminator.
265 (1 sblock) ; Primary Volume Descriptor
266 (_ (read-iso9660-primary-volume-descriptor device (+ offset 2048))))))
268 (define (read-iso9660-superblock device)
269 "Return the raw contents of DEVICE's iso9660 primary volume descriptor
270 as a bytevector, or #f if DEVICE does not contain an iso9660 file system."
271 ;; Start reading at sector 16.
272 ;; Since we are not sure that the device contains an ISO9660 file system,
273 ;; we have to find that out first.
274 (if (read-superblock device (* 2048 16) 2048 iso9660-superblock?)
275 (read-iso9660-primary-volume-descriptor device (* 2048 16))
276 #f)) ; Device does not contain an iso9660 file system.
278 (define (iso9660-superblock-uuid sblock)
279 "Return the modification time of an iso9660 primary volume descriptor
280 SBLOCK as a bytevector. If that's not set, returns the creation time."
281 ;; Drops GMT offset for compatibility with Grub, blkid and /dev/disk/by-uuid.
282 ;; Compare Grub: "2014-12-02-19-30-23-00".
283 ;; Compare blkid result: "2014-12-02-19-30-23-00".
284 ;; Compare /dev/disk/by-uuid entry: "2014-12-02-19-30-23-00".
285 (let* ((creation-time (sub-bytevector sblock 813 17))
286 (modification-time (sub-bytevector sblock 830 17))
287 (unset-time (make-bytevector 17 0))
288 (time (if (bytevector=? unset-time modification-time)
291 (sub-bytevector time 0 16))) ; strips GMT offset.
293 (define (iso9660-superblock-volume-name sblock)
294 "Return the volume name of SBLOCK as a string. The volume name is an ASCII
295 string. Trailing spaces are trimmed."
296 ;; Note: Valid characters are of the set "[0-9][A-Z]_" (ECMA-119 Appendix A)
297 (string-trim-right (latin1->string (sub-bytevector sblock 40 32)
298 (lambda (c) #f)) #\space))
302 ;;; JFS file systems.
305 ;; Taken from <linux-libre>/fs/jfs/jfs_superblock.h.
307 (define-syntax %jfs-endianness
308 ;; Endianness of JFS file systems.
309 (identifier-syntax (endianness little)))
311 (define (jfs-superblock? sblock)
312 "Return #t when SBLOCK is a JFS superblock."
313 (bytevector=? (sub-bytevector sblock 0 4)
314 (string->utf8 "JFS1")))
316 (define (read-jfs-superblock device)
317 "Return the raw contents of DEVICE's JFS superblock as a bytevector, or #f
318 if DEVICE does not contain a JFS file system."
319 (read-superblock device 32768 184 jfs-superblock?))
321 (define (jfs-superblock-uuid sblock)
322 "Return the UUID of JFS superblock SBLOCK as a 16-byte bytevector."
323 (sub-bytevector sblock 136 16))
325 (define (jfs-superblock-volume-name sblock)
326 "Return the volume name of SBLOCK as a string of at most 16 characters, or
327 #f if SBLOCK has no volume name."
328 (null-terminated-latin1->string (sub-bytevector sblock 152 16)))
330 (define (check-jfs-file-system device)
331 "Return the health of a JFS file system on DEVICE."
332 (match (status:exit-val
333 (system* "jfs_fsck" "-p" "-v" device))
335 (1 'errors-corrected)
341 ;;; LUKS encrypted devices.
344 ;; The LUKS header format is described in "LUKS On-Disk Format Specification":
345 ;; <https://gitlab.com/cryptsetup/cryptsetup/wikis/Specification>. We follow
346 ;; version 1.2.1 of this document.
348 ;; The LUKS2 header format is described in "LUKS2 On-Disk Format Specification":
349 ;; <https://gitlab.com/cryptsetup/LUKS2-docs/blob/master/luks2_doc_wip.pdf>.
350 ;; It is a WIP document.
352 (define-syntax %luks-endianness
353 ;; Endianness of LUKS headers.
354 (identifier-syntax (endianness big)))
356 (define (luks-superblock? sblock)
357 "Return #t when SBLOCK is a luks superblock."
359 ;; The 'LUKS_MAGIC' constant.
360 (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
362 (let ((magic (sub-bytevector sblock 0 6))
363 (version (bytevector-u16-ref sblock 6 %luks-endianness)))
364 (and (bytevector=? magic %luks-magic)
365 (or (= version 1) (= version 2)))))
367 (define (read-luks-header file)
368 "Read a LUKS header from FILE. Return the raw header on success, and #f if
369 not valid header was found."
370 ;; Size in bytes of the LUKS binary header, which includes key slots in
371 ;; LUKS1. In LUKS2 the binary header is partially backward compatible, so
372 ;; that UUID can be extracted as for LUKS1. Keyslots and other metadata are
373 ;; not part of this header in LUKS2, but are included in the JSON metadata
374 ;; area that follows.
375 (read-superblock file 0 592 luks-superblock?))
377 (define (luks-header-uuid header)
378 "Return the LUKS UUID from HEADER, as a 16-byte bytevector."
379 ;; 40 bytes are reserved for the UUID, but in practice, it contains the 36
380 ;; bytes of its ASCII representation.
381 (let ((uuid (sub-bytevector header 168 36)))
382 (string->uuid (utf8->string uuid))))
386 ;;; Partition lookup.
389 (define (disk-partitions)
390 "Return the list of device names corresponding to valid disk partitions."
391 (define (partition? name major minor)
392 ;; grub-mkrescue does some funny things for EFI support which
393 ;; makes it a lot more difficult than one would expect to support
394 ;; booting an ISO-9660 image from an USB flash drive.
395 ;; For example there's a buggy (too small) hidden partition in it
396 ;; which Linux mounts and then proceeds to fail while trying to
397 ;; fall off the edge.
398 ;; In any case, partition tables are supposed to be optional so
399 ;; here we allow checking entire disks for file systems, too.
400 (> major 2)) ;ignore RAM disks and floppy disks
402 (call-with-input-file "/proc/partitions"
404 ;; Skip the two header lines.
408 ;; Read each subsequent line, and extract the last space-separated
410 (let loop ((parts '()))
411 (let ((line (read-line port)))
412 (if (eof-object? line)
414 (match (string-tokenize line)
415 (((= string->number major) (= string->number minor)
417 (if (partition? name major minor)
418 (loop (cons name parts))
419 (loop parts))))))))))
421 (define (ENOENT-safe proc)
422 "Wrap the one-argument PROC such that ENOENT errors are caught and lead to a
423 warning and #f as the result."
429 ;; When running on the hand-made /dev,
430 ;; 'disk-partitions' could return partitions for which
431 ;; we have no /dev node. Handle that gracefully.
432 (let ((errno (system-error-errno args)))
433 (cond ((= ENOENT errno)
434 (format (current-error-port)
435 "warning: device '~a' not found~%" device)
437 ((= ENOMEDIUM errno) ;for removable media
439 ((= EIO errno) ;unreadable hardware like audio CDs
440 (format (current-error-port)
441 "warning: failed to read from device '~a'~%" device)
444 (apply throw args))))))))
446 (define (partition-field-reader read field)
447 "Return a procedure that takes a device and returns the value of a FIELD in
448 the partition superblock or #f."
449 (let ((read (ENOENT-safe read)))
451 (let ((sblock (read device)))
455 (define (read-partition-field device partition-field-readers)
456 "Returns the value of a FIELD in the partition superblock of DEVICE or #f. It
457 takes a list of PARTITION-FIELD-READERS and returns the result of the first
458 partition field reader that returned a value."
459 (match (filter-map (cut apply <> (list device)) partition-field-readers)
463 (define %partition-label-readers
464 (list (partition-field-reader read-iso9660-superblock
465 iso9660-superblock-volume-name)
466 (partition-field-reader read-ext2-superblock
467 ext2-superblock-volume-name)
468 (partition-field-reader read-btrfs-superblock
469 btrfs-superblock-volume-name)
470 (partition-field-reader read-fat32-superblock
471 fat32-superblock-volume-name)
472 (partition-field-reader read-fat16-superblock
473 fat16-superblock-volume-name)
474 (partition-field-reader read-jfs-superblock
475 jfs-superblock-volume-name)))
477 (define %partition-uuid-readers
478 (list (partition-field-reader read-iso9660-superblock
479 iso9660-superblock-uuid)
480 (partition-field-reader read-ext2-superblock
481 ext2-superblock-uuid)
482 (partition-field-reader read-btrfs-superblock
483 btrfs-superblock-uuid)
484 (partition-field-reader read-fat32-superblock
485 fat32-superblock-uuid)
486 (partition-field-reader read-fat16-superblock
487 fat16-superblock-uuid)
488 (partition-field-reader read-jfs-superblock
489 jfs-superblock-uuid)))
491 (define read-partition-label
492 (cut read-partition-field <> %partition-label-readers))
494 (define read-partition-uuid
495 (cut read-partition-field <> %partition-uuid-readers))
497 (define luks-partition-field-reader
498 (partition-field-reader read-luks-header luks-header-uuid))
500 (define read-luks-partition-uuid
501 (cut read-partition-field <> (list luks-partition-field-reader)))
503 (define (partition-predicate reader =)
504 "Return a predicate that returns true if the FIELD of partition header that
505 was READ is = to the given value."
508 (let ((actual (reader device)))
510 (= actual expected))))))
512 (define partition-label-predicate
513 (partition-predicate read-partition-label string=?))
515 (define partition-uuid-predicate
516 (partition-predicate read-partition-uuid uuid=?))
518 (define luks-partition-uuid-predicate
519 (partition-predicate luks-partition-field-reader uuid=?))
521 (define (find-partition predicate)
522 "Return the first partition found that matches PREDICATE, or #f if none
525 (find (predicate expected)
526 (map (cut string-append "/dev/" <>)
527 (disk-partitions)))))
529 (define find-partition-by-label
530 (find-partition partition-label-predicate))
532 (define find-partition-by-uuid
533 (find-partition partition-uuid-predicate))
535 (define find-partition-by-luks-uuid
536 (find-partition luks-partition-uuid-predicate))
539 (define (canonicalize-device-spec spec)
540 "Return the device name corresponding to SPEC, which can be a <uuid>, a
541 <file-system-label>, or a string (typically a /dev file name)."
543 ;; Number of times we retry partition label resolution, 1 second per
544 ;; trial. Note: somebody reported a delay of 16 seconds (!) before their
545 ;; USB key would be detected by the kernel, so we must wait for at least
549 (define (resolve find-partition spec fmt)
550 (let loop ((count 0))
551 (let ((device (find-partition spec)))
553 ;; Some devices take a bit of time to appear, most notably USB
554 ;; storage devices. Thus, wait for the device to appear.
555 (if (> count max-trials)
556 (error "failed to resolve partition" (fmt spec))
558 (format #t "waiting for partition '~a' to appear...~%"
561 (loop (+ 1 count))))))))
565 ;; Nothing to do, but wait until SPEC shows up.
566 (resolve identity spec identity))
567 ((? file-system-label?)
568 ;; Resolve the label.
569 (resolve find-partition-by-label
570 (file-system-label->string spec)
573 (resolve find-partition-by-uuid
574 (uuid-bytevector spec)
577 (define (check-file-system device type)
578 "Run a file system check of TYPE on DEVICE."
579 (define check-procedure
581 ((string-prefix? "ext" type) check-ext2-file-system)
582 ((string-prefix? "btrfs" type) check-btrfs-file-system)
583 ((string-suffix? "fat" type) check-fat-file-system)
584 ((string-prefix? "jfs" type) check-jfs-file-system)
585 ((string-prefix? "nfs" type) (const 'pass))
589 (match (check-procedure device)
593 (format (current-error-port)
594 "File system check corrected errors on ~a; continuing~%"
597 (format (current-error-port)
598 "File system check corrected errors on ~a; rebooting~%"
603 (format (current-error-port) "File system check on ~a failed~%"
606 ;; Spawn a REPL only if someone would be able to interact with it.
607 (when (isatty? (current-input-port))
608 (format (current-error-port) "Spawning Bourne-like REPL.~%")
610 ;; 'current-output-port' is typically connected to /dev/klog (in
611 ;; PID 1), but here we want to make sure we talk directly to the
613 (with-output-to-file "/dev/console"
615 (start-repl %bournish-language))))))
616 (format (current-error-port)
617 "No file system check procedure for ~a; skipping~%"
620 (define (mount-flags->bit-mask flags)
621 "Return the number suitable for the 'flags' argument of 'mount' that
622 corresponds to the symbols listed in FLAGS."
623 (let loop ((flags flags))
625 (('read-only rest ...)
626 (logior MS_RDONLY (loop rest)))
627 (('bind-mount rest ...)
628 (logior MS_BIND (loop rest)))
630 (logior MS_NOSUID (loop rest)))
632 (logior MS_NODEV (loop rest)))
634 (logior MS_NOEXEC (loop rest)))
635 (('no-atime rest ...)
636 (logior MS_NOATIME (loop rest)))
637 (('strict-atime rest ...)
638 (logior MS_STRICTATIME (loop rest)))
639 (('lazy-time rest ...)
640 (logior MS_LAZYTIME (loop rest)))
644 (define* (mount-file-system fs #:key (root "/root"))
645 "Mount the file system described by FS, a <file-system> object, under ROOT."
647 (define (mount-nfs source mount-point type flags options)
648 (let* ((idx (string-rindex source #\:))
649 (host-part (string-take source idx))
650 ;; Strip [] from around host if present
651 (host (match (string-split host-part (string->char-set "[]"))
654 (aa (match (getaddrinfo host "nfs") ((x . _) x)))
655 (sa (addrinfo:addr aa))
656 (inet-addr (inet-ntop (sockaddr:fam sa)
657 (sockaddr:addr sa))))
659 ;; Mounting an NFS file system requires passing the address
660 ;; of the server in the addr= option
661 (mount source mount-point type flags
662 (string-append "addr="
665 (string-append "," options)
667 (let ((type (file-system-type fs))
668 (options (file-system-options fs))
669 (source (canonicalize-device-spec (file-system-device fs)))
670 (mount-point (string-append root "/"
671 (file-system-mount-point fs)))
672 (flags (mount-flags->bit-mask (file-system-flags fs))))
673 (when (file-system-check? fs)
674 (check-file-system source type))
676 ;; Create the mount point. Most of the time this is a directory, but
677 ;; in the case of a bind mount, a regular file or socket may be needed.
678 (if (and (= MS_BIND (logand flags MS_BIND))
679 (not (file-is-directory? source)))
680 (unless (file-exists? mount-point)
681 (mkdir-p (dirname mount-point))
682 (call-with-output-file mount-point (const #t)))
683 (mkdir-p mount-point))
686 ((string-prefix? "nfs" type)
687 (mount-nfs source mount-point type flags options))
689 (mount source mount-point type flags options)))
691 ;; For read-only bind mounts, an extra remount is needed, as per
692 ;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
693 (when (and (= MS_BIND (logand flags MS_BIND))
694 (= MS_RDONLY (logand flags MS_RDONLY)))
695 (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY)))
696 (mount source mount-point type flags #f)))))
698 ;;; file-systems.scm ends here