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