From patchwork Thu Dec 16 13:06:44 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Mathieu Othacehe X-Patchwork-Id: 35274 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 1078527BBEA; Thu, 16 Dec 2021 13:09:55 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-3.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H2,SPF_HELO_PASS, URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 2CEF927BBE9 for ; Thu, 16 Dec 2021 13:09:51 +0000 (GMT) Received: from localhost ([::1]:52262 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1mxqW6-00073C-4f for patchwork@mira.cbaines.net; Thu, 16 Dec 2021 08:09:50 -0500 Received: from eggs.gnu.org ([209.51.188.92]:59946) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1mxqUO-0005ll-80 for guix-patches@gnu.org; Thu, 16 Dec 2021 08:08:05 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:51687) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1mxqUN-0004af-BL for guix-patches@gnu.org; Thu, 16 Dec 2021 08:08:03 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1mxqUN-0006fr-83 for guix-patches@gnu.org; Thu, 16 Dec 2021 08:08:03 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#52550] [PATCH 05/10] system: vm: Use the image API to generate QEMU images. Resent-From: Mathieu Othacehe Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 16 Dec 2021 13:08:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 52550 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 52550@debbugs.gnu.org Cc: Mathieu Othacehe Received: via spool by 52550-submit@debbugs.gnu.org id=B52550.163966003425502 (code B ref 52550); Thu, 16 Dec 2021 13:08:03 +0000 Received: (at 52550) by debbugs.gnu.org; 16 Dec 2021 13:07:14 +0000 Received: from localhost ([127.0.0.1]:34977 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mxqTZ-0006dC-2l for submit@debbugs.gnu.org; Thu, 16 Dec 2021 08:07:14 -0500 Received: from eggs.gnu.org ([209.51.188.92]:58772) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mxqTT-0006cA-Um for 52550@debbugs.gnu.org; Thu, 16 Dec 2021 08:07:08 -0500 Received: from [2001:470:142:3::e] (port=33788 helo=fencepost.gnu.org) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1mxqTO-0004Pl-My for 52550@debbugs.gnu.org; Thu, 16 Dec 2021 08:07:02 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=sSVgmgckXgmT0OqQAzKAVX9Wq1s6tjrGKEHIZfvaFrs=; b=Zgmb9ml4JnuHTVlawFNu di1WXqltOE/0GzS8Xx1BdmxX69cOtR1qWJFImbefl0l0OaNH8X9u0ORuOZ3cxQSfuWe3cjiurMqZc FlpoELpgpLkfMCbV9KaXzNFTsW+dIv8ld6pv0g/6znEsyWcddB/yxqVqGKyd4tom9XWMjpRrUDNdT vcHQnvf7GdM7k7gaUM8y5PVoLEBn7/b2jHTx/05IGHdQdKkQvkqKSjSQhPZkdkDolNfSpRmrXQ0Ek 9kxZ974yyqebBcE97Mmwh9B7libhdGjVwSjrdGInEhSe9SCxsuQX4Dg8i6mF9n7mrHnimN6gIpFHR NOKZXt14dCWBGw==; Received: from [2a01:e0a:19b:d9a0:2f3b:16f2:b776:3ef9] (port=57550 helo=localhost.localdomain) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1mxqTM-0003iQ-OO; Thu, 16 Dec 2021 08:07:01 -0500 From: Mathieu Othacehe Date: Thu, 16 Dec 2021 14:06:44 +0100 Message-Id: <20211216130649.30285-5-othacehe@gnu.org> X-Mailer: git-send-email 2.34.0 In-Reply-To: <20211216130649.30285-1-othacehe@gnu.org> References: <20211216130649.30285-1-othacehe@gnu.org> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches Also add a volatile? argument to the virtual-machine record. When volatile? is true generate a QEMU script that mounts an overlay on top of a read only storage. When volatile? is false, use a persistent, read-write storage. * gnu/system/vm.scm (common-qemu-options): Add a rw-image? argument to use a persistent storage. (system-qemu-image/shared-store-script): Add a volatile? argument and honor it. Use the image API to build the QEMU image. ()[volatile?]: New field. (virtual-machine-compiler): Pass the volatile? argument to the system-qemu-image/shared-store-script procedure. --- gnu/system/vm.scm | 77 +++++++++++++++++++++++++++++++++-------------- 1 file changed, 54 insertions(+), 23 deletions(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 2487539b61..db5c4132c0 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -51,6 +51,8 @@ (define-module (gnu system vm) #:use-module (gnu bootloader) #:use-module (gnu bootloader grub) + #:use-module (gnu image) + #:use-module (gnu system image) #:use-module (gnu system linux-container) #:use-module (gnu system linux-initrd) #:use-module (gnu bootloader) @@ -60,7 +62,7 @@ (define-module (gnu system vm) #:use-module (gnu services base) #:use-module (gnu system uuid) - #:use-module (srfi srfi-1) + #:use-module ((srfi srfi-1) #:hide (partition)) #:use-module (srfi srfi-26) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) @@ -592,7 +594,8 @@ (define (mapping->file-system mapping) (check? #f) (create-mount-point? #t))))) -(define* (virtualized-operating-system os mappings #:optional (full-boot? #f)) +(define* (virtualized-operating-system os mappings + #:key (full-boot? #f) volatile?) "Return an operating system based on OS suitable for use in a virtualized environment with the store shared with the host. MAPPINGS is a list of to realize in the virtualized OS." @@ -635,7 +638,7 @@ (define virtual-file-systems (initrd (lambda (file-systems . rest) (apply (operating-system-initrd os) file-systems - #:volatile-root? #t + #:volatile-root? volatile? rest))) ;; Disable swap. @@ -692,7 +695,8 @@ (define bootcfg #:register-closures? #f #:copy-inputs? full-boot?)) -(define* (common-qemu-options image shared-fs) +(define* (common-qemu-options image shared-fs + #:key rw-image?) "Return the a string-value gexp with the common QEMU options to boot IMAGE, with '-virtfs' options for the host file systems listed in SHARED-FS." @@ -712,8 +716,10 @@ (define (virtfs-option fs) "-device" "virtio-rng-pci,rng=guix-vm-rng" #$@(map virtfs-option shared-fs) - (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly=on" - #$image))) + #$@(if rw-image? + #~((format #f "-drive file=~a,if=virtio" #$image)) + #~((format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly=on" + #$image))))) (define* (system-qemu-image/shared-store-script os #:key @@ -721,7 +727,8 @@ (define* (system-qemu-image/shared-store-script os (target (%current-target-system)) (qemu qemu) (graphic? #t) - (memory-size 256) + (volatile? #t) + (memory-size 2048) (mappings '()) full-boot? (disk-image-size @@ -736,20 +743,31 @@ (define* (system-qemu-image/shared-store-script os 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 mappings full-boot?)) - (image (system-qemu-image/shared-store - os - #:system system - #:target target +bootloader; otherwise it directly starts the operating system kernel. When +VOLATILE? is true, an overlay is created on top of a read-only +storage. Otherwise the storage is made persistent. 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 mappings #:full-boot? full-boot? - #:disk-image-size disk-image-size))) + #:volatile? volatile?)) + (base-image -> (system-image + (image + (inherit + (raw-with-offset-disk-image)) + (operating-system os) + (size disk-image-size) + (shared-store? + (and (not full-boot?) volatile?)) + (volatile-root? volatile?))))) (define kernel-arguments #~(list #$@(if graphic? #~() #~("console=ttyS0")) #+@(operating-system-kernel-arguments os "/dev/vda1"))) + (define rw-image + #~(format #f "/tmp/.~a-rw" (basename #$base-image))) + (define qemu-exec #~(list #+(file-append qemu "/bin/" (qemu-command (or target system))) @@ -761,17 +779,25 @@ (define qemu-exec "-initrd" #$(file-append os "/initrd") (format #f "-append ~s" (string-join #$kernel-arguments " ")))) - #$@(common-qemu-options image + #$@(common-qemu-options (if volatile? base-image rw-image) (map file-system-mapping-source - (cons %store-mapping mappings))) + (cons %store-mapping mappings)) + #:rw-image? (not volatile?)) "-m " (number->string #$memory-size) #$@options)) (define builder #~(call-with-output-file #$output (lambda (port) - (format port "#!~a~% exec ~a \"$@\"~%" - #+(file-append bash "/bin/sh") + (format port "#!~a~%" + #+(file-append bash "/bin/sh")) + (when (not #$volatile?) + (format port "~a~%" + #$(program-file "copy-image" + #~(unless (file-exists? #$rw-image) + (copy-file #$base-image #$rw-image) + (chmod #$rw-image #o640))))) + (format port "exec ~a \"$@\"~%" (string-join #$qemu-exec " ")) (chmod port #o555)))) @@ -788,6 +814,8 @@ (define-record-type* %virtual-machine (operating-system virtual-machine-operating-system) ; (qemu virtual-machine-qemu ; (default qemu-minimal)) + (volatile? virtual-machine-volatile? ;Boolean + (default #t)) (graphic? virtual-machine-graphic? ;Boolean (default #f)) (memory-size virtual-machine-memory-size ;integer (MiB) @@ -821,17 +849,19 @@ (define (port-forwardings->qemu-options forwardings) (define-gexp-compiler (virtual-machine-compiler (vm ) system target) (match vm - (($ os qemu graphic? memory-size disk-image-size ()) + (($ os qemu volatile? graphic? memory-size + disk-image-size ()) (system-qemu-image/shared-store-script os #:system system #:target target #:qemu qemu #:graphic? graphic? + #:volatile? volatile? #:memory-size memory-size #:disk-image-size disk-image-size)) - (($ os qemu graphic? memory-size disk-image-size - forwardings) + (($ os qemu volatile? graphic? memory-size + disk-image-size forwardings) (let ((options `("-nic" ,(string-append "user,model=virtio-net-pci," @@ -841,6 +871,7 @@ (define-gexp-compiler (virtual-machine-compiler (vm ) #:target target #:qemu qemu #:graphic? graphic? + #:volatile? volatile? #:memory-size memory-size #:disk-image-size disk-image-size