[PATCH] WIP refactor file-system-check-procedure

[David Craven]

* 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 address@hidden))
+                                      (and address@hidden)
+                                      (and address@hidden))
                         #:linux-modules '#$linux-modules
                         #:linux-module-directory '#$kodir
                         #:qemu-guest-networking? #$qemu-networking?
-- 
2.11.0