projects/guix·blob bootstrap-team · refs

582 lines · 20.3 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-eq "create default network"
123 0
124 (marionette-eval
125 '(begin
126 (chdir "/tmp")
127 (system* #$(file-append libvirt "/bin/virsh")
128 "-c" "qemu:///system" "net-define"
129 #$(file-append libvirt
130 "/etc/libvirt/qemu/networks/default.xml")))
131 marionette))
132
133 (test-eq "start default network"
134 0
135 (marionette-eval
136 '(begin
137 (chdir "/tmp")
138 (system* #$(file-append libvirt "/bin/virsh")
139 "-c" "qemu:///system" "net-start" "default"))
140 marionette))
141
142 (test-assert "configured firmwares are available to libvirt"
143 (marionette-eval
144 '(begin
145 (use-modules (ice-9 popen)
146 (ice-9 textual-ports)
147 (srfi srfi-1)
148 (srfi srfi-26))
149 (let* ((conf-firmwares (list #$@(libvirt-configuration-firmwares
150 (libvirt-configuration))))
151 (virsh #$(file-append libvirt "/bin/virsh"))
152 (input-pipe (open-pipe*
153 OPEN_READ
154 virsh "-c" "qemu:///system"
155 "domcapabilities" "--xpath"
156 "/domainCapabilities/os/loader/value/text()"))
157 (output (get-string-all input-pipe))
158 (found-firmwares (string-split (string-trim-both output)
159 #\newline)))
160 (close-pipe input-pipe)
161 ;; Check that every configured firmware package is covered
162 ;; by at least by one firmware file available to libvirt.
163 (every (lambda (conf-firmware)
164 ;; The firmwares listed by virsh contains their
165 ;; full file names, not just their package output.
166 (any (cut string-prefix? conf-firmware <>)
167 found-firmwares))
168 conf-firmwares)))
169 marionette))
170
171 (test-end))))
172
173 (gexp->derivation "libvirt-test" test))
174
175(define %test-libvirt
176 (system-test
177 (name "libvirt")
178 (description "Connect to the running LIBVIRT service.")
179 (value (run-libvirt-test))))
180
181
182;;;
183;;; QEMU Guest Agent service.
184;;;
185
186(define %qemu-guest-agent-os
187 (simple-operating-system
188 (service qemu-guest-agent-service-type)))
189
190(define (run-qemu-guest-agent-test)
191 "Run tests in %QEMU-GUEST-AGENT-OS."
192 (define os
193 (marionette-operating-system
194 %qemu-guest-agent-os
195 #:imported-modules '((gnu services herd))))
196
197 (define vm
198 (virtual-machine
199 (operating-system os)
200 (port-forwardings '())))
201
202 (define test
203 (with-imported-modules '((gnu build marionette))
204 #~(begin
205 (use-modules (gnu build marionette)
206 (ice-9 rdelim)
207 (srfi srfi-64))
208
209 (define marionette
210 ;; Ensure we look for the socket in the correct place below.
211 (make-marionette (list #$vm) #:socket-directory "/tmp"))
212
213 (define* (try-read port #:optional (attempts 10))
214 ;; Try reading from a port several times before giving up.
215 (cond ((char-ready? port)
216 (let ((response (read-line port)))
217 (close-port port)
218 response))
219 ((> attempts 1)
220 (sleep 1)
221 (try-read port (- attempts 1)))
222 (else "")))
223
224 (define (run command)
225 ;; Run a QEMU guest agent command and return the response.
226 (let ((s (socket PF_UNIX SOCK_STREAM 0)))
227 (connect s AF_UNIX "/tmp/qemu-ga")
228 (display command s)
229 (try-read s)))
230
231 (test-runner-current (system-test-runner #$output))
232 (test-begin "qemu-guest-agent")
233
234 (test-assert "service running"
235 (marionette-eval
236 '(begin
237 (use-modules (gnu services herd))
238 (match (start-service 'qemu-guest-agent)
239 (#f #f)
240 (('service response-parts ...)
241 (match (assq-ref response-parts 'running)
242 ((pid) pid)))))
243 marionette))
244
245 (test-equal "ping guest"
246 "{\"return\": {}}"
247 (run "{\"execute\": \"guest-ping\"}"))
248
249 (test-assert "get network interfaces"
250 (string-contains
251 (run "{\"execute\": \"guest-network-get-interfaces\"}")
252 "127.0.0.1"))
253
254 (test-end))))
255
256 (gexp->derivation "qemu-guest-agent-test" test))
257
258(define %test-qemu-guest-agent
259 (system-test
260 (name "qemu-guest-agent")
261 (description "Run commands in a virtual machine using QEMU guest agent.")
262 (value (run-qemu-guest-agent-test))))
263
264
265;;;
266;;; GNU/Hurd virtual machines, aka. childhurds.
267;;;
268
269(define %childhurd-os
270 (simple-operating-system
271 (service dhcpcd-service-type)
272 (service hurd-vm-service-type
273 (hurd-vm-configuration
274 (os (operating-system
275 (inherit %hurd-vm-operating-system)
276 (users (cons (user-account
277 (name "test")
278 (group "users")
279 (password "")) ;empty password
280 %base-user-accounts))))))))
281
282(define %childhurd64-os
283 (simple-operating-system
284 (service dhcpcd-service-type)
285 (service hurd-vm-service-type
286 (hurd-vm-configuration
287 (type 'hurd64-qcow2)
288 (os (operating-system
289 (inherit %hurd-vm-operating-system)
290 (kernel %hurd64-default-operating-system-kernel)
291 (kernel-arguments '("noide")) ;use rumpdisk
292 (users (cons (user-account
293 (name "test")
294 (group "users")
295 (password "")) ;empty password
296 %base-user-accounts))))))))
297
298(define* (run-command-over-ssh command
299 #:key (port 10022) (user "test"))
300 "Return a program that runs COMMAND over SSH and prints the result on standard
301output."
302 (define run
303 (with-extensions (list guile-ssh)
304 #~(begin
305 (use-modules (ssh session)
306 (ssh auth)
307 (ssh popen)
308 (ice-9 match)
309 (ice-9 textual-ports))
310
311 (let ((session (make-session #:user #$user
312 #:port #$port
313 #:host "localhost"
314 #:timeout 120
315 #:log-verbosity 'rare)))
316 (match (connect! session)
317 ('ok
318 (userauth-password! session "")
319 (display
320 (get-string-all
321 (open-remote-input-pipe* session #$@command))))
322 (status
323 (error "could not connect to guest over SSH"
324 session status)))))))
325
326 (program-file "run-command-over-ssh" run))
327
328(define (run-childhurd-test childhurd-os)
329 (define (import-module? module)
330 ;; This module is optional and depends on Guile-Gcrypt, do skip it.
331 (and (guix-module-name? module)
332 (not (equal? module '(guix store deduplication)))))
333
334 (define os
335 (marionette-operating-system
336 childhurd-os
337 #:imported-modules (source-module-closure
338 '((gnu services herd)
339 (guix combinators)
340 (gnu build install))
341 #:select? import-module?)))
342
343 (define vm
344 (virtual-machine
345 (operating-system os)
346 (memory-size (* 1024 3))))
347
348 (define test
349 (with-imported-modules '((gnu build marionette))
350 #~(begin
351 (use-modules (gnu build marionette)
352 (srfi srfi-64)
353 (ice-9 match))
354
355 (define marionette
356 ;; Emulate as much as the host CPU supports so that, possibly, KVM
357 ;; is available inside as well ("nested KVM"), provided
358 ;; /sys/module/kvm_intel/parameters/nested (or similar) allows it.
359 (make-marionette (list #$vm "-cpu" "max")))
360
361 (test-runner-current (system-test-runner #$output))
362 (test-begin "childhurd")
363
364 (test-assert "service running"
365 (marionette-eval
366 '(begin
367 (use-modules (gnu services herd)
368 (ice-9 match))
369
370 (match (start-service 'childhurd)
371 (#f #f)
372 (('service response-parts ...)
373 (match (assq-ref response-parts 'running)
374 ((pid) pid)))))
375 marionette))
376
377 (test-equal "childhurd SSH server replies"
378 "SSH"
379 ;; Check from within the guest whether its childhurd's SSH
380 ;; server is reachable. Do that from the guest: port forwarding
381 ;; to the host won't work because QEMU listens on 127.0.0.1.
382 (marionette-eval
383 '(begin
384 (use-modules (ice-9 match)
385 (ice-9 textual-ports))
386
387 (let loop ((n 60))
388 (if (zero? n)
389 'all-attempts-failed
390 (let ((s (socket PF_INET SOCK_STREAM 0))
391 (a (make-socket-address AF_INET
392 INADDR_LOOPBACK
393 10022)))
394 (format #t "connecting to childhurd SSH server...~%")
395 (connect s a)
396 (match (get-string-n s 3)
397 ((? eof-object?)
398 (close-port s)
399 (sleep 1)
400 (loop (- n 1)))
401 (str
402 (close-port s)
403 str))))))
404 marionette))
405
406 (test-equal "SSH up and running"
407 "childhurd GNU\n"
408
409 ;; Connect from the guest to the chidhurd over SSH and run the
410 ;; 'uname' command.
411 (marionette-eval
412 '(begin
413 (use-modules (ice-9 popen)
414 (ice-9 textual-ports))
415
416 (get-string-all
417 (open-input-pipe #$(run-command-over-ssh '("uname" "-on")))))
418 marionette))
419
420 (test-assert "guix-daemon up and running"
421 (let ((drv (marionette-eval
422 '(begin
423 (use-modules (ice-9 popen)
424 (ice-9 textual-ports))
425
426 (get-string-all
427 (open-input-pipe
428 #$(run-command-over-ssh
429 '("guix" "build" "coreutils"
430 "--no-grafts" "-d")))))
431 marionette)))
432 ;; We cannot compare the .drv with (raw-derivation-file
433 ;; coreutils) on the host: they may differ due to fixed-output
434 ;; derivations and changes introduced compared to the 'guix'
435 ;; package snapshot.
436 (and (string-suffix? ".drv"
437 (pk 'drv (string-trim-right drv)))
438 drv)))
439
440 (test-assert "copy-on-write store"
441 ;; Set up a writable store. The root partition is already an
442 ;; overlayfs, which is not suitable as the bottom part of this
443 ;; additional overlayfs; thus, create a tmpfs for the backing
444 ;; store.
445 ;; TODO: Remove this when <virtual-machine> creates a writable
446 ;; store.
447 (marionette-eval
448 '(begin
449 (use-modules (gnu build install)
450 (guix build syscalls))
451
452 (mkdir "/run/writable-store")
453 (mount "none" "/run/writable-store" "tmpfs")
454 (mount-cow-store "/run/writable-store" "/backing-store")
455 (system* "df" "-hT"))
456 marionette))
457
458 (test-equal "offloading"
459 0
460 (marionette-eval
461 '(and (file-exists? "/etc/guix/machines.scm")
462 (system* "guix" "offload" "test"))
463 marionette))
464
465 (test-end))))
466
467 (gexp->derivation "childhurd-test" test))
468
469(define %test-childhurd
470 (system-test
471 (name "childhurd")
472 (description
473 "Connect to the GNU/Hurd virtual machine service, aka. a childhurd, making
474sure that the childhurd boots and runs its SSH server.")
475 (value (run-childhurd-test %childhurd-os))))
476
477(define %test-childhurd64
478 (system-test
479 (name "childhurd64")
480 (description
481 "Connect to the 64-bit GNU/Hurd virtual machine service, aka. a childhurd,
482 making sure that the childhurd boots and runs its SSH server.")
483 (value (run-childhurd-test %childhurd64-os))))
484
485
486;;;
487;;; Virtual build machine.
488;;;
489
490(define %build-vm-os
491 (simple-operating-system
492 (service virtual-build-machine-service-type
493 (virtual-build-machine
494 (cpu-count 1)
495 (memory-size (* 1 1024))))))
496
497(define (run-build-vm-test)
498 (define (import-module? module)
499 ;; This module is optional and depends on Guile-Gcrypt, do skip it.
500 (and (guix-module-name? module)
501 (not (equal? module '(guix store deduplication)))))
502
503 (define os
504 (marionette-operating-system
505 %build-vm-os
506 #:imported-modules (source-module-closure
507 '((gnu services herd)
508 (gnu build install))
509 #:select? import-module?)))
510
511 (define vm
512 (virtual-machine
513 (operating-system os)
514 (memory-size (* 1024 3))))
515
516 (define test
517 (with-imported-modules '((gnu build marionette))
518 #~(begin
519 (use-modules (gnu build marionette)
520 (srfi srfi-64)
521 (ice-9 match))
522
523 (define marionette
524 ;; Emulate as much as the host CPU supports so that, possibly, KVM
525 ;; is available inside as well ("nested KVM"), provided
526 ;; /sys/module/kvm_intel/parameters/nested (or similar) allows it.
527 (make-marionette (list #$vm "-cpu" "max")))
528
529 (test-runner-current (system-test-runner #$output))
530 (test-begin "build-vm")
531
532 (test-assert "service running"
533 (marionette-eval
534 '(begin
535 (use-modules (gnu services herd)
536 (ice-9 match))
537
538 (start-service 'build-vm))
539 marionette))
540
541 (test-assert "guest SSH up and running"
542 ;; Note: Pass #:peek? #t because due to the way QEMU port
543 ;; forwarding works, connecting to 11022 always works even if the
544 ;; 'sshd' service hasn't been started yet in the guest.
545 (wait-for-tcp-port 11022 marionette
546 #:peek? #t))
547
548 (test-assert "copy-on-write store"
549 ;; Set up a writable store. The root partition is already an
550 ;; overlayfs, which is not suitable as the bottom part of this
551 ;; additional overlayfs; thus, create a tmpfs for the backing
552 ;; store.
553 ;; TODO: Remove this when <virtual-machine> creates a writable
554 ;; store.
555 (marionette-eval
556 '(begin
557 (use-modules (gnu build install)
558 (guix build syscalls))
559
560 (mkdir "/run/writable-store")
561 (mount "none" "/run/writable-store" "tmpfs")
562 (mount-cow-store "/run/writable-store" "/backing-store")
563 (system* "df" "-hT"))
564 marionette))
565
566 (test-equal "offloading"
567 0
568 (marionette-eval
569 '(and (file-exists? "/etc/guix/machines.scm")
570 (system* "guix" "offload" "test"))
571 marionette))
572
573 (test-end))))
574
575 (gexp->derivation "build-vm-test" test))
576
577(define %test-build-vm
578 (system-test
579 (name "build-vm")
580 (description
581 "Offload to a virtual build machine over SSH.")
582 (value (run-build-vm-test))))