From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:48249) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1dXOPJ-00051J-EO for guix-patches@gnu.org; Tue, 18 Jul 2017 05:03:10 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1dXOPG-0005TH-8P for guix-patches@gnu.org; Tue, 18 Jul 2017 05:03:05 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:42659) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1dXOPG-0005TB-4d for guix-patches@gnu.org; Tue, 18 Jul 2017 05:03:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1dXOPF-0000cO-Ta for guix-patches@gnu.org; Tue, 18 Jul 2017 05:03:01 -0400 Subject: [bug#27751] [PATCH 1/2] vm: Add a type and associated gexp compiler. References: <20170718085807.21546-1-ludo@gnu.org> In-Reply-To: <20170718085807.21546-1-ludo@gnu.org> Resent-Message-ID: From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Tue, 18 Jul 2017 11:02:16 +0200 Message-Id: <20170718090217.21822-1-ludo@gnu.org> List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 27751@debbugs.gnu.org * gnu/system/vm.scm (system-qemu-image/shared-store-script): Add #:options parameter and honor it. (): 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?)) ;;; 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))) + +;;; +;;; High-level abstraction. +;;; + +(define-record-type* %virtual-machine + make-virtual-machine + virtual-machine? + (operating-system virtual-machine-operating-system) ; + (qemu virtual-machine-qemu ; + (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 ) + system target) + ;; XXX: SYSTEM and TARGET are ignored. + (match vm + (($ os qemu graphic? memory-size ()) + (system-qemu-image/shared-store-script os + #:qemu qemu + #:graphic? graphic? + #:memory-size memory-size)) + (($ 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