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

1 files changed, 120 insertions, 1 deletions

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