aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-01-29 21:57:56 +0100
committerLudovic Courtès <ludo@gnu.org>2014-01-29 21:57:56 +0100
commitd4254711821f7df93e33aa4a3f6484b901c7b5e3 (patch)
treeef6ffc4e68b2673a0e0bc9a9a8cfeee42633628c
parent735c6dd7faec036adbfa44d927c823ffa9ea1243 (diff)
downloadguix-d4254711821f7df93e33aa4a3f6484b901c7b5e3.tar
guix-d4254711821f7df93e33aa4a3f6484b901c7b5e3.tar.gz
gnu: linux-initrd: Factorize boot code.
* guix/build/linux-initrd.scm (boot-system): New procedure. * gnu/system/linux-initrd.scm (qemu-initrd): Add keyword parameters 'guile-modules-in-chroot?' and 'mounts'. Change builder to simply call 'boot-system'. (gnu-system-initrd): Change to a simple call to 'qemu-initrd'. * gnu/system/vm.scm (expression->derivation-in-linux-vm): Call 'qemu-initrd' with #:guile-modules-in-chroot?.
-rw-r--r--gnu/system/linux-initrd.scm192
-rw-r--r--gnu/system/vm.scm4
-rw-r--r--guix/build/linux-initrd.scm121
3 files changed, 152 insertions, 165 deletions
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index a28b913c3e..ea9d708dac 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -19,6 +19,8 @@
(define-module (gnu system linux-initrd)
#:use-module (guix monads)
#:use-module (guix utils)
+ #:use-module ((guix store)
+ #:select (%store-prefix))
#:use-module (gnu packages cpio)
#:use-module (gnu packages compression)
#:use-module (gnu packages linux)
@@ -181,180 +183,46 @@ list of Guile module names to be embedded in the initrd."
#:modules '((guix build utils))
#:inputs inputs)))
-(define (qemu-initrd)
+(define* (qemu-initrd #:key
+ guile-modules-in-chroot?
+ (mounts `((cifs "/store" ,(%store-prefix))
+ (cifs "/xchg" "/xchg"))))
"Return a monadic derivation that builds an initrd for use in a QEMU guest
-where the store is shared with the host."
- (expression->initrd
- '(begin
- (use-modules (srfi srfi-1)
- (srfi srfi-26)
- (ice-9 match)
- ((system base compile) #:select (compile-file))
- (guix build utils)
- (guix build linux-initrd))
-
- (display "Welcome, this is GNU's early boot Guile.\n")
- (display "Use '--repl' for an initrd REPL.\n\n")
-
- (mount-essential-file-systems)
- (let* ((args (linux-command-line))
- (option (lambda (opt)
- (let ((opt (string-append opt "=")))
- (and=> (find (cut string-prefix? opt <>)
- args)
- (lambda (arg)
- (substring arg (+ 1 (string-index arg #\=))))))))
- (to-load (option "--load"))
- (root (option "--root")))
-
- (when (member "--repl" args)
- ((@ (system repl repl) start-repl)))
-
- (display "loading CIFS and companion modules...\n")
- (for-each (compose load-linux-module*
- (cut string-append "/modules/" <>))
- (list "md4.ko" "ecb.ko" "cifs.ko"))
-
- (unless (configure-qemu-networking)
- (display "network interface is DOWN\n"))
+where the store is shared with the host. MOUNTS is a list of file systems to
+be mounted atop the root file system, where each item has the form:
- ;; Make /dev nodes.
- (make-essential-device-nodes)
+ (FILE-SYSTEM-TYPE SOURCE TARGET)
- ;; Prepare the real root file system under /root.
- (unless (file-exists? "/root")
- (mkdir "/root"))
- (if root
- (mount root "/root" "ext3")
- (mount "none" "/root" "tmpfs"))
- (mount-essential-file-systems #:root "/root")
+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
+access to these modules (which is the case if it wants to even just print an
+exception and backtrace!)."
+ (define cifs-modules
+ ;; Modules needed to mount CIFS file systems.
+ '("md4.ko" "ecb.ko" "cifs.ko"))
- (mkdir-p "/root/xchg")
- (mkdir-p "/root/nix/store")
+ (define linux-modules
+ ;; Modules added to the initrd and loaded from the initrd.
+ (if (assoc-ref mounts 'cifs)
+ cifs-modules
+ '()))
- (unless (file-exists? "/root/dev")
- (mkdir "/root/dev")
- (make-essential-device-nodes #:root "/root"))
-
- ;; Mount the host's store and exchange directory.
- (mount-qemu-smb-share "/store" "/root/nix/store")
- (mount-qemu-smb-share "/xchg" "/root/xchg")
-
- ;; Copy the directories that contain .scm and .go files so that the
- ;; child process in the chroot can load modules (we would bind-mount
- ;; them but for some reason that fails with EINVAL -- XXX).
- (mkdir-p "/root/share")
- (mkdir-p "/root/lib")
- (mount "none" "/root/share" "tmpfs")
- (mount "none" "/root/lib" "tmpfs")
- (copy-recursively "/share" "/root/share"
- #:log (%make-void-port "w"))
- (copy-recursively "/lib" "/root/lib"
- #:log (%make-void-port "w"))
-
-
- (if to-load
- (letrec ((resolve
- (lambda (file)
- ;; If FILE is a symlink to an absolute file name,
- ;; resolve it as if we were under /root.
- (let ((st (lstat file)))
- (if (eq? 'symlink (stat:type st))
- (let ((target (readlink file)))
- (resolve (string-append "/root" target)))
- file)))))
- (format #t "loading boot file '~a'...\n" to-load)
- (compile-file (resolve (string-append "/root/" to-load))
- #:output-file "/root/loader.go"
- #:opts %auto-compilation-options)
- (match (primitive-fork)
- (0
- (chroot "/root")
- (load-compiled "/loader.go")
+ (expression->initrd
+ `(begin
+ (use-modules (guix build linux-initrd))
- ;; TODO: Remove /lib, /share, and /loader.go.
- )
- (pid
- (format #t "boot file loaded under PID ~a~%" pid)
- (let ((status (waitpid pid)))
- (reboot)))))
- (begin
- (display "no boot file passed via '--load'\n")
- (display "entering a warm and cozy REPL\n")
- ((@ (system repl repl) start-repl))))))
+ (boot-system #:mounts ',mounts
+ #:linux-modules ',linux-modules
+ #:qemu-guest-networking? #t
+ #:guile-modules-in-chroot? ',guile-modules-in-chroot?))
#:name "qemu-initrd"
#:modules '((guix build utils)
(guix build linux-initrd))
#:linux linux-libre
- #:linux-modules '("cifs.ko" "md4.ko" "ecb.ko")))
+ #:linux-modules linux-modules))
(define (gnu-system-initrd)
"Initrd for the GNU system itself, with nothing QEMU-specific."
- (expression->initrd
- '(begin
- (use-modules (srfi srfi-1)
- (srfi srfi-26)
- (ice-9 match)
- (guix build utils)
- (guix build linux-initrd))
-
- (display "Welcome, this is GNU's early boot Guile.\n")
- (display "Use '--repl' for an initrd REPL.\n\n")
-
- (mount-essential-file-systems)
- (let* ((args (linux-command-line))
- (option (lambda (opt)
- (let ((opt (string-append opt "=")))
- (and=> (find (cut string-prefix? opt <>)
- args)
- (lambda (arg)
- (substring arg (+ 1 (string-index arg #\=))))))))
- (to-load (option "--load"))
- (root (option "--root")))
-
- (when (member "--repl" args)
- ((@ (system repl repl) start-repl)))
-
- ;; Make /dev nodes.
- (make-essential-device-nodes)
-
- ;; Prepare the real root file system under /root.
- (mkdir-p "/root")
- (if root
- ;; Assume ROOT has a usable /dev tree.
- (mount root "/root" "ext3")
- (begin
- (mount "none" "/root" "tmpfs")
- (make-essential-device-nodes #:root "/root")))
-
- (mount-essential-file-systems #:root "/root")
-
- (mkdir-p "/root/tmp")
- (mount "none" "/root/tmp" "tmpfs")
-
- ;; XXX: We don't copy our fellow Guile modules to /root (see
- ;; 'qemu-initrd'), so if TO-LOAD tries to load a module (which can
- ;; happen if it throws, to display the exception!), then we're
- ;; screwed. Hopefully TO-LOAD is a simple expression that just does
- ;; '(execlp ...)'.
-
- (if to-load
- (begin
- (format #t "loading '~a'...\n" to-load)
- (chroot "/root")
- (primitive-load to-load)
- (format (current-error-port)
- "boot program '~a' terminated, rebooting~%"
- to-load)
- (sleep 2)
- (reboot))
- (begin
- (display "no init file passed via '--load'\n")
- (display "entering a warm and cozy REPL\n")
- ((@ (system repl repl) start-repl))))))
- #:name "qemu-system-initrd"
- #:modules '((guix build linux-initrd)
- (guix build utils))
- #:linux linux-libre))
+ (qemu-initrd #:guile-modules-in-chroot? #f))
;;; linux-initrd.scm ends here
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index fa93654144..151535303a 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -178,9 +178,9 @@ made available under the /xchg CIFS share."
(user-builder (text-file "builder-in-linux-vm"
(object->string exp*)))
(coreutils -> (car (assoc-ref %final-inputs "coreutils")))
- (initrd (if initrd
+ (initrd (if initrd ; use the default initrd?
(return initrd)
- (qemu-initrd))) ; default initrd
+ (qemu-initrd #:guile-modules-in-chroot? #t)))
(inputs (lower-inputs `(("qemu" ,qemu)
("linux" ,linux)
("initrd" ,initrd)
diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm
index ae18a16e11..039a60acf3 100644
--- a/guix/build/linux-initrd.scm
+++ b/guix/build/linux-initrd.scm
@@ -19,6 +19,12 @@
(define-module (guix build linux-initrd)
#:use-module (rnrs io ports)
#:use-module (system foreign)
+ #:autoload (system repl repl) (start-repl)
+ #:autoload (system base compile) (compile-file)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+ #:use-module (guix build utils)
#:export (mount-essential-file-systems
linux-command-line
make-essential-device-nodes
@@ -26,7 +32,8 @@
mount-qemu-smb-share
bind-mount
load-linux-module*
- device-number))
+ device-number
+ boot-system))
;;; Commentary:
;;;
@@ -151,4 +158,116 @@ Vanilla QEMU's `-smb' option just exports a /qemu share, whereas our
the last argument of `mknod'."
(+ (* major 256) minor))
+(define* (boot-system #:key
+ (linux-modules '())
+ qemu-guest-networking?
+ guile-modules-in-chroot?
+ (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
+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'.
+
+MOUNTS must be a list of elements of the form:
+
+ (FILE-SYSTEM-TYPE SOURCE TARGET)
+
+When GUILE-MODULES-IN-CHROOT? is true, make core Guile modules available in
+the new root."
+ (define (resolve file)
+ ;; If FILE is a symlink to an absolute file name, resolve it as if we were
+ ;; under /root.
+ (let ((st (lstat file)))
+ (if (eq? 'symlink (stat:type st))
+ (let ((target (readlink file)))
+ (resolve (string-append "/root" target)))
+ file)))
+
+ (display "Welcome, this is GNU's early boot Guile.\n")
+ (display "Use '--repl' for an initrd REPL.\n\n")
+
+ (mount-essential-file-systems)
+ (let* ((args (linux-command-line))
+ (option (lambda (opt)
+ (let ((opt (string-append opt "=")))
+ (and=> (find (cut string-prefix? opt <>)
+ args)
+ (lambda (arg)
+ (substring arg (+ 1 (string-index arg #\=))))))))
+ (to-load (option "--load"))
+ (root (option "--root")))
+
+ (when (member "--repl" args)
+ (start-repl))
+
+ (display "loading kernel modules...\n")
+ (for-each (compose load-linux-module*
+ (cut string-append "/modules/" <>))
+ linux-modules)
+
+ (when qemu-guest-networking?
+ (unless (configure-qemu-networking)
+ (display "network interface is DOWN\n")))
+
+ ;; Make /dev nodes.
+ (make-essential-device-nodes)
+
+ ;; Prepare the real root file system under /root.
+ (unless (file-exists? "/root")
+ (mkdir "/root"))
+ (if root
+ (mount root "/root" "ext3")
+ (mount "none" "/root" "tmpfs"))
+ (mount-essential-file-systems #:root "/root")
+
+ (unless (file-exists? "/root/dev")
+ (mkdir "/root/dev")
+ (make-essential-device-nodes #:root "/root"))
+
+ ;; Mount the specified file systems.
+ (for-each (match-lambda
+ (('cifs source target)
+ (let ((target (string-append "/root/" target)))
+ (mkdir-p target)
+ (mount-qemu-smb-share source target)))
+ ;; TODO: Add 9p.
+ )
+ mounts)
+
+ (when guile-modules-in-chroot?
+ ;; Copy the directories that contain .scm and .go files so that the
+ ;; child process in the chroot can load modules (we would bind-mount
+ ;; them but for some reason that fails with EINVAL -- XXX).
+ (mkdir-p "/root/share")
+ (mkdir-p "/root/lib")
+ (mount "none" "/root/share" "tmpfs")
+ (mount "none" "/root/lib" "tmpfs")
+ (copy-recursively "/share" "/root/share"
+ #:log (%make-void-port "w"))
+ (copy-recursively "/lib" "/root/lib"
+ #:log (%make-void-port "w")))
+
+ (if to-load
+ (begin
+ (format #t "loading '~a'...\n" to-load)
+ (chroot "/root")
+ ;; TODO: Remove /lib, /share, and /loader.go.
+ (catch #t
+ (lambda ()
+ (primitive-load to-load))
+ (lambda args
+ (format (current-error-port) "'~a' raised an exception: ~s~%"
+ to-load args)
+ (start-repl)))
+ (format (current-error-port)
+ "boot program '~a' terminated, rebooting~%"
+ to-load)
+ (sleep 2)
+ (reboot))
+ (begin
+ (display "no boot file passed via '--load'\n")
+ (display "entering a warm and cozy REPL\n")
+ (start-repl)))))
+
;;; linux-initrd.scm ends here