From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp2 ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms11 with LMTPS id CGTjLfjbBmDZHAAA0tVLHw (envelope-from ) for ; Tue, 19 Jan 2021 13:17:44 +0000 Received: from aspmx1.migadu.com ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp2 with LMTPS id +PfHKfjbBmCGaQAAB5/wlQ (envelope-from ) for ; Tue, 19 Jan 2021 13:17:44 +0000 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 3B4AB9404E4 for ; Tue, 19 Jan 2021 13:17:43 +0000 (UTC) Received: from localhost ([::1]:36226 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1l1qtC-0006v6-63 for larch@yhetil.org; Tue, 19 Jan 2021 08:17:42 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]:48276) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1l1qsY-0006tR-JA for guix-patches@gnu.org; Tue, 19 Jan 2021 08:17:02 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:38155) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1l1qsY-0008HW-BC for guix-patches@gnu.org; Tue, 19 Jan 2021 08:17:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1l1qsY-0001mZ-68 for guix-patches@gnu.org; Tue, 19 Jan 2021 08:17:02 -0500 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-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+larch=yhetil.org@gnu.org Sender: "Guix-patches" X-Migadu-Flow: FLOW_IN X-Migadu-Spam-Score: -2.85 Authentication-Results: aspmx1.migadu.com; dkim=none; dmarc=pass (policy=none) header.from=gnu.org; spf=pass (aspmx1.migadu.com: domain of guix-patches-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=guix-patches-bounces@gnu.org X-Migadu-Queue-Id: 3B4AB9404E4 X-Spam-Score: -2.85 X-Migadu-Scanner: scn1.migadu.com X-TUID: xIMcU3vDDHbk --=-=-= 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 --=-=-=--