guix
/
guix
mirror of git://git.savannah.gnu.org/guix.git
3
4
Fork 0
Code Issues Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gnu/system.scm
View File

@ -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

27
gnu/system/linux-initrd.scm
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
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))

9
gnu/system/vm.scm
View File

@ -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

62
guix/build/linux-initrd.scm
View File

@ -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