projects/guix·blob ruby-team · refs

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