1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2020, 2021 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, 2020 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?))
101 (define (bytevector-utf16-length bv)
102 "Given a bytevector BV containing a NUL-terminated UTF16-encoded string,
103 determine where the NUL terminator is and return its index. If there's no
104 NUL terminator, return the size of the bytevector."
105 (let ((length (bytevector-length bv)))
106 (let loop ((index 0))
108 (if (zero? (bytevector-u16-ref bv index 'little))
113 (define* (bytevector->u16-list bv endianness #:optional (index 0))
114 (if (< index (bytevector-length bv))
115 (cons (bytevector-u16-ref bv index endianness)
116 (bytevector->u16-list bv endianness (+ index 2)))
119 ;; The initrd doesn't have iconv data, so do the conversion ourselves.
120 (define (utf16->string bv endianness)
124 (let loop ((remainder (bytevector->u16-list bv endianness))
128 ((a) (cons a result))
130 (if (and (>= a #xD800) (< a #xDC00) ; high surrogate
131 (>= b #xDC00) (< b #xE000)) ; low surrogate
132 (loop x (cons (+ #x10000
133 (* #x400 (- a #xD800))
136 (loop (cons b x) (cons a result))))))))))
138 (define (null-terminated-utf16->string bv endianness)
139 (utf16->string (sub-bytevector bv 0 (bytevector-utf16-length bv))
144 ;;; Ext2 file systems.
147 ;; <http://www.nongnu.org/ext2-doc/ext2.html#DEF-SUPERBLOCK>.
148 ;; TODO: Use "packed structs" from Guile-OpenGL or similar.
150 (define-syntax %ext2-endianness
151 ;; Endianness of ext2 file systems.
152 (identifier-syntax (endianness little)))
154 (define (ext2-superblock? sblock)
155 "Return #t when SBLOCK is an ext2 superblock."
156 (let ((magic (bytevector-u16-ref sblock 56 %ext2-endianness)))
159 (define (read-ext2-superblock device)
160 "Return the raw contents of DEVICE's ext2 superblock as a bytevector, or #f
161 if DEVICE does not contain an ext2 file system."
162 (read-superblock device 1024 264 ext2-superblock?))
164 (define (ext2-superblock-uuid sblock)
165 "Return the UUID of ext2 superblock SBLOCK as a 16-byte bytevector."
166 (sub-bytevector sblock 104 16))
168 (define (ext2-superblock-volume-name sblock)
169 "Return the volume name of SBLOCK as a string of at most 16 characters, or
170 #f if SBLOCK has no volume name."
171 (null-terminated-latin1->string (sub-bytevector sblock 120 16)))
173 (define (check-ext2-file-system device)
174 "Return the health of an ext2 file system on DEVICE."
175 (match (status:exit-val
176 (system* "e2fsck" "-v" "-p" "-C" "0" device))
178 (1 'errors-corrected)
187 ;; Linux "swap space" is not a file system but it has a UUID and volume name,
188 ;; like actual file systems, and we want to be able to look up swap partitions
189 ;; by UUID and by label.
191 (define %linux-swap-magic
192 (string->utf8 "SWAPSPACE2"))
194 ;; Like 'PAGE_SIZE' in Linux, arch/x86/include/asm/page.h.
195 ;; XXX: This is always 4K on x86_64, i386, and ARMv7. However, on AArch64,
196 ;; this is determined by 'CONFIG_ARM64_PAGE_SHIFT' in the kernel, which is 12
197 ;; by default (4K) but can be 14 or 16.
198 (define %page-size 4096)
200 (define (linux-swap-superblock? sblock)
201 "Return #t when SBLOCK is an linux-swap superblock."
202 (and (= (bytevector-length sblock) %page-size)
203 (bytevector=? (sub-bytevector sblock (- %page-size 10) 10)
206 (define (read-linux-swap-superblock device)
207 "Return the raw contents of DEVICE's linux-swap superblock as a bytevector, or #f
208 if DEVICE does not contain an linux-swap file system."
209 (read-superblock device 0 %page-size linux-swap-superblock?))
211 ;; See 'union swap_header' in 'include/linux/swap.h'.
213 (define (linux-swap-superblock-uuid sblock)
214 "Return the UUID of Linux-swap superblock SBLOCK as a 16-byte bytevector."
215 (sub-bytevector sblock (+ 1024 4 4 4) 16))
217 (define (linux-swap-superblock-volume-name sblock)
218 "Return the label of Linux-swap superblock SBLOCK as a string."
219 (null-terminated-latin1->string
220 (sub-bytevector sblock (+ 1024 4 4 4 16) 16)))
224 ;;; Bcachefs file systems.
227 ;; <https://evilpiepirate.org/git/bcachefs-tools.git/tree/libbcachefs/bcachefs_format.h>
229 (define-syntax %bcachefs-endianness
230 ;; Endianness of bcachefs file systems.
231 (identifier-syntax (endianness little)))
233 (define (bcachefs-superblock? sblock)
234 "Return #t when SBLOCK is an bcachefs superblock."
235 (bytevector=? (sub-bytevector sblock 24 16)
236 #vu8(#xc6 #x85 #x73 #xf6 #x4e #x1a #x45 #xca
237 #x82 #x65 #xf5 #x7f #x48 #xba #x6d #x81)))
239 (define (read-bcachefs-superblock device)
240 "Return the raw contents of DEVICE's bcachefs superblock as a bytevector, or #f
241 if DEVICE does not contain a bcachefs file system."
242 ;; We completely ignore the back-up superblock & any checksum errors.
243 ;; Superblock field names, with offset & length respectively, in bytes:
247 ;; 40 16 uuid ← ‘internal UUID’, you probably don't want this
248 ;; 56 16 user_uuid ← ‘external UUID’, the one by which to mount
250 ;; … there are more & the superblock is extensible, but we don't care yet.
251 (read-superblock device 4096 104 bcachefs-superblock?))
253 (define (bcachefs-superblock-external-uuid sblock)
254 "Return the external UUID of bcachefs superblock SBLOCK as a 16-byte
256 (sub-bytevector sblock 56 16))
258 (define (bcachefs-superblock-volume-name sblock)
259 "Return the volume name of SBLOCK as a string of at most 32 characters, or
260 #f if SBLOCK has no volume name."
261 (null-terminated-latin1->string (sub-bytevector sblock 72 32)))
263 (define (check-bcachefs-file-system device)
264 "Return the health of a bcachefs file system on DEVICE."
265 (let ((ignored-bits (logior 2)) ; DEVICE was mounted read-only
268 (apply system* "bcachefs" "fsck" "-p" "-v"
269 ;; Make each multi-device member a separate argument.
270 (string-split device #\:)))))
271 (match (logand (lognot ignored-bits) status)
273 (1 'errors-corrected)
278 ;;; Btrfs file systems.
281 ;; <https://btrfs.wiki.kernel.org/index.php/On-disk_Format#Superblock>.
283 (define-syntax %btrfs-endianness
284 ;; Endianness of btrfs file systems.
285 (identifier-syntax (endianness little)))
287 (define (btrfs-superblock? sblock)
288 "Return #t when SBLOCK is a btrfs superblock."
289 (bytevector=? (sub-bytevector sblock 64 8)
290 (string->utf8 "_BHRfS_M")))
292 (define (read-btrfs-superblock device)
293 "Return the raw contents of DEVICE's btrfs superblock as a bytevector, or #f
294 if DEVICE does not contain a btrfs file system."
295 (read-superblock device 65536 4096 btrfs-superblock?))
297 (define (btrfs-superblock-uuid sblock)
298 "Return the UUID of a btrfs superblock SBLOCK as a 16-byte bytevector."
299 (sub-bytevector sblock 32 16))
301 (define (btrfs-superblock-volume-name sblock)
302 "Return the volume name of SBLOCK as a string of at most 256 characters, or
303 #f if SBLOCK has no volume name."
304 (null-terminated-latin1->string (sub-bytevector sblock 299 256)))
306 (define (check-btrfs-file-system device)
307 "Return the health of a btrfs file system on DEVICE."
308 (match (status:exit-val
309 (system* "btrfs" "device" "scan"))
315 ;;; FAT32 file systems.
318 ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-107.pdf>.
320 (define (fat32-superblock? sblock)
321 "Return #t when SBLOCK is a fat32 superblock."
322 (bytevector=? (sub-bytevector sblock 82 8)
323 (string->utf8 "FAT32 ")))
325 (define (read-fat32-superblock device)
326 "Return the raw contents of DEVICE's fat32 superblock as a bytevector, or
327 #f if DEVICE does not contain a fat32 file system."
328 (read-superblock device 0 90 fat32-superblock?))
330 (define (fat32-superblock-uuid sblock)
331 "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
332 (sub-bytevector sblock 67 4))
334 (define (fat32-superblock-volume-name sblock)
335 "Return the volume name of SBLOCK as a string of at most 11 characters, or
336 #f if SBLOCK has no volume name. The volume name is a latin1 string.
337 Trailing spaces are trimmed."
338 (string-trim-right (latin1->string (sub-bytevector sblock 71 11) (lambda (c) #f)) #\space))
340 (define (check-fat-file-system device)
341 "Return the health of a fat file system on DEVICE."
342 (match (status:exit-val
343 (system* "fsck.vfat" "-v" "-a" device))
345 (1 'errors-corrected)
350 ;;; FAT16 file systems.
353 (define (fat16-superblock? sblock)
354 "Return #t when SBLOCK is a fat16 boot record."
355 (bytevector=? (sub-bytevector sblock 54 8)
356 (string->utf8 "FAT16 ")))
358 (define (read-fat16-superblock device)
359 "Return the raw contents of DEVICE's fat16 superblock as a bytevector, or
360 #f if DEVICE does not contain a fat16 file system."
361 (read-superblock device 0 62 fat16-superblock?))
363 (define (fat16-superblock-uuid sblock)
364 "Return the Volume ID of a fat superblock SBLOCK as a 4-byte bytevector."
365 (sub-bytevector sblock 39 4))
367 (define (fat16-superblock-volume-name sblock)
368 "Return the volume name of SBLOCK as a string of at most 11 characters, or
369 #f if SBLOCK has no volume name. The volume name is a latin1 string.
370 Trailing spaces are trimmed."
371 (string-trim-right (latin1->string (sub-bytevector sblock 43 11)
377 ;;; ISO9660 file systems.
380 ;; <http://www.ecma-international.org/publications/files/ECMA-ST/Ecma-119.pdf>.
382 (define (iso9660-superblock? sblock)
383 "Return #t when SBLOCK is an iso9660 volume descriptor."
384 (bytevector=? (sub-bytevector sblock 1 6)
385 ;; Note: "\x01" is the volume descriptor format version
386 (string->utf8 "CD001\x01")))
388 (define (read-iso9660-primary-volume-descriptor device offset)
389 "Find and read the first primary volume descriptor, starting at OFFSET.
390 Return #f if not found."
391 (let* ((sblock (read-superblock device offset 2048 iso9660-superblock?))
392 (type-code (if sblock
393 (bytevector-u8-ref sblock 0)
395 "Could not read ISO9660 primary
396 volume descriptor from ~s"
399 (255 #f) ; Volume Descriptor Set Terminator.
400 (1 sblock) ; Primary Volume Descriptor
401 (_ (read-iso9660-primary-volume-descriptor device (+ offset 2048))))))
403 (define (read-iso9660-superblock device)
404 "Return the raw contents of DEVICE's iso9660 primary volume descriptor
405 as a bytevector, or #f if DEVICE does not contain an iso9660 file system."
406 ;; Start reading at sector 16.
407 ;; Since we are not sure that the device contains an ISO9660 file system,
408 ;; we have to find that out first.
409 (if (read-superblock device (* 2048 16) 2048 iso9660-superblock?)
410 (read-iso9660-primary-volume-descriptor device (* 2048 16))
411 #f)) ; Device does not contain an iso9660 file system.
413 (define (iso9660-superblock-uuid sblock)
414 "Return the modification time of an iso9660 primary volume descriptor
415 SBLOCK as a bytevector. If that's not set, returns the creation time."
416 ;; Drops GMT offset for compatibility with Grub, blkid and /dev/disk/by-uuid.
417 ;; Compare Grub: "2014-12-02-19-30-23-00".
418 ;; Compare blkid result: "2014-12-02-19-30-23-00".
419 ;; Compare /dev/disk/by-uuid entry: "2014-12-02-19-30-23-00".
420 (let* ((creation-time (sub-bytevector sblock 813 17))
421 (modification-time (sub-bytevector sblock 830 17))
422 (unset-time (make-bytevector 17 0))
423 (time (if (bytevector=? unset-time modification-time)
426 (sub-bytevector time 0 16))) ; strips GMT offset.
428 (define (iso9660-superblock-volume-name sblock)
429 "Return the volume name of SBLOCK as a string. The volume name is an ASCII
430 string. Trailing spaces are trimmed."
431 ;; Note: Valid characters are of the set "[0-9][A-Z]_" (ECMA-119 Appendix A)
432 (string-trim-right (latin1->string (sub-bytevector sblock 40 32)
433 (lambda (c) #f)) #\space))
437 ;;; JFS file systems.
440 ;; Taken from <linux-libre>/fs/jfs/jfs_superblock.h.
442 (define-syntax %jfs-endianness
443 ;; Endianness of JFS file systems.
444 (identifier-syntax (endianness little)))
446 (define (jfs-superblock? sblock)
447 "Return #t when SBLOCK is a JFS superblock."
448 (bytevector=? (sub-bytevector sblock 0 4)
449 (string->utf8 "JFS1")))
451 (define (read-jfs-superblock device)
452 "Return the raw contents of DEVICE's JFS superblock as a bytevector, or #f
453 if DEVICE does not contain a JFS file system."
454 (read-superblock device 32768 184 jfs-superblock?))
456 (define (jfs-superblock-uuid sblock)
457 "Return the UUID of JFS superblock SBLOCK as a 16-byte bytevector."
458 (sub-bytevector sblock 136 16))
460 (define (jfs-superblock-volume-name sblock)
461 "Return the volume name of SBLOCK as a string of at most 16 characters, or
462 #f if SBLOCK has no volume name."
463 (null-terminated-latin1->string (sub-bytevector sblock 152 16)))
465 (define (check-jfs-file-system device)
466 "Return the health of a JFS file system on DEVICE."
467 (match (status:exit-val
468 (system* "jfs_fsck" "-p" "-v" device))
470 (1 'errors-corrected)
476 ;;; F2FS (Flash-Friendly File System)
479 ;;; https://git.kernel.org/pub/scm/linux/kernel/git/jaegeuk/f2fs.git/tree/include/linux/f2fs_fs.h
480 ;;; (but using xxd proved to be simpler)
482 (define-syntax %f2fs-endianness
483 ;; Endianness of F2FS file systems
484 (identifier-syntax (endianness little)))
486 ;; F2FS actually stores two adjacent copies of the superblock.
487 ;; should we read both?
488 (define (f2fs-superblock? sblock)
489 "Return #t when SBLOCK is an F2FS superblock."
490 (let ((magic (bytevector-u32-ref sblock 0 %f2fs-endianness)))
491 (= magic #xF2F52010)))
493 (define (read-f2fs-superblock device)
494 "Return the raw contents of DEVICE's F2FS superblock as a bytevector, or #f
495 if DEVICE does not contain an F2FS file system."
496 (read-superblock device
497 ;; offset of magic in first copy
499 ;; difference between magic of second
504 (define (f2fs-superblock-uuid sblock)
505 "Return the UUID of F2FS superblock SBLOCK as a 16-byte bytevector."
506 (sub-bytevector sblock
508 ;; subtract superblock offset
512 (define (f2fs-superblock-volume-name sblock)
513 "Return the volume name of SBLOCK as a string of at most 512 characters, or
514 #f if SBLOCK has no volume name."
515 (null-terminated-utf16->string
516 (sub-bytevector sblock (- (+ #x470 12) #x400) 512)
519 (define (check-f2fs-file-system device)
520 "Return the health of a F2FS file system on DEVICE."
521 (match (status:exit-val
522 (system* "fsck.f2fs" "-p" device))
523 ;; 0 and -1 are the only two possibilities
524 ;; (according to the manpage)
530 ;;; LUKS encrypted devices.
533 ;; The LUKS header format is described in "LUKS On-Disk Format Specification":
534 ;; <https://gitlab.com/cryptsetup/cryptsetup/wikis/Specification>. We follow
535 ;; version 1.2.1 of this document.
537 ;; The LUKS2 header format is described in "LUKS2 On-Disk Format Specification":
538 ;; <https://gitlab.com/cryptsetup/LUKS2-docs/blob/master/luks2_doc_wip.pdf>.
539 ;; It is a WIP document.
541 (define-syntax %luks-endianness
542 ;; Endianness of LUKS headers.
543 (identifier-syntax (endianness big)))
545 (define (luks-superblock? sblock)
546 "Return #t when SBLOCK is a luks superblock."
548 ;; The 'LUKS_MAGIC' constant.
549 (u8-list->bytevector (append (map char->integer (string->list "LUKS"))
551 (let ((magic (sub-bytevector sblock 0 6))
552 (version (bytevector-u16-ref sblock 6 %luks-endianness)))
553 (and (bytevector=? magic %luks-magic)
554 (or (= version 1) (= version 2)))))
556 (define (read-luks-header file)
557 "Read a LUKS header from FILE. Return the raw header on success, and #f if
558 not valid header was found."
559 ;; Size in bytes of the LUKS binary header, which includes key slots in
560 ;; LUKS1. In LUKS2 the binary header is partially backward compatible, so
561 ;; that UUID can be extracted as for LUKS1. Keyslots and other metadata are
562 ;; not part of this header in LUKS2, but are included in the JSON metadata
563 ;; area that follows.
564 (read-superblock file 0 592 luks-superblock?))
566 (define (luks-header-uuid header)
567 "Return the LUKS UUID from HEADER, as a 16-byte bytevector."
568 ;; 40 bytes are reserved for the UUID, but in practice, it contains the 36
569 ;; bytes of its ASCII representation.
570 (let ((uuid (sub-bytevector header 168 36)))
571 (string->uuid (utf8->string uuid))))
575 ;;; NTFS file systems.
578 ;; Taken from <linux-libre>/fs/ntfs/layout.h
580 (define-syntax %ntfs-endianness
581 ;; Endianness of NTFS file systems.
582 (identifier-syntax (endianness little)))
584 (define (ntfs-superblock? sblock)
585 "Return #t when SBLOCK is a NTFS superblock."
586 (bytevector=? (sub-bytevector sblock 3 8)
587 (string->utf8 "NTFS ")))
589 (define (read-ntfs-superblock device)
590 "Return the raw contents of DEVICE's NTFS superblock as a bytevector, or #f
591 if DEVICE does not contain a NTFS file system."
592 (read-superblock device 0 511 ntfs-superblock?))
594 (define (ntfs-superblock-uuid sblock)
595 "Return the UUID of NTFS superblock SBLOCK as a 8-byte bytevector."
596 (sub-bytevector sblock 72 8))
598 ;; TODO: Add ntfs-superblock-volume-name. The partition label is not stored
599 ;; in the BOOT SECTOR like the UUID, but in the MASTER FILE TABLE, which seems
600 ;; way harder to access.
602 (define (check-ntfs-file-system device)
603 "Return the health of a NTFS file system on DEVICE."
604 (match (status:exit-val
605 (system* "ntfsfix" device))
611 ;;; Partition lookup.
614 (define (disk-partitions)
615 "Return the list of device names corresponding to valid disk partitions."
616 (define (partition? name major minor)
617 ;; grub-mkrescue does some funny things for EFI support which
618 ;; makes it a lot more difficult than one would expect to support
619 ;; booting an ISO-9660 image from an USB flash drive.
620 ;; For example there's a buggy (too small) hidden partition in it
621 ;; which Linux mounts and then proceeds to fail while trying to
622 ;; fall off the edge.
623 ;; In any case, partition tables are supposed to be optional so
624 ;; here we allow checking entire disks for file systems, too.
625 (> major 2)) ;ignore RAM disks and floppy disks
627 (call-with-input-file "/proc/partitions"
629 ;; Skip the two header lines.
633 ;; Read each subsequent line, and extract the last space-separated
635 (let loop ((parts '()))
636 (let ((line (read-line port)))
637 (if (eof-object? line)
639 (match (string-tokenize line)
640 (((= string->number major) (= string->number minor)
642 (if (partition? name major minor)
643 (loop (cons name parts))
644 (loop parts))))))))))
646 (define (ENOENT-safe proc)
647 "Wrap the one-argument PROC such that ENOENT errors are caught and lead to a
648 warning and #f as the result."
654 ;; When running on the hand-made /dev,
655 ;; 'disk-partitions' could return partitions for which
656 ;; we have no /dev node. Handle that gracefully.
657 (let ((errno (system-error-errno args)))
658 (cond ((= ENOENT errno)
659 (format (current-error-port)
660 "warning: device '~a' not found~%" device)
662 ((= ENOMEDIUM errno) ;for removable media
664 ((= EIO errno) ;unreadable hardware like audio CDs
665 (format (current-error-port)
666 "warning: failed to read from device '~a'~%" device)
669 (apply throw args))))))))
671 (define (partition-field-reader read field)
672 "Return a procedure that takes a device and returns the value of a FIELD in
673 the partition superblock or #f."
674 (let ((read (ENOENT-safe read)))
676 (let ((sblock (read device)))
680 (define (read-partition-field device partition-field-readers)
681 "Returns the value of a FIELD in the partition superblock of DEVICE or #f. It
682 takes a list of PARTITION-FIELD-READERS and returns the result of the first
683 partition field reader that returned a value."
684 (match (filter-map (cut apply <> (list device)) partition-field-readers)
688 (define %partition-label-readers
689 (list (partition-field-reader read-iso9660-superblock
690 iso9660-superblock-volume-name)
691 (partition-field-reader read-ext2-superblock
692 ext2-superblock-volume-name)
693 (partition-field-reader read-linux-swap-superblock
694 linux-swap-superblock-volume-name)
695 (partition-field-reader read-bcachefs-superblock
696 bcachefs-superblock-volume-name)
697 (partition-field-reader read-btrfs-superblock
698 btrfs-superblock-volume-name)
699 (partition-field-reader read-fat32-superblock
700 fat32-superblock-volume-name)
701 (partition-field-reader read-fat16-superblock
702 fat16-superblock-volume-name)
703 (partition-field-reader read-jfs-superblock
704 jfs-superblock-volume-name)
705 (partition-field-reader read-f2fs-superblock
706 f2fs-superblock-volume-name)))
708 (define %partition-uuid-readers
709 (list (partition-field-reader read-iso9660-superblock
710 iso9660-superblock-uuid)
711 (partition-field-reader read-ext2-superblock
712 ext2-superblock-uuid)
713 (partition-field-reader read-linux-swap-superblock
714 linux-swap-superblock-uuid)
715 (partition-field-reader read-bcachefs-superblock
716 bcachefs-superblock-external-uuid)
717 (partition-field-reader read-btrfs-superblock
718 btrfs-superblock-uuid)
719 (partition-field-reader read-fat32-superblock
720 fat32-superblock-uuid)
721 (partition-field-reader read-fat16-superblock
722 fat16-superblock-uuid)
723 (partition-field-reader read-jfs-superblock
725 (partition-field-reader read-f2fs-superblock
726 f2fs-superblock-uuid)
727 (partition-field-reader read-ntfs-superblock
728 ntfs-superblock-uuid)))
730 (define read-partition-label
731 (cut read-partition-field <> %partition-label-readers))
733 (define read-partition-uuid
734 (cut read-partition-field <> %partition-uuid-readers))
736 (define luks-partition-field-reader
737 (partition-field-reader read-luks-header luks-header-uuid))
739 (define read-luks-partition-uuid
740 (cut read-partition-field <> (list luks-partition-field-reader)))
742 (define (partition-predicate reader =)
743 "Return a predicate that returns true if the FIELD of partition header that
744 was READ is = to the given value."
747 (let ((actual (reader device)))
749 (= actual expected))))))
751 (define partition-label-predicate
752 (partition-predicate read-partition-label string=?))
754 (define partition-uuid-predicate
755 (partition-predicate read-partition-uuid uuid=?))
757 (define luks-partition-uuid-predicate
758 (partition-predicate luks-partition-field-reader uuid=?))
760 (define (find-partition predicate)
761 "Return the first partition found that matches PREDICATE, or #f if none
764 (find (predicate expected)
765 (map (cut string-append "/dev/" <>)
766 (disk-partitions)))))
768 (define find-partition-by-label
769 (find-partition partition-label-predicate))
771 (define find-partition-by-uuid
772 (find-partition partition-uuid-predicate))
774 (define find-partition-by-luks-uuid
775 (find-partition luks-partition-uuid-predicate))
778 (define (canonicalize-device-spec spec)
779 "Return the device name corresponding to SPEC, which can be a <uuid>, a
780 <file-system-label>, or a string (typically a /dev file name or an nfs-root
783 ;; Number of times we retry partition label resolution, 1 second per
784 ;; trial. Note: somebody reported a delay of 16 seconds (!) before their
785 ;; USB key would be detected by the kernel, so we must wait for at least
789 (define (resolve find-partition spec fmt)
790 (let loop ((count 0))
791 (let ((device (find-partition spec)))
793 ;; Some devices take a bit of time to appear, most notably USB
794 ;; storage devices. Thus, wait for the device to appear.
795 (if (> count max-trials)
796 (error "failed to resolve partition" (fmt spec))
798 (format #t "waiting for partition '~a' to appear...~%"
801 (loop (+ 1 count))))))))
805 (if (string-contains spec ":/")
806 spec ; do not resolve NFS devices
807 ;; Nothing to do, but wait until SPEC shows up.
808 (resolve identity spec identity)))
809 ((? file-system-label?)
810 ;; Resolve the label.
811 (resolve find-partition-by-label
812 (file-system-label->string spec)
815 (resolve find-partition-by-uuid
816 (uuid-bytevector spec)
819 (define (check-file-system device type)
820 "Run a file system check of TYPE on DEVICE."
821 (define check-procedure
823 ((string-prefix? "ext" type) check-ext2-file-system)
824 ((string-prefix? "bcachefs" type) check-bcachefs-file-system)
825 ((string-prefix? "btrfs" type) check-btrfs-file-system)
826 ((string-suffix? "fat" type) check-fat-file-system)
827 ((string-prefix? "jfs" type) check-jfs-file-system)
828 ((string-prefix? "f2fs" type) check-f2fs-file-system)
829 ((string-prefix? "ntfs" type) check-ntfs-file-system)
830 ((string-prefix? "nfs" type) (const 'pass))
834 (match (check-procedure device)
838 (format (current-error-port)
839 "File system check corrected errors on ~a; continuing~%"
842 (format (current-error-port)
843 "File system check corrected errors on ~a; rebooting~%"
848 (format (current-error-port) "File system check on ~a failed~%"
851 ;; Spawn a REPL only if someone would be able to interact with it.
852 (when (isatty? (current-input-port))
853 (format (current-error-port) "Spawning Bourne-like REPL.~%")
855 ;; 'current-output-port' is typically connected to /dev/klog (in
856 ;; PID 1), but here we want to make sure we talk directly to the
858 (with-output-to-file "/dev/console"
860 (start-repl %bournish-language))))))
861 (format (current-error-port)
862 "No file system check procedure for ~a; skipping~%"
865 (define (mount-flags->bit-mask flags)
866 "Return the number suitable for the 'flags' argument of 'mount' that
867 corresponds to the symbols listed in FLAGS."
868 (let loop ((flags flags))
870 (('read-only rest ...)
871 (logior MS_RDONLY (loop rest)))
872 (('bind-mount rest ...)
873 (logior MS_BIND (loop rest)))
875 (logior MS_NOSUID (loop rest)))
877 (logior MS_NODEV (loop rest)))
879 (logior MS_NOEXEC (loop rest)))
880 (('no-atime rest ...)
881 (logior MS_NOATIME (loop rest)))
882 (('strict-atime rest ...)
883 (logior MS_STRICTATIME (loop rest)))
884 (('lazy-time rest ...)
885 (logior MS_LAZYTIME (loop rest)))
889 (define* (mount-file-system fs #:key (root "/root"))
890 "Mount the file system described by FS, a <file-system> object, under ROOT."
892 (define (mount-nfs source mount-point type flags options)
893 (let* ((idx (string-rindex source #\:))
894 (host-part (string-take source idx))
895 ;; Strip [] from around host if present
896 (host (match (string-split host-part (string->char-set "[]"))
899 (aa (match (getaddrinfo host "nfs") ((x . _) x)))
900 (sa (addrinfo:addr aa))
901 (inet-addr (inet-ntop (sockaddr:fam sa)
902 (sockaddr:addr sa))))
904 ;; Mounting an NFS file system requires passing the address
905 ;; of the server in the addr= option
906 (mount source mount-point type flags
907 (string-append "addr="
910 (string-append "," options)
912 (let* ((type (file-system-type fs))
913 (source (canonicalize-device-spec (file-system-device fs)))
914 (target (string-append root "/"
915 (file-system-mount-point fs)))
916 (flags (logior (mount-flags->bit-mask (file-system-flags fs))
918 ;; For bind mounts, preserve the original flags such
919 ;; as MS_NOSUID, etc. Failing to do that, the
920 ;; MS_REMOUNT call below fails with EPERM.
921 ;; See <https://bugs.gnu.org/46292>
922 (if (memq 'bind-mount (file-system-flags fs))
923 (statfs-flags->mount-flags
924 (file-system-mount-flags (statfs source)))
926 (options (file-system-options fs)))
927 (when (file-system-check? fs)
928 (check-file-system source type))
932 ;; Create the mount point. Most of the time this is a directory, but
933 ;; in the case of a bind mount, a regular file or socket may be
935 (if (and (= MS_BIND (logand flags MS_BIND))
936 (not (file-is-directory? source)))
937 (unless (file-exists? target)
938 (mkdir-p (dirname target))
939 (call-with-output-file target (const #t)))
943 ((string-prefix? "nfs" type)
944 (mount-nfs source target type flags options))
946 (mount source target type flags options)))
948 ;; For read-only bind mounts, an extra remount is needed, as per
949 ;; <http://lwn.net/Articles/281157/>, which still applies to Linux
951 (when (and (= MS_BIND (logand flags MS_BIND))
952 (= MS_RDONLY (logand flags MS_RDONLY)))
953 (let ((flags (logior MS_REMOUNT flags)))
954 (mount source target type flags options))))
956 (or (file-system-mount-may-fail? fs)
957 (apply throw args))))))
959 ;;; file-systems.scm ends here