diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/file-systems.scm | 318 | ||||
| -rw-r--r-- | gnu/build/linux-boot.scm | 97 |
2 files changed, 295 insertions, 120 deletions
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 4eeb81cf26..d8a5ddf1e5 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -166,14 +166,23 @@ if DEVICE does not contain an ext2 file system." (sub-bytevector sblock 104 16)) (define (ext2-superblock-volume-name sblock) - "Return the volume name of SBLOCK as a string of at most 16 characters, or -#f if SBLOCK has no volume name." + "Return the volume name of ext2 superblock SBLOCK as a string of at most 16 +characters, or #f if SBLOCK has no volume name." (null-terminated-latin1->string (sub-bytevector sblock 120 16))) -(define (check-ext2-file-system device) - "Return the health of an ext2 file system on DEVICE." +(define (check-ext2-file-system device force? repair) + "Return the health of an unmounted ext2 file system on DEVICE. If FORCE? is +true, check the file system even if it's marked as clean. If REPAIR is false, +do not write to the file system to fix errors. If it's #t, fix all +errors. Otherwise, fix only those considered safe to repair automatically." (match (status:exit-val - (system* "e2fsck" "-v" "-p" "-C" "0" device)) + (apply system* `("e2fsck" "-v" "-C" "0" + ,@(if force? '("-f") '()) + ,@(match repair + (#f '("-n")) + (#t '("-y")) + (_ '("-p"))) + ,device))) (0 'pass) (1 'errors-corrected) (2 'reboot-required) @@ -256,19 +265,27 @@ bytevector." (sub-bytevector sblock 56 16)) (define (bcachefs-superblock-volume-name sblock) - "Return the volume name of SBLOCK as a string of at most 32 characters, or -#f if SBLOCK has no volume name." + "Return the volume name of bcachefs superblock SBLOCK as a string of at most +32 characters, or #f if SBLOCK has no volume name." (null-terminated-latin1->string (sub-bytevector sblock 72 32))) -(define (check-bcachefs-file-system device) - "Return the health of a bcachefs file system on DEVICE." +(define (check-bcachefs-file-system device force? repair) + "Return the health of an unmounted bcachefs file system on DEVICE. If FORCE? +is true, check the file system even if it's marked as clean. If REPAIR is +false, do not write to the file system to fix errors. If it's #t, fix all +errors. Otherwise, fix only those considered safe to repair automatically." (let ((ignored-bits (logior 2)) ; DEVICE was mounted read-only (status ;; A number, or #f on abnormal termination (e.g., assertion failure). (status:exit-val - (apply system* "bcachefs" "fsck" "-p" "-v" - ;; Make each multi-device member a separate argument. - (string-split device #\:))))) + (apply system* `("bcachefs" "fsck" "-v" + ,@(if force? '("-f") '()) + ,@(match repair + (#f '("-n")) + (#t '("-y")) + (_ '("-p"))) + ;; Make each multi-device member a separate argument. + ,@(string-split device #\:)))))) (match (and=> status (cut logand <> (lognot ignored-bits))) (0 'pass) (1 'errors-corrected) @@ -300,16 +317,33 @@ if DEVICE does not contain a btrfs file system." (sub-bytevector sblock 32 16)) (define (btrfs-superblock-volume-name sblock) - "Return the volume name of SBLOCK as a string of at most 256 characters, or -#f if SBLOCK has no volume name." + "Return the volume name of btrfs superblock SBLOCK as a string of at most 256 +characters, or #f if SBLOCK has no volume name." (null-terminated-latin1->string (sub-bytevector sblock 299 256))) -(define (check-btrfs-file-system device) - "Return the health of a btrfs file system on DEVICE." - (match (status:exit-val - (system* "btrfs" "device" "scan")) - (0 'pass) - (_ 'fatal-error))) +(define (check-btrfs-file-system device force? repair) + "Return the health of an unmounted btrfs file system on DEVICE. If FORCE? is +false, return 'PASS unconditionally as btrfs claims no need for off-line checks. +When FORCE? is true, do perform a real check. This is not recommended! See +@uref{https://bugzilla.redhat.com/show_bug.cgi?id=625967#c8}. If REPAIR is +false, do not write to DEVICE. If it's #t, fix any errors found. Otherwise, +fix only those considered safe to repair automatically." + (if force? + (match (status:exit-val + (apply system* `("btrfs" "check" "--progress" + ;; Btrfs's ‘--force’ is not relevant to us here. + ,@(match repair + ;; Upstream considers ALL repairs dangerous + ;; and will warn the user at run time. + (#t '("--repair")) + (_ '("--readonly" ; a no-op for clarity + ;; A 466G file system with 180G used is + ;; enough to kill btrfs with 6G of RAM. + "--mode" "lowmem"))) + ,device))) + (0 'pass) + (_ 'fatal-error)) + 'pass)) ;;; @@ -333,15 +367,22 @@ if DEVICE does not contain a btrfs file system." (sub-bytevector sblock 67 4)) (define (fat32-superblock-volume-name sblock) - "Return the volume name of SBLOCK as a string of at most 11 characters, or -#f if SBLOCK has no volume name. The volume name is a latin1 string. -Trailing spaces are trimmed." + "Return the volume name of fat superblock SBLOCK as a string of at most 11 +characters, or #f if SBLOCK has no volume name. The volume name is a latin1 +string. Trailing spaces are trimmed." (string-trim-right (latin1->string (sub-bytevector sblock 71 11) (lambda (c) #f)) #\space)) -(define (check-fat-file-system device) - "Return the health of a fat file system on DEVICE." +(define (check-fat-file-system device force? repair) + "Return the health of an unmounted FAT file system on DEVICE. FORCE? is +ignored: a full file system scan is always performed. If REPAIR is false, do +not write to the file system to fix errors. Otherwise, automatically fix them +using the least destructive approach." (match (status:exit-val - (system* "fsck.vfat" "-v" "-a" device)) + (apply system* `("fsck.vfat" "-v" + ,@(match repair + (#f '("-n")) + (_ '("-a"))) ; no 'safe/#t distinction + ,device))) (0 'pass) (1 'errors-corrected) (_ 'fatal-error))) @@ -366,9 +407,9 @@ Trailing spaces are trimmed." (sub-bytevector sblock 39 4)) (define (fat16-superblock-volume-name sblock) - "Return the volume name of SBLOCK as a string of at most 11 characters, or -#f if SBLOCK has no volume name. The volume name is a latin1 string. -Trailing spaces are trimmed." + "Return the volume name of fat superblock SBLOCK as a string of at most 11 +characters, or #f if SBLOCK has no volume name. The volume name is a latin1 +string. Trailing spaces are trimmed." (string-trim-right (latin1->string (sub-bytevector sblock 43 11) (lambda (c) #f)) #\space)) @@ -427,8 +468,8 @@ SBLOCK as a bytevector. If that's not set, returns the creation time." (sub-bytevector time 0 16))) ; strips GMT offset. (define (iso9660-superblock-volume-name sblock) - "Return the volume name of SBLOCK as a string. The volume name is an ASCII -string. Trailing spaces are trimmed." + "Return the volume name of iso9660 superblock SBLOCK as a string. The volume +name is an ASCII string. Trailing spaces are trimmed." ;; Note: Valid characters are of the set "[0-9][A-Z]_" (ECMA-119 Appendix A) (string-trim-right (latin1->string (sub-bytevector sblock 40 32) (lambda (c) #f)) #\space)) @@ -459,14 +500,32 @@ if DEVICE does not contain a JFS file system." (sub-bytevector sblock 136 16)) (define (jfs-superblock-volume-name sblock) - "Return the volume name of SBLOCK as a string of at most 16 characters, or -#f if SBLOCK has no volume name." + "Return the volume name of JFS superblock SBLOCK as a string of at most 16 +characters, or #f if SBLOCK has no volume name." (null-terminated-latin1->string (sub-bytevector sblock 152 16))) -(define (check-jfs-file-system device) - "Return the health of a JFS file system on DEVICE." +(define (check-jfs-file-system device force? repair) + "Return the health of an unmounted JFS file system on DEVICE. If FORCE? is +true, check the file system even if it's marked as clean. If REPAIR is false, +do not write to the file system to fix errors, and replay the transaction log +only if FORCE? is true. Otherwise, replay the transaction log before checking +and automatically fix found errors." (match (status:exit-val - (system* "jfs_fsck" "-p" "-v" device)) + (apply system* + `("jfs_fsck" "-v" + ;; The ‘LEVEL’ logic is convoluted. To quote fsck/xchkdsk.c + ;; (‘-p’, ‘-a’, and ‘-r’ are aliases in every way): + ;; “If -f was chosen, have it override [-p] by [forcing] a + ;; check regardless of the outcome after the log is + ;; replayed”. + ;; “If -n is specified by itself, don't replay the journal. + ;; If -n is specified with [-p], replay the journal but + ;; don't make any other changes”. + ,@(if force? '("-f") '()) + ,@(match repair + (#f '("-n")) + (_ '("-p"))) ; no 'safe/#t distinction + ,device))) (0 'pass) (1 'errors-corrected) (2 'reboot-required) @@ -511,18 +570,28 @@ if DEVICE does not contain an F2FS file system." 16)) (define (f2fs-superblock-volume-name sblock) - "Return the volume name of SBLOCK as a string of at most 512 characters, or -#f if SBLOCK has no volume name." + "Return the volume name of F2FS superblock SBLOCK as a string of at most 512 +characters, or #f if SBLOCK has no volume name." (null-terminated-utf16->string (sub-bytevector sblock (- (+ #x470 12) #x400) 512) %f2fs-endianness)) -(define (check-f2fs-file-system device) - "Return the health of a F2FS file system on DEVICE." +(define (check-f2fs-file-system device force? repair) + "Return the health of an unmuounted F2FS file system on DEVICE. If FORCE? is +true, check the file system even if it's marked as clean. If either FORCE? or +REPAIR are true, automatically fix found errors." + ;; There's no ‘-n’ equivalent (‘--dry-run’ does not disable writes). + ;; ’-y’ is an alias of ‘-f’. The man page is bad: read main.c. + (when (and force? (not repair)) + (format (current-error-port) + "warning: forced check of F2FS ~a implies repairing any errors~%" + device)) (match (status:exit-val - (system* "fsck.f2fs" "-p" device)) - ;; 0 and -1 are the only two possibilities - ;; (according to the manpage) + (apply system* `("fsck.f2fs" + ,@(if force? '("-f") '()) + ,@(if repair '("-p") '("--dry-run")) + ,device))) + ;; 0 and -1 are the only two possibilities according to the man page. (0 'pass) (_ 'fatal-error))) @@ -600,14 +669,82 @@ if DEVICE does not contain a NTFS file system." ;; in the BOOT SECTOR like the UUID, but in the MASTER FILE TABLE, which seems ;; way harder to access. -(define (check-ntfs-file-system device) - "Return the health of a NTFS file system on DEVICE." +(define (check-ntfs-file-system device force? repair) + "Return the health of an unmounted NTFS file system on DEVICE. FORCE? is +ignored: a full check is always performed. Repair is not possible: if REPAIR is +true and the volume has been repaired by an external tool, clear the volume +dirty flag to indicate that it's now safe to mount." (match (status:exit-val - (system* "ntfsfix" device)) + (apply system* `("ntfsfix" + ,@(if repair '("--clear-dirty") '("--no-action")) + ,device))) (0 'pass) (_ 'fatal-error))) + +;;; +;;; XFS file systems. +;;; + +;; <https://git.kernel.org/pub/scm/fs/xfs/xfs-documentation.git/tree/design/XFS_Filesystem_Structure/allocation_groups.asciidoc> + +(define-syntax %xfs-endianness + ;; Endianness of XFS file systems. + (identifier-syntax (endianness big))) + +(define (xfs-superblock? sblock) + "Return #t when SBLOCK is an XFS superblock." + (bytevector=? (sub-bytevector sblock 0 4) + (string->utf8 "XFSB"))) + +(define (read-xfs-superblock device) + "Return the raw contents of DEVICE's XFS superblock as a bytevector, or #f +if DEVICE does not contain an XFS file system." + (read-superblock device 0 120 xfs-superblock?)) + +(define (xfs-superblock-uuid sblock) + "Return the UUID of XFS superblock SBLOCK as a 16-byte bytevector." + (sub-bytevector sblock 32 16)) + +(define (xfs-superblock-volume-name sblock) + "Return the volume name of XFS superblock SBLOCK as a string of at most 12 +characters, or #f if SBLOCK has no volume name." + (null-terminated-latin1->string (sub-bytevector sblock 108 12))) + +(define (check-xfs-file-system device force? repair) + "Return the health of an unmounted XFS file system on DEVICE. If FORCE? is +false, return 'PASS unconditionally as XFS claims no need for off-line checks. +When FORCE? is true, do perform a thorough check. If REPAIR is false, do not +write to DEVICE. If it's #t, replay the log, check, and fix any errors found. +Otherwise, only replay the log, and check without attempting further repairs." + (define (xfs_repair) + (status:exit-val + (apply system* `("xfs_repair" "-Pv" + ,@(match repair + (#t '("-e")) + (_ '("-n"))) ; will miss some errors + ,device)))) + (if force? + ;; xfs_repair fails with exit status 2 if the log is dirty, which is + ;; likely in situations where you're running xfs_repair. Only the kernel + ;; can replay the log by {,un}mounting it cleanly. + (match (let ((status (xfs_repair))) + (if (and repair (eq? 2 status)) + (let ((target "/replay-XFS-log")) + ;; The kernel helpfully prints a ‘Mounting…’ notice for us. + (mkdir target) + (mount device target "xfs") + (umount target) + (rmdir target) + (xfs_repair)) + status)) + (0 'pass) + (4 'errors-corrected) + (_ 'fatal-error)) + 'pass)) + + ;;; ;;; Partition lookup. ;;; @@ -700,7 +837,9 @@ partition field reader that returned a value." (partition-field-reader read-jfs-superblock jfs-superblock-volume-name) (partition-field-reader read-f2fs-superblock - f2fs-superblock-volume-name))) + f2fs-superblock-volume-name) + (partition-field-reader read-xfs-superblock + xfs-superblock-volume-name))) (define %partition-uuid-readers (list (partition-field-reader read-iso9660-superblock @@ -722,7 +861,9 @@ partition field reader that returned a value." (partition-field-reader read-f2fs-superblock f2fs-superblock-uuid) (partition-field-reader read-ntfs-superblock - ntfs-superblock-uuid))) + ntfs-superblock-uuid) + (partition-field-reader read-xfs-superblock + xfs-superblock-uuid))) (define read-partition-label (cut read-partition-field <> %partition-label-readers)) @@ -816,8 +957,13 @@ containing ':/')." (uuid-bytevector spec) uuid->string)))) -(define (check-file-system device type) - "Run a file system check of TYPE on DEVICE." +(define (check-file-system device type force? repair) + "Check an unmounted TYPE file system on DEVICE. Do nothing but warn if it is +mounted. If FORCE? is true, check even when considered unnecessary. If REPAIR +is false, try not to write to DEVICE at all. If it's #t, try to fix all errors +found. Otherwise, fix only those considered safe to repair automatically. Not +all TYPEs support all values or combinations of FORCE? and REPAIR. Don't throw +an exception in such cases but perform the nearest sane action." (define check-procedure (cond ((string-prefix? "ext" type) check-ext2-file-system) @@ -828,36 +974,44 @@ containing ':/')." ((string-prefix? "f2fs" type) check-f2fs-file-system) ((string-prefix? "ntfs" type) check-ntfs-file-system) ((string-prefix? "nfs" type) (const 'pass)) + ((string-prefix? "xfs" type) check-xfs-file-system) (else #f))) (if check-procedure - (match (check-procedure device) - ('pass - #t) - ('errors-corrected - (format (current-error-port) - "File system check corrected errors on ~a; continuing~%" - device)) - ('reboot-required - (format (current-error-port) - "File system check corrected errors on ~a; rebooting~%" - device) - (sleep 3) - (reboot)) - ('fatal-error - (format (current-error-port) "File system check on ~a failed~%" - device) - - ;; Spawn a REPL only if someone would be able to interact with it. - (when (isatty? (current-input-port)) - (format (current-error-port) "Spawning Bourne-like REPL.~%") - - ;; 'current-output-port' is typically connected to /dev/klog (in - ;; PID 1), but here we want to make sure we talk directly to the - ;; user. - (with-output-to-file "/dev/console" - (lambda () - (start-repl %bournish-language)))))) + (let ((mount (find (lambda (mount) + (string=? device (mount-source mount))) + (mounts)))) + (if mount + (format (current-error-port) + "Refusing to check ~a file system already mounted at ~a~%" + device (mount-point mount)) + (match (check-procedure device force? repair) + ('pass + #t) + ('errors-corrected + (format (current-error-port) + "File system check corrected errors on ~a; continuing~%" + device)) + ('reboot-required + (format (current-error-port) + "File system check corrected errors on ~a; rebooting~%" + device) + (sleep 3) + (reboot)) + ('fatal-error + (format (current-error-port) "File system check on ~a failed~%" + device) + + ;; Spawn a REPL only if someone might interact with it. + (when (isatty? (current-input-port)) + (format (current-error-port) "Spawning Bourne-like REPL.~%") + + ;; 'current-output-port' is typically connected to /dev/klog + ;; (in PID 1), but here we want to make sure we talk directly + ;; to the user. + (with-output-to-file "/dev/console" + (lambda () + (start-repl %bournish-language)))))))) (format (current-error-port) "No file system check procedure for ~a; skipping~%" device))) @@ -886,7 +1040,11 @@ corresponds to the symbols listed in FLAGS." (() 0)))) -(define* (mount-file-system fs #:key (root "/root")) +(define* (mount-file-system fs #:key (root "/root") + (check? (file-system-check? fs)) + (skip-check-if-clean? + (file-system-skip-check-if-clean? fs)) + (repair (file-system-repair fs))) "Mount the file system described by FS, a <file-system> object, under ROOT." (define (mount-nfs source mount-point type flags options) @@ -924,8 +1082,8 @@ corresponds to the symbols listed in FLAGS." (file-system-mount-flags (statfs source))) 0))) (options (file-system-options fs))) - (when (file-system-check? fs) - (check-file-system source type)) + (when check? + (check-file-system source type (not skip-check-if-clean?) repair)) (catch 'system-error (lambda () diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm index 95d0a1fe79..8efe6e5f9c 100644 --- a/gnu/build/linux-boot.scm +++ b/gnu/build/linux-boot.scm @@ -25,6 +25,7 @@ #:autoload (system repl repl) (start-repl) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) @@ -44,7 +45,6 @@ make-static-device-nodes configure-qemu-networking - device-number boot-system)) ;;; Commentary: @@ -134,14 +134,9 @@ succeeds. Return nothing otherwise. The kernel logs any details to dmesg." ;; is found on the command line; our canonicalize-device-spec gives ;; up after 20 seconds. We could emulate the former by looping… (device (canonicalize-device-spec spec)) - (rdev (stat:rdev (stat device))) - ;; For backwards compatibility, device numbering is a baroque affair. - ;; This is the full 64-bit scheme used by glibc's <sys/sysmacros.h>. - (major (logior (ash (logand #x00000000000fff00 rdev) -8) - (ash (logand #xfffff00000000000 rdev) -32))) - (minor (logior (logand #x00000000000000ff rdev) - (ash (logand #x00000ffffff00000 rdev) -12)))) - (format #f "~a:~a" major minor))) + (rdev (stat:rdev (stat device)))) + (let-values (((major minor) (device-number->major+minor rdev))) + (format #f "~a:~a" major minor)))) ;; Write the resume DEVICE to this magic file, using the MAJOR:MINOR device ;; numbers if possible. The kernel will immediately try to resume from it. @@ -392,11 +387,6 @@ networking values.) Return #t if INTERFACE is up, #f otherwise." (logand (network-interface-flags sock interface) IFF_UP))) -(define (device-number major minor) - "Return the device number for the device with MAJOR and MINOR, for use as -the last argument of `mknod'." - (+ (* major 256) minor)) - (define (pidof program) "Return the PID of the first presumed instance of PROGRAM." (let ((program (basename program))) @@ -408,12 +398,17 @@ the last argument of `mknod'." (define* (mount-root-file-system root type #:key volatile-root? (flags 0) options - check?) + check? skip-check-if-clean? repair) "Mount the root file system of type TYPE at device ROOT. If VOLATILE-ROOT? is true, mount ROOT read-only and make it an overlay with a writable tmpfs using the kernel built-in overlayfs. FLAGS and OPTIONS indicates the options to use to mount ROOT, and behave the same as for the `mount' procedure. -If CHECK? is true, first run ROOT's fsck tool (if any) non-interactively." + +If CHECK? is true, first run ROOT's fsck tool (if any) non-interactively. +If SKIP-CHECK-IF-CLEAN? is true, ask fsck to return immediately if ROOT is +marked as clean. If REPAIR is true, fsck may write to ROOT to perform repairs. +If REPAIR is also 'PREEN, ask fsck to perform only those repairs that it +considers safe." (if volatile-root? (begin @@ -435,7 +430,7 @@ If CHECK? is true, first run ROOT's fsck tool (if any) non-interactively." "lowerdir=/real-root,upperdir=/rw-root/upper,workdir=/rw-root/work")) (begin (when check? - (check-file-system root type)) + (check-file-system root type (not skip-check-if-clean?) repair)) (mount root "/root" type flags options))) ;; Make sure /root/etc/mtab is a symlink to /proc/self/mounts. @@ -536,21 +531,36 @@ upon error." (mount-essential-file-systems) (let* ((args (linux-command-line)) (to-load (find-long-option "--load" args)) - (root-fs (find root-mount-point? mounts)) - (root-fs-type (or (and=> root-fs file-system-type) - "ext4")) - (root-fs-device (and=> root-fs file-system-device)) - (root-fs-flags (mount-flags->bit-mask - (or (and=> root-fs file-system-flags) - '()))) - (root-options (if root-fs - (file-system-options root-fs) - #f)) - ;; --root takes precedence over the 'device' field of the root - ;; <file-system> record. - (root-device (or (and=> (find-long-option "--root" args) - device-string->file-system-device) - root-fs-device))) + ;; If present, ‘--root’ on the kernel command line takes precedence + ;; over the ‘device’ field of the root <file-system> record. + (root-device (and=> (find-long-option "--root" args) + device-string->file-system-device)) + (root-fs (or (find root-mount-point? mounts) + ;; Fall back to fictitious defaults. + (file-system (device (or root-device "/dev/root")) + (mount-point "/") + (type "ext4")))) + (fsck.mode (find-long-option "fsck.mode" args))) + + (define (check? fs) + (match fsck.mode + ("skip" #f) + ("force" #t) + (_ (file-system-check? fs)))) ; assume "auto" + + (define (skip-check-if-clean? fs) + (match fsck.mode + ("force" #f) + (_ (file-system-skip-check-if-clean? fs)))) + + (define (repair fs) + (let ((arg (find-long-option "fsck.repair" args))) + (if arg + (match arg + ("no" #f) + ("yes" #t) + (_ 'preen)) + (file-system-repair fs)))) (when (member "--repl" args) (start-repl)) @@ -606,17 +616,24 @@ upon error." (if root-device (mount-root-file-system (canonicalize-device-spec root-device) - root-fs-type + (file-system-type root-fs) #:volatile-root? volatile-root? - #:flags root-fs-flags - #:options root-options - #:check? (if root-fs - (file-system-check? root-fs) - #t)) + #:flags (mount-flags->bit-mask + (file-system-flags root-fs)) + #:options (file-system-options root-fs) + #:check? (check? root-fs) + #:skip-check-if-clean? + (skip-check-if-clean? root-fs) + #:repair (repair root-fs)) (mount "none" "/root" "tmpfs")) - ;; Mount the specified file systems. - (for-each mount-file-system + ;; Mount the specified non-root file systems. + (for-each (lambda (fs) + (mount-file-system fs + #:check? (check? fs) + #:skip-check-if-clean? + (skip-check-if-clean? fs) + #:repair (repair fs))) (remove root-mount-point? mounts)) (setenv "EXT2FS_NO_MTAB_OK" #f) |