ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-11 13:49:23 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

system: vm: Use the image API to generate QEMU images.

Browse source 
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 2021-12-16 10:11:53 +01:00
parent 59912117d4
commit da92479674
No known key found for this signature in database
GPG key ID: 8354763531769CA6
1 changed files with 54 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

77
gnu/system/vm.scm
View file

@ -51,6 +51,8 @@ (define-module (gnu system vm)
#:use-module (gnu bootloader) #:use-module (gnu bootloader)
#:use-module (gnu bootloader grub) #: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-container)
#:use-module (gnu system linux-initrd) #:use-module (gnu system linux-initrd)
#:use-module (gnu bootloader) #:use-module (gnu bootloader)
@ -60,7 +62,7 @@ (define-module (gnu system vm)
#:use-module (gnu services base) #:use-module (gnu services base)
#:use-module (gnu system uuid) #:use-module (gnu system uuid)
#:use-module (srfi srfi-1) #:use-module ((srfi srfi-1) #:hide (partition))
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -592,7 +594,8 @@ (define (mapping->file-system mapping)
(check? #f) (check? #f)
(create-mount-point? #t))))) (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 "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 environment with the store shared with the host. MAPPINGS is a list of
<file-system-mapping> to realize in the virtualized OS." <file-system-mapping> to realize in the virtualized OS."
@ -635,7 +638,7 @@ (define virtual-file-systems
(initrd (lambda (file-systems . rest) (initrd (lambda (file-systems . rest)
(apply (operating-system-initrd os) (apply (operating-system-initrd os)
file-systems file-systems
#:volatile-root? #t #:volatile-root? volatile?
rest))) rest)))
;; Disable swap. ;; Disable swap.
@ -692,7 +695,8 @@ (define bootcfg
#:register-closures? #f #:register-closures? #f
#:copy-inputs? full-boot?)) #: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, "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." 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" "-device" "virtio-rng-pci,rng=guix-vm-rng"
#$@(map virtfs-option shared-fs) #$@(map virtfs-option shared-fs)
(format #f "-drive file=~a,if=virtio,cache=writeback,werror=report,readonly=on" #$@(if rw-image?
#$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 (define* (system-qemu-image/shared-store-script os
#:key #:key
@ -721,7 +727,8 @@ (define* (system-qemu-image/shared-store-script os
(target (%current-target-system)) (target (%current-target-system))
(qemu qemu) (qemu qemu)
(graphic? #t) (graphic? #t)
(memory-size 256) (volatile? #t)
(memory-size 2048)
(mappings '()) (mappings '())
full-boot? full-boot?
(disk-image-size (disk-image-size
@ -736,20 +743,31 @@ (define* (system-qemu-image/shared-store-script os
systems into the guest. systems into the guest.
When FULL-BOOT? is true, the returned script runs everything starting from the When FULL-BOOT? is true, the returned script runs everything starting from the
bootloader; otherwise it directly starts the operating system kernel. The bootloader; otherwise it directly starts the operating system kernel. When
DISK-IMAGE-SIZE parameter specifies the size in bytes of the root disk image; VOLATILE? is true, an overlay is created on top of a read-only
it is mostly useful when FULL-BOOT? is true." storage. Otherwise the storage is made persistent. The DISK-IMAGE-SIZE
(mlet* %store-monad ((os -> (virtualized-operating-system os mappings full-boot?)) parameter specifies the size in bytes of the root disk image; it is mostly
(image (system-qemu-image/shared-store useful when FULL-BOOT? is true."
os (mlet* %store-monad ((os -> (virtualized-operating-system
#:system system os mappings
#:target target
#:full-boot? full-boot? #: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 (define kernel-arguments
#~(list #$@(if graphic? #~() #~("console=ttyS0")) #~(list #$@(if graphic? #~() #~("console=ttyS0"))
#+@(operating-system-kernel-arguments os "/dev/vda1"))) #+@(operating-system-kernel-arguments os "/dev/vda1")))
(define rw-image
#~(format #f "/tmp/.~a-rw" (basename #$base-image)))
(define qemu-exec (define qemu-exec
#~(list #+(file-append qemu "/bin/" #~(list #+(file-append qemu "/bin/"
(qemu-command (or target system))) (qemu-command (or target system)))
@ -761,17 +779,25 @@ (define qemu-exec
"-initrd" #$(file-append os "/initrd") "-initrd" #$(file-append os "/initrd")
(format #f "-append ~s" (format #f "-append ~s"
(string-join #$kernel-arguments " ")))) (string-join #$kernel-arguments " "))))
#$@(common-qemu-options image #$@(common-qemu-options (if volatile? base-image rw-image)
(map file-system-mapping-source (map file-system-mapping-source
(cons %store-mapping mappings))) (cons %store-mapping mappings))
#:rw-image? (not volatile?))
"-m " (number->string #$memory-size) "-m " (number->string #$memory-size)
#$@options)) #$@options))
(define builder (define builder
#~(call-with-output-file #$output #~(call-with-output-file #$output
(lambda (port) (lambda (port)
(format port "#!~a~% exec ~a \"$@\"~%" (format port "#!~a~%"
#+(file-append bash "/bin/sh") #+(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 " ")) (string-join #$qemu-exec " "))
(chmod port #o555)))) (chmod port #o555))))
@ -788,6 +814,8 @@ (define-record-type* <virtual-machine> %virtual-machine
(operating-system virtual-machine-operating-system) ;<operating-system> (operating-system virtual-machine-operating-system) ;<operating-system>
(qemu virtual-machine-qemu ;<package> (qemu virtual-machine-qemu ;<package>
(default qemu-minimal)) (default qemu-minimal))
(volatile? virtual-machine-volatile? ;Boolean
(default #t))
(graphic? virtual-machine-graphic? ;Boolean (graphic? virtual-machine-graphic? ;Boolean
(default #f)) (default #f))
(memory-size virtual-machine-memory-size ;integer (MiB) (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>) (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
system target) system target)
(match vm (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-qemu-image/shared-store-script os
#:system system #:system system
#:target target #:target target
#:qemu qemu #:qemu qemu
#:graphic? graphic? #:graphic? graphic?
#:volatile? volatile?
#:memory-size memory-size #:memory-size memory-size
#:disk-image-size #:disk-image-size
disk-image-size)) disk-image-size))
(($ <virtual-machine> os qemu graphic? memory-size disk-image-size (($ <virtual-machine> os qemu volatile? graphic? memory-size
forwardings) disk-image-size forwardings)
(let ((options (let ((options
`("-nic" ,(string-append `("-nic" ,(string-append
"user,model=virtio-net-pci," "user,model=virtio-net-pci,"
@ -841,6 +871,7 @@ (define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
#:target target #:target target
#:qemu qemu #:qemu qemu
#:graphic? graphic? #:graphic? graphic?
#:volatile? volatile?
#:memory-size memory-size #:memory-size memory-size
#:disk-image-size #:disk-image-size
disk-image-size disk-image-size