From ab11f0bed4084f19698752fa5451ea73a52400f9 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 7 Nov 2014 22:43:33 +0100
Subject: vm: Support 'guix system vm --full-boot'.

* gnu/system/vm.scm (system-qemu-image/shared-store-script): Add
  #:full-boot? parameter and honor it.
* guix/scripts/system.scm (system-derivation-for-action): Likewise.
  (perform-action): Likewise.
  (show-help): Document '--full-boot'.
  (%options): Add '--full-boot'.
  (guix-system): Add #:full-boot? argument in call to 'perform-action'.
* doc/guix.texi (Invoking guix system): Document it.
---
 doc/guix.texi           |  4 ++++
 gnu/system/vm.scm       | 27 ++++++++++++++++-----------
 guix/scripts/system.scm | 18 +++++++++++++-----
 3 files changed, 33 insertions(+), 16 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 7927ca0b00..2da956cc73 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4151,6 +4151,10 @@ Build a virtual machine that contain the operating system declared in
 
 The VM shares its store with the host system.
 
+On GNU/Linux, the default is to boot directly to the kernel.  The
+@code{--full-boot} option forces a complete boot sequence, starting with
+the bootloader.
+
 @item vm-image
 @itemx disk-image
 Return a virtual machine or disk image of the operating system declared
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index dc5b1bafd4..c687bb43f5 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -402,13 +402,15 @@ (define* (common-qemu-options image)
   ",if=virtio,cache=writeback,werror=report,readonly \
   -m 256\n"))
 
-(define* (system-qemu-image/shared-store-script
-          os
-          #:key
-          (qemu qemu)
-          (graphic? #t))
+(define* (system-qemu-image/shared-store-script os
+                                                #:key
+                                                (qemu qemu)
+                                                (graphic? #t)
+                                                full-boot?)
   "Return a derivation that builds a script to run a virtual machine image of
-OS that shares its store with the host."
+OS that shares its store with the host.  When FULL-BOOT? is true, the returned
+script runs everything starting from the bootloader; otherwise it directly
+starts the operating system kernel."
   (mlet* %store-monad
       ((os ->  (virtualized-operating-system os))
        (os-drv (operating-system-derivation os))
@@ -419,11 +421,14 @@ (define builder
             (display
              (string-append "#!" #$bash "/bin/sh
 exec " #$qemu "/bin/" #$(qemu-command (%current-system))
-" -kernel " #$(operating-system-kernel os) "/bzImage \
-  -initrd " #$os-drv "/initrd \
-  -append \"" #$(if graphic? "" "console=ttyS0 ")
-  "--system=" #$os-drv " --load=" #$os-drv "/boot --root=/dev/vda1\" "
-  #$(common-qemu-options image))
+
+#$@(if full-boot?
+       #~()
+       #~(" -kernel " #$(operating-system-kernel os) "/bzImage \
+            -initrd " #$os-drv "/initrd \
+            -append \"" #$(if graphic? "" "console=ttyS0 ")
+            "--system=" #$os-drv " --load=" #$os-drv "/boot --root=/dev/vda1\" "))
+#$(common-qemu-options image))
              port)
             (chmod port #o555))))
 
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 056c8e6d30..7eb86c293d 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -250,7 +250,7 @@ (define (system->grub-entry system)
 ;;;
 
 (define* (system-derivation-for-action os action
-                                       #:key image-size)
+                                       #:key image-size full-boot?)
   "Return as a monadic value the derivation for OS according to ACTION."
   (case action
     ((build init reconfigure)
@@ -258,7 +258,7 @@ (define* (system-derivation-for-action os action
     ((vm-image)
      (system-qemu-image os #:disk-image-size image-size))
     ((vm)
-     (system-qemu-image/shared-store-script os))
+     (system-qemu-image/shared-store-script os #:full-boot? full-boot?))
     ((disk-image)
      (system-disk-image os #:disk-image-size image-size))))
 
@@ -282,14 +282,16 @@ (define* (maybe-build drvs
 (define* (perform-action action os
                          #:key grub? dry-run?
                          use-substitutes? device target
-                         image-size)
+                         image-size full-boot?)
   "Perform ACTION for OS.  GRUB? specifies whether to install GRUB; DEVICE is
 the target devices for GRUB; TARGET is the target root directory; IMAGE-SIZE
 is the size of the image to be built, for the 'vm-image' and 'disk-image'
-actions."
+actions.  FULL-BOOT? is used for the 'vm' action; it determines whether to
+boot directly to the kernel or to the bootloader."
   (mlet* %store-monad
       ((sys       (system-derivation-for-action os action
-                                                #:image-size image-size))
+                                                #:image-size image-size
+                                                #:full-boot? full-boot?))
        (grub      (package->derivation grub))
        (grub.cfg  (grub.cfg os))
        (drvs   -> (if (and grub? (memq action '(init reconfigure)))
@@ -361,6 +363,8 @@ (define (show-help)
       --image-size=SIZE  for 'vm-image', produce an image of SIZE"))
   (display (_ "
       --no-grub          for 'init', do not install GRUB"))
+  (display (_ "
+      --full-boot        for 'vm', make a full boot sequence"))
   (newline)
   (display (_ "
   -h, --help             display this help and exit"))
@@ -385,6 +389,9 @@ (define %options
          (option '("no-grub") #f #f
                  (lambda (opt name arg result)
                    (alist-delete 'install-grub? result)))
+         (option '("full-boot") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'full-boot? #t result)))
          (option '(#\n "dry-run") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'dry-run? #t result)))
@@ -478,6 +485,7 @@ (define (fail)
                         #:dry-run? dry?
                         #:use-substitutes? (assoc-ref opts 'substitutes?)
                         #:image-size (assoc-ref opts 'image-size)
+                        #:full-boot? (assoc-ref opts 'full-boot?)
                         #:grub? grub?
                         #:target target #:device device)
         #:system system))))
-- 
cgit v1.2.3