* [bug#45979] system: vm: Introduce system-qemu-image/script.
@ 2021-01-19 13:16 Mathieu Othacehe
2021-01-19 15:13 ` Mathieu Othacehe
0 siblings, 1 reply; 3+ messages in thread
From: Mathieu Othacehe @ 2021-01-19 13:16 UTC (permalink / raw)
To: 45979
[-- Attachment #1: Type: text/plain, Size: 187 bytes --]
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
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-system-vm-Introduce-system-qemu-image-script.patch --]
[-- Type: text/x-diff, Size: 11785 bytes --]
From 3f1aff7d391453adbbe4a693ae20f4e0f2d5fcf6 Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@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
^ permalink raw reply related [flat|nested] 3+ messages in thread
* [bug#45979] system: vm: Introduce system-qemu-image/script.
2021-01-19 13:16 [bug#45979] system: vm: Introduce system-qemu-image/script Mathieu Othacehe
@ 2021-01-19 15:13 ` Mathieu Othacehe
2021-03-26 9:55 ` bug#45979: " Mathieu Othacehe
0 siblings, 1 reply; 3+ messages in thread
From: Mathieu Othacehe @ 2021-01-19 15:13 UTC (permalink / raw)
To: 45979
> 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
^ permalink raw reply [flat|nested] 3+ messages in thread
* bug#45979: system: vm: Introduce system-qemu-image/script.
2021-01-19 15:13 ` Mathieu Othacehe
@ 2021-03-26 9:55 ` Mathieu Othacehe
0 siblings, 0 replies; 3+ messages in thread
From: Mathieu Othacehe @ 2021-03-26 9:55 UTC (permalink / raw)
To: 45979-done
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
^ permalink raw reply [flat|nested] 3+ messages in thread
end of thread, other threads:[~2021-03-26 9:56 UTC | newest]
Thread overview: 3+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-01-19 13:16 [bug#45979] system: vm: Introduce system-qemu-image/script Mathieu Othacehe
2021-01-19 15:13 ` Mathieu Othacehe
2021-03-26 9:55 ` bug#45979: " Mathieu Othacehe
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).