projects/guix·blob ruby-team · refs

589 lines · 20.5 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2017 Christopher Baines <[email protected]>
3;;; Copyright © 2020-2024 Ludovic Courtès <[email protected]>
4;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <[email protected]>
5;;; Copyright © 2021 Pierre Langlois <[email protected]>
6;;; Copyright © 2022 Marius Bakke <[email protected]>
7;;; Copyright © 2025 Maxim Cournoyer <[email protected]>
8;;;
9;;; This file is part of GNU Guix.
10;;;
11;;; GNU Guix is free software; you can redistribute it and/or modify it
12;;; under the terms of the GNU General Public License as published by
13;;; the Free Software Foundation; either version 3 of the License, or (at
14;;; your option) any later version.
15;;;
16;;; GNU Guix is distributed in the hope that it will be useful, but
17;;; WITHOUT ANY WARRANTY; without even the implied warranty of
18;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;;; GNU General Public License for more details.
20;;;
21;;; You should have received a copy of the GNU General Public License
22;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
23
24(define-module (gnu tests virtualization)
25 #:use-module (gnu tests)
26 #:use-module (gnu image)
27 #:use-module (gnu system)
28 #:use-module (gnu system accounts)
29 #:use-module (gnu system file-systems)
30 #:use-module (gnu system hurd)
31 #:use-module (gnu system image)
32 #:use-module (gnu system images hurd)
33 #:use-module ((gnu system shadow) #:select (%base-user-accounts))
34 #:use-module (gnu system vm)
35 #:use-module (gnu services)
36 #:use-module (gnu services dbus)
37 #:use-module (gnu services networking)
38 #:use-module (gnu services ssh)
39 #:use-module (gnu services virtualization)
40 #:use-module (gnu packages ssh)
41 #:use-module (gnu packages virtualization)
42 #:use-module (guix gexp)
43 #:use-module (guix records)
44 #:use-module (guix store)
45 #:use-module (guix modules)
46 #:export (%test-libvirt
47 %test-qemu-guest-agent
48 %test-childhurd
49 %test-childhurd64
50 %test-build-vm))
51
52
53;;;
54;;; Libvirt.
55;;;
56
57(define %libvirt-os
58 (simple-operating-system
59 (service dhcpcd-service-type)
60 (service dbus-root-service-type)
61 (service polkit-service-type)
62 (service libvirt-service-type)))
63
64(define (run-libvirt-test)
65 "Run tests in %LIBVIRT-OS."
66 (define os
67 (marionette-operating-system
68 %libvirt-os
69 #:imported-modules '((gnu services herd)
70 (guix combinators))))
71
72 (define vm
73 (virtual-machine
74 (operating-system os)
75 (port-forwardings '())
76 (memory-size 512)))
77
78 (define test
79 (with-imported-modules '((gnu build marionette))
80 #~(begin
81 (use-modules (srfi srfi-11) (srfi srfi-64)
82 (gnu build marionette))
83
84 (define marionette
85 (make-marionette (list #$vm)))
86
87 (test-runner-current (system-test-runner #$output))
88 (test-begin "libvirt")
89
90 (test-assert "service running"
91 (marionette-eval
92 '(begin
93 (use-modules (gnu services herd))
94 (match (start-service 'libvirtd)
95 (#f #f)
96 (('service response-parts ...)
97 (match (assq-ref response-parts 'running)
98 ((pid) pid)))))
99 marionette))
100
101 ;; Give the libvirtd service time to start up.
102 (sleep 1)
103
104 (test-eq "fetch version"
105 0
106 (marionette-eval
107 `(begin
108 (chdir "/tmp")
109 (system* ,(string-append #$libvirt "/bin/virsh")
110 "-c" "qemu:///system" "version"))
111 marionette))
112
113 (test-eq "connect"
114 0
115 (marionette-eval
116 `(begin
117 (chdir "/tmp")
118 (system* ,(string-append #$libvirt "/bin/virsh")
119 "-c" "qemu:///system" "connect"))
120 marionette))
121
122 (test-equal "default network is inactive"
123 "no"
124 (marionette-eval
125 '(begin
126 (use-modules (ice-9 popen)
127 (ice-9 textual-ports))
128 (chdir "/tmp")
129 (define port
130 (open-input-pipe
131 (string-join '(#$(file-append libvirt "/bin/virsh")
132 "-c" "qemu:///system" "net-info"
133 "default" "|" "grep" "Active:" "|"
134 "awk" "'{ print $2; }'")
135 " ")))
136 (define answer (get-string-all port))
137 (close-port port)
138 (string-trim-both answer))
139 marionette))
140
141 (test-eq "start default network"
142 0
143 (marionette-eval
144 '(begin
145 (chdir "/tmp")
146 (system* #$(file-append libvirt "/bin/virsh")
147 "-c" "qemu:///system" "net-start" "default"))
148 marionette))
149
150 (test-assert "configured firmwares are available to libvirt"
151 (marionette-eval
152 '(begin
153 (use-modules (ice-9 popen)
154 (ice-9 textual-ports)
155 (srfi srfi-1)
156 (srfi srfi-26))
157 (let* ((conf-firmwares (list #$@(libvirt-configuration-firmwares
158 (libvirt-configuration))))
159 (virsh #$(file-append libvirt "/bin/virsh"))
160 (input-pipe (open-pipe*
161 OPEN_READ
162 virsh "-c" "qemu:///system"
163 "domcapabilities" "--xpath"
164 "/domainCapabilities/os/loader/value/text()"))
165 (output (get-string-all input-pipe))
166 (found-firmwares (string-split (string-trim-both output)
167 #\newline)))
168 (close-pipe input-pipe)
169 ;; Check that every configured firmware package is covered
170 ;; by at least by one firmware file available to libvirt.
171 (every (lambda (conf-firmware)
172 ;; The firmwares listed by virsh contains their
173 ;; full file names, not just their package output.
174 (any (cut string-prefix? conf-firmware <>)
175 found-firmwares))
176 conf-firmwares)))
177 marionette))
178
179 (test-end))))
180
181 (gexp->derivation "libvirt-test" test))
182
183(define %test-libvirt
184 (system-test
185 (name "libvirt")
186 (description "Connect to the running LIBVIRT service.")
187 (value (run-libvirt-test))))
188
189
190;;;
191;;; QEMU Guest Agent service.
192;;;
193
194(define %qemu-guest-agent-os
195 (simple-operating-system
196 (service qemu-guest-agent-service-type)))
197
198(define (run-qemu-guest-agent-test)
199 "Run tests in %QEMU-GUEST-AGENT-OS."
200 (define os
201 (marionette-operating-system
202 %qemu-guest-agent-os
203 #:imported-modules '((gnu services herd))))
204
205 (define vm
206 (virtual-machine
207 (operating-system os)
208 (port-forwardings '())))
209
210 (define test
211 (with-imported-modules '((gnu build marionette))
212 #~(begin
213 (use-modules (gnu build marionette)
214 (ice-9 rdelim)
215 (srfi srfi-64))
216
217 (define marionette
218 ;; Ensure we look for the socket in the correct place below.
219 (make-marionette (list #$vm) #:socket-directory "/tmp"))
220
221 (define* (try-read port #:optional (attempts 10))
222 ;; Try reading from a port several times before giving up.
223 (cond ((char-ready? port)
224 (let ((response (read-line port)))
225 (close-port port)
226 response))
227 ((> attempts 1)
228 (sleep 1)
229 (try-read port (- attempts 1)))
230 (else "")))
231
232 (define (run command)
233 ;; Run a QEMU guest agent command and return the response.
234 (let ((s (socket PF_UNIX SOCK_STREAM 0)))
235 (connect s AF_UNIX "/tmp/qemu-ga")
236 (display command s)
237 (try-read s)))
238
239 (test-runner-current (system-test-runner #$output))
240 (test-begin "qemu-guest-agent")
241
242 (test-assert "service running"
243 (marionette-eval
244 '(begin
245 (use-modules (gnu services herd))
246 (match (start-service 'qemu-guest-agent)
247 (#f #f)
248 (('service response-parts ...)
249 (match (assq-ref response-parts 'running)
250 ((pid) pid)))))
251 marionette))
252
253 (test-equal "ping guest"
254 "{\"return\": {}}"
255 (run "{\"execute\": \"guest-ping\"}"))
256
257 (test-assert "get network interfaces"
258 (string-contains
259 (run "{\"execute\": \"guest-network-get-interfaces\"}")
260 "127.0.0.1"))
261
262 (test-end))))
263
264 (gexp->derivation "qemu-guest-agent-test" test))
265
266(define %test-qemu-guest-agent
267 (system-test
268 (name "qemu-guest-agent")
269 (description "Run commands in a virtual machine using QEMU guest agent.")
270 (value (run-qemu-guest-agent-test))))
271
272
273;;;
274;;; GNU/Hurd virtual machines, aka. childhurds.
275;;;
276
277(define %childhurd-os
278 (simple-operating-system
279 (service dhcpcd-service-type)
280 (service hurd-vm-service-type
281 (hurd-vm-configuration
282 (os (operating-system
283 (inherit %hurd-vm-operating-system)
284 (users (cons (user-account
285 (name "test")
286 (group "users")
287 (password "")) ;empty password
288 %base-user-accounts))))))))
289
290(define %childhurd64-os
291 (simple-operating-system
292 (service dhcpcd-service-type)
293 (service hurd-vm-service-type
294 (hurd-vm-configuration
295 (type 'hurd64-qcow2)
296 (os (operating-system
297 (inherit %hurd-vm-operating-system)
298 (kernel-arguments '("noide")) ;use rumpdisk
299 (users (cons (user-account
300 (name "test")
301 (group "users")
302 (password "")) ;empty password
303 %base-user-accounts))))))))
304
305(define* (run-command-over-ssh command
306 #:key (port 10022) (user "test"))
307 "Return a program that runs COMMAND over SSH and prints the result on standard
308output."
309 (define run
310 (with-extensions (list guile-ssh)
311 #~(begin
312 (use-modules (ssh session)
313 (ssh auth)
314 (ssh popen)
315 (ice-9 match)
316 (ice-9 textual-ports))
317
318 (let ((session (make-session #:user #$user
319 #:port #$port
320 #:host "localhost"
321 #:timeout 120
322 #:log-verbosity 'rare)))
323 (match (connect! session)
324 ('ok
325 (userauth-password! session "")
326 (display
327 (get-string-all
328 (open-remote-input-pipe* session #$@command))))
329 (status
330 (error "could not connect to guest over SSH"
331 session status)))))))
332
333 (program-file "run-command-over-ssh" run))
334
335(define (run-childhurd-test childhurd-os)
336 (define (import-module? module)
337 ;; This module is optional and depends on Guile-Gcrypt, do skip it.
338 (and (guix-module-name? module)
339 (not (equal? module '(guix store deduplication)))))
340
341 (define os
342 (marionette-operating-system
343 childhurd-os
344 #:imported-modules (source-module-closure
345 '((gnu services herd)
346 (guix combinators)
347 (gnu build install))
348 #:select? import-module?)))
349
350 (define vm
351 (virtual-machine
352 (operating-system os)
353 (memory-size (* 1024 3))))
354
355 (define test
356 (with-imported-modules '((gnu build marionette))
357 #~(begin
358 (use-modules (gnu build marionette)
359 (srfi srfi-64)
360 (ice-9 match))
361
362 (define marionette
363 ;; Emulate as much as the host CPU supports so that, possibly, KVM
364 ;; is available inside as well ("nested KVM"), provided
365 ;; /sys/module/kvm_intel/parameters/nested (or similar) allows it.
366 (make-marionette (list #$vm "-cpu" "max")))
367
368 (test-runner-current (system-test-runner #$output))
369 (test-begin "childhurd")
370
371 (test-assert "service running"
372 (marionette-eval
373 '(begin
374 (use-modules (gnu services herd)
375 (ice-9 match))
376
377 (match (start-service 'childhurd)
378 (#f #f)
379 (('service response-parts ...)
380 (match (assq-ref response-parts 'running)
381 ((pid) pid)))))
382 marionette))
383
384 (test-equal "childhurd SSH server replies"
385 "SSH"
386 ;; Check from within the guest whether its childhurd's SSH
387 ;; server is reachable. Do that from the guest: port forwarding
388 ;; to the host won't work because QEMU listens on 127.0.0.1.
389 (marionette-eval
390 '(begin
391 (use-modules (ice-9 match)
392 (ice-9 textual-ports))
393
394 (let loop ((n 60))
395 (if (zero? n)
396 'all-attempts-failed
397 (let ((s (socket PF_INET SOCK_STREAM 0))
398 (a (make-socket-address AF_INET
399 INADDR_LOOPBACK
400 10022)))
401 (format #t "connecting to childhurd SSH server...~%")
402 (connect s a)
403 (match (get-string-n s 3)
404 ((? eof-object?)
405 (close-port s)
406 (sleep 1)
407 (loop (- n 1)))
408 (str
409 (close-port s)
410 str))))))
411 marionette))
412
413 (test-equal "SSH up and running"
414 "childhurd GNU\n"
415
416 ;; Connect from the guest to the chidhurd over SSH and run the
417 ;; 'uname' command.
418 (marionette-eval
419 '(begin
420 (use-modules (ice-9 popen)
421 (ice-9 textual-ports))
422
423 (get-string-all
424 (open-input-pipe #$(run-command-over-ssh '("uname" "-on")))))
425 marionette))
426
427 (test-assert "guix-daemon up and running"
428 (let ((drv (marionette-eval
429 '(begin
430 (use-modules (ice-9 popen)
431 (ice-9 textual-ports))
432
433 (get-string-all
434 (open-input-pipe
435 #$(run-command-over-ssh
436 '("guix" "build" "coreutils"
437 "--no-grafts" "-d")))))
438 marionette)))
439 ;; We cannot compare the .drv with (raw-derivation-file
440 ;; coreutils) on the host: they may differ due to fixed-output
441 ;; derivations and changes introduced compared to the 'guix'
442 ;; package snapshot.
443 (and (string-suffix? ".drv"
444 (pk 'drv (string-trim-right drv)))
445 drv)))
446
447 (test-assert "copy-on-write store"
448 ;; Set up a writable store. The root partition is already an
449 ;; overlayfs, which is not suitable as the bottom part of this
450 ;; additional overlayfs; thus, create a tmpfs for the backing
451 ;; store.
452 ;; TODO: Remove this when <virtual-machine> creates a writable
453 ;; store.
454 (marionette-eval
455 '(begin
456 (use-modules (gnu build install)
457 (guix build syscalls))
458
459 (mkdir "/run/writable-store")
460 (mount "none" "/run/writable-store" "tmpfs")
461 (mount-cow-store "/run/writable-store" "/backing-store")
462 (system* "df" "-hT"))
463 marionette))
464
465 (test-equal "offloading"
466 0
467 (marionette-eval
468 '(and (file-exists? "/etc/guix/machines.scm")
469 (system* "guix" "offload" "test"))
470 marionette))
471
472 (test-end))))
473
474 (gexp->derivation "childhurd-test" test))
475
476(define %test-childhurd
477 (system-test
478 (name "childhurd")
479 (description
480 "Connect to the GNU/Hurd virtual machine service, aka. a childhurd, making
481sure that the childhurd boots and runs its SSH server.")
482 (value (run-childhurd-test %childhurd-os))))
483
484(define %test-childhurd64
485 (system-test
486 (name "childhurd64")
487 (description
488 "Connect to the 64-bit GNU/Hurd virtual machine service, aka. a childhurd,
489 making sure that the childhurd boots and runs its SSH server.")
490 (value (run-childhurd-test %childhurd64-os))))
491
492
493;;;
494;;; Virtual build machine.
495;;;
496
497(define %build-vm-os
498 (simple-operating-system
499 (service virtual-build-machine-service-type
500 (virtual-build-machine
501 (cpu-count 1)
502 (memory-size (* 1 1024))))))
503
504(define (run-build-vm-test)
505 (define (import-module? module)
506 ;; This module is optional and depends on Guile-Gcrypt, do skip it.
507 (and (guix-module-name? module)
508 (not (equal? module '(guix store deduplication)))))
509
510 (define os
511 (marionette-operating-system
512 %build-vm-os
513 #:imported-modules (source-module-closure
514 '((gnu services herd)
515 (gnu build install))
516 #:select? import-module?)))
517
518 (define vm
519 (virtual-machine
520 (operating-system os)
521 (memory-size (* 1024 3))))
522
523 (define test
524 (with-imported-modules '((gnu build marionette))
525 #~(begin
526 (use-modules (gnu build marionette)
527 (srfi srfi-64)
528 (ice-9 match))
529
530 (define marionette
531 ;; Emulate as much as the host CPU supports so that, possibly, KVM
532 ;; is available inside as well ("nested KVM"), provided
533 ;; /sys/module/kvm_intel/parameters/nested (or similar) allows it.
534 (make-marionette (list #$vm "-cpu" "max")))
535
536 (test-runner-current (system-test-runner #$output))
537 (test-begin "build-vm")
538
539 (test-assert "service running"
540 (marionette-eval
541 '(begin
542 (use-modules (gnu services herd)
543 (ice-9 match))
544
545 (start-service 'build-vm))
546 marionette))
547
548 (test-assert "guest SSH up and running"
549 ;; Note: Pass #:peek? #t because due to the way QEMU port
550 ;; forwarding works, connecting to 11022 always works even if the
551 ;; 'sshd' service hasn't been started yet in the guest.
552 (wait-for-tcp-port 11022 marionette
553 #:peek? #t))
554
555 (test-assert "copy-on-write store"
556 ;; Set up a writable store. The root partition is already an
557 ;; overlayfs, which is not suitable as the bottom part of this
558 ;; additional overlayfs; thus, create a tmpfs for the backing
559 ;; store.
560 ;; TODO: Remove this when <virtual-machine> creates a writable
561 ;; store.
562 (marionette-eval
563 '(begin
564 (use-modules (gnu build install)
565 (guix build syscalls))
566
567 (mkdir "/run/writable-store")
568 (mount "none" "/run/writable-store" "tmpfs")
569 (mount-cow-store "/run/writable-store" "/backing-store")
570 (system* "df" "-hT"))
571 marionette))
572
573 (test-equal "offloading"
574 0
575 (marionette-eval
576 '(and (file-exists? "/etc/guix/machines.scm")
577 (system* "guix" "offload" "test"))
578 marionette))
579
580 (test-end))))
581
582 (gexp->derivation "build-vm-test" test))
583
584(define %test-build-vm
585 (system-test
586 (name "build-vm")
587 (description
588 "Offload to a virtual build machine over SSH.")
589 (value (run-build-vm-test))))