guix system: Add '--share' and '--expose' options for 'vm'.

* guix/scripts/system.scm (system-derivation-for-action): Add #:mappings
  parameter.  Pass it to 'system-qemu-image/shared-store-script'.
  (perform-action): Likewise.
  (show-help): Document --share and --expose.
  (specification->file-system-mapping): New procedure.
  (%options): Add --share and --expose.
  (guix-system): Pass #:mapping to 'perform-action'.
* doc/guix.texi (Invoking guix system): Document it.
This commit is contained in:
Ludovic Courtès 2014-11-21 00:02:26 +01:00
parent fcf63cf880
commit 0276f697b3
2 changed files with 56 additions and 4 deletions

View file

@ -4375,12 +4375,27 @@ This command also installs GRUB on the device specified in
@item vm
@cindex virtual machine
@cindex VM
Build a virtual machine that contain the operating system declared in
@var{file}, and return a script to run that virtual machine (VM).
Arguments given to the script are passed as is to QEMU.
The VM shares its store with the host system.
Additional file systems can be shared between the host and the VM using
the @code{--share} and @code{--expose} command-line options: the former
specifies a directory to be shared with write access, while the latter
provides read-only access to the shared directory.
The example below creates a VM in which the user's home directory is
accessible read-only, and where the @file{/exchange} directory is a
read-write mapping of the host's @file{$HOME/tmp}:
@example
guix system vm my-config.scm \
--expose=$HOME --share=$HOME/tmp=/exchange
@end example
On GNU/Linux, the default is to boot directly to the kernel; this has
the advantage of requiring only a very tiny root disk image since the
host's store can then be mounted.

View file

@ -264,7 +264,7 @@ (define (system->grub-entry system number time)
;;;
(define* (system-derivation-for-action os action
#:key image-size full-boot?)
#:key image-size full-boot? mappings)
"Return as a monadic value the derivation for OS according to ACTION."
(case action
((build init reconfigure)
@ -274,7 +274,8 @@ (define* (system-derivation-for-action os action
((vm)
(system-qemu-image/shared-store-script os
#:full-boot? full-boot?
#:disk-image-size image-size))
#:disk-image-size image-size
#:mappings mappings))
((disk-image)
(system-disk-image os #:disk-image-size image-size))))
@ -298,7 +299,8 @@ (define* (maybe-build drvs
(define* (perform-action action os
#:key grub? dry-run?
use-substitutes? device target
image-size full-boot?)
image-size full-boot?
(mappings '()))
"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'
@ -307,7 +309,8 @@ (define* (perform-action action os
(mlet* %store-monad
((sys (system-derivation-for-action os action
#:image-size image-size
#:full-boot? full-boot?))
#:full-boot? full-boot?
#:mappings mappings))
(grub (package->derivation grub))
(grub.cfg (grub.cfg os))
(drvs -> (if (and grub? (memq action '(init reconfigure)))
@ -379,6 +382,10 @@ (define (show-help)
--image-size=SIZE for 'vm-image', produce an image of SIZE"))
(display (_ "
--no-grub for 'init', do not install GRUB"))
(display (_ "
--share=SPEC for 'vm', share host file system according to SPEC"))
(display (_ "
--expose=SPEC for 'vm', expose host file system according to SPEC"))
(display (_ "
--full-boot for 'vm', make a full boot sequence"))
(newline)
@ -389,6 +396,19 @@ (define (show-help)
(newline)
(show-bug-report-information))
(define (specification->file-system-mapping spec writable?)
"Read the SPEC and return the corresponding <file-system-mapping>."
(let ((index (string-index spec #\=)))
(if index
(file-system-mapping
(source (substring spec 0 index))
(target (substring spec (+ 1 index)))
(writable? writable?))
(file-system-mapping
(source spec)
(target spec)
(writable? writable?)))))
(define %options
;; Specifications of the command-line options.
(cons* (option '(#\h "help") #f #f
@ -408,6 +428,18 @@ (define %options
(option '("full-boot") #f #f
(lambda (opt name arg result)
(alist-cons 'full-boot? #t result)))
(option '("share") #t #f
(lambda (opt name arg result)
(alist-cons 'file-system-mapping
(specification->file-system-mapping arg #t)
result)))
(option '("expose") #t #f
(lambda (opt name arg result)
(alist-cons 'file-system-mapping
(specification->file-system-mapping arg #f)
result)))
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
(alist-cons 'dry-run? #t result)))
@ -502,6 +534,11 @@ (define (fail)
#:use-substitutes? (assoc-ref opts 'substitutes?)
#:image-size (assoc-ref opts 'image-size)
#:full-boot? (assoc-ref opts 'full-boot?)
#:mappings (filter-map (match-lambda
(('file-system-mapping . m)
m)
(_ #f))
opts)
#:grub? grub?
#:target target #:device device)
#:system system))))