projects/guix·blob python-team · refs

1414 lines · 56.2 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2016-2020, 2022, 2024-2026 Ludovic Courtès <[email protected]>
3;;; Copyright © 2018 Clément Lassieur <[email protected]>
4;;; Copyright © 2022, 2025 Maxim Cournoyer <[email protected]>
5;;; Copyright © 2022 Marius Bakke <[email protected]>
6;;; Copyright © 2024 Dariqq <[email protected]>
7;;;
8;;; This file is part of GNU Guix.
9;;;
10;;; GNU Guix is free software; you can redistribute it and/or modify it
11;;; under the terms of the GNU General Public License as published by
12;;; the Free Software Foundation; either version 3 of the License, or (at
13;;; your option) any later version.
14;;;
15;;; GNU Guix is distributed in the hope that it will be useful, but
16;;; WITHOUT ANY WARRANTY; without even the implied warranty of
17;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18;;; GNU General Public License for more details.
19;;;
20;;; You should have received a copy of the GNU General Public License
21;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
22
23(define-module (gnu tests base)
24 #:use-module (gnu tests)
25 #:use-module (gnu image)
26 #:use-module (gnu system)
27 #:use-module (gnu system file-systems)
28 #:autoload (gnu system image) (system-image qcow2-image-type)
29 #:use-module (gnu system privilege)
30 #:use-module (gnu system shadow)
31 #:use-module (gnu system vm)
32 #:use-module (gnu services)
33 #:use-module (gnu services base)
34 #:use-module (gnu services shepherd)
35 #:use-module (gnu services networking)
36 #:use-module (gnu packages base)
37 #:use-module (gnu packages bash)
38 #:use-module (gnu packages bootstrap)
39 #:use-module (gnu packages guile)
40 #:use-module (gnu packages imagemagick)
41 #:use-module (gnu packages linux)
42 #:use-module (gnu packages ocr)
43 #:use-module (gnu packages package-management)
44 #:use-module (gnu packages tmux)
45 #:use-module (gnu packages virtualization)
46 #:use-module (guix gexp)
47 #:use-module (guix store)
48 #:use-module (guix monads)
49 #:use-module (guix modules)
50 #:use-module (guix packages)
51 #:use-module (guix profiles)
52 #:use-module (guix utils)
53 #:use-module ((srfi srfi-1) #:hide (partition))
54 #:use-module (ice-9 match)
55 #:export (run-basic-test
56 %test-basic-os
57 %test-linux-libre-6.18
58 %test-linux-libre-6.12
59 %test-linux-libre-6.6
60 %test-linux-libre-6.1
61 %test-linux-debian-6.12
62 %test-halt
63 %test-root-unmount
64 %test-cleanup
65 %test-activation
66
67 %test-missing-file-system
68
69 %hello-dependencies-manifest
70 guix-daemon-test-cases
71 %test-guix-daemon
72 %test-guix-daemon-unprivileged))
73
74(define %simple-os
75 (simple-operating-system))
76
77
78(define* (run-basic-test os command #:optional (name "basic")
79 #:key
80 initialization
81 root-password
82 desktop?
83 extra-tests)
84 "Return a derivation called NAME that tests basic features of the OS started
85using COMMAND, a gexp that evaluates to a list of strings. Compare some
86properties of running system to what's declared in OS, an <operating-system>.
87
88When INITIALIZATION is true, it must be a one-argument procedure that is
89passed a gexp denoting the marionette, and it must return gexp that is
90inserted before the first test. This is used to introduce an extra
91initialization step, such as entering a LUKS passphrase.
92
93When ROOT-PASSWORD is true, enter it as the root password when logging in.
94Otherwise assume that there is no password for root.
95
96When EXTRA-TESTS is true, it must be a one-argument procedure that is
97passed a gexp denoting the marionette. It must then return a gexp that is
98inserted after the last test. This is meant as a way of extending the basic
99tests that are defined within this procedure."
100 (define special-files
101 (service-value
102 (fold-services (operating-system-services os)
103 #:target-type special-files-service-type)))
104
105 (define guix&co
106 (match (package-transitive-propagated-inputs guix)
107 (((labels packages) ...)
108 (cons guix packages))))
109
110 (define test
111 (with-imported-modules '((gnu build marionette)
112 (guix build syscalls))
113 #~(begin
114 (use-modules (gnu build marionette)
115 (guix build syscalls)
116 (srfi srfi-1)
117 (srfi srfi-19)
118 (srfi srfi-26)
119 (srfi srfi-64)
120 (ice-9 match))
121
122 (define marionette
123 (make-marionette #$command))
124
125 (test-runner-current (system-test-runner #$output))
126 (test-begin "basic")
127
128 #$(and initialization
129 (initialization #~marionette))
130
131 (test-assert "uname"
132 (match (marionette-eval '(uname) marionette)
133 (#("Linux" host-name version _ architecture)
134 (and (string=? host-name
135 #$(operating-system-host-name os))
136 (string-prefix? #$(package-version
137 (operating-system-kernel os))
138 version)
139 (string-prefix? architecture %host-type)))))
140
141 ;; Shepherd reads the config file *before* binding its control
142 ;; socket, so /var/run/shepherd/socket might not exist yet when the
143 ;; 'marionette' service is started.
144 (test-assert "shepherd socket ready"
145 (marionette-eval
146 `(begin
147 (use-modules (gnu services herd))
148 (let loop ((i 10))
149 (cond ((file-exists? (%shepherd-socket-file))
150 #t)
151 ((> i 0)
152 (sleep 1)
153 (loop (- i 1)))
154 (else
155 #f))))
156 marionette))
157
158 (test-eq "stdin is /dev/null"
159 'eof
160 ;; Make sure services can no longer read from stdin once the
161 ;; system has booted.
162 (marionette-eval
163 `(begin
164 (use-modules (gnu services herd))
165 (start-service 'user-processes)
166 ((@@ (gnu services herd) eval-there)
167 '(let ((result (read (current-input-port))))
168 (if (eof-object? result)
169 'eof
170 result))))
171 marionette))
172
173 (test-assert "shell and user commands"
174 ;; Is everything in $PATH?
175 (zero? (marionette-eval '(system "
176. /etc/profile
177set -e -x
178guix --version
179ls --version
180grep --version
181info --version")
182 marionette)))
183
184 (test-equal "special files"
185 '#$special-files
186 (marionette-eval
187 '(begin
188 (use-modules (ice-9 match))
189
190 (map (match-lambda
191 ((file target)
192 (list file (readlink file))))
193 '#$special-files))
194 marionette))
195
196 (test-assert "accounts"
197 (let ((users (marionette-eval '(begin
198 (use-modules (ice-9 match))
199 (let loop ((result '()))
200 (match (getpw)
201 (#f (reverse result))
202 (x (loop (cons x result))))))
203 marionette)))
204 (lset= equal?
205 (map (lambda (user)
206 (list (passwd:name user)
207 (passwd:dir user)))
208 users)
209 (list
210 #$@(map (lambda (account)
211 `(list ,(user-account-name account)
212 ,(user-account-home-directory account)))
213 (operating-system-user-accounts os))))))
214
215 (test-assert "shepherd services"
216 (let ((services (marionette-eval
217 '(begin
218 (use-modules (gnu services herd)
219 (srfi srfi-1))
220
221 (append-map live-service-provision
222 (current-services)))
223 marionette)))
224 (lset= eq?
225 (pk 'services services)
226 '(root
227 shepherd
228 #$@(operating-system-shepherd-service-names os)))))
229
230 (test-equal "libc honors /etc/localtime"
231 -7200 ;CEST = GMT+2
232 ;; Assume OS is configured to have a CEST timezone.
233 (let* ((sept-2021 (time-second
234 (date->time-utc
235 (make-date 0 0 00 12 01 09 2021 7200)))))
236 (marionette-eval
237 `(tm:gmtoff (localtime ,sept-2021))
238 marionette)))
239
240 (test-equal "/etc/localtime is a symlink to the timezone data file"
241 ;; This is a systemd-ism that most distributions follow; we do to,
242 ;; for compatibility with software that assumes this is convention
243 ;; is followed (see:
244 ;; <https://www.freedesktop.org/software/systemd/man/latest/localtime.html#>)
245 #$(operating-system-timezone os)
246 (marionette-eval
247 `(string-join
248 (take-right (string-split (readlink "/etc/localtime") #\/) 2)
249 "/")
250 marionette))
251
252 (test-equal "/var/log/messages is not world-readable"
253 #o640 ;<https://bugs.gnu.org/40405>
254 (begin
255 (wait-for-file "/var/log/messages" marionette
256 #:read 'get-u8)
257 (marionette-eval '(stat:perms (lstat "/var/log/messages"))
258 marionette)))
259
260 (test-assert "homes"
261 (let ((homes
262 '#$(map user-account-home-directory
263 (filter user-account-create-home-directory?
264 (operating-system-user-accounts os)))))
265 (marionette-eval
266 `(begin
267 (use-modules (gnu services herd) (srfi srfi-1))
268
269 ;; Home directories are supposed to exist once 'user-homes'
270 ;; has been started.
271 (start-service 'user-homes)
272
273 (every (lambda (home)
274 (and (file-exists? home)
275 (file-is-directory? home)))
276 ',homes))
277 marionette)))
278
279 (test-assert "skeletons in home directories"
280 (let ((users+homes
281 '#$(filter-map (lambda (account)
282 (and (user-account-create-home-directory?
283 account)
284 (not (user-account-system? account))
285 (list (user-account-name account)
286 (user-account-home-directory
287 account))))
288 (operating-system-user-accounts os))))
289 (marionette-eval
290 `(begin
291 (use-modules (guix build utils) (srfi srfi-1)
292 (ice-9 ftw) (ice-9 match))
293
294 (every (match-lambda
295 ((user home)
296 ;; Make sure HOME has all the skeletons...
297 (and (null? (lset-difference string=?
298 (scandir "/etc/skel/")
299 (scandir home)))
300
301 ;; ... and that everything is user-owned.
302 (let* ((pw (getpwnam user))
303 (uid (passwd:uid pw))
304 (gid (passwd:gid pw))
305 (st (lstat home)))
306 (define (user-owned? file)
307 (= uid (stat:uid (lstat file))))
308
309 (and (= uid (stat:uid st))
310 (eq? 'directory (stat:type st))
311 (every user-owned?
312 (find-files home
313 #:directories? #t)))))))
314 ',users+homes))
315 marionette)))
316
317 (test-equal "permissions on /root"
318 #o700
319 (let ((root-home #$(any (lambda (account)
320 (and (zero? (user-account-uid account))
321 (user-account-home-directory
322 account)))
323 (operating-system-user-accounts os))))
324 (stat:perms (marionette-eval `(stat ,root-home) marionette))))
325
326 (test-equal "permissions on /tmp"
327 #o1777
328 (stat:perms (marionette-eval '(lstat "/tmp") marionette)))
329
330 (test-equal "ownership and permissions of /var/empty"
331 '(0 0 #o555)
332 (let ((st (marionette-eval `(stat "/var/empty") marionette)))
333 (list (stat:uid st) (stat:gid st)
334 (stat:perms st))))
335
336 (test-equal "no extra home directories"
337 '()
338
339 ;; Make sure the home directories that are not supposed to be
340 ;; created are indeed not created.
341 (let ((nonexistent
342 '#$(filter-map (lambda (user)
343 (and (not
344 (user-account-create-home-directory?
345 user))
346 (user-account-home-directory user)))
347 (operating-system-user-accounts os))))
348 (marionette-eval
349 `(begin
350 (use-modules (srfi srfi-1))
351
352 ;; Note: Do not flag "/var/empty".
353 (filter file-exists?
354 ',(remove (cut string-prefix? "/var/" <>)
355 nonexistent)))
356 marionette)))
357
358 (test-equal "login on tty1"
359 "root\n"
360 (begin
361 ;; XXX: On desktop, GDM3 will switch to TTY7. If this happens
362 ;; after we switched to TTY1, we won't be able to login. Make
363 ;; sure to wait long enough before switching to TTY1.
364 (when #$desktop?
365 (sleep 30))
366
367 (marionette-control "sendkey ctrl-alt-f1" marionette)
368 ;; Wait for the 'term-tty1' service to be running (using
369 ;; 'start-service' is the simplest and most reliable way to do
370 ;; that.)
371 (marionette-eval
372 '(begin
373 (use-modules (gnu services herd))
374 (start-service 'term-tty1))
375 marionette)
376
377 ;; Now we can type.
378 (let ((password #$root-password))
379 (if password
380 (begin
381 (marionette-type "root\n" marionette)
382 (wait-for-screen-text marionette
383 (lambda (text)
384 (string-contains text "Password"))
385 #:ocr
386 #$(file-append ocrad "/bin/ocrad"))
387 (marionette-type (string-append password "\n\n")
388 marionette))
389 (marionette-type "root\n\n" marionette)))
390 (marionette-type "id -un > logged-in\n" marionette)
391
392 ;; It can take a while before the shell commands are executed.
393 (marionette-eval '(use-modules (rnrs io ports)) marionette)
394 (wait-for-file "/root/logged-in" marionette
395 #:read 'get-string-all
396 #:timeout 30)))
397
398 (test-equal "getlogin on tty1"
399 "\"root\""
400 (begin
401 ;; Assume we logged in in the previous test and type.
402 (marionette-type "guile -c '(write (getlogin))' > /root/login-id.tmp\n"
403 marionette)
404 (marionette-type "mv /root/login-id{.tmp,}\n"
405 marionette)
406
407 ;; It can take a while before the shell commands are executed.
408 (marionette-eval '(use-modules (rnrs io ports)) marionette)
409 (wait-for-file "/root/login-id" marionette
410 #:read 'get-string-all
411 #:timeout 30)))
412
413 ;; There should be one utmpx entry for the user logged in on tty1.
414 (test-equal "utmpx entry"
415 '(("root" "tty1" #f))
416 (marionette-eval
417 '(begin
418 (use-modules (guix build syscalls)
419 (srfi srfi-1))
420
421 (filter-map (lambda (entry)
422 (and (equal? (login-type USER_PROCESS)
423 (utmpx-login-type entry))
424 (list (utmpx-user entry) (utmpx-line entry)
425 (utmpx-host entry))))
426 (utmpx-entries)))
427 marionette))
428
429 ;; Likewise for /var/log/wtmp (used by 'last').
430 (test-assert "wtmp entry"
431 (match (marionette-eval
432 '(begin
433 (use-modules (guix build syscalls)
434 (srfi srfi-1))
435
436 (define (entry->list entry)
437 (list (utmpx-user entry) (utmpx-line entry)
438 (utmpx-host entry) (utmpx-login-type entry)))
439
440 (call-with-input-file "/var/log/wtmp"
441 (lambda (port)
442 (let loop ((result '()))
443 (if (eof-object? (peek-char port))
444 (map entry->list (reverse result))
445 (loop (cons (read-utmpx port) result)))))))
446 marionette)
447 (((users lines hosts types) ..1)
448 (every (lambda (type)
449 (eqv? type (login-type LOGIN_PROCESS)))
450 types))))
451
452 (test-assert "host name resolution"
453 (match (marionette-eval
454 '(begin
455 ;; Wait for nscd or our requests go through it.
456 (use-modules (gnu services herd))
457 (start-service 'nscd)
458
459 (list (getaddrinfo "localhost")
460 (getaddrinfo #$(operating-system-host-name os))))
461 marionette)
462 ((((? vector?) ..1) ((? vector?) ..1))
463 #t)
464 (x
465 (pk 'failure x #f))))
466
467 (test-assert "nscd configuration action"
468 (marionette-eval '(with-shepherd-action 'nscd ('configuration)
469 results
470 (file-exists? (car results)))
471 marionette))
472
473 (test-equal "nscd invalidate action"
474 '(#t) ;one value, #t
475 (marionette-eval '(with-shepherd-action 'nscd ('invalidate "hosts")
476 result
477 result)
478 marionette))
479
480 ;; FIXME: The 'invalidate' action can't reliably obtain the exit
481 ;; code of 'nscd' so skip this test.
482 (test-skip 1)
483 (test-equal "nscd invalidate action, wrong table"
484 '(#f) ;one value, #f
485 (marionette-eval '(with-shepherd-action 'nscd ('invalidate "xyz")
486 result
487 result)
488 marionette))
489
490 (test-equal "host not found"
491 #f
492 (marionette-eval
493 '(false-if-exception (getaddrinfo "does-not-exist"))
494 marionette))
495
496 (test-equal "locale"
497 "en_US.utf8"
498 (marionette-eval '(let ((before (setlocale LC_ALL "en_US.utf8")))
499 (setlocale LC_ALL before))
500 marionette))
501
502 (test-eq "/run/current-system is a GC root"
503 'success!
504 (marionette-eval '(begin
505 ;; Make sure the (guix …) modules are found.
506 (eval-when (expand load eval)
507 (set! %load-path
508 (append (map (lambda (package)
509 (string-append package
510 "/share/guile/site/"
511 (effective-version)))
512 '#$guix&co)
513 %load-path)))
514
515 (use-modules (srfi srfi-34) (guix store))
516
517 (let ((system (readlink "/run/current-system")))
518 (guard (c ((store-protocol-error? c)
519 (and (file-exists? system)
520 'success!)))
521 (with-store store
522 (delete-paths store (list system))
523 #f))))
524 marionette))
525
526 ;; This symlink is currently unused, but better have it point to the
527 ;; right place. See
528 ;; <https://lists.gnu.org/archive/html/guix-devel/2016-08/msg01641.html>.
529 (test-equal "/var/guix/gcroots/profiles is a valid symlink"
530 "/var/guix/profiles"
531 (marionette-eval '(readlink "/var/guix/gcroots/profiles")
532 marionette))
533
534 (test-equal "guix-daemon set-http-proxy action"
535 '(#t) ;one value, #t
536 (marionette-eval '(with-shepherd-action 'guix-daemon
537 ('set-http-proxy "http://localhost:8118")
538 result
539 result)
540 marionette))
541
542 (test-equal "guix-daemon set-http-proxy action, clear"
543 '(#t) ;one value, #t
544 (marionette-eval '(with-shepherd-action 'guix-daemon
545 ('set-http-proxy)
546 result
547 result)
548 marionette))
549
550 (test-assert "screendump"
551 (begin
552 (let ((capture
553 (string-append #$output "/tty1.ppm")))
554 (marionette-control
555 (string-append "screendump " capture) marionette)
556 (file-exists? capture))))
557
558 (test-assert "screen text"
559 (wait-for-screen-text
560 marionette
561 (lambda (text)
562 ;; Check whether the welcome message and shell prompt are
563 ;; displayed. Note: OCR confuses "y" and "V" for instance, so
564 ;; we cannot reliably match the whole text.
565 (and (string-contains text "This is the GNU")
566 (string-contains text
567 (string-append
568 "root@"
569 #$(operating-system-host-name os)))))
570 #:ocr #$(file-append ocrad "/bin/ocrad")))
571
572 (test-equal "block devices have correct default polling value"
573 "2000"
574 ;; This tests that the 'udevadm trigger' correctly creates the
575 ;; subsystems nodes, by checking that the standard 60-block.rules
576 ;; udev rules was applied.
577 (marionette-eval
578 '(begin
579 (use-modules (ice-9 textual-ports))
580 (call-with-input-file
581 "/sys/module/block/parameters/events_dfl_poll_msecs"
582 (compose string-trim-right get-string-all)))
583 marionette))
584
585 #$(and extra-tests
586 (extra-tests #~marionette))
587
588 (test-end))))
589
590 (gexp->derivation name test))
591
592(define* (test-basic-os #:optional (kernel linux-libre))
593 (system-test
594 (name (if (eq? kernel linux-libre)
595 "basic"
596 (string-append (package-name kernel) "-"
597 (version-major+minor (package-version kernel)))))
598 (description
599 "Instrument %SIMPLE-OS, run it in a VM, and run a series of basic
600functionality tests, using the given KERNEL.")
601 (value
602 (let* ((os (marionette-operating-system
603 (operating-system
604 (inherit %simple-os)
605 (kernel kernel)
606 (services (cons* (service
607 etc-profile-d-service-type
608 (list (plain-file
609 "test_profile_d.sh"
610 "export PROFILE_D_OK=yes\n")
611 (plain-file
612 "invalid-name"
613 "not a POSIX script -- ignore me")))
614 (simple-service
615 'extra-bashrc-d-files
616 etc-bashrc-d-service-type
617 (list (plain-file
618 "test_bashrc_d.sh"
619 "export BASHRC_D_OK=yes\n")
620 (plain-file
621 "invalid-name"
622 "not a Bash script -- ignore me")))
623 %base-services)))
624 #:imported-modules '((gnu services herd)
625 (guix combinators))))
626 (vm (virtual-machine os)))
627 ;; XXX: Add call to 'virtualized-operating-system' to get the exact same
628 ;; set of services as the OS produced by
629 ;; 'system-qemu-image/shared-store-script'.
630 (run-basic-test (virtualized-operating-system os '())
631 #~(list #$vm)
632 name
633 ;; Add extra tests for the etc-profile-d-service-type
634 ;; and etc-bashrc-d-service-type services defined above.
635 ;; Those tests cannot directly be part of the
636 ;; run-basic-test procedure that is used in many other
637 ;; locations.
638 #:extra-tests
639 (lambda (marionette)
640 #~(begin
641 (test-assert "/etc/profile.d is sourced"
642 (zero?
643 (marionette-eval '(system "
644. /etc/profile
645set -e -x
646test -f /etc/profile.d/test_profile_d.sh
647test \"$PROFILE_D_OK\" = yes")
648 #$marionette)))
649
650 (test-assert "/etc/bashrc.d is sourced"
651 (zero?
652 (marionette-eval
653 '(system* "bash"
654 "-i" ;run interactively
655 #$(plain-file "test_bashrc_d.sh"
656 "\
657. /etc/bashrc
658set -e -x
659test -f /etc/bashrc.d/bash_completion.sh
660test -f /etc/bashrc.d/aliases.sh
661test \"$(alias ls)\" = \"alias ls='ls -p --color=auto'\"
662test \"$(alias ll)\" = \"alias ll='ls -l'\"
663test \"$(alias grep)\" = \"alias grep='grep --color=auto'\"
664test \"$(alias ip)\" = \"alias ip='ip -color=auto'\"
665test -f /etc/bashrc.d/test_bashrc_d.sh
666test \"$BASHRC_D_OK\" = yes"))
667 #$marionette))))))))))
668
669(define %test-basic-os
670 (test-basic-os))
671
672;; Ensure the LTS kernels are up to snuff, too.
673(define %test-linux-libre-6.18
674 (test-basic-os linux-libre-6.18))
675
676(define %test-linux-libre-6.12
677 (test-basic-os linux-libre-6.12))
678
679(define %test-linux-libre-6.6
680 (test-basic-os linux-libre-6.6))
681
682(define %test-linux-libre-6.1
683 (test-basic-os linux-libre-6.1))
684
685(define %test-linux-debian-6.12
686 (test-basic-os linux-debian-6.12))
687
688
689;;;
690;;; Halt.
691;;;
692
693(define (run-halt-test vm)
694 ;; As reported in <http://bugs.gnu.org/26931>, running tmux would previously
695 ;; lead the 'stop' method of 'user-processes' to an infinite loop, with the
696 ;; tmux server process as a zombie that remains in the list of processes.
697 ;; This test reproduces this scenario.
698 (define test
699 (with-imported-modules '((gnu build marionette))
700 #~(begin
701 (use-modules (gnu build marionette))
702
703 (define marionette
704 (make-marionette '(#$vm)))
705
706 (define ocrad
707 #$(file-append ocrad "/bin/ocrad"))
708
709 ;; Wait for tty1 and log in.
710 (marionette-eval '(begin
711 (use-modules (gnu services herd))
712 (start-service 'term-tty1))
713 marionette)
714 (marionette-type "root\n" marionette)
715
716 ;; Start tmux and wait for it to be ready.
717 (marionette-type "tmux new-session 'echo 1 > /ready; bash'\n"
718 marionette)
719 (wait-for-file "/ready" marionette)
720
721 ;; Make sure to stop the test after a while.
722 (sigaction SIGALRM (lambda _
723 (format (current-error-port)
724 "FAIL: Time is up, but VM still running.\n")
725 (primitive-exit 1)))
726 (alarm 10)
727
728 ;; Get debugging info.
729 (marionette-eval '(current-output-port
730 (open-file "/dev/console" "w0"))
731 marionette)
732 (marionette-eval '(system* #$(file-append procps "/bin/ps")
733 "-eo" "pid,ppid,stat,comm")
734 marionette)
735
736 ;; See if 'halt' actually works.
737 (marionette-eval '(system* "/run/current-system/profile/sbin/halt")
738 marionette)
739
740 ;; If we reach this line, that means the VM was properly stopped in
741 ;; a timely fashion.
742 (alarm 0)
743 (call-with-output-file #$output
744 (lambda (port)
745 (display "success!" port))))))
746
747 (gexp->derivation "halt" test))
748
749(define %test-halt
750 (system-test
751 (name "halt")
752 (description
753 "Use the 'halt' command and make sure it succeeds and does not get stuck
754in a loop. See <http://bugs.gnu.org/26931>.")
755 (value
756 (let ((os (marionette-operating-system
757 (operating-system
758 (inherit %simple-os)
759 (packages (cons tmux %base-packages)))
760 #:imported-modules '((gnu services herd)
761 (guix combinators)))))
762 (run-halt-test (virtual-machine os))))))
763
764
765;;;
766;;; Root cleanly unmounted.
767;;;
768
769(define (run-root-unmount-test os)
770 (define test-image
771 (image (operating-system os)
772 (format 'compressed-qcow2)
773 (volatile-root? #f)
774 (shared-store? #f)
775 (partition-table-type 'mbr)
776 (partitions
777 (list (partition
778 (size 'guess)
779 (offset (* 512 2048)) ;leave room for GRUB
780 (flags '(boot))
781 (label "root-under-test")))))) ;max 16 characters!
782
783 (define observer-os
784 (marionette-operating-system
785 %simple-os
786 #:imported-modules
787 (source-module-closure '((guix build syscalls)
788 (gnu build file-systems)))))
789
790 (define test
791 (with-imported-modules (source-module-closure
792 '((gnu build marionette)
793 (guix build utils)))
794 #~(begin
795 (use-modules (gnu build marionette)
796 (guix build utils)
797 (srfi srfi-64)
798 (ice-9 ftw))
799
800 (define image
801 "/tmp/writable-image.qcow2")
802
803 (define (test-system-marionette)
804 ;; Return a marionette on a system where we'll run 'halt'.
805 (invoke #$(file-append qemu-minimal "/bin/qemu-img")
806 "create" "-f" "qcow2" image "3G"
807 "-b" #$(system-image test-image) "-F" "qcow2")
808 (make-marionette
809 `(,(string-append #$qemu-minimal "/bin/" (qemu-command))
810 ,@(if (file-exists? "/dev/kvm")
811 '("-enable-kvm")
812 '())
813 "-no-reboot"
814 "-m" "1024" ;memory size, in MiB
815 "-drive" ,(format #f "file=~a,if=virtio" image))))
816
817 (define witness-size
818 ;; Size of the /witness file.
819 (* 20 (expt 2 20)))
820
821 (test-runner-current (system-test-runner #$output))
822 (test-begin "root-unmount")
823
824 (let ((marionette (test-system-marionette)))
825 (test-assert "file created"
826 (marionette-eval `(begin
827 (use-modules (guix build utils))
828 (call-with-output-file "/witness"
829 (lambda (port)
830 (call-with-input-file "/dev/random"
831 (lambda (input)
832 (dump-port input port
833 ,witness-size))))))
834 marionette))
835
836 ;; Cause PID 1 to create a mapping to nscd's database files.
837 ;; Those mappings used to prevent 'root-file-system' to remount
838 ;; read-only on shutdown. See
839 ;; <https://codeberg.org/guix/guix/issues/4269>.
840 (test-equal "open libc NSS database"
841 "root"
842 (marionette-eval '(begin
843 (use-modules (gnu services herd))
844 (start-service 'nscd) ;wait for nscd
845 (eval-there '(passwd:name (getgr "root"))))
846 marionette))
847
848 ;; Halt the system.
849 (marionette-eval '(system* "/run/current-system/profile/sbin/halt")
850 marionette)
851
852 (display "waiting for marionette to complete...")
853 (force-output)
854 (false-if-exception (waitpid (marionette-pid marionette)))
855 (display " done\n")
856 (force-output))
857
858 ;; Remove the sockets used by the marionette above to avoid
859 ;; EADDRINUSE.
860 (for-each delete-file
861 (find-files "/tmp" (lambda (file stat)
862 (eq? (stat:type stat) 'socket))))
863
864 ;; Now boot another system and check whether the root file system of
865 ;; the first one was cleanly unmounted.
866
867 (let ((observer
868 (make-marionette (list #$(virtual-machine observer-os)
869 "-drive"
870 (format #f "file=~a,if=virtio" image)))))
871 (test-assert "partitions"
872 (marionette-eval '(begin
873 (use-modules (gnu build file-systems))
874 (disk-partitions))
875 observer))
876
877 (test-assert "partition found"
878 (marionette-eval '(find-partition-by-label "root-under-test")
879 observer))
880
881 (test-assert "root file system is clean"
882 (marionette-eval '(cleanly-unmounted-ext2?
883 (find-partition-by-label "root-under-test"))
884 observer))
885
886 (test-equal "root file system contains /witness"
887 witness-size
888 (let ((files (marionette-eval
889 '(begin
890 (use-modules (guix build syscalls)
891 (ice-9 ftw))
892 (mount (find-partition-by-label "root-under-test")
893 "/mnt" "ext4" MS_RDONLY)
894 (scandir "/mnt"))
895 observer)))
896 (if (member "witness" files)
897 (marionette-eval '(stat:size (stat "/mnt/witness"))
898 observer)
899 files))))
900
901 (test-end))))
902
903 (gexp->derivation "root-unmount" test))
904
905(define %test-root-unmount
906 (system-test
907 (name "root-unmount")
908 (description
909 "Make sure the root file system is cleanly unmounted when the system is
910halted.")
911 (value
912 (let ((os (marionette-operating-system
913 %simple-os
914 #:imported-modules '((gnu services herd)
915 (guix combinators)))))
916 (run-root-unmount-test os)))))
917
918
919;;;
920;;; Cleanup of /tmp, /var/run, etc.
921;;;
922
923(define %cleanup-os
924 (simple-operating-system
925 (simple-service 'dirty-things
926 boot-service-type
927 (let ((script (plain-file
928 "create-utf8-file.sh"
929 (string-append
930 "echo $0: dirtying /tmp...\n"
931 "set -e; set -x\n"
932 "touch /witness\n"
933 "exec touch /tmp/λαμβδα"))))
934 (with-imported-modules '((guix build utils))
935 #~(begin
936 (setenv "PATH"
937 #$(file-append coreutils "/bin"))
938 (invoke #$(file-append bash "/bin/sh")
939 #$script)))))))
940
941(define (run-cleanup-test name)
942 (define os
943 (marionette-operating-system %cleanup-os
944 #:imported-modules '((gnu services herd)
945 (guix combinators))))
946 (define test
947 (with-imported-modules '((gnu build marionette))
948 #~(begin
949 (use-modules (gnu build marionette)
950 (srfi srfi-64)
951 (ice-9 match))
952
953 (define marionette
954 (make-marionette (list #$(virtual-machine os))))
955
956 (test-runner-current (system-test-runner #$output))
957 (test-begin "cleanup")
958
959 (test-assert "dirty service worked"
960 (marionette-eval '(file-exists? "/witness") marionette))
961
962 (test-equal "/tmp cleaned up"
963 '("." "..")
964 (marionette-eval '(begin
965 (use-modules (ice-9 ftw))
966 (scandir "/tmp"))
967 marionette))
968
969 (test-end))))
970
971 (gexp->derivation "cleanup" test))
972
973(define %test-cleanup
974 ;; See <https://bugs.gnu.org/26353>.
975 (system-test
976 (name "cleanup")
977 (description "Make sure the 'cleanup' service can remove files with
978non-ASCII names from /tmp.")
979 (value (run-cleanup-test name))))
980
981
982;;;
983;;; Activation: Order of activation scripts
984;;; Create accounts before running scripts using them
985
986(define %activation-os
987 ;; System with a new user/group, a setuid/setgid binary and an activation script
988 (let* ((%hello-accounts
989 (list (user-group (name "hello") (system? #t))
990 (user-account
991 (name "hello")
992 (group "hello")
993 (system? #t)
994 (comment "")
995 (home-directory "/var/empty"))))
996 (%hello-privileged
997 (list
998 (privileged-program
999 (program (file-append hello "/bin/hello"))
1000 (setuid? #t)
1001 (setgid? #t)
1002 (user "hello")
1003 (group "hello"))))
1004 (%hello-activation
1005 (with-imported-modules (source-module-closure
1006 '((gnu build activation)))
1007 #~(begin
1008 (use-modules (gnu build activation))
1009
1010 (let ((user (getpwnam "hello")))
1011 (mkdir-p/perms "/run/hello" user #o755)))))
1012
1013 (hello-service-type
1014 (service-type
1015 (name 'hello)
1016 (extensions
1017 (list (service-extension account-service-type
1018 (const %hello-accounts))
1019 (service-extension activation-service-type
1020 (const %hello-activation))
1021 (service-extension privileged-program-service-type
1022 (const %hello-privileged))))
1023 (default-value #f)
1024 (description ""))))
1025
1026 (operating-system
1027 (inherit %simple-os)
1028 (services
1029 (cons* (service hello-service-type)
1030 (operating-system-user-services
1031 %simple-os))))))
1032
1033(define (run-activation-test name)
1034 (define os
1035 (marionette-operating-system
1036 %activation-os))
1037
1038 (define test
1039 (with-imported-modules '((gnu build marionette))
1040 #~(begin
1041 (use-modules (gnu build marionette)
1042 (srfi srfi-64))
1043
1044 (define marionette
1045 (make-marionette (list #$(virtual-machine os))))
1046
1047 (test-runner-current (system-test-runner #$output))
1048 (test-begin "activation")
1049
1050 (test-assert "directory exists"
1051 (marionette-eval
1052 '(file-exists? "/run/hello")
1053 marionette))
1054
1055 (test-assert "directory correct permissions and owner"
1056 (marionette-eval
1057 '(let ((dir (stat "/run/hello"))
1058 (user (getpwnam "hello")))
1059 (and (eqv? (stat:uid dir)
1060 (passwd:uid user))
1061 (eqv? (stat:gid dir)
1062 (passwd:gid user))
1063 (= (stat:perms dir)
1064 #o0755)))
1065 marionette))
1066
1067 (test-assert "privileged-program exists"
1068 (marionette-eval
1069 '(file-exists? "/run/privileged/bin/hello")
1070 marionette))
1071
1072 (test-assert "privileged-program correct permissions and owner"
1073 (marionette-eval
1074 '(let ((binary (stat "/run/privileged/bin/hello"))
1075 (user (getpwnam "hello"))
1076 (group (getgrnam "hello")))
1077 (and (eqv? (stat:uid binary)
1078 (passwd:uid user))
1079 (eqv? (stat:gid binary)
1080 (group:gid group))
1081 (= (stat:perms binary)
1082 (+ #o0555 ;; base
1083 #o4000 ;; setuid
1084 #o2000)))) ;; setgid
1085 marionette))
1086
1087 (test-end))))
1088
1089 (gexp->derivation name test))
1090
1091(define %test-activation
1092 (system-test
1093 (name "activation")
1094 (description "Test that activation scripts are run in the correct order")
1095 (value (run-activation-test name))))
1096
1097
1098;;;
1099;;; Build daemon.
1100;;;
1101
1102(define %daemon-os
1103 (operating-system-with-console-syslog
1104 (simple-operating-system)))
1105
1106(define (manifest-entry-without-grafts entry)
1107 "Return ENTRY with grafts disabled on its contents."
1108 (manifest-entry
1109 (inherit entry)
1110 (item (with-parameters ((%graft? #f))
1111 (manifest-entry-item entry)))))
1112
1113(define %hello-dependencies-manifest
1114 ;; Build dependencies of 'hello' needed to test 'guix build hello'.
1115 (concatenate-manifests
1116 (list (map-manifest-entries
1117 manifest-entry-without-grafts
1118 (package->development-manifest hello))
1119
1120 ;; Add the source of 'hello'.
1121 (manifest
1122 (list (manifest-entry
1123 (name "hello-source")
1124 (version (package-version hello))
1125 (item (let ((file (origin-actual-file-name
1126 (package-source hello))))
1127 (computed-file
1128 "hello-source"
1129 #~(begin
1130 ;; Put the tarball in a subdirectory since
1131 ;; profile union crashes otherwise.
1132 (mkdir #$output)
1133 (mkdir (in-vicinity #$output "src"))
1134 (symlink #$(package-source hello)
1135 (in-vicinity #$output
1136 (string-append "src/"
1137 #$file))))))))))
1138
1139 ;; Include 'guile-final', which is needed when building derivations
1140 ;; such as that of 'hello' but missing from the development manifest.
1141 ;; Add '%bootstrap-guile', used by 'guix install --bootstrap'.
1142 (map-manifest-entries
1143 manifest-entry-without-grafts
1144 (packages->manifest (list (canonical-package guile-3.0)
1145 %bootstrap-guile))))))
1146
1147(define (guix-daemon-test-cases marionette)
1148 "Return a gexp with SRFI-64 test cases testing guix-daemon. Those test are
1149evaluated in MARIONETTE, a gexp denoting a marionette (system under test).
1150Assume that an unprivileged account for 'user' exists on the system under
1151test."
1152 (define chown-snippet
1153 ;; XXX: This snippet exists primarily so that #$output is understood in
1154 ;; the right context.
1155 '(object->string
1156 `(begin
1157 (use-modules (guix)
1158 (gnu packages bootstrap))
1159 (computed-file "chown-to-supplementary-group"
1160 #~(begin
1161 (use-modules (srfi srfi-1))
1162
1163 ',(gettimeofday) ;nonce
1164 (let* ((groups (getgroups))
1165 (other (find (lambda (gid)
1166 (not (= gid (getgid))))
1167 (vector->list groups))))
1168 (format #t "attempting to chown \
1169to supplementary group ~a...~%" other)
1170 (pk 'supplementary-groups (getgroups)
1171 'gid (getgid) 'other other)
1172 (force-output)
1173 (mkdir "test")
1174 (chown "test" (getuid) other)
1175 (mkdir #$output)))
1176 #:guile %bootstrap-guile))))
1177
1178 #~(begin
1179 (test-equal "guix describe"
1180 0
1181 (marionette-eval '(system* "guix" "describe")
1182 #$marionette))
1183
1184 (test-equal "hello not already built"
1185 #f
1186 ;; Check that the next test will really build 'hello'.
1187 (marionette-eval '(file-exists?
1188 #$(with-parameters ((%graft? #f))
1189 hello))
1190 #$marionette))
1191
1192 (test-equal "guix build hello"
1193 0
1194 ;; Check that guix-daemon is up and running and that the build
1195 ;; environment is properly set up (build users, etc.).
1196 (marionette-eval '(system* "guix" "build" "hello" "--no-grafts")
1197 #$marionette))
1198
1199 (test-assert "hello indeed built"
1200 (marionette-eval '(file-exists?
1201 #$(with-parameters ((%graft? #f))
1202 hello))
1203 #$marionette))
1204
1205 (test-equal "kvm GID mapped"
1206 0
1207 ;; The "kvm" group should be among the supplementary groups of the
1208 ;; build user. Try to chown a file to that group; this fails with
1209 ;; EINVAL when running the unprivileged guix-daemon and the "kvm" GID
1210 ;; is not mapped in its user namespace. See
1211 ;; <https://bugs.gnu.org/77862>.
1212 (marionette-eval
1213 '(system* "guix" "build" "--no-grafts" "-e" #$chown-snippet)
1214 #$marionette))
1215
1216 (test-equal "guix install hello"
1217 0
1218 ;; Check that ~/.guix-profile & co. are properly created.
1219 (marionette-eval '(let ((pw (getpwuid (getuid))))
1220 (setenv "USER" (passwd:name pw))
1221 (setenv "HOME" (pk 'home (passwd:dir pw)))
1222 (system* "guix" "install" "hello"
1223 "--no-grafts" "--bootstrap"))
1224 #$marionette))
1225
1226 (test-equal "user profile created"
1227 0
1228 (marionette-eval '(system "ls -lad ~/.guix-profile")
1229 #$marionette))
1230
1231 (test-equal "hello"
1232 0
1233 (marionette-eval '(system "~/.guix-profile/bin/hello")
1234 #$marionette))
1235
1236 (test-equal "guix install hello, unprivileged user"
1237 0
1238 ;; Check that 'guix' is in $PATH for new users and that
1239 ;; ~user/.guix-profile also gets created, assuming that 'user' exists
1240 ;; as an unprivileged user account.
1241 (marionette-eval '(system "su - user -c \
1242'guix install hello --no-grafts --bootstrap'")
1243 #$marionette))
1244
1245 (test-equal "user hello"
1246 0
1247 (marionette-eval '(system "~user/.guix-profile/bin/hello")
1248 #$marionette))
1249
1250 (test-equal "unprivileged user profile created"
1251 0
1252 (marionette-eval '(system "ls -lad ~user/.guix-profile")
1253 #$marionette))
1254
1255 (test-equal "store is read-only"
1256 EROFS
1257 (marionette-eval '(catch 'system-error
1258 (lambda ()
1259 (mkdir (in-vicinity #$(%store-prefix)
1260 "whatever"))
1261 0)
1262 (lambda args
1263 (system-error-errno args)))
1264 #$marionette))))
1265
1266(define (run-guix-daemon-test os name)
1267 (define test-image
1268 (image (operating-system os)
1269 (format 'compressed-qcow2)
1270 (volatile-root? #f)
1271 (shared-store? #f)
1272 (partition-table-type 'mbr)
1273 (partitions
1274 (list (partition
1275 (size (* 4 (expt 2 30)))
1276 (offset (* 512 2048)) ;leave room for GRUB
1277 (flags '(boot))
1278 (label "root"))))))
1279
1280 (define test
1281 (with-imported-modules (source-module-closure
1282 '((gnu build marionette)
1283 (guix build utils)))
1284 #~(begin
1285 (use-modules (gnu build marionette)
1286 (guix build utils)
1287 (srfi srfi-64))
1288
1289 (define marionette
1290 (make-marionette
1291 (list (string-append #$qemu-minimal "/bin/" (qemu-command))
1292 #$@(common-qemu-options (system-image test-image) '()
1293 #:image-format "qcow2"
1294 #:rw-image? #t)
1295 "-m" "512"
1296 "-nographic" "-serial" "stdio"
1297 "-snapshot")))
1298
1299 (test-runner-current (system-test-runner #$output))
1300 (test-begin "guix-daemon")
1301
1302 (test-assert "guix-service is running"
1303 ;; Wait for 'guix-daemon' to be up.
1304 (marionette-eval '(begin
1305 (use-modules (gnu services herd))
1306 (start-service 'guix-daemon))
1307 marionette))
1308
1309 #$(guix-daemon-test-cases #~marionette)
1310
1311 (test-end))))
1312
1313 (gexp->derivation name test))
1314
1315(define %test-guix-daemon
1316 (system-test
1317 (name "guix-daemon")
1318 (description
1319 "Test 'guix-daemon' behavior on a multi-user system.")
1320 (value
1321 (let ((os (marionette-operating-system
1322 (operating-system
1323 (inherit (operating-system-with-gc-roots
1324 %daemon-os
1325 (list (profile
1326 (name "hello-build-dependencies")
1327 (content %hello-dependencies-manifest)))))
1328 (kernel-arguments '("console=ttyS0"))
1329 (users (cons (user-account
1330 (name "user")
1331 (group "users"))
1332 %base-user-accounts)))
1333 #:imported-modules '((gnu services herd)
1334 (guix combinators)))))
1335 (run-guix-daemon-test os "guix-daemon-test")))))
1336
1337(define %test-guix-daemon-unprivileged
1338 (system-test
1339 (name "guix-daemon-unprivileged")
1340 (description
1341 "Test 'guix-daemon' behavior on a multi-user system, where 'guix-daemon'
1342runs unprivileged.")
1343 (value
1344 (let ((os (marionette-operating-system
1345 (let ((base (operating-system-with-gc-roots
1346 %daemon-os
1347 (list (profile
1348 (name "hello-build-dependencies")
1349 (content %hello-dependencies-manifest))))))
1350 (operating-system
1351 (inherit base)
1352 (kernel-arguments '("console=ttyS0"))
1353 (users (cons (user-account
1354 (name "user")
1355 (group "users"))
1356 %base-user-accounts))
1357 (services
1358 (modify-services services
1359 (guix-service-type
1360 config => (guix-configuration
1361 (inherit config)
1362 (privileged? #f)))))))
1363 #:imported-modules '((gnu services herd)
1364 (guix combinators)))))
1365 (run-guix-daemon-test os "guix-daemon-unprivileged-test")))))
1366
1367(define %test-missing-file-system
1368 (system-test
1369 (name "missing-file-system")
1370 (description
1371 "Test that boot does not fail when a file system that might fail
1372is specified and isn't provided by any device.")
1373 (value
1374 (let* ((os (marionette-operating-system
1375 (operating-system
1376 (inherit %simple-os)
1377 (kernel-arguments (list "console=ttyS0,115200"))
1378 (file-systems
1379 (cons* (file-system
1380 (device (uuid "abcdef12-3456-7890-abcd-ef1234567890"))
1381 (mount-point "/somewhere/1")
1382 (mount? #t)
1383 (mount-may-fail? #t)
1384 (type "ext4"))
1385 (file-system
1386 (device (file-system-label "missing-fs"))
1387 (mount-point "/somewhere/2")
1388 (mount? #t)
1389 (mount-may-fail? #t)
1390 (type "ext4"))
1391 (file-system
1392 (device "/dev/missing")
1393 (mount-point "/somewhere/3")
1394 (mount? #t)
1395 (mount-may-fail? #t)
1396 (type "ext4"))
1397 (file-system
1398 (device (file-system-label "my-root"))
1399 (mount-point "/")
1400 (type "ext4"))
1401 %base-file-systems)))
1402 #:imported-modules '((gnu services herd)
1403 (guix combinators))))
1404 (image (system-image (os->image os #:type qcow2-image-type)))
1405 (command
1406 #~`(,(string-append #$qemu-minimal "/bin/" (qemu-command))
1407 ,@(if (file-exists? "/dev/kvm")
1408 '("-enable-kvm")
1409 '())
1410 "-m" "1024" ;memory size, in MiB
1411 "-serial" "stdio"
1412 "-snapshot" ;for volatile root, writable overlay
1413 "-drive" ,(format #f "file=~a,if=virtio" #$image))))
1414 (run-basic-test os command name)))))