summaryrefslogtreecommitdiff
path: root/gnu/system
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2017-07-18 10:36:21 +0200
committerLudovic Courtès <ludo@gnu.org>2017-07-20 11:57:13 +0200
commited419fa0c56e6ff3aa8bd8e8f100a81442c51e6d (patch)
tree69dd465880414ab49e44a46ed6ecceeace034c6b /gnu/system
parentc97cef0a91abc960e871be30da2c5096f4f83dd1 (diff)
vm: Add a <virtual-machine> type and associated gexp compiler.
* 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.
Diffstat (limited to 'gnu/system')
-rw-r--r--gnu/system/vm.scm70
1 files changed, 67 insertions, 3 deletions
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 6f979aee43..90d29b0783 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -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