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

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 0276f697b3dbab417dcad7ff32dfb4b9fb330ec4
Author: Ludovic Courtès <address@hidden>
Date:   Fri Nov 21 00:02:26 2014 +0100

    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.
---
 doc/guix.texi           |   15 +++++++++++++++
 guix/scripts/system.scm |   45 +++++++++++++++++++++++++++++++++++++++++----
 2 files changed, 56 insertions(+), 4 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 730b6a3..5697900 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4375,12 +4375,27 @@ This command also installs GRUB on the device specified 
in
 
 @item vm
 @cindex virtual machine
address@hidden 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}:
+
address@hidden
+guix system vm my-config.scm \
+   --expose=$HOME --share=$HOME/tmp=/exchange
address@hidden 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.
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 92364fd..398a5a3 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -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)))
@@ -380,6 +383,10 @@ Build the operating system declared in FILE according to 
ACTION.\n"))
   (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)
   (display (_ "
@@ -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))))