vm: Introduce 'file-system-mapping'.

* gnu/system/vm.scm (<file-system-mapping>): New record type.
  (%store-mapping): New variable.
  (host-9p-file-system): Rename to...
  (mapping->file-system): ... this.  Replace 'source' and 'target'
  parameters with 'mapping'.  Set 'flags' field.
  (virtualized-operating-system): Add 'mappings' parameter and  honor
  it.
  (system-qemu-image/shared-store-script): Add 'mappings' parameter.
  Pass it to 'virtualized-operating-system'.  Use it in argument to
  'common-qemu-options'.

1 files changed, 68 insertions, 25 deletions

diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 328168f4f4..07b13deeca 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -23,6 +23,8 @@
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix monads)
+  #:use-module (guix records)
+
   #:use-module ((gnu build vm)
                 #:select (qemu-command))
   #:use-module (gnu packages base)
@@ -55,6 +57,13 @@
   #:export (expression->derivation-in-linux-vm
             qemu-image
             system-qemu-image
+
+            file-system-mapping
+            file-system-mapping?
+            file-system-mapping-source
+            file-system-mapping-target
+            file-system-mapping-writable?
+
             system-qemu-image/shared-store
             system-qemu-image/shared-store-script
             system-disk-image))
@@ -338,6 +347,27 @@ of the GNU system as described by OS."
                               ("grub.cfg" ,grub.cfg))
                    #:copy-inputs? #t))))
 
+
+;;;
+;;; VMs that share file systems with the host.
+;;;
+
+;; Mapping of host file system SOURCE to mount point TARGET in the guest.
+(define-record-type* <file-system-mapping> file-system-mapping
+  make-file-system-mapping
+  file-system-mapping?
+  (source    file-system-mapping-source)          ;string
+  (target    file-system-mapping-target)          ;string
+  (writable? file-system-mapping-writable?        ;Boolean
+             (default #f)))
+
+(define %store-mapping
+  ;; Mapping of the host's store into the guest.
+  (file-system-mapping
+   (source (%store-prefix))
+   (target (%store-prefix))
+   (writable? #f)))
+
 (define (file-system->mount-tag fs)
   "Return a 9p mount tag for host file system FS."
   ;; QEMU mount tags cannot contain slashes and cannot start with '_'.
@@ -348,19 +378,34 @@ of the GNU system as described by OS."
                               (chr chr))
                              fs)))
 
-(define (host-9p-file-system source target)
-  "Return a <file-system> to mount the host's SOURCE file system as TARGET in
-the guest, using a 9p virtfs."
-  (file-system
-    (mount-point target)
-    (device (file-system->mount-tag source))
-    (type "9p")
-    (options "trans=virtio")
-    (check? #f)))
-
-(define (virtualized-operating-system os)
+(define (mapping->file-system mapping)
+  "Return a 9p file system that realizes MAPPING."
+  (match mapping
+    (($ <file-system-mapping> source target writable?)
+     (file-system
+       (mount-point target)
+       (device (file-system->mount-tag source))
+       (type "9p")
+       (flags (if writable? '() '(read-only)))
+       (options (string-append "trans=virtio"))
+       (check? #f)
+       (create-mount-point? #t)))))
+
+(define (virtualized-operating-system os mappings)
   "Return an operating system based on OS suitable for use in a virtualized
-environment with the store shared with the host."
+environment with the store shared with the host.  MAPPINGS is a list of
+<file-system-mapping> to realize in the virtualized OS."
+  (define user-file-systems
+    ;; Remove file systems that conflict with those added below, or that are
+    ;; normally bound to real devices.
+    (remove (lambda (fs)
+              (let ((target (file-system-mount-point fs))
+                    (source (file-system-device fs)))
+                (or (string=? target (%store-prefix))
+                    (string=? target "/")
+                    (string-prefix? "/dev/" source))))
+            (operating-system-file-systems os)))
+
   (operating-system (inherit os)
     (initrd (lambda (file-systems . rest)
               (apply base-initrd file-systems
@@ -378,19 +423,11 @@ environment with the store shared with the host."
                            (type "ext4"))
 
                          (file-system (inherit
-                                       (host-9p-file-system (%store-prefix)
-                                                            (%store-prefix)))
+                                       (mapping->file-system %store-mapping))
                             (needed-for-boot? #t))
 
-                         ;; Remove file systems that conflict with those
-                         ;; above, or that are normally bound to real devices.
-                         (remove (lambda (fs)
-                                   (let ((target (file-system-mount-point fs))
-                                         (source (file-system-device fs)))
-                                     (or (string=? target (%store-prefix))
-                                         (string=? target "/")
-                                         (string-prefix? "/dev/" source))))
-                                 (operating-system-file-systems os))))))
+                         (append (map mapping->file-system mappings)
+                                 user-file-systems)))))
 
 (define* (system-qemu-image/shared-store
           os
@@ -442,6 +479,7 @@ with '-virtfs' options for the host file systems listed in SHARED-FS."
                                                 #:key
                                                 (qemu qemu)
                                                 (graphic? #t)
+                                                (mappings '())
                                                 full-boot?
                                                 (disk-image-size
                                                  (* (if full-boot? 500 15)
@@ -449,11 +487,14 @@ with '-virtfs' options for the host file systems listed in SHARED-FS."
   "Return a derivation that builds a script to run a virtual machine image of
 OS that shares its store with the host.
 
+MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
+systems into the guest.
+
 When FULL-BOOT? is true, the returned script runs everything starting from the
 bootloader; otherwise it directly starts the operating system kernel.  The
 DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image;
 it is mostly useful when FULL-BOOT?  is true."
-  (mlet* %store-monad ((os ->  (virtualized-operating-system os))
+  (mlet* %store-monad ((os ->  (virtualized-operating-system os mappings))
                        (os-drv (operating-system-derivation os))
                        (image  (system-qemu-image/shared-store
                                 os
@@ -472,7 +513,9 @@ exec " #$qemu "/bin/" #$(qemu-command (%current-system))
             -initrd " #$os-drv "/initrd \
             -append \"" #$(if graphic? "" "console=ttyS0 ")
             "--system=" #$os-drv " --load=" #$os-drv "/boot --root=/dev/vda1\" "))
-#$(common-qemu-options image (list (%store-prefix)))
+#$(common-qemu-options image
+                       (map file-system-mapping-source
+                            (cons %store-mapping mappings)))
 " \"$@\"\n")
              port)
             (chmod port #o555))))