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?.

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