gnu: vm: First stab at building a populated QEMU image.

* gnu/packages/linux-initrd.scm (gnu-system-initrd): New variable.
* gnu/system/vm.scm (qemu-image): Add #:linux-arguments parameter.
  [input->name+derivation]: Add case for 'store-path?' items.
  Remove LOADER from `inputs'.

2 files changed, 104 insertions, 23 deletions

diff --git a/gnu/packages/linux-initrd.scm b/gnu/packages/linux-initrd.scm
index ab8787f02c..6dd2a10e53 100644
--- a/gnu/packages/linux-initrd.scm
+++ b/gnu/packages/linux-initrd.scm
@@ -332,4 +332,70 @@ the Linux kernel.")
    #:linux linux-libre
    #:linux-modules '("cifs.ko" "md4.ko" "ecb.ko")))
 
+(define-public 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.
+        (unless (file-exists? "/root")
+          (mkdir "/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")
+
+        ;; 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~%")
+              (sleep 2)
+              (reboot))
+            (begin
+              (display "no init file passed via '--exec'\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))
+
 ;;; linux-initrd.scm ends here
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 596a697738..86430ea168 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -21,7 +21,11 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix packages)
-  #:use-module ((gnu packages base) #:select (%final-inputs guile-final))
+  #:use-module ((gnu packages base) #:select (%final-inputs
+                                              guile-final
+                                              coreutils))
+  #:use-module (gnu packages guile)
+  #:use-module (gnu packages bash)
   #:use-module (gnu packages qemu)
   #:use-module (gnu packages parted)
   #:use-module (gnu packages grub)
@@ -30,7 +34,7 @@
   #:use-module ((gnu packages make-bootstrap)
                 #:select (%guile-static-stripped))
   #:use-module ((gnu packages system)
-                #:select (shadow))
+                #:select (mingetty))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
@@ -177,11 +181,14 @@ made available under the /xchg CIFS share."
                      (system (%current-system))
                      (disk-image-size (* 100 (expt 2 20)))
                      (linux linux-libre)
+                     (linux-arguments '())
                      (initrd qemu-initrd)
                      (inputs '())
                      (inputs-to-copy '())
                      (boot-expression #f))
-  "Return a bootable, stand-alone QEMU image.
+  "Return a bootable, stand-alone QEMU image.  The returned image is a full
+disk image, with a GRUB installation whose default entry boots LINUX, with the
+arguments LINUX-ARGUMENTS, and using INITRD as its initial RAM disk.
 
 INPUTS-TO-COPY is a list of inputs (as for packages) whose closure is copied
 into the image being built.
@@ -197,13 +204,9 @@ process."
      ((name (? package? package) sub-drv)
       `(,name . ,(derivation-path->output-path
                   (package-derivation store package system)
-                  sub-drv)))))
-
-  (define loader
-    (and boot-expression
-         (add-text-to-store store "loader"
-                            (object->string boot-expression)
-                            '())))
+                  sub-drv)))
+     ((input (and (? string?) (? store-path?) file))
+      `(,input . ,file))))
 
   (expression->derivation-in-linux-vm
    store "qemu-image"
@@ -299,12 +302,10 @@ set timeout=5
 search.file /boot/bzImage
 
 menuentry \"Boot-to-Guile! (GNU System technology preview)\" {
-  linux /boot/bzImage --root=/dev/vda1 ~a
+  linux /boot/bzImage ~a
   initrd /boot/initrd
 }"
-                                  ,(if loader
-                                       (string-append "--load=" loader)
-                                       ""))))
+                                  ,(string-join linux-arguments))))
                       (and (zero?
                             (system* grub "--no-floppy"
                                      "--boot-directory" "/fs/boot"
@@ -319,10 +320,6 @@ menuentry \"Boot-to-Guile! (GNU System technology preview)\" {
               ("linux" ,linux-libre)
               ("initrd" ,initrd)
 
-              ,@(if loader
-                    `(("loader" ,loader))
-                    '())
-
               ;; For shell scripts.
               ("sed" ,(car (assoc-ref %final-inputs "sed")))
               ("grep" ,(car (assoc-ref %final-inputs "grep")))
@@ -367,13 +364,31 @@ menuentry \"Boot-to-Guile! (GNU System technology preview)\" {
         (set! store (open-connection)))
       (lambda ()
         (parameterize ((%guile-for-build (package-derivation store guile-final)))
-          (let* ((drv   (package-derivation store shadow))
-                 (login (string-append (derivation-path->output-path drv)
-                                       "/bin/login")))
+          (let* ((out   (derivation-path->output-path
+                         (package-derivation store mingetty)))
+                 (getty (string-append out "/sbin/mingetty"))
+                 (boot  (add-text-to-store store "boot"
+                                           (object->string
+                                            `(begin
+                                               ;; Become the session leader,
+                                               ;; so that mingetty can do
+                                               ;; 'TIOCSCTTY'.
+                                               (setsid)
+
+                                               ;; Directly into mingetty.
+                                               (execl ,getty "mingetty"
+                                                      "--noclear" "tty1")))
+                                           (list out))))
            (qemu-image store
-                       #:boot-expression `(execl ,login "login" "tty1")
+                       #:initrd gnu-system-initrd
+                       #:linux-arguments `("--root=/dev/vda1"
+                                           ,(string-append "--load=" boot))
                        #:disk-image-size (* 400 (expt 2 20))
-                       #:inputs-to-copy `(("shadow" ,shadow))))))
+                       #:inputs-to-copy `(("boot" ,boot)
+                                          ("coreutils" ,coreutils)
+                                          ("bash" ,bash)
+                                          ("guile" ,guile-2.0)
+                                          ("mingetty" ,mingetty))))))
       (lambda ()
         (close-connection store)))))