From unknown Tue Jun 17 01:35:59 2025 X-Loop: help-debbugs@gnu.org Subject: [bug#45979] system: vm: Introduce system-qemu-image/script. Resent-From: Mathieu Othacehe Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 19 Jan 2021 13:17:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 45979 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: To: 45979@debbugs.gnu.org X-Debbugs-Original-To: guix-patches@gnu.org Received: via spool by submit@debbugs.gnu.org id=B.16110622136826 (code B ref -1); Tue, 19 Jan 2021 13:17:02 +0000 Received: (at submit) by debbugs.gnu.org; 19 Jan 2021 13:16:53 +0000 Received: from localhost ([127.0.0.1]:49701 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1l1qsL-0001ly-Qd for submit@debbugs.gnu.org; Tue, 19 Jan 2021 08:16:53 -0500 Received: from lists.gnu.org ([209.51.188.17]:58466) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1l1qsG-0001ll-UM for submit@debbugs.gnu.org; Tue, 19 Jan 2021 08:16:48 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:48220) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1l1qsG-0006qY-OY for guix-patches@gnu.org; Tue, 19 Jan 2021 08:16:44 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]:51487) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1l1qsF-0008DK-Vu for guix-patches@gnu.org; Tue, 19 Jan 2021 08:16:44 -0500 Received: from [2a01:e0a:19b:d9a0:1538:87ab:3a95:7600] (port=38274 helo=cervin) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1l1qsF-0003BD-Da for guix-patches@gnu.org; Tue, 19 Jan 2021 08:16:43 -0500 From: Mathieu Othacehe Date: Tue, 19 Jan 2021 14:16:42 +0100 Message-ID: <87a6t5xe11.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.1 (gnu/linux) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Spam-Score: -2.3 (--) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) --=-=-= Content-Type: text/plain Hello, Here's a patch turning system-qemu-image/shared-store-script into system-qemu-image/script so that it can be used for system test requiring a read-write store. Thanks, Mathieu --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-system-vm-Introduce-system-qemu-image-script.patch >From 3f1aff7d391453adbbe4a693ae20f4e0f2d5fcf6 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 19 Jan 2021 13:57:52 +0100 Subject: [PATCH] system: vm: Introduce system-qemu-image/script. Some system tests may require to run a virtual machine with a freestanding store, that can be written to. This is not possible when using the host store as a read-only mount. Add a "shared-store?" field to the record, so that it can be lowered to a virtual machine running a freestanding Guix System image. * gnu/system/vm.scm (system-qemu-image/shared-store-script): Rename to ... (system-qemu-image/script): ... this new procedure. Add a "shared-store?" argument and honor it. ()[shared-store?]: New field. (virtual-machine-compiler): Honor it. * guix/scripts/system.scm (system-derivation-for-action): Adapt accordingly. * gnu/tests/base.scm (%test-basic-os): Adapt comment. --- gnu/system/vm.scm | 112 ++++++++++++++++++++++++---------------- gnu/tests/base.scm | 2 +- guix/scripts/system.scm | 14 ++--- 3 files changed, 75 insertions(+), 53 deletions(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 1afae6b4ed..945b9d1378 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -52,8 +52,10 @@ #:use-module (gnu packages linux) #:use-module (gnu packages admin) + #:use-module (gnu image) #:use-module (gnu bootloader) #:use-module (gnu bootloader grub) + #:use-module (gnu system image) #:use-module (gnu system shadow) #:use-module (gnu system pam) #:use-module (gnu system linux-container) @@ -65,7 +67,7 @@ #: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) @@ -76,7 +78,7 @@ system-qemu-image system-qemu-image/shared-store - system-qemu-image/shared-store-script + system-qemu-image/script system-docker-image virtual-machine @@ -772,22 +774,25 @@ with '-virtfs' options for the host file systems listed in SHARED-FS." (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly" #$image))) -(define* (system-qemu-image/shared-store-script os - #:key - (system (%current-system)) - (target (%current-target-system)) - (qemu qemu) - (graphic? #t) - (memory-size 256) - (mappings '()) - full-boot? - (disk-image-size - (* (if full-boot? 500 70) - (expt 2 20))) - (options '())) +(define* (system-qemu-image/script os + #:key + (system (%current-system)) + (target (%current-target-system)) + (qemu qemu) + (graphic? #t) + (shared-store? #t) + (memory-size 256) + (mappings '()) + (full-boot? + (not shared-store?)) + (disk-image-size + (* (if full-boot? 500 70) + (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. +OS that shares its store with the host or uses a freestanding Guix System +image is SHARED-STORE? is false. The virtual machine runs with MEMORY-SIZE +MiB of memory. MAPPINGS is a list of specifying mapping of host file systems into the guest. @@ -796,13 +801,22 @@ 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 - #:full-boot? full-boot? - #:disk-image-size disk-image-size))) + (mlet* %store-monad + ((os -> (virtualized-operating-system os mappings full-boot?)) + (image (if shared-store? + (system-qemu-image/shared-store + os + #:system system + #:target target + #:full-boot? full-boot? + #:disk-image-size disk-image-size) + (lower-object + (system-image + (image + (inherit (os->image os #:type qcow2-image-type)) + (size disk-image-size))) + system + #:target target)))) (define kernel-arguments #~(list #$@(if graphic? #~() #~("console=ttyS0")) #+@(operating-system-kernel-arguments os "/dev/vda1"))) @@ -818,7 +832,9 @@ it is mostly useful when FULL-BOOT? is true." (string-join #$kernel-arguments " ")))) #$@(common-qemu-options image (map file-system-mapping-source - (cons %store-mapping mappings))) + (if shared-store? + (cons %store-mapping mappings) + mappings))) "-m " (number->string #$memory-size) #$@options)) @@ -845,6 +861,8 @@ it is mostly useful when FULL-BOOT? is true." (default qemu)) (graphic? virtual-machine-graphic? ;Boolean (default #f)) + (shared-store? virtual-machine-shared-store? ;Boolean + (default #t)) (memory-size virtual-machine-memory-size ;integer (MiB) (default 256)) (disk-image-size virtual-machine-disk-image-size ;integer (bytes) @@ -876,29 +894,33 @@ FORWARDINGS is a list of host-port/guest-port pairs." (define-gexp-compiler (virtual-machine-compiler (vm ) system target) (match vm - (($ os qemu graphic? memory-size disk-image-size ()) - (system-qemu-image/shared-store-script os - #:system system - #:target target - #:qemu qemu - #:graphic? graphic? - #:memory-size memory-size - #:disk-image-size - disk-image-size)) - (($ os qemu graphic? memory-size disk-image-size - forwardings) + (($ os qemu graphic? shared-store? memory-size + disk-image-size ()) + (system-qemu-image/script os + #:system system + #:target target + + #:qemu qemu + #:graphic? graphic? + #:shared-store? shared-store? + #:memory-size memory-size + #:disk-image-size + disk-image-size)) + (($ os qemu graphic? shared-store? memory-size + disk-image-size forwardings) (let ((options `("-nic" ,(string-append "user,model=virtio-net-pci," (port-forwardings->qemu-options forwardings))))) - (system-qemu-image/shared-store-script os - #:system system - #:target target - #:qemu qemu - #:graphic? graphic? - #:memory-size memory-size - #:disk-image-size - disk-image-size - #:options options))))) + (system-qemu-image/script os + #:system system + #:target target + #:qemu qemu + #:graphic? graphic? + #:shared-store? shared-store? + #:memory-size memory-size + #:disk-image-size + disk-image-size + #:options options))))) ;;; vm.scm ends here diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index e5f9b87b1d..16163bc1f3 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -524,7 +524,7 @@ functionality tests.") (vm (virtual-machine os))) ;; XXX: Add call to 'virtualized-operating-system' to get the exact same ;; set of services as the OS produced by - ;; 'system-qemu-image/shared-store-script'. + ;; 'system-qemu-image/script'. (run-basic-test (virtualized-operating-system os '()) #~(list #$vm)))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index eb7137b7a9..f805db7a72 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -698,13 +698,13 @@ checking this by themselves in their 'check' procedure." ((vm-image) (system-qemu-image os #:disk-image-size image-size)) ((vm) - (system-qemu-image/shared-store-script os - #:full-boot? full-boot? - #:disk-image-size - (if full-boot? - image-size - (* 70 (expt 2 20))) - #:mappings mappings)) + (system-qemu-image/script os + #:full-boot? full-boot? + #:disk-image-size + (if full-boot? + image-size + (* 70 (expt 2 20))) + #:mappings mappings)) ((disk-image) (let* ((base-image (os->image os #:type image-type)) (base-target (image-target base-image))) -- 2.29.2 --=-=-=-- From unknown Tue Jun 17 01:35:59 2025 X-Loop: help-debbugs@gnu.org Subject: [bug#45979] system: vm: Introduce system-qemu-image/script. Resent-From: Mathieu Othacehe Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 19 Jan 2021 15:14:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 45979 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: To: 45979@debbugs.gnu.org Received: via spool by 45979-submit@debbugs.gnu.org id=B45979.16110692406165 (code B ref 45979); Tue, 19 Jan 2021 15:14:02 +0000 Received: (at 45979) by debbugs.gnu.org; 19 Jan 2021 15:14:00 +0000 Received: from localhost ([127.0.0.1]:51274 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1l1shk-0001bM-4c for submit@debbugs.gnu.org; Tue, 19 Jan 2021 10:14:00 -0500 Received: from eggs.gnu.org ([209.51.188.92]:33036) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1l1shj-0001b6-CJ for 45979@debbugs.gnu.org; Tue, 19 Jan 2021 10:13:59 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]:53720) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1l1she-0001nC-7O for 45979@debbugs.gnu.org; Tue, 19 Jan 2021 10:13:54 -0500 Received: from [2a01:e0a:19b:d9a0:1538:87ab:3a95:7600] (port=40334 helo=cervin) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1l1shd-0005e7-FM for 45979@debbugs.gnu.org; Tue, 19 Jan 2021 10:13:53 -0500 From: Mathieu Othacehe References: <87a6t5xe11.fsf@gnu.org> Date: Tue, 19 Jan 2021 16:13:51 +0100 In-Reply-To: <87a6t5xe11.fsf@gnu.org> (Mathieu Othacehe's message of "Tue, 19 Jan 2021 14:16:42 +0100") Message-ID: <8735yxx8ls.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.1 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain X-Spam-Score: -2.3 (--) X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) > Here's a patch turning system-qemu-image/shared-store-script into > system-qemu-image/script so that it can be used for system test > requiring a read-write store. While this achieves the desired effect, producing big freestanding images is quite inconvenient for the tests. In wonder if it could be possible to overlay the store 9p mount and keep using VM with shared store. Mathieu From unknown Tue Jun 17 01:35:59 2025 MIME-Version: 1.0 X-Mailer: MIME-tools 5.505 (Entity 5.505) X-Loop: help-debbugs@gnu.org From: help-debbugs@gnu.org (GNU bug Tracking System) To: Mathieu Othacehe Subject: bug#45979: closed (Re: bug#45979: system: vm: Introduce system-qemu-image/script.) Message-ID: References: <87y2ea9r3g.fsf_-_@gnu.org> <87a6t5xe11.fsf@gnu.org> X-Gnu-PR-Message: they-closed 45979 X-Gnu-PR-Package: guix-patches Reply-To: 45979@debbugs.gnu.org Date: Fri, 26 Mar 2021 09:56:02 +0000 Content-Type: multipart/mixed; boundary="----------=_1616752562-2391-1" This is a multi-part message in MIME format... ------------=_1616752562-2391-1 Content-Disposition: inline Content-Transfer-Encoding: quoted-printable Content-Type: text/plain; charset="utf-8" Your bug report #45979: system: vm: Introduce system-qemu-image/script. which was filed against the guix-patches package, has been closed. The explanation is attached below, along with your original report. If you require more details, please reply to 45979@debbugs.gnu.org. --=20 45979: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=3D45979 GNU Bug Tracking System Contact help-debbugs@gnu.org with problems ------------=_1616752562-2391-1 Content-Type: message/rfc822 Content-Disposition: inline Content-Transfer-Encoding: 7bit Received: (at 45979-done) by debbugs.gnu.org; 26 Mar 2021 09:55:43 +0000 Received: from localhost ([127.0.0.1]:40491 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lPjBv-0000bx-FS for submit@debbugs.gnu.org; Fri, 26 Mar 2021 05:55:43 -0400 Received: from eggs.gnu.org ([209.51.188.92]:59392) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lPjBu-0000bl-Hv for 45979-done@debbugs.gnu.org; Fri, 26 Mar 2021 05:55:43 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:50831) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lPjBn-0002MR-SZ for 45979-done@debbugs.gnu.org; Fri, 26 Mar 2021 05:55:37 -0400 Received: from [2a01:cb18:832e:5f00:6ddb:76f4:5f3e:7dde] (port=45224 helo=mathieu-HP-EliteBook-840-G1) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1lPjBk-0000Nz-Nf for 45979-done@debbugs.gnu.org; Fri, 26 Mar 2021 05:55:33 -0400 From: Mathieu Othacehe To: 45979-done@debbugs.gnu.org Subject: Re: bug#45979: system: vm: Introduce system-qemu-image/script. References: <87a6t5xe11.fsf@gnu.org> <8735yxx8ls.fsf@gnu.org> Date: Fri, 26 Mar 2021 10:55:31 +0100 In-Reply-To: <8735yxx8ls.fsf@gnu.org> (Mathieu Othacehe's message of "Tue, 19 Jan 2021 16:13:51 +0100") Message-ID: <87y2ea9r3g.fsf_-_@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.1 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain X-Spam-Score: -0.7 (/) X-Debbugs-Envelope-To: 45979-done X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.7 (-) Hello, > While this achieves the desired effect, producing big freestanding > images is quite inconvenient for the tests. In wonder if it could be > possible to overlay the store 9p mount and keep using VM with shared > store. I don't have any need for that patch right now, so closing. Thanks, Mathieu ------------=_1616752562-2391-1 Content-Type: message/rfc822 Content-Disposition: inline Content-Transfer-Encoding: 7bit Received: (at submit) by debbugs.gnu.org; 19 Jan 2021 13:16:53 +0000 Received: from localhost ([127.0.0.1]:49701 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1l1qsL-0001ly-Qd for submit@debbugs.gnu.org; Tue, 19 Jan 2021 08:16:53 -0500 Received: from lists.gnu.org ([209.51.188.17]:58466) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1l1qsG-0001ll-UM for submit@debbugs.gnu.org; Tue, 19 Jan 2021 08:16:48 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:48220) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1l1qsG-0006qY-OY for guix-patches@gnu.org; Tue, 19 Jan 2021 08:16:44 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]:51487) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1l1qsF-0008DK-Vu for guix-patches@gnu.org; Tue, 19 Jan 2021 08:16:44 -0500 Received: from [2a01:e0a:19b:d9a0:1538:87ab:3a95:7600] (port=38274 helo=cervin) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1l1qsF-0003BD-Da for guix-patches@gnu.org; Tue, 19 Jan 2021 08:16:43 -0500 From: Mathieu Othacehe To: guix-patches@gnu.org Subject: system: vm: Introduce system-qemu-image/script. Date: Tue, 19 Jan 2021 14:16:42 +0100 Message-ID: <87a6t5xe11.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/27.1 (gnu/linux) MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: submit X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) --=-=-= Content-Type: text/plain Hello, Here's a patch turning system-qemu-image/shared-store-script into system-qemu-image/script so that it can be used for system test requiring a read-write store. Thanks, Mathieu --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=0001-system-vm-Introduce-system-qemu-image-script.patch >From 3f1aff7d391453adbbe4a693ae20f4e0f2d5fcf6 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 19 Jan 2021 13:57:52 +0100 Subject: [PATCH] system: vm: Introduce system-qemu-image/script. Some system tests may require to run a virtual machine with a freestanding store, that can be written to. This is not possible when using the host store as a read-only mount. Add a "shared-store?" field to the record, so that it can be lowered to a virtual machine running a freestanding Guix System image. * gnu/system/vm.scm (system-qemu-image/shared-store-script): Rename to ... (system-qemu-image/script): ... this new procedure. Add a "shared-store?" argument and honor it. ()[shared-store?]: New field. (virtual-machine-compiler): Honor it. * guix/scripts/system.scm (system-derivation-for-action): Adapt accordingly. * gnu/tests/base.scm (%test-basic-os): Adapt comment. --- gnu/system/vm.scm | 112 ++++++++++++++++++++++++---------------- gnu/tests/base.scm | 2 +- guix/scripts/system.scm | 14 ++--- 3 files changed, 75 insertions(+), 53 deletions(-) diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 1afae6b4ed..945b9d1378 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -52,8 +52,10 @@ #:use-module (gnu packages linux) #:use-module (gnu packages admin) + #:use-module (gnu image) #:use-module (gnu bootloader) #:use-module (gnu bootloader grub) + #:use-module (gnu system image) #:use-module (gnu system shadow) #:use-module (gnu system pam) #:use-module (gnu system linux-container) @@ -65,7 +67,7 @@ #: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) @@ -76,7 +78,7 @@ system-qemu-image system-qemu-image/shared-store - system-qemu-image/shared-store-script + system-qemu-image/script system-docker-image virtual-machine @@ -772,22 +774,25 @@ with '-virtfs' options for the host file systems listed in SHARED-FS." (format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly" #$image))) -(define* (system-qemu-image/shared-store-script os - #:key - (system (%current-system)) - (target (%current-target-system)) - (qemu qemu) - (graphic? #t) - (memory-size 256) - (mappings '()) - full-boot? - (disk-image-size - (* (if full-boot? 500 70) - (expt 2 20))) - (options '())) +(define* (system-qemu-image/script os + #:key + (system (%current-system)) + (target (%current-target-system)) + (qemu qemu) + (graphic? #t) + (shared-store? #t) + (memory-size 256) + (mappings '()) + (full-boot? + (not shared-store?)) + (disk-image-size + (* (if full-boot? 500 70) + (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. +OS that shares its store with the host or uses a freestanding Guix System +image is SHARED-STORE? is false. The virtual machine runs with MEMORY-SIZE +MiB of memory. MAPPINGS is a list of specifying mapping of host file systems into the guest. @@ -796,13 +801,22 @@ 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 - #:full-boot? full-boot? - #:disk-image-size disk-image-size))) + (mlet* %store-monad + ((os -> (virtualized-operating-system os mappings full-boot?)) + (image (if shared-store? + (system-qemu-image/shared-store + os + #:system system + #:target target + #:full-boot? full-boot? + #:disk-image-size disk-image-size) + (lower-object + (system-image + (image + (inherit (os->image os #:type qcow2-image-type)) + (size disk-image-size))) + system + #:target target)))) (define kernel-arguments #~(list #$@(if graphic? #~() #~("console=ttyS0")) #+@(operating-system-kernel-arguments os "/dev/vda1"))) @@ -818,7 +832,9 @@ it is mostly useful when FULL-BOOT? is true." (string-join #$kernel-arguments " ")))) #$@(common-qemu-options image (map file-system-mapping-source - (cons %store-mapping mappings))) + (if shared-store? + (cons %store-mapping mappings) + mappings))) "-m " (number->string #$memory-size) #$@options)) @@ -845,6 +861,8 @@ it is mostly useful when FULL-BOOT? is true." (default qemu)) (graphic? virtual-machine-graphic? ;Boolean (default #f)) + (shared-store? virtual-machine-shared-store? ;Boolean + (default #t)) (memory-size virtual-machine-memory-size ;integer (MiB) (default 256)) (disk-image-size virtual-machine-disk-image-size ;integer (bytes) @@ -876,29 +894,33 @@ FORWARDINGS is a list of host-port/guest-port pairs." (define-gexp-compiler (virtual-machine-compiler (vm ) system target) (match vm - (($ os qemu graphic? memory-size disk-image-size ()) - (system-qemu-image/shared-store-script os - #:system system - #:target target - #:qemu qemu - #:graphic? graphic? - #:memory-size memory-size - #:disk-image-size - disk-image-size)) - (($ os qemu graphic? memory-size disk-image-size - forwardings) + (($ os qemu graphic? shared-store? memory-size + disk-image-size ()) + (system-qemu-image/script os + #:system system + #:target target + + #:qemu qemu + #:graphic? graphic? + #:shared-store? shared-store? + #:memory-size memory-size + #:disk-image-size + disk-image-size)) + (($ os qemu graphic? shared-store? memory-size + disk-image-size forwardings) (let ((options `("-nic" ,(string-append "user,model=virtio-net-pci," (port-forwardings->qemu-options forwardings))))) - (system-qemu-image/shared-store-script os - #:system system - #:target target - #:qemu qemu - #:graphic? graphic? - #:memory-size memory-size - #:disk-image-size - disk-image-size - #:options options))))) + (system-qemu-image/script os + #:system system + #:target target + #:qemu qemu + #:graphic? graphic? + #:shared-store? shared-store? + #:memory-size memory-size + #:disk-image-size + disk-image-size + #:options options))))) ;;; vm.scm ends here diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index e5f9b87b1d..16163bc1f3 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -524,7 +524,7 @@ functionality tests.") (vm (virtual-machine os))) ;; XXX: Add call to 'virtualized-operating-system' to get the exact same ;; set of services as the OS produced by - ;; 'system-qemu-image/shared-store-script'. + ;; 'system-qemu-image/script'. (run-basic-test (virtualized-operating-system os '()) #~(list #$vm)))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index eb7137b7a9..f805db7a72 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -698,13 +698,13 @@ checking this by themselves in their 'check' procedure." ((vm-image) (system-qemu-image os #:disk-image-size image-size)) ((vm) - (system-qemu-image/shared-store-script os - #:full-boot? full-boot? - #:disk-image-size - (if full-boot? - image-size - (* 70 (expt 2 20))) - #:mappings mappings)) + (system-qemu-image/script os + #:full-boot? full-boot? + #:disk-image-size + (if full-boot? + image-size + (* 70 (expt 2 20))) + #:mappings mappings)) ((disk-image) (let* ((base-image (os->image os #:type image-type)) (base-target (image-target base-image))) -- 2.29.2 --=-=-=-- ------------=_1616752562-2391-1--