linux-initrd: Check the root and other early file systems.

* gnu/system.scm (operating-system-derivation)[boot-file-systems]: Keep "/".
* gnu/system/linux-initrd.scm (file-system->spec): Keep the 'check?'
  flag.
  (qemu-initrd)[helper-packages]: New variable.  Pass it as #:to-copy.
  <gexp>: Add 'set-path-environment-variable' call.  Remove #:unionfs
  argument for 'boot-system'.
* gnu/system/vm.scm (%linux-vm-file-systems): Add 'check?' field/
  (virtualized-operating-system): Likewise for the "9p" file system.
* guix/build/linux-initrd.scm (mount-root-file-system): Change #:unionfs
  default.  Call 'check-file-system' before mounting ROOT, when
  VOLATILE-ROOT? is false.
  (check-file-system): New procedure.
  (mount-file-system): Honor 'check?' element in list; add
  'check-file-system' call.
  (boot-system): Remove #:root-fs-type and #:unionfs parameters.
  [root-mount-point?, root-fs-type]: New variables.
  Call 'mount-file-system' on all MOUNTS but "/".
This commit is contained in:
Ludovic Courtès 2014-05-04 00:30:39 +02:00
parent ad896f23a5
commit 3c05b4bc25
4 changed files with 80 additions and 24 deletions

View File

