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.
This commit is contained in:
Ludovic Courtès 2014-11-07 22:43:33 +01:00
parent c1941588dd
commit ab11f0bed4
3 changed files with 33 additions and 16 deletions

View file

@ -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

View file

@ -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
(define* (system-qemu-image/shared-store-script os
#:key
(qemu qemu)
(graphic? #t))
(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 \
#$@(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))
"--system=" #$os-drv " --load=" #$os-drv "/boot --root=/dev/vda1\" "))
#$(common-qemu-options image))
port)
(chmod port #o555))))

View file

@ -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))))