summaryrefslogtreecommitdiff
path: root/gnu/build/file-systems.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/build/file-systems.scm')
-rw-r--r--gnu/build/file-systems.scm318
1 files changed, 238 insertions, 80 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 ()
generated by cgit v1.2.3 (git 2.45.2) at 2024-07-03 06:36:58 +0000