gnu: linux-initrd: Allow the root file system to be volatile.

* gnu/system/linux-initrd.scm (qemu-initrd): Add 'volatile-root?'
  parameter.
* guix/build/linux-initrd.scm (boot-system): Likewise.  Honor it.
This commit is contained in:
Ludovic Courtès 2014-01-31 14:26:30 +01:00
parent 70b33d81cf
commit 44ddf33ed5
2 changed files with 40 additions and 4 deletions

View File

@ -191,6 +191,7 @@ list of Guile module names to be embedded in the initrd."
(define* (qemu-initrd #:key (define* (qemu-initrd #:key
guile-modules-in-chroot? guile-modules-in-chroot?
volatile-root?
(mounts `((cifs "/store" ,(%store-prefix)) (mounts `((cifs "/store" ,(%store-prefix))
(cifs "/xchg" "/xchg")))) (cifs "/xchg" "/xchg"))))
"Return a monadic derivation that builds an initrd for use in a QEMU guest "Return a monadic derivation that builds an initrd for use in a QEMU guest
@ -202,7 +203,10 @@ be mounted atop the root file system, where each item has the form:
When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in
the new root. This is necessary is the file specified as '--load' needs the new root. This is necessary is the file specified as '--load' needs
access to these modules (which is the case if it wants to even just print an access to these modules (which is the case if it wants to even just print an
exception and backtrace!)." exception and backtrace!).
When VOLATILE-ROOT? is true, the root file system is writable but any changes
to it are lost."
(define cifs-modules (define cifs-modules
;; Modules needed to mount CIFS file systems. ;; Modules needed to mount CIFS file systems.
'("md4.ko" "ecb.ko" "cifs.ko")) '("md4.ko" "ecb.ko" "cifs.ko"))
@ -229,7 +233,8 @@ exception and backtrace!)."
(boot-system #:mounts ',mounts (boot-system #:mounts ',mounts
#: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?
#: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))

View File

@ -24,6 +24,7 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 ftw)
#:use-module (guix build utils) #:use-module (guix build utils)
#:export (mount-essential-file-systems #:export (mount-essential-file-systems
linux-command-line linux-command-line
@ -179,6 +180,7 @@ the last argument of `mknod'."
(linux-modules '()) (linux-modules '())
qemu-guest-networking? qemu-guest-networking?
guile-modules-in-chroot? guile-modules-in-chroot?
volatile-root?
(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
@ -191,7 +193,10 @@ MOUNTS must be a list of elements of the form:
(FILE-SYSTEM-TYPE SOURCE TARGET) (FILE-SYSTEM-TYPE SOURCE TARGET)
When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in
the new root." the new root.
When VOLATILE-ROOT? is true, the root file system is writable but any changes
to it are lost."
(define (resolve file) (define (resolve file)
;; If FILE is a symlink to an absolute file name, resolve it as if we were ;; If FILE is a symlink to an absolute file name, resolve it as if we were
;; under /root. ;; under /root.
@ -201,6 +206,8 @@ the new root."
(resolve (string-append "/root" target))) (resolve (string-append "/root" target)))
file))) file)))
(define MS_RDONLY 1)
(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")
@ -236,12 +243,36 @@ the new root."
(if root (if root
(catch #t (catch #t
(lambda () (lambda ()
(mount root "/root" "ext3")) (if volatile-root?
(begin
;; XXX: For lack of a union file system...
(mkdir-p "/real-root")
(mount root "/real-root" "ext3" MS_RDONLY)
(mount "none" "/root" "tmpfs")
;; XXX: 'copy-recursively' cannot deal with device nodes, so
;; explicitly avoid /dev.
(for-each (lambda (file)
(unless (string=? "dev" file)
(copy-recursively (string-append "/real-root/"
file)
(string-append "/root/"
file)
#:log (%make-void-port
"w"))))
(scandir "/real-root"
(lambda (file)
(not (member file '("." ".."))))))
;; TODO: Unmount /real-root.
)
(mount root "/root" "ext3")))
(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)))
(mount "none" "/root" "tmpfs")) (mount "none" "/root" "tmpfs"))
(mount-essential-file-systems #:root "/root") (mount-essential-file-systems #:root "/root")
(unless (file-exists? "/root/dev") (unless (file-exists? "/root/dev")