From 1b89a66e1badbb8a597db0529e468f9950119a30 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 5 Sep 2013 00:45:53 +0200
Subject: 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'.
---
 gnu/system/vm.scm | 61 ++++++++++++++++++++++++++++++++++---------------------
 1 file changed, 38 insertions(+), 23 deletions(-)

(limited to 'gnu/system')

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)))))
 
-- 
cgit v1.2.3