projects/guix·blob ruby-team · refs

1410 lines · 56.0 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 -f /etc/bashrc.d/test_bashrc_d.sh
662test \"$BASHRC_D_OK\" = yes"))
663 #$marionette))))))))))
664
665(define %test-basic-os
666 (test-basic-os))
667
668;; Ensure the LTS kernels are up to snuff, too.
669(define %test-linux-libre-6.18
670 (test-basic-os linux-libre-6.18))
671
672(define %test-linux-libre-6.12
673 (test-basic-os linux-libre-6.12))
674
675(define %test-linux-libre-6.6
676 (test-basic-os linux-libre-6.6))
677
678(define %test-linux-libre-6.1
679 (test-basic-os linux-libre-6.1))
680
681(define %test-linux-debian-6.12
682 (test-basic-os linux-debian-6.12))
683
684
685;;;
686;;; Halt.
687;;;
688
689(define (run-halt-test vm)
690 ;; As reported in <http://bugs.gnu.org/26931>, running tmux would previously
691 ;; lead the 'stop' method of 'user-processes' to an infinite loop, with the
692 ;; tmux server process as a zombie that remains in the list of processes.
693 ;; This test reproduces this scenario.
694 (define test
695 (with-imported-modules '((gnu build marionette))
696 #~(begin
697 (use-modules (gnu build marionette))
698
699 (define marionette
700 (make-marionette '(#$vm)))
701
702 (define ocrad
703 #$(file-append ocrad "/bin/ocrad"))
704
705 ;; Wait for tty1 and log in.
706 (marionette-eval '(begin
707 (use-modules (gnu services herd))
708 (start-service 'term-tty1))
709 marionette)
710 (marionette-type "root\n" marionette)
711
712 ;; Start tmux and wait for it to be ready.
713 (marionette-type "tmux new-session 'echo 1 > /ready; bash'\n"
714 marionette)
715 (wait-for-file "/ready" marionette)
716
717 ;; Make sure to stop the test after a while.
718 (sigaction SIGALRM (lambda _
719 (format (current-error-port)
720 "FAIL: Time is up, but VM still running.\n")
721 (primitive-exit 1)))
722 (alarm 10)
723
724 ;; Get debugging info.
725 (marionette-eval '(current-output-port
726 (open-file "/dev/console" "w0"))
727 marionette)
728 (marionette-eval '(system* #$(file-append procps "/bin/ps")
729 "-eo" "pid,ppid,stat,comm")
730 marionette)
731
732 ;; See if 'halt' actually works.
733 (marionette-eval '(system* "/run/current-system/profile/sbin/halt")
734 marionette)
735
736 ;; If we reach this line, that means the VM was properly stopped in
737 ;; a timely fashion.
738 (alarm 0)
739 (call-with-output-file #$output
740 (lambda (port)
741 (display "success!" port))))))
742
743 (gexp->derivation "halt" test))
744
745(define %test-halt
746 (system-test
747 (name "halt")
748 (description
749 "Use the 'halt' command and make sure it succeeds and does not get stuck
750in a loop. See <http://bugs.gnu.org/26931>.")
751 (value
752 (let ((os (marionette-operating-system
753 (operating-system
754 (inherit %simple-os)
755 (packages (cons tmux %base-packages)))
756 #:imported-modules '((gnu services herd)
757 (guix combinators)))))
758 (run-halt-test (virtual-machine os))))))
759
760
761;;;
762;;; Root cleanly unmounted.
763;;;
764
765(define (run-root-unmount-test os)
766 (define test-image
767 (image (operating-system os)
768 (format 'compressed-qcow2)
769 (volatile-root? #f)
770 (shared-store? #f)
771 (partition-table-type 'mbr)
772 (partitions
773 (list (partition
774 (size 'guess)
775 (offset (* 512 2048)) ;leave room for GRUB
776 (flags '(boot))
777 (label "root-under-test")))))) ;max 16 characters!
778
779 (define observer-os
780 (marionette-operating-system
781 %simple-os
782 #:imported-modules
783 (source-module-closure '((guix build syscalls)
784 (gnu build file-systems)))))
785
786 (define test
787 (with-imported-modules (source-module-closure
788 '((gnu build marionette)
789 (guix build utils)))
790 #~(begin
791 (use-modules (gnu build marionette)
792 (guix build utils)
793 (srfi srfi-64)
794 (ice-9 ftw))
795
796 (define image
797 "/tmp/writable-image.qcow2")
798
799 (define (test-system-marionette)
800 ;; Return a marionette on a system where we'll run 'halt'.
801 (invoke #$(file-append qemu-minimal "/bin/qemu-img")
802 "create" "-f" "qcow2" image "3G"
803 "-b" #$(system-image test-image) "-F" "qcow2")
804 (make-marionette
805 `(,(string-append #$qemu-minimal "/bin/" (qemu-command))
806 ,@(if (file-exists? "/dev/kvm")
807 '("-enable-kvm")
808 '())
809 "-no-reboot"
810 "-m" "1024" ;memory size, in MiB
811 "-drive" ,(format #f "file=~a,if=virtio" image))))
812
813 (define witness-size
814 ;; Size of the /witness file.
815 (* 20 (expt 2 20)))
816
817 (test-runner-current (system-test-runner #$output))
818 (test-begin "root-unmount")
819
820 (let ((marionette (test-system-marionette)))
821 (test-assert "file created"
822 (marionette-eval `(begin
823 (use-modules (guix build utils))
824 (call-with-output-file "/witness"
825 (lambda (port)
826 (call-with-input-file "/dev/random"
827 (lambda (input)
828 (dump-port input port
829 ,witness-size))))))
830 marionette))
831
832 ;; Cause PID 1 to create a mapping to nscd's database files.
833 ;; Those mappings used to prevent 'root-file-system' to remount
834 ;; read-only on shutdown. See
835 ;; <https://codeberg.org/guix/guix/issues/4269>.
836 (test-equal "open libc NSS database"
837 "root"
838 (marionette-eval '(begin
839 (use-modules (gnu services herd))
840 (start-service 'nscd) ;wait for nscd
841 (eval-there '(passwd:name (getgr "root"))))
842 marionette))
843
844 ;; Halt the system.
845 (marionette-eval '(system* "/run/current-system/profile/sbin/halt")
846 marionette)
847
848 (display "waiting for marionette to complete...")
849 (force-output)
850 (false-if-exception (waitpid (marionette-pid marionette)))
851 (display " done\n")
852 (force-output))
853
854 ;; Remove the sockets used by the marionette above to avoid
855 ;; EADDRINUSE.
856 (for-each delete-file
857 (find-files "/tmp" (lambda (file stat)
858 (eq? (stat:type stat) 'socket))))
859
860 ;; Now boot another system and check whether the root file system of
861 ;; the first one was cleanly unmounted.
862
863 (let ((observer
864 (make-marionette (list #$(virtual-machine observer-os)
865 "-drive"
866 (format #f "file=~a,if=virtio" image)))))
867 (test-assert "partitions"
868 (marionette-eval '(begin
869 (use-modules (gnu build file-systems))
870 (disk-partitions))
871 observer))
872
873 (test-assert "partition found"
874 (marionette-eval '(find-partition-by-label "root-under-test")
875 observer))
876
877 (test-assert "root file system is clean"
878 (marionette-eval '(cleanly-unmounted-ext2?
879 (find-partition-by-label "root-under-test"))
880 observer))
881
882 (test-equal "root file system contains /witness"
883 witness-size
884 (let ((files (marionette-eval
885 '(begin
886 (use-modules (guix build syscalls)
887 (ice-9 ftw))
888 (mount (find-partition-by-label "root-under-test")
889 "/mnt" "ext4" MS_RDONLY)
890 (scandir "/mnt"))
891 observer)))
892 (if (member "witness" files)
893 (marionette-eval '(stat:size (stat "/mnt/witness"))
894 observer)
895 files))))
896
897 (test-end))))
898
899 (gexp->derivation "root-unmount" test))
900
901(define %test-root-unmount
902 (system-test
903 (name "root-unmount")
904 (description
905 "Make sure the root file system is cleanly unmounted when the system is
906halted.")
907 (value
908 (let ((os (marionette-operating-system
909 %simple-os
910 #:imported-modules '((gnu services herd)
911 (guix combinators)))))
912 (run-root-unmount-test os)))))
913
914
915;;;
916;;; Cleanup of /tmp, /var/run, etc.
917;;;
918
919(define %cleanup-os
920 (simple-operating-system
921 (simple-service 'dirty-things
922 boot-service-type
923 (let ((script (plain-file
924 "create-utf8-file.sh"
925 (string-append
926 "echo $0: dirtying /tmp...\n"
927 "set -e; set -x\n"
928 "touch /witness\n"
929 "exec touch /tmp/λαμβδα"))))
930 (with-imported-modules '((guix build utils))
931 #~(begin
932 (setenv "PATH"
933 #$(file-append coreutils "/bin"))
934 (invoke #$(file-append bash "/bin/sh")
935 #$script)))))))
936
937(define (run-cleanup-test name)
938 (define os
939 (marionette-operating-system %cleanup-os
940 #:imported-modules '((gnu services herd)
941 (guix combinators))))
942 (define test
943 (with-imported-modules '((gnu build marionette))
944 #~(begin
945 (use-modules (gnu build marionette)
946 (srfi srfi-64)
947 (ice-9 match))
948
949 (define marionette
950 (make-marionette (list #$(virtual-machine os))))
951
952 (test-runner-current (system-test-runner #$output))
953 (test-begin "cleanup")
954
955 (test-assert "dirty service worked"
956 (marionette-eval '(file-exists? "/witness") marionette))
957
958 (test-equal "/tmp cleaned up"
959 '("." "..")
960 (marionette-eval '(begin
961 (use-modules (ice-9 ftw))
962 (scandir "/tmp"))
963 marionette))
964
965 (test-end))))
966
967 (gexp->derivation "cleanup" test))
968
969(define %test-cleanup
970 ;; See <https://bugs.gnu.org/26353>.
971 (system-test
972 (name "cleanup")
973 (description "Make sure the 'cleanup' service can remove files with
974non-ASCII names from /tmp.")
975 (value (run-cleanup-test name))))
976
977
978;;;
979;;; Activation: Order of activation scripts
980;;; Create accounts before running scripts using them
981
982(define %activation-os
983 ;; System with a new user/group, a setuid/setgid binary and an activation script
984 (let* ((%hello-accounts
985 (list (user-group (name "hello") (system? #t))
986 (user-account
987 (name "hello")
988 (group "hello")
989 (system? #t)
990 (comment "")
991 (home-directory "/var/empty"))))
992 (%hello-privileged
993 (list
994 (privileged-program
995 (program (file-append hello "/bin/hello"))
996 (setuid? #t)
997 (setgid? #t)
998 (user "hello")
999 (group "hello"))))
1000 (%hello-activation
1001 (with-imported-modules (source-module-closure
1002 '((gnu build activation)))
1003 #~(begin
1004 (use-modules (gnu build activation))
1005
1006 (let ((user (getpwnam "hello")))
1007 (mkdir-p/perms "/run/hello" user #o755)))))
1008
1009 (hello-service-type
1010 (service-type
1011 (name 'hello)
1012 (extensions
1013 (list (service-extension account-service-type
1014 (const %hello-accounts))
1015 (service-extension activation-service-type
1016 (const %hello-activation))
1017 (service-extension privileged-program-service-type
1018 (const %hello-privileged))))
1019 (default-value #f)
1020 (description ""))))
1021
1022 (operating-system
1023 (inherit %simple-os)
1024 (services
1025 (cons* (service hello-service-type)
1026 (operating-system-user-services
1027 %simple-os))))))
1028
1029(define (run-activation-test name)
1030 (define os
1031 (marionette-operating-system
1032 %activation-os))
1033
1034 (define test
1035 (with-imported-modules '((gnu build marionette))
1036 #~(begin
1037 (use-modules (gnu build marionette)
1038 (srfi srfi-64))
1039
1040 (define marionette
1041 (make-marionette (list #$(virtual-machine os))))
1042
1043 (test-runner-current (system-test-runner #$output))
1044 (test-begin "activation")
1045
1046 (test-assert "directory exists"
1047 (marionette-eval
1048 '(file-exists? "/run/hello")
1049 marionette))
1050
1051 (test-assert "directory correct permissions and owner"
1052 (marionette-eval
1053 '(let ((dir (stat "/run/hello"))
1054 (user (getpwnam "hello")))
1055 (and (eqv? (stat:uid dir)
1056 (passwd:uid user))
1057 (eqv? (stat:gid dir)
1058 (passwd:gid user))
1059 (= (stat:perms dir)
1060 #o0755)))
1061 marionette))
1062
1063 (test-assert "privileged-program exists"
1064 (marionette-eval
1065 '(file-exists? "/run/privileged/bin/hello")
1066 marionette))
1067
1068 (test-assert "privileged-program correct permissions and owner"
1069 (marionette-eval
1070 '(let ((binary (stat "/run/privileged/bin/hello"))
1071 (user (getpwnam "hello"))
1072 (group (getgrnam "hello")))
1073 (and (eqv? (stat:uid binary)
1074 (passwd:uid user))
1075 (eqv? (stat:gid binary)
1076 (group:gid group))
1077 (= (stat:perms binary)
1078 (+ #o0555 ;; base
1079 #o4000 ;; setuid
1080 #o2000)))) ;; setgid
1081 marionette))
1082
1083 (test-end))))
1084
1085 (gexp->derivation name test))
1086
1087(define %test-activation
1088 (system-test
1089 (name "activation")
1090 (description "Test that activation scripts are run in the correct order")
1091 (value (run-activation-test name))))
1092
1093
1094;;;
1095;;; Build daemon.
1096;;;
1097
1098(define %daemon-os
1099 (operating-system-with-console-syslog
1100 (simple-operating-system)))
1101
1102(define (manifest-entry-without-grafts entry)
1103 "Return ENTRY with grafts disabled on its contents."
1104 (manifest-entry
1105 (inherit entry)
1106 (item (with-parameters ((%graft? #f))
1107 (manifest-entry-item entry)))))
1108
1109(define %hello-dependencies-manifest
1110 ;; Build dependencies of 'hello' needed to test 'guix build hello'.
1111 (concatenate-manifests
1112 (list (map-manifest-entries
1113 manifest-entry-without-grafts
1114 (package->development-manifest hello))
1115
1116 ;; Add the source of 'hello'.
1117 (manifest
1118 (list (manifest-entry
1119 (name "hello-source")
1120 (version (package-version hello))
1121 (item (let ((file (origin-actual-file-name
1122 (package-source hello))))
1123 (computed-file
1124 "hello-source"
1125 #~(begin
1126 ;; Put the tarball in a subdirectory since
1127 ;; profile union crashes otherwise.
1128 (mkdir #$output)
1129 (mkdir (in-vicinity #$output "src"))
1130 (symlink #$(package-source hello)
1131 (in-vicinity #$output
1132 (string-append "src/"
1133 #$file))))))))))
1134
1135 ;; Include 'guile-final', which is needed when building derivations
1136 ;; such as that of 'hello' but missing from the development manifest.
1137 ;; Add '%bootstrap-guile', used by 'guix install --bootstrap'.
1138 (map-manifest-entries
1139 manifest-entry-without-grafts
1140 (packages->manifest (list (canonical-package guile-3.0)
1141 %bootstrap-guile))))))
1142
1143(define (guix-daemon-test-cases marionette)
1144 "Return a gexp with SRFI-64 test cases testing guix-daemon. Those test are
1145evaluated in MARIONETTE, a gexp denoting a marionette (system under test).
1146Assume that an unprivileged account for 'user' exists on the system under
1147test."
1148 (define chown-snippet
1149 ;; XXX: This snippet exists primarily so that #$output is understood in
1150 ;; the right context.
1151 '(object->string
1152 `(begin
1153 (use-modules (guix)
1154 (gnu packages bootstrap))
1155 (computed-file "chown-to-supplementary-group"
1156 #~(begin
1157 (use-modules (srfi srfi-1))
1158
1159 ',(gettimeofday) ;nonce
1160 (let* ((groups (getgroups))
1161 (other (find (lambda (gid)
1162 (not (= gid (getgid))))
1163 (vector->list groups))))
1164 (format #t "attempting to chown \
1165to supplementary group ~a...~%" other)
1166 (pk 'supplementary-groups (getgroups)
1167 'gid (getgid) 'other other)
1168 (force-output)
1169 (mkdir "test")
1170 (chown "test" (getuid) other)
1171 (mkdir #$output)))
1172 #:guile %bootstrap-guile))))
1173
1174 #~(begin
1175 (test-equal "guix describe"
1176 0
1177 (marionette-eval '(system* "guix" "describe")
1178 #$marionette))
1179
1180 (test-equal "hello not already built"
1181 #f
1182 ;; Check that the next test will really build 'hello'.
1183 (marionette-eval '(file-exists?
1184 #$(with-parameters ((%graft? #f))
1185 hello))
1186 #$marionette))
1187
1188 (test-equal "guix build hello"
1189 0
1190 ;; Check that guix-daemon is up and running and that the build
1191 ;; environment is properly set up (build users, etc.).
1192 (marionette-eval '(system* "guix" "build" "hello" "--no-grafts")
1193 #$marionette))
1194
1195 (test-assert "hello indeed built"
1196 (marionette-eval '(file-exists?
1197 #$(with-parameters ((%graft? #f))
1198 hello))
1199 #$marionette))
1200
1201 (test-equal "kvm GID mapped"
1202 0
1203 ;; The "kvm" group should be among the supplementary groups of the
1204 ;; build user. Try to chown a file to that group; this fails with
1205 ;; EINVAL when running the unprivileged guix-daemon and the "kvm" GID
1206 ;; is not mapped in its user namespace. See
1207 ;; <https://bugs.gnu.org/77862>.
1208 (marionette-eval
1209 '(system* "guix" "build" "--no-grafts" "-e" #$chown-snippet)
1210 #$marionette))
1211
1212 (test-equal "guix install hello"
1213 0
1214 ;; Check that ~/.guix-profile & co. are properly created.
1215 (marionette-eval '(let ((pw (getpwuid (getuid))))
1216 (setenv "USER" (passwd:name pw))
1217 (setenv "HOME" (pk 'home (passwd:dir pw)))
1218 (system* "guix" "install" "hello"
1219 "--no-grafts" "--bootstrap"))
1220 #$marionette))
1221
1222 (test-equal "user profile created"
1223 0
1224 (marionette-eval '(system "ls -lad ~/.guix-profile")
1225 #$marionette))
1226
1227 (test-equal "hello"
1228 0
1229 (marionette-eval '(system "~/.guix-profile/bin/hello")
1230 #$marionette))
1231
1232 (test-equal "guix install hello, unprivileged user"
1233 0
1234 ;; Check that 'guix' is in $PATH for new users and that
1235 ;; ~user/.guix-profile also gets created, assuming that 'user' exists
1236 ;; as an unprivileged user account.
1237 (marionette-eval '(system "su - user -c \
1238'guix install hello --no-grafts --bootstrap'")
1239 #$marionette))
1240
1241 (test-equal "user hello"
1242 0
1243 (marionette-eval '(system "~user/.guix-profile/bin/hello")
1244 #$marionette))
1245
1246 (test-equal "unprivileged user profile created"
1247 0
1248 (marionette-eval '(system "ls -lad ~user/.guix-profile")
1249 #$marionette))
1250
1251 (test-equal "store is read-only"
1252 EROFS
1253 (marionette-eval '(catch 'system-error
1254 (lambda ()
1255 (mkdir (in-vicinity #$(%store-prefix)
1256 "whatever"))
1257 0)
1258 (lambda args
1259 (system-error-errno args)))
1260 #$marionette))))
1261
1262(define (run-guix-daemon-test os name)
1263 (define test-image
1264 (image (operating-system os)
1265 (format 'compressed-qcow2)
1266 (volatile-root? #f)
1267 (shared-store? #f)
1268 (partition-table-type 'mbr)
1269 (partitions
1270 (list (partition
1271 (size (* 4 (expt 2 30)))
1272 (offset (* 512 2048)) ;leave room for GRUB
1273 (flags '(boot))
1274 (label "root"))))))
1275
1276 (define test
1277 (with-imported-modules (source-module-closure
1278 '((gnu build marionette)
1279 (guix build utils)))
1280 #~(begin
1281 (use-modules (gnu build marionette)
1282 (guix build utils)
1283 (srfi srfi-64))
1284
1285 (define marionette
1286 (make-marionette
1287 (list (string-append #$qemu-minimal "/bin/" (qemu-command))
1288 #$@(common-qemu-options (system-image test-image) '()
1289 #:image-format "qcow2"
1290 #:rw-image? #t)
1291 "-m" "512"
1292 "-nographic" "-serial" "stdio"
1293 "-snapshot")))
1294
1295 (test-runner-current (system-test-runner #$output))
1296 (test-begin "guix-daemon")
1297
1298 (test-assert "guix-service is running"
1299 ;; Wait for 'guix-daemon' to be up.
1300 (marionette-eval '(begin
1301 (use-modules (gnu services herd))
1302 (start-service 'guix-daemon))
1303 marionette))
1304
1305 #$(guix-daemon-test-cases #~marionette)
1306
1307 (test-end))))
1308
1309 (gexp->derivation name test))
1310
1311(define %test-guix-daemon
1312 (system-test
1313 (name "guix-daemon")
1314 (description
1315 "Test 'guix-daemon' behavior on a multi-user system.")
1316 (value
1317 (let ((os (marionette-operating-system
1318 (operating-system
1319 (inherit (operating-system-with-gc-roots
1320 %daemon-os
1321 (list (profile
1322 (name "hello-build-dependencies")
1323 (content %hello-dependencies-manifest)))))
1324 (kernel-arguments '("console=ttyS0"))
1325 (users (cons (user-account
1326 (name "user")
1327 (group "users"))
1328 %base-user-accounts)))
1329 #:imported-modules '((gnu services herd)
1330 (guix combinators)))))
1331 (run-guix-daemon-test os "guix-daemon-test")))))
1332
1333(define %test-guix-daemon-unprivileged
1334 (system-test
1335 (name "guix-daemon-unprivileged")
1336 (description
1337 "Test 'guix-daemon' behavior on a multi-user system, where 'guix-daemon'
1338runs unprivileged.")
1339 (value
1340 (let ((os (marionette-operating-system
1341 (let ((base (operating-system-with-gc-roots
1342 %daemon-os
1343 (list (profile
1344 (name "hello-build-dependencies")
1345 (content %hello-dependencies-manifest))))))
1346 (operating-system
1347 (inherit base)
1348 (kernel-arguments '("console=ttyS0"))
1349 (users (cons (user-account
1350 (name "user")
1351 (group "users"))
1352 %base-user-accounts))
1353 (services
1354 (modify-services services
1355 (guix-service-type
1356 config => (guix-configuration
1357 (inherit config)
1358 (privileged? #f)))))))
1359 #:imported-modules '((gnu services herd)
1360 (guix combinators)))))
1361 (run-guix-daemon-test os "guix-daemon-unprivileged-test")))))
1362
1363(define %test-missing-file-system
1364 (system-test
1365 (name "missing-file-system")
1366 (description
1367 "Test that boot does not fail when a file system that might fail
1368is specified and isn't provided by any device.")
1369 (value
1370 (let* ((os (marionette-operating-system
1371 (operating-system
1372 (inherit %simple-os)
1373 (kernel-arguments (list "console=ttyS0,115200"))
1374 (file-systems
1375 (cons* (file-system
1376 (device (uuid "abcdef12-3456-7890-abcd-ef1234567890"))
1377 (mount-point "/somewhere/1")
1378 (mount? #t)
1379 (mount-may-fail? #t)
1380 (type "ext4"))
1381 (file-system
1382 (device (file-system-label "missing-fs"))
1383 (mount-point "/somewhere/2")
1384 (mount? #t)
1385 (mount-may-fail? #t)
1386 (type "ext4"))
1387 (file-system
1388 (device "/dev/missing")
1389 (mount-point "/somewhere/3")
1390 (mount? #t)
1391 (mount-may-fail? #t)
1392 (type "ext4"))
1393 (file-system
1394 (device (file-system-label "my-root"))
1395 (mount-point "/")
1396 (type "ext4"))
1397 %base-file-systems)))
1398 #:imported-modules '((gnu services herd)
1399 (guix combinators))))
1400 (image (system-image (os->image os #:type qcow2-image-type)))
1401 (command
1402 #~`(,(string-append #$qemu-minimal "/bin/" (qemu-command))
1403 ,@(if (file-exists? "/dev/kvm")
1404 '("-enable-kvm")
1405 '())
1406 "-m" "1024" ;memory size, in MiB
1407 "-serial" "stdio"
1408 "-snapshot" ;for volatile root, writable overlay
1409 "-drive" ,(format #f "file=~a,if=virtio" #$image))))
1410 (run-basic-test os command name)))))