ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

vm: Introduce 'file-system-mapping'.

Browse source 
* 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'.
This commit is contained in:
Ludovic Courtès 2014-11-20 23:32:54 +01:00
parent 96ffa27ba4
commit fcf63cf880
1 changed files with 67 additions and 24 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

83
gnu/system/vm.scm
View file

@ -23,6 +23,8 @@ (define-module (gnu system vm)
#: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 @@ (define-module (gnu system vm)
#: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 @@ (define file-systems-to-keep
("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 @@ (define (file-system->mount-tag fs)
(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."
(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")
(options "trans=virtio")
(check? #f)))
(flags (if writable? '() '(read-only)))
(options (string-append "trans=virtio"))
(check? #f)
(create-mount-point? #t)))))
(define (virtualized-operating-system os)
(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 @@ (define (virtualized-operating-system os)
(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 @@ (define* (system-qemu-image/shared-store-script os
#:key
(qemu qemu)
(graphic? #t)
(mappings '())
full-boot?
(disk-image-size
(* (if full-boot? 500 15)
@ -449,11 +487,14 @@ (define* (system-qemu-image/shared-store-script os
"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 @@ (define builder
-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))))