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
parent
fcf63cf880
commit
0276f697b3
2 changed files with 56 additions and 4 deletions
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -264,7 +264,7 @@ it atomically, and then run OS's activation script."
|
|||
;;;
|
||||
|
||||
(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 @@ it atomically, and then run OS's activation script."
|
|||
((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 @@ true."
|
|||
(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 @@ boot directly to the kernel or to the bootloader."
|
|||
(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 @@ Build the operating system declared in FILE according to ACTION.\n"))
|
|||
--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 @@ Build the operating system declared in FILE according to ACTION.\n"))
|
|||
(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 @@ Build the operating system declared in FILE according to ACTION.\n"))
|
|||
(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 @@ Build the operating system declared in FILE according to ACTION.\n"))
|
|||
#: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))))
|
||||
|
|
|
|||
Reference in a new issue