From: "Ludovic Courtès" <ludo@gnu.org>
To: 27751@debbugs.gnu.org
Subject: [bug#27751] [PATCH 1/2] vm: Add a <virtual-machine> type and associated gexp compiler.
Date: Tue, 18 Jul 2017 11:02:16 +0200 [thread overview]
Message-ID: <20170718090217.21822-1-ludo@gnu.org> (raw)
In-Reply-To: <20170718085807.21546-1-ludo@gnu.org>
* 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.
---
gnu/system/vm.scm | 70 ++++++++++++++++++++++++++++++++++++++++++++++++++++---
1 file changed, 67 insertions(+), 3 deletions(-)
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 028649f80..ec3fb031a 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?))
\f
;;; Commentary:
@@ -576,7 +579,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.
@@ -609,7 +613,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
@@ -621,4 +626,63 @@ it is mostly useful when FULL-BOOT? is true."
(gexp->derivation "run-vm.sh" builder)))
+\f
+;;;
+;;; 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
--
2.13.2
next prev parent reply other threads:[~2017-07-18 9:03 UTC|newest]
Thread overview: 4+ messages / expand[flat|nested] mbox.gz Atom feed top
2017-07-18 8:58 [bug#27751] [PATCH 0/2] Simplify VM handling in system tests Ludovic Courtès
2017-07-18 9:02 ` Ludovic Courtès [this message]
2017-07-18 9:02 ` [bug#27751] [PATCH 2/2] tests: Use 'virtual-machine' records instead of monadic procedures Ludovic Courtès
2017-07-20 9:57 ` bug#27751: [PATCH 0/2] Simplify VM handling in system tests Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20170718090217.21822-1-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=27751@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).