* [PATCH] WIP refactor file-system-check-procedure
@ 2017-01-07 15:54 David Craven
2017-01-07 16:05 ` David Craven
0 siblings, 1 reply; 2+ messages in thread
From: David Craven @ 2017-01-07 15:54 UTC (permalink / raw)
To: guix-devel
* gnu/build/file-systems.scm
* gnu/system/file-systems.scm
* gnu/system/linux-initrd.scm
---
gnu/build/file-systems.scm | 51 +++++++++++++++++++-----------------
gnu/system/file-systems.scm | 64 ++++++++++++++++++++++++++++++++++++++++++++-
gnu/system/linux-initrd.scm | 28 +++++++++++---------
3 files changed, 105 insertions(+), 38 deletions(-)
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 4c18cb34c..3a37cbbf4 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -447,28 +447,31 @@ the following:
(else
(error "unknown device title" title))))
-(define (check-file-system device type)
- "Run a file system check of TYPE on DEVICE."
- (define fsck
- (string-append "fsck." type))
-
- (let ((status (system* fsck "-v" "-p" "-C" "0" device)))
- (match (status:exit-val status)
- (0
- #t)
- (1
- (format (current-error-port) "'~a' corrected errors on ~a; continuing~%"
- fsck device))
- (2
- (format (current-error-port) "'~a' corrected errors on ~a; rebooting~%"
- fsck device)
- (sleep 3)
- (reboot))
- (code
- (format (current-error-port) "'~a' exited with code ~a on ~a; \
-spawning Bourne-like REPL~%"
- fsck code device)
- (start-repl %bournish-language)))))
+(define (check-file-system check-procedure device)
+ "Run a file system check on DEVICE with CHECK-PROCEDURE. When CHECK-PROCEDURE
+is #f skip file system check."
+ (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; spawning Bourne-like REPL~%"
+ device)
+ (start-repl %bournish-language)))
+ (format (current-error-port)
+ "No file system check procedure for ~a; skipping~%"
+ device)))
(define (mount-flags->bit-mask flags)
"Return the number suitable for the 'flags' argument of 'mount' that
@@ -527,8 +530,8 @@ run a file system check."
(let ((source (canonicalize-device-spec source title))
(mount-point (string-append root "/" mount-point))
(flags (mount-flags->bit-mask flags)))
- (when check?
- (check-file-system source type))
+ ;;(when check?
+ ;; (check-file-system check-procedure source))
;; Create the mount point. Most of the time this is a directory, but
;; in the case of a bind mount, a regular file may be needed.
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 4cc1221eb..b265fe8b0 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -18,10 +18,14 @@
(define-module (gnu system file-systems)
#:use-module (ice-9 match)
+ #:use-module (guix gexp)
#:use-module (guix records)
#:use-module (guix store)
+ #:use-module ((gnu packages linux) #:select (e2fsck/static btrfs-progs/static))
+ #:use-module ((gnu packages disk) #:select (fatfsck/static))
#:use-module ((gnu build file-systems)
#:select (string->uuid uuid->string))
+ #:use-module (srfi srfi-26)
#:re-export (string->uuid
uuid->string)
#:export (<file-system>
@@ -36,6 +40,7 @@
file-system-options
file-system-mount?
file-system-check?
+ file-system-check-procedure
file-system-create-mount-point?
file-system-dependencies
@@ -43,6 +48,7 @@
spec->file-system
specification->file-system-mapping
uuid
+ default-check-procedure
%fuse-control-file-system
%binary-format-file-system
@@ -93,7 +99,9 @@
(create-mount-point? file-system-create-mount-point? ; Boolean
(default #f))
(dependencies file-system-dependencies ; list of <file-system>
- (default '()))) ; or <mapped-device>
+ (default '())) ; or <mapped-device>
+ (check-procedure file-system-check-procedure ; Gexp or #f
+ (default #f)))
(define-inlinable (file-system-needed-for-boot? fs)
"Return true if FS has the 'needed-for-boot?' flag set, or if it's the root
@@ -135,6 +143,60 @@ TARGET in the other system."
(target spec)
(writable? writable?)))))
+(define-record-type* <file-system-checker> file-system-checker
+ make-file-system-checker
+ file-system-checker?
+ (predicate file-system-checker-predicate)
+ (procedure file-system-checker-procedure))
+
+(define %ext2-checker
+ (file-system-checker
+ (predicate (cut string-prefix? "ext" <>))
+ (procedure (lambda (device)
+ #~(match (status:exit-val
+ (system* #$(file-append e2fsck/static "/sbin/e2fsck")
+ "-v" "-p" "-C" "0" #$device))
+ (0 'pass)
+ (1 'errors-corrected)
+ (2 'reboot-required)
+ (code 'fatal-error))))))
+
+;; BTRFS file systems don't require a file system check. We run
+;; btrfs device scan which is required before mounting multiple
+;; device file systems (like a BTRFS RAID).
+(define %btrfs-checker
+ (file-system-checker
+ (predicate (cut string-prefix? "btrfs" <>))
+ (procedure (lambda (device)
+ #~(match (status:exit-val
+ (system* #$(file-append btrfs-progs/static "/bin/btrfs")
+ "device" "scan"))
+ (0 'pass)
+ (code 'fatal-error))))))
+
+(define %vfat-checker
+ (file-system-checker
+ (predicate (cut string-prefix? "vfat" <>))
+ (procedure (lambda (device)
+ #~(match (status:exit-val
+ (system* #$(file-append fatfsck/static "/sbin/dosfsck")
+ "-v" "-a" #$device))
+ (0 'pass)
+ (1 'errors-corrected)
+ (code 'fatal-error))))))
+
+(define %file-system-checkers
+ (list %ext2-checker %btrfs-checker %vfat-checker))
+
+(define (default-check-procedure fs)
+ "Returns the default check procedure for FS."
+ (let ((type (file-system-type fs)))
+ (match (filter (lambda (checker)
+ ((file-system-checker-predicate checker) type))
+ %file-system-checkers)
+ ((($ <file-system-checker> _ procedure)) procedure)
+ (_ #f))))
+
(define-syntax uuid
(lambda (s)
"Return the bytevector corresponding to the given UUID representation."
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 92ff96a4c..c50c9e936 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -207,17 +207,7 @@ loaded at boot time in the order in which they appear."
(define helper-packages
;; Packages to be copied on the initrd.
- `(,@(if (find (lambda (fs)
- (string-prefix? "ext" (file-system-type fs)))
- file-systems)
- (list e2fsck/static)
- '())
- ,@(if (find (lambda (fs)
- (string-suffix? "fat" (file-system-type fs)))
- file-systems)
- (list fatfsck/static)
- '())
- ,@(if volatile-root?
+ `(,@(if volatile-root?
(list unionfs-fuse/static)
'())))
@@ -231,6 +221,15 @@ loaded at boot time in the order in which they appear."
(open source target)))
mapped-devices))
+ (define check-file-system-commands
+ (fold (lambda (fs checkers)
+ (let ((check-procedure (or (file-system-check-procedure fs)
+ (default-check-procedure fs))))
+ (if (and check-procedure (file-system-check? fs))
+ (cons (check-procedure (file-system-device fs)) checkers)
+ checkers)))
+ '() file-systems))
+
(mlet %store-monad ((kodir (flat-linux-module-directory linux
linux-modules)))
(expression->initrd
@@ -238,11 +237,13 @@ loaded at boot time in the order in which they appear."
'((gnu build linux-boot)
(guix build utils)
(guix build bournish)
- (gnu build file-systems)))
+ (gnu build file-systems)
+ (ice9 match)))
#~(begin
(use-modules (gnu build linux-boot)
(guix build utils)
(guix build bournish) ;add the 'bournish' meta-command
+ (ice-9 match)
(srfi srfi-26)
;; FIXME: The following modules are for
@@ -259,7 +260,8 @@ loaded at boot time in the order in which they appear."
(boot-system #:mounts '#$(map file-system->spec file-systems)
#:pre-mount (lambda ()
- (and #$@device-mapping-commands))
+ (and #$@device-mapping-commands)
+ (and #$@check-file-system-commands))
#:linux-modules '#$linux-modules
#:linux-module-directory '#$kodir
#:qemu-guest-networking? #$qemu-networking?
--
2.11.0
^ permalink raw reply related [flat|nested] 2+ messages in thread* Re: [PATCH] WIP refactor file-system-check-procedure
2017-01-07 15:54 [PATCH] WIP refactor file-system-check-procedure David Craven
@ 2017-01-07 16:05 ` David Craven
0 siblings, 0 replies; 2+ messages in thread
From: David Craven @ 2017-01-07 16:05 UTC (permalink / raw)
To: guix-devel
Hi!
It doesn't quite work yet, but wanted to know if you think that moving
checking the file systems outside the mounting procedure to be a good
idea or not.
Alternatively I could try moving all of the file-system-checking to
the build side, but I wanted to use gexps so that we can avoid this:
- `(,@(if (find (lambda (fs)
- (string-prefix? "ext" (file-system-type fs)))
- file-systems)
- (list e2fsck/static)
- '())
- ,@(if (find (lambda (fs)
- (string-suffix? "fat" (file-system-type fs)))
- file-systems)
- (list fatfsck/static)
- '())
David
^ permalink raw reply [flat|nested] 2+ messages in thread
end of thread, other threads:[~2017-01-07 16:05 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2017-01-07 15:54 [PATCH] WIP refactor file-system-check-procedure David Craven
2017-01-07 16:05 ` David Craven
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).