From mboxrd@z Thu Jan 1 00:00:00 1970 From: David Craven Subject: [PATCH] WIP refactor file-system-check-procedure Date: Sat, 7 Jan 2017 16:54:54 +0100 Message-ID: <20170107155454.9645-1-david@craven.ch> Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:57246) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1cPtLA-00087G-5T for guix-devel@gnu.org; Sat, 07 Jan 2017 10:55:33 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1cPtL7-0002PS-24 for guix-devel@gnu.org; Sat, 07 Jan 2017 10:55:32 -0500 Received: from so254-10.mailgun.net ([198.61.254.10]:23220) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1cPtL6-0002OO-Rx for guix-devel@gnu.org; Sat, 07 Jan 2017 10:55:28 -0500 List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: "Guix-devel" To: guix-devel@gnu.org * 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 ( @@ -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 - (default '()))) ; or + (default '())) ; or + (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 + 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) + ((($ _ 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