projects/guix·blob python-team · refs

514 lines · 21.1 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2013-2026 Ludovic Courtès <[email protected]>
3;;; Copyright © 2016 Christine Lemmer-Webber <[email protected]>
4;;; Copyright © 2016, 2017 Leo Famulari <[email protected]>
5;;; Copyright © 2017 Mathieu Othacehe <[email protected]>
6;;; Copyright © 2017 Marius Bakke <[email protected]>
7;;; Copyright © 2018 Chris Marusich <[email protected]>
8;;; Copyright © 2024 Zheng Junjie <[email protected]>
9;;; Copyright © 2026 Sergio Pastor Pérez <[email protected]>
10;;;
11;;; This file is part of GNU Guix.
12;;;
13;;; GNU Guix is free software; you can redistribute it and/or modify it
14;;; under the terms of the GNU General Public License as published by
15;;; the Free Software Foundation; either version 3 of the License, or (at
16;;; your option) any later version.
17;;;
18;;; GNU Guix is distributed in the hope that it will be useful, but
19;;; WITHOUT ANY WARRANTY; without even the implied warranty of
20;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21;;; GNU General Public License for more details.
22;;;
23;;; You should have received a copy of the GNU General Public License
24;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
25
26;;; Commentary:
27;;;
28;;; Tools to evaluate build expressions within virtual machines.
29;;;
30;;; Code:
31
32(define-module (gnu system vm)
33 #:use-module (guix config)
34 #:use-module (guix store)
35 #:use-module (guix gexp)
36 #:use-module (guix derivations)
37 #:use-module (guix packages)
38 #:use-module (guix monads)
39 #:use-module (guix records)
40 #:use-module (guix modules)
41 #:use-module (guix utils)
42 #:use-module (gcrypt hash)
43 #:use-module (guix base32)
44 #:use-module ((guix self) #:select (make-config.scm))
45
46 #:use-module ((gnu build marionette)
47 #:select (qemu-command))
48 #:use-module (gnu packages base)
49 #:use-module (gnu packages bootloaders)
50 #:use-module (gnu packages cdrom)
51 #:use-module (gnu packages compression)
52 #:use-module (gnu packages guile)
53 #:autoload (gnu packages gnupg) (guile-gcrypt)
54 #:use-module (gnu packages gawk)
55 #:use-module (gnu packages bash)
56 #:use-module (gnu packages virtualization)
57 #:use-module (gnu packages disk)
58 #:use-module (gnu packages linux)
59 #:use-module (gnu packages spice)
60
61 #:use-module (gnu bootloader)
62 #:use-module (gnu bootloader grub)
63 #:use-module (gnu bootloader u-boot)
64 #:use-module (gnu image)
65 #:use-module (gnu system image)
66 #:use-module (gnu system linux-container)
67 #:use-module (gnu system linux-initrd)
68 #:use-module (gnu bootloader)
69 #:use-module (gnu system file-systems)
70 #:use-module (gnu system)
71 #:use-module (gnu services)
72 #:use-module (gnu services base)
73 #:use-module (gnu services spice)
74 #:use-module (gnu system uuid)
75
76 #:use-module ((srfi srfi-1) #:hide (partition))
77 #:use-module (srfi srfi-19)
78 #:use-module (srfi srfi-26)
79 #:use-module (rnrs bytevectors)
80 #:use-module (ice-9 match)
81
82 #:export (virtualized-operating-system
83 system-qemu-image/shared-store-script
84
85 linux-image-startup-command
86
87 virtual-machine
88 virtual-machine?
89 virtual-machine-operating-system
90 virtual-machine-qemu
91 virtual-machine-cpu-count
92 virtual-machine-volatile?
93 virtual-machine-graphic?
94 virtual-machine-memory-size
95 virtual-machine-disk-image-size
96 virtual-machine-port-forwardings
97 virtual-machine-date
98
99 file-system->mount-tag
100 common-qemu-options))
101
102
103;; By default, the msize value is 8 KiB, which according to QEMU is
104;; insufficient and would degrade performance. The msize value should roughly
105;; match the bandwidth of the system's IO (see:
106;; https://wiki.qemu.org/Documentation/9psetup#msize). Use 100 MiB as a
107;; conservative default.
108(define %default-msize-value (* 100 (expt 2 20))) ;100 MiB
109
110;;;
111;;; VMs that share file systems with the host.
112;;;
113
114(define (file-system->mount-tag fs)
115 "Return a 9p mount tag for host file system FS."
116 ;; QEMU mount tags must be ASCII, at most 31-byte long, cannot contain
117 ;; slashes, and cannot start with '_'. Compute an identifier that
118 ;; corresponds to the rules.
119 (string-append "TAG"
120 (string-drop (bytevector->base32-string
121 (sha1 (string->utf8 fs)))
122 4)))
123
124(define (mapping->file-system mapping)
125 "Return a 9p file system that realizes MAPPING."
126 (match mapping
127 (($ <file-system-mapping> source target writable?)
128 (file-system
129 (mount-point target)
130 (device (file-system->mount-tag source))
131 (type "9p")
132 (flags (if writable? '() '(read-only)))
133
134 ;; The 9p documentation says that cache=loose is "intended for
135 ;; exclusive, read-only mounts", without additional details. It's
136 ;; faster than the default cache=none, especially when copying and
137 ;; registering store items. Thus, use cache=loose, except for writable
138 ;; mounts, to ensure consistency.
139 (options (string-append "trans=virtio"
140 (if writable? "" ",cache=loose")
141 ",msize=" (number->string %default-msize-value)))
142 (check? #f)
143 (create-mount-point? #t)))))
144
145(define* (virtualized-operating-system os
146 #:optional (mappings '())
147 #:key
148 (full-boot? #f)
149 spice?
150 volatile?
151 (system (%current-system))
152 (target (%current-target-system)))
153 "Return an operating system based on OS suitable for use in a virtualized
154environment with the store shared with the host. MAPPINGS is a list of
155<file-system-mapping> to realize in the virtualized OS."
156 (define user-file-systems
157 ;; Remove file systems that conflict with those added below, or that are
158 ;; normally bound to real devices.
159 (remove (lambda (fs)
160 (let ((target (file-system-mount-point fs))
161 (source (file-system-device fs)))
162 (or (string=? target "/")
163 (and (string? source)
164 (string-prefix? "/dev/" source))
165
166 ;; Labels and UUIDs are necessarily invalid in the VM.
167 (and (file-system-mount? fs)
168 (or (file-system-label? source)
169 (uuid? source))))))
170 (operating-system-file-systems os)))
171
172 (define virtual-file-systems
173 (cons (file-system
174 (mount-point "/")
175 (device "/dev/vda1")
176 (type "ext4"))
177
178 (append (map mapping->file-system mappings)
179 user-file-systems)))
180
181 (operating-system
182 (inherit os)
183
184 (services
185 (if (and spice?
186 (not (find (lambda (service)
187 (eq? (service-kind service)
188 spice-vdagent-service-type))
189 services)))
190 (cons (service spice-vdagent-service-type)
191 services)
192 services))
193
194 (initrd (lambda (file-systems . rest)
195 (apply (operating-system-initrd os)
196 file-systems
197 #:volatile-root? volatile?
198 rest)))
199 ;; The (QEMU-only) "cirrus" graphics driver is still expected by some
200 ;; VPS with old QEMU versions. See <https://bugs.gnu.org/36069>.
201 ;;
202 ;; XXX In 6.14, the kernel renamed the "cirrus" module to "cirrus-qemu", so
203 ;; we account for that here. The renaming was done in this commit:
204 ;; https://git.kernel.org/pub/scm/linux/kernel/git/sashal/linux-stable.git/commit/?id=5c3c99868aa2e0b68ac69f8050a6b9c994e73397
205 (initrd-modules (let* ((modules initrd-modules)
206 (kernel-version
207 (package-version (operating-system-kernel os)))
208 (cirrus-module
209 (if (version>=? kernel-version "6.14")
210 "cirrus-qemu"
211 "cirrus")))
212 (if (member cirrus-module modules)
213 modules
214 (cons cirrus-module modules))))
215
216 ;; Disable swap.
217 (swap-devices '())
218
219 ;; XXX: When FULL-BOOT? is true, do not add a 9p mount for /gnu/store
220 ;; since that would lead the bootloader config to look for the kernel and
221 ;; initrd in it.
222 (file-systems (if full-boot?
223 virtual-file-systems
224 (cons
225 (file-system
226 (inherit (mapping->file-system %store-mapping))
227 (needed-for-boot? #t))
228 virtual-file-systems)))))
229
230(define* (common-qemu-options image shared-fs
231 #:key
232 (image-format "raw")
233 rw-image?
234 (target (%current-target-system)))
235 "Return the a string-value gexp with the common QEMU options to boot IMAGE,
236with '-virtfs' options for the host file systems listed in SHARED-FS."
237
238 (define (virtfs-option fs)
239 (list "-virtfs"
240 #~(format #f "local,path=~a,security_model=none,mount_tag=~a"
241 #$fs #$(file-system->mount-tag fs))))
242
243 #~(;; Only enable kvm if we see /dev/kvm exists.
244 ;; This allows users without hardware virtualization to still use these
245 ;; commands.
246 #$@(if (and (not target) (file-exists? "/dev/kvm"))
247 '("-enable-kvm")
248 '())
249
250 "-object" "rng-random,filename=/dev/urandom,id=guix-vm-rng"
251 "-device" "virtio-rng-pci,rng=guix-vm-rng"
252
253 #$@(append-map virtfs-option shared-fs)
254 "-drive"
255 #$(if rw-image?
256 #~(format #f "file=~a,format=qcow2,if=virtio" #$image)
257 #~(format #f "file=~a,format=~a,if=virtio,cache=writeback,werror=report,readonly=on"
258 #$image #$image-format))))
259
260(define common-qemu-spice-options
261 '("-device" "virtio-serial"
262 "-chardev" "spicevmc,id=vdagent,name=vdagent"
263 "-device" "virtserialport,chardev=vdagent,name=com.redhat.spice.0"
264 "-display" "spice-app,gl=on"
265 "-device" "virtio-gpu-gl"
266 "-vga" "none"))
267
268(define* (system-qemu-image/shared-store-script os
269 #:key
270 (system (%current-system))
271 (target (%current-target-system))
272 (qemu qemu)
273 (graphic? #t)
274 (volatile? #t)
275 (memory-size 512)
276 (mappings '())
277 full-boot?
278 spice
279 (disk-image-size
280 (* (if full-boot? 500 70)
281 (expt 2 20)))
282 (options '()))
283 "Return a derivation that builds a script to run a virtual machine image of
284OS that shares its store with the host. The virtual machine runs with
285MEMORY-SIZE MiB of memory.
286
287MAPPINGS is a list of <file-system-mapping> specifying mapping of host file
288systems into the guest.
289
290When FULL-BOOT? is true, the returned script runs everything starting from the
291bootloader; otherwise it directly starts the operating system kernel. When
292VOLATILE? is true, an overlay is created on top of a read-only
293storage. Otherwise the storage is made persistent. The DISK-IMAGE-SIZE
294parameter specifies the size in bytes of the root disk image; it is mostly
295useful when FULL-BOOT? is true."
296 (mlet* %store-monad ((os -> (virtualized-operating-system
297 os mappings
298 #:spice? spice
299 #:full-boot? full-boot?
300 #:volatile? volatile?
301 #:system system
302 #:target target))
303 (base-image -> (system-image
304 (image
305 (inherit
306 (raw-with-offset-disk-image))
307 (operating-system os)
308 (size disk-image-size)
309 (shared-store?
310 (and (not full-boot?) volatile?))
311 (volatile-root? volatile?)))))
312 (define kernel-arguments
313 #~(list #$@(if graphic? #~() #~("console=ttyS0"))
314 #$@(operating-system-kernel-arguments os "/dev/vda1")))
315
316 (define rw-image
317 #~(format #f "/tmp/guix-image-~a" (basename #$base-image)))
318
319 (define qemu-exec
320 #~(list #+(with-parameters ((%current-system %system)
321 (%current-target-system #f))
322 ;; Override %CURRENT-SYSTEM to always use a native emulator.
323 (file-append qemu "/bin/"
324 (qemu-command (or target system))))
325 ;; Tells qemu to use the terminal it was started in for IO.
326 #$@(if graphic? '() #~("-nographic"))
327 #$@(if (and graphic? spice)
328 common-qemu-spice-options
329 #~())
330 #$@(if full-boot?
331 #~()
332 #~("-kernel" #$(operating-system-kernel-file os)
333 "-initrd" #$(file-append os "/initrd")
334 (format #f "-append ~s"
335 (string-join #$kernel-arguments " "))))
336 ;; Default qemu-riscv64 have not PCI, virt have it, so we set it.
337 #$@(if (target-riscv64? (or target system))
338 #~("-M" "virt")
339 #~())
340 #$@(common-qemu-options (if volatile? base-image rw-image)
341 (map file-system-mapping-source
342 (cons %store-mapping mappings))
343 #:rw-image? (not volatile?)
344 #:target target)
345 "-m " (number->string #$memory-size)
346 #$@options))
347
348 (define copy-image
349 ;; Script that "copies" BASE-IMAGE to /tmp. Make a copy-on-write image,
350 ;; which is much cheaper than actually copying it.
351 (program-file "copy-image"
352 (with-imported-modules '((guix build utils))
353 #~(begin
354 (use-modules (guix build utils))
355 (unless (file-exists? #$rw-image)
356 (invoke #+(file-append qemu "/bin/qemu-img")
357 "create" "-b" #$base-image
358 "-F" "raw" "-f" "qcow2" #$rw-image))))))
359
360 (define builder
361 #~(call-with-output-file #$output
362 (lambda (port)
363 (format port "#!~a~%"
364 #+(file-append bash "/bin/sh"))
365 #$@(if volatile?
366 #~()
367 #~((format port "~a~%" #+copy-image)))
368 (format port "exec ~a \"$@\"~%"
369 (string-join #$qemu-exec " "))
370 (chmod port #o555))))
371
372 (gexp->derivation "run-vm.sh" builder)))
373
374(define* (linux-image-startup-command image
375 #:key
376 (system (%current-system))
377 (target #f)
378 (qemu qemu-minimal)
379 (graphic? #f)
380 (cpu "max")
381 (cpu-count 1)
382 (memory-size 1024)
383 (port-forwardings '())
384 (date #f))
385 "Return a list-valued gexp representing the command to start QEMU to run
386IMAGE, assuming it uses the Linux kernel, and not sharing the store with the
387host."
388 (define os
389 ;; Note: 'image-operating-system' would return the wrong OS, before
390 ;; its root partition has been assigned a UUID.
391 (operating-system-for-image image))
392
393 (define kernel-arguments
394 #~(list #$@(if graphic? #~() #~("console=ttyS0"))
395 #$@(operating-system-kernel-arguments os "/dev/vda1")))
396
397 #~`(#+(file-append qemu "/bin/"
398 (qemu-command (or target system)))
399 ,@(if (access? "/dev/kvm" (logior R_OK W_OK))
400 '("-enable-kvm")
401 '())
402
403 "-cpu" #$cpu
404 #$@(if (> cpu-count 1)
405 #~("-smp" #$(string-append "cpus=" (number->string cpu-count)))
406 #~())
407 "-m" #$(number->string memory-size)
408 "-nic" #$(string-append
409 "user,model=virtio-net-pci,"
410 (port-forwardings->qemu-options port-forwardings))
411 "-kernel" #$(operating-system-kernel-file os)
412 "-initrd" #$(file-append os "/initrd")
413 "-append" ,(string-join #$kernel-arguments)
414 "-serial" "stdio"
415
416 #$@(if date
417 #~("-rtc"
418 #$(string-append "base=" (date->string date "~5")))
419 #~())
420
421 "-object" "rng-random,filename=/dev/urandom,id=guix-vm-rng"
422 "-device" "virtio-rng-pci,rng=guix-vm-rng"
423
424 "-drive"
425 ,(string-append "file=" #$(system-image image)
426 ",format=qcow2,if=virtio,"
427 "cache=writeback,werror=report,readonly=off")
428 "-snapshot"
429 "-no-reboot"))
430
431
432;;;
433;;; High-level abstraction.
434;;;
435
436(define-record-type* <virtual-machine> %virtual-machine
437 make-virtual-machine
438 virtual-machine?
439 (operating-system virtual-machine-operating-system) ;<operating-system>
440 (qemu virtual-machine-qemu ;<package>
441 (default qemu-minimal))
442 (cpu-count virtual-machine-cpu-count ;integer
443 (default 1))
444 (volatile? virtual-machine-volatile? ;Boolean
445 (default #t))
446 (graphic? virtual-machine-graphic? ;Boolean
447 (default #f))
448 (memory-size virtual-machine-memory-size ;integer (MiB)
449 (default 256))
450 (disk-image-size virtual-machine-disk-image-size ;integer (bytes)
451 (default 'guess))
452 (port-forwardings virtual-machine-port-forwardings ;list of integer pairs
453 (default '()))
454 (date virtual-machine-date ;SRFI-19 date | #f
455 (default #f)))
456
457(define-syntax virtual-machine
458 (syntax-rules (operating-system)
459 "Declare a virtual machine running the specified OS, with the given
460options."
461 ((_ (operating-system os))
462 ;; Also accept the long form (virtual-machine (operating-system os)), for
463 ;; correctness.
464 (%virtual-machine (operating-system os)))
465 ((_ os) ;shortcut
466 (%virtual-machine (operating-system os)))
467 ((_ fields ...)
468 (%virtual-machine fields ...))))
469
470(define (port-forwardings->qemu-options forwardings)
471 "Return the QEMU option for the given port FORWARDINGS as a string, where
472FORWARDINGS is a list of host-port/guest-port pairs."
473 (string-join
474 (map (match-lambda
475 ((host-port . guest-port)
476 (string-append "hostfwd=tcp::"
477 (number->string host-port)
478 "-:" (number->string guest-port))))
479 forwardings)
480 ","))
481
482(define-gexp-compiler (virtual-machine-compiler (vm <virtual-machine>)
483 system target)
484 (match vm
485 (($ <virtual-machine> os qemu cpus volatile? graphic? memory-size
486 disk-image-size forwardings date)
487 (let ((options
488 (append (if (null? forwardings)
489 '()
490 `("-nic" ,(string-append
491 "user,model=virtio-net-pci,"
492 (port-forwardings->qemu-options
493 forwardings))))
494 (if (> cpus 1)
495 `("-smp" ,(string-append "cpus="
496 (number->string cpus)))
497 '())
498 (if date
499 `("-rtc"
500 ,(string-append
501 "base=" (date->string date "~5")))
502 '()))))
503 (system-qemu-image/shared-store-script os
504 #:system system
505 #:target target
506 #:qemu qemu
507 #:graphic? graphic?
508 #:volatile? volatile?
509 #:memory-size memory-size
510 #:disk-image-size
511 disk-image-size
512 #:options options)))))
513
514;;; vm.scm ends here