Package: guix-patches;
Reported by: Mathieu Othacehe <othacehe <at> gnu.org>
Date: Tue, 19 Jan 2021 13:17:02 UTC
Severity: normal
Done: Mathieu Othacehe <othacehe <at> gnu.org>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: help-debbugs <at> gnu.org (GNU bug Tracking System) To: Mathieu Othacehe <othacehe <at> gnu.org> Cc: tracker <at> debbugs.gnu.org Subject: bug#45979: closed (system: vm: Introduce system-qemu-image/script.) Date: Fri, 26 Mar 2021 09:56:02 +0000
[Message part 1 (text/plain, inline)]
Your message dated Fri, 26 Mar 2021 10:55:31 +0100 with message-id <87y2ea9r3g.fsf_-_ <at> gnu.org> and subject line Re: bug#45979: system: vm: Introduce system-qemu-image/script. has caused the debbugs.gnu.org bug report #45979, regarding system: vm: Introduce system-qemu-image/script. to be marked as done. (If you believe you have received this mail in error, please contact help-debbugs <at> gnu.org.) -- 45979: http://debbugs.gnu.org/cgi/bugreport.cgi?bug=45979 GNU Bug Tracking System Contact help-debbugs <at> gnu.org with problems
[Message part 2 (message/rfc822, inline)]
From: Mathieu Othacehe <othacehe <at> gnu.org> To: guix-patches <at> gnu.org Subject: system: vm: Introduce system-qemu-image/script. Date: Tue, 19 Jan 2021 14:16:42 +0100[Message part 3 (text/plain, inline)]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[0001-system-vm-Introduce-system-qemu-image-script.patch (text/x-diff, inline)]From 3f1aff7d391453adbbe4a693ae20f4e0f2d5fcf6 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe <othacehe <at> gnu.org> 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 <virtual-machine> 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. (<virtual-machine>)[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 <file-system-mapping> 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 <virtual-machine>) system target) (match vm - (($ <virtual-machine> 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)) - (($ <virtual-machine> os qemu graphic? memory-size disk-image-size - forwardings) + (($ <virtual-machine> 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)) + (($ <virtual-machine> 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
[Message part 5 (message/rfc822, inline)]
From: Mathieu Othacehe <othacehe <at> gnu.org> To: 45979-done <at> debbugs.gnu.org Subject: Re: bug#45979: system: vm: Introduce system-qemu-image/script. Date: Fri, 26 Mar 2021 10:55:31 +0100Hello, > 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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.