[PATCH] file-systems: Refactor <file-system> to include check-procedure.

[David Craven]

From: Marius Bakke <address@hidden>

* gnu/system/file-systems.scm (file-system-check-procedure): New
  variable.  Extend file-system record to include it.  Export it.
* gnu/build/file-systems.scm (check-file-system): Use it.
  (mount-file-system): Serialize spec before calling check-file-system.
* gnu/build/linux-boot.scm: Adjust check-file-system arguments.
* gnu/services/base.scm: Likewise.
* gnu/system/linux-initrd.scm (base-initrd): Remove e2fsck/static from
  helper-packages.

Co-authored-by: David Craven <address@hidden>
---
 gnu/build/file-systems.scm  | 52 +++++++++++++++++++++++----------------------
 gnu/build/linux-boot.scm    | 13 +++++++++---
 gnu/system/file-systems.scm | 24 ++++++++++++++++++---
 gnu/system/linux-initrd.scm |  7 +-----
 4 files changed, 59 insertions(+), 37 deletions(-)

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 431b287..c853352 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -410,28 +410,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 (status:exit-val (check-procedure device))
+        (0
+         #t)
+        (1
+         (format (current-error-port)
+                 "fsck corrected errors on ~a; continuing~%"
+                 device))
+        (2
+         (format (current-error-port)
+                 "fsck corrected errors on ~a; rebooting~%"
+                 device)
+         (sleep 3)
+         (reboot))
+        (code
+         (format (current-error-port)
+                 "fsck exited with code ~a on ~a; spawning Bourne-like REPL~%"
+                 code device)
+         (start-repl %bournish-language)))
+      (format (current-error-port)
+              "'~a' doesn't have a file system check procedure; skipping~%"
+              device)))
 
 (define (mount-flags->bit-mask flags)
   "Return the number suitable for the 'flags' argument of 'mount' that
@@ -486,12 +489,11 @@ run a file system check."
                                 (string-append "," options)
                                 "")))))
   (match spec
-    ((source title mount-point type (flags ...) options check?)
+    ((source title mount-point type (flags ...) options 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))
+       (check-file-system check 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/build/linux-boot.scm b/gnu/build/linux-boot.scm
index c34a3f7..7d2c022 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -236,7 +236,7 @@ the last argument of `mknod'."
                      (compose (cut string=? program <>) basename))))
           (filter-map string->number (scandir "/proc")))))
 
-(define* (mount-root-file-system root type
+(define* (mount-root-file-system root type check-procedure
                                  #:key volatile-root? (unionfs "unionfs"))
   "Mount the root file system of type TYPE at device ROOT.  If VOLATILE-ROOT?
 is true, mount ROOT read-only and make it a union with a writable tmpfs using
@@ -277,7 +277,7 @@ UNIONFS."
         ;; have to resort to 'pidof' here.
         (mark-as-not-killable (pidof unionfs)))
       (begin
-        (check-file-system root type)
+        (check-file-system check-procedure root)
         (mount root "/root" type)))
 
   ;; Make sure /root/etc/mtab is a symlink to /proc/self/mounts.
@@ -363,6 +363,13 @@ to it are lost."
              mounts)
         "ext4"))
 
+  (define root-fs-check-procedure
+    (or (any (match-lambda
+               ((device _ "/" _ _ _ check) check)
+               (_ #f))
+             mounts)
+        #f))
+
   (define (lookup-module name)
     (string-append linux-module-directory "/"
                    (ensure-dot-ko name)))
@@ -402,7 +409,7 @@ to it are lost."
 
        (if root
            (mount-root-file-system (canonicalize-device-spec root)
-                                   root-fs-type
+                                   root-fs-type root-fs-check-procedure
                                    #:volatile-root? volatile-root?)
            (mount "none" "/root" "tmpfs"))
 
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index b51d57f..cc2cf9a 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -18,8 +18,10 @@
 
 (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))
   #:use-module ((gnu build file-systems)
                 #:select (string->uuid uuid->string))
   #:re-export (string->uuid
@@ -36,6 +38,7 @@
             file-system-options
             file-system-mount?
             file-system-check?
+            file-system-check-procedure
             file-system-create-mount-point?
             file-system-dependencies
 
@@ -92,7 +95,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
@@ -104,8 +109,11 @@ file system."
   "Return a list corresponding to file-system FS that can be passed to the
 initrd code."
   (match fs
-    (($ <file-system> device title mount-point type flags options _ _ check?)
-     (list device title mount-point type flags options check?))))
+    (($ <file-system> device title mount-point type flags options mount?
+                      needed-for-boot? check? create-mount-point? depencencies
+                      check-procedure)
+     (list device title mount-point type flags options
+           (and check? (or check-procedure (file-system-check-procedure 
fs)))))))
 
 (define (specification->file-system-mapping spec writable?)
   "Read the SPEC and return the corresponding <file-system-mapping>.  SPEC is
@@ -124,6 +132,16 @@ TARGET in the other system."
          (target spec)
          (writable? writable?)))))
 
+(define (file-system-check-procedure fs)
+  "Return an fsck command corresponding to file-system FS."
+  (let ((type   (file-system-type fs))
+        (device (file-system-device fs)))
+    (cond
+     ((string-prefix? "ext" type)
+      #~(system* #$(file-append e2fsck/static "/sbin/fsck." type)
+                 "-v" "-p" "-C" "0" device))
+     (else #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 174239a..d4b8e45 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -200,12 +200,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 volatile-root?
+    `(,@(if volatile-root?
             (list unionfs-fuse/static)
             '())))
 
-- 
2.9.0