me/guix
Archived
1
0
Fork 0
Code Activity

vm: Add a <virtual-machine> type and associated gexp compiler.

Browse source 
* gnu/system/vm.scm (system-qemu-image/shared-store-script): Add
 #:options parameter and honor it.
(<virtual-machine>): New record type.
(virtual-machine): New macro.
(port-forwardings->qemu-options, virtual-machine-compiler): New
procedures.
This commit is contained in:
Ludovic Courtès 2017-07-18 10:36:21 +02:00
parent c97cef0a91
commit ed419fa0c5
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 67 additions and 3 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

70
gnu/system/vm.scm
View file

@ -68,7 +68,10 @@
system-qemu-image/shared-store
system-qemu-image/shared-store-script
system-disk-image))
system-disk-image
virtual-machine
virtual-machine?))
;;; Commentary:
@ -581,7 +584,8 @@ with '-virtfs' options for the host file systems listed in SHARED-FS."
full-boot?
(disk-image-size
(* (if full-boot? 500 70)
(expt 2 20))))
(expt 2 20)))
(options '()))
"Return a derivation that builds a script to run a virtual machine image of
OS that shares its store with the host. The virtual machine runs with
MEMORY-SIZE MiB of memory.
@ -614,7 +618,8 @@ it is mostly useful when FULL-BOOT? is true."
#$@(common-qemu-options image
(map file-system-mapping-source
(cons %store-mapping mappings)))
"-m " (number->string #$memory-size)))
"-m " (number->string #$memory-size)
#$@options))
(define builder
#~(call-with-output-file #$output
@ -626,4 +631,63 @@ it is mostly useful when FULL-BOOT? is true."
(gexp->derivation "run-vm.sh" builder)))
;;;
;;; High-level abstraction.
;;;
(define-record-type* <virtual-machine> %virtual-machine
make-virtual-machine
virtual-machine?
(operating-system virtual-machine-operating-system) ;<operating-system>
(qemu virtual-machine-qemu ;<package>
(default qemu))
(graphic? virtual-machine-graphic? ;Boolean
(default #f))
(memory-size virtual-machine-memory-size ;integer (MiB)
(default 256))
(port-forwardings virtual-machine-port-forwardings ;list of integer pairs
(default '())))
(define-syntax virtual-machine
(syntax-rules ()
"Declare a virtual machine running the specified OS, with the given
options."
((_ os) ;shortcut
(%virtual-machine (operating-system os)))
((_ fields ...)
(%virtual-machine fields ...))))
(define (port-forwardings->qemu-options forwardings)
"Return the QEMU option for the given port FORWARDINGS as a string, where
FORWARDINGS is a list of host-port/guest-port pairs."
(string-join
(map (match-lambda
((host-port . guest-port)
(string-append "hostfwd=tcp::"
(number->string host-port)
"-:" (number->string guest-port))))
forwardings)
","))
(define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
system target)
;; XXX: SYSTEM and TARGET are ignored.
(match vm
(($ <virtual-machine> os qemu graphic? memory-size ())
(system-qemu-image/shared-store-script os
#:qemu qemu
#:graphic? graphic?
#:memory-size memory-size))
(($ <virtual-machine> os qemu graphic? memory-size forwardings)
(let ((options
`("-net" ,(string-append
"user,"
(port-forwardings->qemu-options forwardings)))))
(system-qemu-image/shared-store-script os
#:qemu qemu
#:graphic? graphic?
#:memory-size memory-size
#:options options)))))
;;; vm.scm ends here