@ -349,8 +349,10 @@ we're running in the final root."
"Return a derivation that builds OS." "Return a derivation that builds OS."
(define boot-file-systems (define boot-file-systems
(filter (match-lambda (filter (match-lambda
(($ <file-system> device mount-point type _ _ boot?) (($ <file-system> device "/")
(and boot? (not (string=? mount-point "/"))))) #t)
(($ <file-system> device mount-point type flags options boot?)
boot?))
(operating-system-file-systems os))) (operating-system-file-systems os)))
(mlet* %store-monad (mlet* %store-monad

View File

@ -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 "Return a list corresponding to file-system FS that can be passed to the
initrd code." initrd code."
(match fs (match fs
(($ <file-system> device mount-point type flags options) (($ <file-system> device mount-point type flags options _ check?)
(list device mount-point type flags options)))) (list device mount-point type flags options check?))))
(define* (qemu-initrd file-systems (define* (qemu-initrd file-systems
#:key #:key
@ -243,24 +243,37 @@ exception and backtrace!)."
'("fuse.ko") '("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 (expression->initrd
#~(begin #~(begin
(use-modules (guix build linux-initrd) (use-modules (guix build linux-initrd)
(guix build utils)
(srfi srfi-26)) (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) (boot-system #:mounts '#$(map file-system->spec file-systems)
#:linux-modules '#$linux-modules #:linux-modules '#$linux-modules
#:qemu-guest-networking? #t #:qemu-guest-networking? #t
#:guile-modules-in-chroot? '#$guile-modules-in-chroot? #: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?)) #:volatile-root? '#$volatile-root?))
#:name "qemu-initrd" #:name "qemu-initrd"
#:modules '((guix build utils) #:modules '((guix build utils)
(guix build linux-initrd)) (guix build linux-initrd))
#:to-copy (if volatile-root? #:to-copy helper-packages
(list unionfs-fuse/static)
'())
#:linux linux-libre #:linux linux-libre
#:linux-modules linux-modules)) #:linux-modules linux-modules))

View File

@ -90,13 +90,15 @@ input tuple. The output file name is when building for SYSTEM."
(device "store") (device "store")
(type "9p") (type "9p")
(needed-for-boot? #t) (needed-for-boot? #t)
(options "trans=virtio")) (options "trans=virtio")
(check? #f))
(file-system (file-system
(mount-point "/xchg") (mount-point "/xchg")
(device "xchg") (device "xchg")
(type "9p") (type "9p")
(needed-for-boot? #t) (needed-for-boot? #t)
(options "trans=virtio")))) (options "trans=virtio")
(check? #f))))
(define* (expression->derivation-in-linux-vm name exp (define* (expression->derivation-in-linux-vm name exp
#:key #:key
@ -333,7 +335,8 @@ environment with the store shared with the host."
(device "store") (device "store")
(type "9p") (type "9p")
(needed-for-boot? #t) (needed-for-boot? #t)
(options "trans=virtio")))))) (options "trans=virtio")
(check? #f))))))
(define* (system-qemu-image/shared-store (define* (system-qemu-image/shared-store
os os

View File

@ -190,7 +190,7 @@ the last argument of `mknod'."
(+ (* major 256) minor)) (+ (* major 256) minor))
(define* (mount-root-file-system root type (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? "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 is true, mount ROOT read-only and make it a union with a writable tmpfs using
UNIONFS." UNIONFS."
@ -212,20 +212,45 @@ UNIONFS."
"/rw-root=RW:/real-root=RO" "/rw-root=RW:/real-root=RO"
"/root")) "/root"))
(error "unionfs failed"))) (error "unionfs failed")))
(mount root "/root" type))) (begin
(check-file-system root type)
(mount root "/root" type))))
(lambda args (lambda args
(format (current-error-port) "exception while mounting '~a': ~s~%" (format (current-error-port) "exception while mounting '~a': ~s~%"
root args) root args)
(start-repl)))) (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")) (define* (mount-file-system spec #:key (root "/root"))
"Mount the file system described by SPEC under ROOT. SPEC must have the "Mount the file system described by SPEC under ROOT. SPEC must have the
form: 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; 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 (define flags->bit-mask
(match-lambda (match-lambda
(('read-only rest ...) (('read-only rest ...)
@ -236,8 +261,10 @@ FLAGS must be a list of symbols."
0))) 0)))
(match spec (match spec
((source mount-point type (flags ...) options) ((source mount-point type (flags ...) options check?)
(let ((mount-point (string-append root "/" mount-point))) (let ((mount-point (string-append root "/" mount-point)))
(when check?
(check-file-system source type))
(mkdir-p mount-point) (mkdir-p mount-point)
(mount source mount-point type (flags->bit-mask flags) (mount source mount-point type (flags->bit-mask flags)
(if options (if options
@ -248,8 +275,7 @@ FLAGS must be a list of symbols."
(linux-modules '()) (linux-modules '())
qemu-guest-networking? qemu-guest-networking?
guile-modules-in-chroot? guile-modules-in-chroot?
volatile-root? unionfs volatile-root?
(root-fs-type "ext4")
(mounts '())) (mounts '()))
"This procedure is meant to be called from an initrd. Boot a system by "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 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 and finally booting into the new root if any. The initrd supports kernel
command-line options '--load', '--root', and '--repl'. command-line options '--load', '--root', and '--repl'.
Mount the root file system, of type ROOT-FS-TYPE, specified by the '--root' Mount the root file system, specified by the '--root' command-line argument,
command-line argument, if any. if any.
MOUNTS must be a list suitable for 'mount-file-system'. MOUNTS must be a list suitable for 'mount-file-system'.
@ -276,6 +302,18 @@ to it are lost."
(resolve (string-append "/root" target))) (resolve (string-append "/root" target)))
file))) 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 "Welcome, this is GNU's early boot Guile.\n")
(display "Use '--repl' for an initrd REPL.\n\n") (display "Use '--repl' for an initrd REPL.\n\n")
@ -310,8 +348,7 @@ to it are lost."
(mkdir "/root")) (mkdir "/root"))
(if root (if root
(mount-root-file-system root root-fs-type (mount-root-file-system root root-fs-type
#:volatile-root? volatile-root? #:volatile-root? volatile-root?)
#:unionfs unionfs)
(mount "none" "/root" "tmpfs")) (mount "none" "/root" "tmpfs"))
(mount-essential-file-systems #:root "/root") (mount-essential-file-systems #:root "/root")
@ -321,7 +358,8 @@ to it are lost."
(make-essential-device-nodes #:root "/root")) (make-essential-device-nodes #:root "/root"))
;; Mount the specified file systems. ;; 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? (when guile-modules-in-chroot?
;; Copy the directories that contain .scm and .go files so that the ;; Copy the directories that contain .scm and .go files so that the