diff options
| -rw-r--r-- | gnu/system/vm.scm | 93 |
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)))) |