diff options
Diffstat (limited to 'gnu/system/vm.scm')
| -rw-r--r-- | gnu/system/vm.scm | 115 |
1 files changed, 95 insertions, 20 deletions
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 8c27ff787d..fcfd1cdb48 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Christine Lemmer-Webber <cwebber@dustycloud.org> ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> @@ -63,6 +63,7 @@ #:use-module (gnu system uuid) #:use-module ((srfi srfi-1) #:hide (partition)) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) @@ -70,8 +71,19 @@ #:export (virtualized-operating-system system-qemu-image/shared-store-script + linux-image-startup-command + virtual-machine - virtual-machine?)) + virtual-machine? + virtual-machine-operating-system + virtual-machine-qemu + virtual-machine-cpu-count + virtual-machine-volatile? + virtual-machine-graphic? + virtual-machine-memory-size + virtual-machine-disk-image-size + virtual-machine-port-forwardings + virtual-machine-date)) ;;; Commentary: @@ -122,7 +134,8 @@ (check? #f) (create-mount-point? #t))))) -(define* (virtualized-operating-system os mappings +(define* (virtualized-operating-system os + #:optional (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 @@ -306,6 +319,63 @@ useful when FULL-BOOT? is true." (gexp->derivation "run-vm.sh" builder))) +(define* (linux-image-startup-command image + #:key + (system (%current-system)) + (target #f) + (qemu qemu-minimal) + (graphic? #f) + (cpu "max") + (cpu-count 1) + (memory-size 1024) + (port-forwardings '()) + (date #f)) + "Return a list-valued gexp representing the command to start QEMU to run +IMAGE, assuming it uses the Linux kernel, and not sharing the store with the +host." + (define os + ;; Note: 'image-operating-system' would return the wrong OS, before + ;; its root partition has been assigned a UUID. + (operating-system-for-image image)) + + (define kernel-arguments + #~(list #$@(if graphic? #~() #~("console=ttyS0")) + #+@(operating-system-kernel-arguments os "/dev/vda1"))) + + #~`(#+(file-append qemu "/bin/" + (qemu-command (or target system))) + ,@(if (access? "/dev/kvm" (logior R_OK W_OK)) + '("-enable-kvm") + '()) + + "-cpu" #$cpu + #$@(if (> cpu-count 1) + #~("-smp" #$(string-append "cpus=" (number->string cpu-count))) + #~()) + "-m" #$(number->string memory-size) + "-nic" #$(string-append + "user,model=virtio-net-pci," + (port-forwardings->qemu-options port-forwardings)) + "-kernel" #$(operating-system-kernel-file os) + "-initrd" #$(file-append os "/initrd") + "-append" ,(string-join #$kernel-arguments) + "-serial" "stdio" + + #$@(if date + #~("-rtc" + #$(string-append "base=" (date->string date "~5"))) + #~()) + + "-object" "rng-random,filename=/dev/urandom,id=guix-vm-rng" + "-device" "virtio-rng-pci,rng=guix-vm-rng" + + "-drive" + ,(string-append "file=" #$(system-image image) + ",format=qcow2,if=virtio," + "cache=writeback,werror=report,readonly=off") + "-snapshot" + "-no-reboot")) + ;;; ;;; High-level abstraction. @@ -317,6 +387,8 @@ useful when FULL-BOOT? is true." (operating-system virtual-machine-operating-system) ;<operating-system> (qemu virtual-machine-qemu ;<package> (default qemu-minimal)) + (cpu-count virtual-machine-cpu-count ;integer + (default 1)) (volatile? virtual-machine-volatile? ;Boolean (default #t)) (graphic? virtual-machine-graphic? ;Boolean @@ -326,7 +398,9 @@ useful when FULL-BOOT? is true." (disk-image-size virtual-machine-disk-image-size ;integer (bytes) (default 'guess)) (port-forwardings virtual-machine-port-forwardings ;list of integer pairs - (default '()))) + (default '())) + (date virtual-machine-date ;SRFI-19 date | #f + (default #f))) (define-syntax virtual-machine (syntax-rules () @@ -352,23 +426,24 @@ 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 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 volatile? graphic? memory-size - disk-image-size forwardings) + (($ <virtual-machine> os qemu cpus volatile? graphic? memory-size + disk-image-size forwardings date) (let ((options - `("-nic" ,(string-append - "user,model=virtio-net-pci," - (port-forwardings->qemu-options forwardings))))) + (append (if (null? forwardings) + '() + `("-nic" ,(string-append + "user,model=virtio-net-pci," + (port-forwardings->qemu-options + forwardings)))) + (if (> cpus 1) + `("-smp" ,(string-append "cpus=" + (number->string cpus))) + '()) + (if date + `("-rtc" + ,(string-append + "base=" (date->string date "~5"))) + '())))) (system-qemu-image/shared-store-script os #:system system #:target target |