diff options
| -rw-r--r-- | gnu/system.scm | 6 | ||||
| -rw-r--r-- | gnu/system/linux-initrd.scm | 27 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 9 | ||||
| -rw-r--r-- | guix/build/linux-initrd.scm | 62 |
4 files changed, 80 insertions, 24 deletions
diff --git a/gnu/system.scm b/gnu/system.scm index 7624b10ae4..65d1ca3418 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -349,8 +349,10 @@ we're running in the final root." "Return a derivation that builds OS." (define boot-file-systems (filter (match-lambda - (($ <file-system> device mount-point type _ _ boot?) - (and boot? (not (string=? mount-point "/"))))) + (($ <file-system> device "/") + #t) + (($ <file-system> device mount-point type flags options boot?) + boot?)) (operating-system-file-systems os))) (mlet* %store-monad diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm index 8b4ab9c4eb..749dfa313f 100644 --- a/gnu/system/linux-initrd.scm +++ b/gnu/system/linux-initrd.scm @@ -198,8 +198,8 @@ a list of Guile module names to be embedded in the initrd." "Return a list corresponding to file-system FS that can be passed to the initrd code." (match fs - (($ <file-system> device mount-point type flags options) - (list device mount-point type flags options)))) + (($ <file-system> device mount-point type flags options _ check?) + (list device mount-point type flags options check?)))) (define* (qemu-initrd file-systems #:key @@ -243,24 +243,37 @@ exception and backtrace!)." '("fuse.ko") '()))) + (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? + (list unionfs-fuse/static) + '()))) + (expression->initrd #~(begin (use-modules (guix build linux-initrd) + (guix build utils) (srfi srfi-26)) + (with-output-to-port (%make-void-port "w") + (lambda () + (set-path-environment-variable "PATH" '("bin" "sbin") + '#$helper-packages))) + (boot-system #:mounts '#$(map file-system->spec file-systems) #:linux-modules '#$linux-modules #:qemu-guest-networking? #t #:guile-modules-in-chroot? '#$guile-modules-in-chroot? - #:unionfs (and=> #$(and volatile-root? unionfs-fuse/static) - (cut string-append <> "/bin/unionfs")) #:volatile-root? '#$volatile-root?)) #:name "qemu-initrd" #:modules '((guix build utils) (guix build linux-initrd)) - #:to-copy (if volatile-root? - (list unionfs-fuse/static) - '()) + #:to-copy helper-packages #:linux linux-libre #:linux-modules linux-modules)) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 786e564031..b20831f44d 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -90,13 +90,15 @@ input tuple. The output file name is when building for SYSTEM." (device "store") (type "9p") (needed-for-boot? #t) - (options "trans=virtio")) + (options "trans=virtio") + (check? #f)) (file-system (mount-point "/xchg") (device "xchg") (type "9p") (needed-for-boot? #t) - (options "trans=virtio")))) + (options "trans=virtio") + (check? #f)))) (define* (expression->derivation-in-linux-vm name exp #:key @@ -333,7 +335,8 @@ environment with the store shared with the host." (device "store") (type "9p") (needed-for-boot? #t) - (options "trans=virtio")))))) + (options "trans=virtio") + (check? #f)))))) (define* (system-qemu-image/shared-store os diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm index fd6c0c4673..b2cbcae7d8 100644 --- a/guix/build/linux-initrd.scm +++ b/guix/build/linux-initrd.scm @@ -190,7 +190,7 @@ the last argument of `mknod'." (+ (* major 256) minor)) (define* (mount-root-file-system root type - #:key volatile-root? unionfs) + #: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 UNIONFS." @@ -212,20 +212,45 @@ UNIONFS." "/rw-root=RW:/real-root=RO" "/root")) (error "unionfs failed"))) - (mount root "/root" type))) + (begin + (check-file-system root type) + (mount root "/root" type)))) (lambda args (format (current-error-port) "exception while mounting '~a': ~s~%" root args) (start-repl)))) +(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" 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 REPL~%" + fsck code device) + (start-repl))))) + (define* (mount-file-system spec #:key (root "/root")) "Mount the file system described by SPEC under ROOT. SPEC must have the form: - (DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS) + (DEVICE MOUNT-POINT TYPE (FLAGS ...) OPTIONS CHECK?) DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f; -FLAGS must be a list of symbols." +FLAGS must be a list of symbols. CHECK? is a Boolean indicating whether to +run a file system check." (define flags->bit-mask (match-lambda (('read-only rest ...) @@ -236,8 +261,10 @@ FLAGS must be a list of symbols." 0))) (match spec - ((source mount-point type (flags ...) options) + ((source mount-point type (flags ...) options check?) (let ((mount-point (string-append root "/" mount-point))) + (when check? + (check-file-system source type)) (mkdir-p mount-point) (mount source mount-point type (flags->bit-mask flags) (if options @@ -248,8 +275,7 @@ FLAGS must be a list of symbols." (linux-modules '()) qemu-guest-networking? guile-modules-in-chroot? - volatile-root? unionfs - (root-fs-type "ext4") + volatile-root? (mounts '())) "This procedure is meant to be called from an initrd. Boot a system by first loading LINUX-MODULES, then setting up QEMU guest networking if @@ -257,8 +283,8 @@ QEMU-GUEST-NETWORKING? is true, mounting the file systems specified in MOUNTS, and finally booting into the new root if any. The initrd supports kernel command-line options '--load', '--root', and '--repl'. -Mount the root file system, of type ROOT-FS-TYPE, specified by the '--root' -command-line argument, if any. +Mount the root file system, specified by the '--root' command-line argument, +if any. MOUNTS must be a list suitable for 'mount-file-system'. @@ -276,6 +302,18 @@ to it are lost." (resolve (string-append "/root" target))) file))) + (define root-mount-point? + (match-lambda + ((device "/" _ ...) #t) + (_ #f))) + + (define root-fs-type + (or (any (match-lambda + ((device "/" type _ ...) type) + (_ #f)) + mounts) + "ext4")) + (display "Welcome, this is GNU's early boot Guile.\n") (display "Use '--repl' for an initrd REPL.\n\n") @@ -310,8 +348,7 @@ to it are lost." (mkdir "/root")) (if root (mount-root-file-system root root-fs-type - #:volatile-root? volatile-root? - #:unionfs unionfs) + #:volatile-root? volatile-root?) (mount "none" "/root" "tmpfs")) (mount-essential-file-systems #:root "/root") @@ -321,7 +358,8 @@ to it are lost." (make-essential-device-nodes #:root "/root")) ;; Mount the specified file systems. - (for-each mount-file-system mounts) + (for-each mount-file-system + (remove root-mount-point? mounts)) (when guile-modules-in-chroot? ;; Copy the directories that contain .scm and .go files so that the |