mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2025-01-11 05:39:41 -05:00
system: vm: Use the image API to generate QEMU images.
Also add a volatile? argument to the virtual-machine record. When volatile? is true generate a QEMU script that mounts an overlay on top of a read only storage. When volatile? is false, use a persistent, read-write storage. * gnu/system/vm.scm (common-qemu-options): Add a rw-image? argument to use a persistent storage. (system-qemu-image/shared-store-script): Add a volatile? argument and honor it. Use the image API to build the QEMU image. (<virtual-machine>)[volatile?]: New field. (virtual-machine-compiler): Pass the volatile? argument to the system-qemu-image/shared-store-script procedure.
This commit is contained in:
Mathieu Othacehe
parent
59912117d4
commit
da92479674
1 changed files with 54 additions and 23 deletions
|
|
@ -51,6 +51,8 @@ (define-module (gnu system vm)
|
|||
|
||||
#:use-module (gnu bootloader)
|
||||
#:use-module (gnu bootloader grub)
|
||||
#:use-module (gnu image)
|
||||
#:use-module (gnu system image)
|
||||
#:use-module (gnu system linux-container)
|
||||
#:use-module (gnu system linux-initrd)
|
||||
#:use-module (gnu bootloader)
|
||||
|
|
@ -60,7 +62,7 @@ (define-module (gnu system vm)
|
|||
#: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)
|
||||
|
|
@ -592,7 +594,8 @@ (define (mapping->file-system mapping)
|
|||
(check? #f)
|
||||
(create-mount-point? #t)))))
|
||||
|
||||
(define* (virtualized-operating-system os mappings #:optional (full-boot? #f))
|
||||
(define* (virtualized-operating-system os mappings
|
||||
#:key (full-boot? #f) volatile?)
|
||||
"Return an operating system based on OS suitable for use in a virtualized
|
||||
environment with the store shared with the host. MAPPINGS is a list of
|
||||
<file-system-mapping> to realize in the virtualized OS."
|
||||
|
|
@ -635,7 +638,7 @@ (define virtual-file-systems
|
|||
(initrd (lambda (file-systems . rest)
|
||||
(apply (operating-system-initrd os)
|
||||
file-systems
|
||||
#:volatile-root? #t
|
||||
#:volatile-root? volatile?
|
||||
rest)))
|
||||
|
||||
;; Disable swap.
|
||||
|
|
@ -692,7 +695,8 @@ (define bootcfg
|
|||
#:register-closures? #f
|
||||
#:copy-inputs? full-boot?))
|
||||
|
||||
(define* (common-qemu-options image shared-fs)
|
||||
(define* (common-qemu-options image shared-fs
|
||||
#:key rw-image?)
|
||||
"Return the a string-value gexp with the common QEMU options to boot IMAGE,
|
||||
with '-virtfs' options for the host file systems listed in SHARED-FS."
|
||||
|
||||
|
|
@ -712,8 +716,10 @@ (define (virtfs-option fs)
|
|||
"-device" "virtio-rng-pci,rng=guix-vm-rng"
|
||||
|
||||
#$@(map virtfs-option shared-fs)
|
||||
(format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly=on"
|
||||
#$image)))
|
||||
#$@(if rw-image?
|
||||
#~((format #f "-drive file=~a,if=virtio" #$image))
|
||||
#~((format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly=on"
|
||||
#$image)))))
|
||||
|
||||
(define* (system-qemu-image/shared-store-script os
|
||||
#:key
|
||||
|
|
@ -721,7 +727,8 @@ (define* (system-qemu-image/shared-store-script os
|
|||
(target (%current-target-system))
|
||||
(qemu qemu)
|
||||
(graphic? #t)
|
||||
(memory-size 256)
|
||||
(volatile? #t)
|
||||
(memory-size 2048)
|
||||
(mappings '())
|
||||
full-boot?
|
||||
(disk-image-size
|
||||
|
|
@ -736,20 +743,31 @@ (define* (system-qemu-image/shared-store-script os
|
|||
systems into the guest.
|
||||
|
||||
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
|
||||
bootloader; otherwise it directly starts the operating system kernel. When
|
||||
VOLATILE? is true, an overlay is created on top of a read-only
|
||||
storage. Otherwise the storage is made persistent. 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? full-boot?
|
||||
#:disk-image-size disk-image-size)))
|
||||
#:volatile? volatile?))
|
||||
(base-image -> (system-image
|
||||
(image
|
||||
(inherit
|
||||
(raw-with-offset-disk-image))
|
||||
(operating-system os)
|
||||
(size disk-image-size)
|
||||
(shared-store?
|
||||
(and (not full-boot?) volatile?))
|
||||
(volatile-root? volatile?)))))
|
||||
(define kernel-arguments
|
||||
#~(list #$@(if graphic? #~() #~("console=ttyS0"))
|
||||
#+@(operating-system-kernel-arguments os "/dev/vda1")))
|
||||
|
||||
(define rw-image
|
||||
#~(format #f "/tmp/.~a-rw" (basename #$base-image)))
|
||||
|
||||
(define qemu-exec
|
||||
#~(list #+(file-append qemu "/bin/"
|
||||
(qemu-command (or target system)))
|
||||
|
|
@ -761,17 +779,25 @@ (define qemu-exec
|
|||
"-initrd" #$(file-append os "/initrd")
|
||||
(format #f "-append ~s"
|
||||
(string-join #$kernel-arguments " "))))
|
||||
#$@(common-qemu-options image
|
||||
#$@(common-qemu-options (if volatile? base-image rw-image)
|
||||
(map file-system-mapping-source
|
||||
(cons %store-mapping mappings)))
|
||||
(cons %store-mapping mappings))
|
||||
#:rw-image? (not volatile?))
|
||||
"-m " (number->string #$memory-size)
|
||||
#$@options))
|
||||
|
||||
(define builder
|
||||
#~(call-with-output-file #$output
|
||||
(lambda (port)
|
||||
(format port "#!~a~% exec ~a \"$@\"~%"
|
||||
#+(file-append bash "/bin/sh")
|
||||
(format port "#!~a~%"
|
||||
#+(file-append bash "/bin/sh"))
|
||||
(when (not #$volatile?)
|
||||
(format port "~a~%"
|
||||
#$(program-file "copy-image"
|
||||
#~(unless (file-exists? #$rw-image)
|
||||
(copy-file #$base-image #$rw-image)
|
||||
(chmod #$rw-image #o640)))))
|
||||
(format port "exec ~a \"$@\"~%"
|
||||
(string-join #$qemu-exec " "))
|
||||
(chmod port #o555))))
|
||||
|
||||
|
|
@ -788,6 +814,8 @@ (define-record-type* <virtual-machine> %virtual-machine
|
|||
(operating-system virtual-machine-operating-system) ;<operating-system>
|
||||
(qemu virtual-machine-qemu ;<package>
|
||||
(default qemu-minimal))
|
||||
(volatile? virtual-machine-volatile? ;Boolean
|
||||
(default #t))
|
||||
(graphic? virtual-machine-graphic? ;Boolean
|
||||
(default #f))
|
||||
(memory-size virtual-machine-memory-size ;integer (MiB)
|
||||
|
|
@ -821,17 +849,19 @@ (define (port-forwardings->qemu-options forwardings)
|
|||
(define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
|
||||
system target)
|
||||
(match vm
|
||||
(($ <virtual-machine> os qemu graphic? memory-size disk-image-size ())
|
||||
(($ <virtual-machine> os qemu volatile? graphic? memory-size
|
||||
disk-image-size ())
|
||||
(system-qemu-image/shared-store-script os
|
||||
#:system system
|
||||
#:target target
|
||||
#:qemu qemu
|
||||
#:graphic? graphic?
|
||||
#:volatile? volatile?
|
||||
#: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 volatile? graphic? memory-size
|
||||
disk-image-size forwardings)
|
||||
(let ((options
|
||||
`("-nic" ,(string-append
|
||||
"user,model=virtio-net-pci,"
|
||||
|
|
@ -841,6 +871,7 @@ (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
|
|||
#:target target
|
||||
#:qemu qemu
|
||||
#:graphic? graphic?
|
||||
#:volatile? volatile?
|
||||
#:memory-size memory-size
|
||||
#:disk-image-size
|
||||
disk-image-size
|
||||
|
|
|
|||
Loading…
Reference in a new issue