| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
| 3 | ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> |
| 4 | ;;; |
| 5 | ;;; This file is part of GNU Guix. |
| 6 | ;;; |
| 7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
| 8 | ;;; under the terms of the GNU General Public License as published by |
| 9 | ;;; the Free Software Foundation; either version 3 of the License, or (at |
| 10 | ;;; your option) any later version. |
| 11 | ;;; |
| 12 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
| 13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
| 14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 15 | ;;; GNU General Public License for more details. |
| 16 | ;;; |
| 17 | ;;; You should have received a copy of the GNU General Public License |
| 18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
| 19 | |
| 20 | (define-module (gnu tests base) |
| 21 | #:use-module (gnu tests) |
| 22 | #:use-module (gnu system) |
| 23 | #:use-module (gnu system shadow) |
| 24 | #:use-module (gnu system nss) |
| 25 | #:use-module (gnu system vm) |
| 26 | #:use-module (gnu services) |
| 27 | #:use-module (gnu services base) |
| 28 | #:use-module (gnu services dbus) |
| 29 | #:use-module (gnu services avahi) |
| 30 | #:use-module (gnu services mcron) |
| 31 | #:use-module (gnu services shepherd) |
| 32 | #:use-module (gnu services networking) |
| 33 | #:use-module (gnu packages base) |
| 34 | #:use-module (gnu packages bash) |
| 35 | #:use-module (gnu packages imagemagick) |
| 36 | #:use-module (gnu packages ocr) |
| 37 | #:use-module (gnu packages package-management) |
| 38 | #:use-module (gnu packages linux) |
| 39 | #:use-module (gnu packages tmux) |
| 40 | #:use-module (guix gexp) |
| 41 | #:use-module (guix store) |
| 42 | #:use-module (guix monads) |
| 43 | #:use-module (guix packages) |
| 44 | #:use-module (srfi srfi-1) |
| 45 | #:use-module (ice-9 match) |
| 46 | #:export (run-basic-test |
| 47 | %test-basic-os |
| 48 | %test-halt |
| 49 | %test-cleanup |
| 50 | %test-mcron |
| 51 | %test-nss-mdns)) |
| 52 | |
| 53 | (define %simple-os |
| 54 | (simple-operating-system)) |
| 55 | |
| 56 | \f |
| 57 | (define* (run-basic-test os command #:optional (name "basic") |
| 58 | #:key |
| 59 | initialization |
| 60 | root-password |
| 61 | desktop?) |
| 62 | "Return a derivation called NAME that tests basic features of the OS started |
| 63 | using COMMAND, a gexp that evaluates to a list of strings. Compare some |
| 64 | properties of running system to what's declared in OS, an <operating-system>. |
| 65 | |
| 66 | When INITIALIZATION is true, it must be a one-argument procedure that is |
| 67 | passed a gexp denoting the marionette, and it must return gexp that is |
| 68 | inserted before the first test. This is used to introduce an extra |
| 69 | initialization step, such as entering a LUKS passphrase. |
| 70 | |
| 71 | When ROOT-PASSWORD is true, enter it as the root password when logging in. |
| 72 | Otherwise assume that there is no password for root." |
| 73 | (define special-files |
| 74 | (service-value |
| 75 | (fold-services (operating-system-services os) |
| 76 | #:target-type special-files-service-type))) |
| 77 | |
| 78 | (define guix&co |
| 79 | (match (package-transitive-propagated-inputs guix) |
| 80 | (((labels packages) ...) |
| 81 | (cons guix packages)))) |
| 82 | |
| 83 | (define test |
| 84 | (with-imported-modules '((gnu build marionette) |
| 85 | (guix build syscalls)) |
| 86 | #~(begin |
| 87 | (use-modules (gnu build marionette) |
| 88 | (guix build syscalls) |
| 89 | (srfi srfi-1) |
| 90 | (srfi srfi-26) |
| 91 | (srfi srfi-64) |
| 92 | (ice-9 match)) |
| 93 | |
| 94 | (define marionette |
| 95 | (make-marionette #$command)) |
| 96 | |
| 97 | (mkdir #$output) |
| 98 | (chdir #$output) |
| 99 | |
| 100 | (test-begin "basic") |
| 101 | |
| 102 | #$(and initialization |
| 103 | (initialization #~marionette)) |
| 104 | |
| 105 | (test-assert "uname" |
| 106 | (match (marionette-eval '(uname) marionette) |
| 107 | (#("Linux" host-name version _ architecture) |
| 108 | (and (string=? host-name |
| 109 | #$(operating-system-host-name os)) |
| 110 | (string-prefix? #$(package-version |
| 111 | (operating-system-kernel os)) |
| 112 | version) |
| 113 | (string-prefix? architecture %host-type))))) |
| 114 | |
| 115 | ;; Shepherd reads the config file *before* binding its control |
| 116 | ;; socket, so /var/run/shepherd/socket might not exist yet when the |
| 117 | ;; 'marionette' service is started. |
| 118 | (test-assert "shepherd socket ready" |
| 119 | (marionette-eval |
| 120 | `(begin |
| 121 | (use-modules (gnu services herd)) |
| 122 | (let loop ((i 10)) |
| 123 | (cond ((file-exists? (%shepherd-socket-file)) |
| 124 | #t) |
| 125 | ((> i 0) |
| 126 | (sleep 1) |
| 127 | (loop (- i 1))) |
| 128 | (else |
| 129 | #f)))) |
| 130 | marionette)) |
| 131 | |
| 132 | (test-eq "stdin is /dev/null" |
| 133 | 'eof |
| 134 | ;; Make sure services can no longer read from stdin once the |
| 135 | ;; system has booted. |
| 136 | (marionette-eval |
| 137 | `(begin |
| 138 | (use-modules (gnu services herd)) |
| 139 | (start 'user-processes) |
| 140 | ((@@ (gnu services herd) eval-there) |
| 141 | '(let ((result (read (current-input-port)))) |
| 142 | (if (eof-object? result) |
| 143 | 'eof |
| 144 | result)))) |
| 145 | marionette)) |
| 146 | |
| 147 | (test-assert "shell and user commands" |
| 148 | ;; Is everything in $PATH? |
| 149 | (zero? (marionette-eval '(system " |
| 150 | . /etc/profile |
| 151 | set -e -x |
| 152 | guix --version |
| 153 | ls --version |
| 154 | grep --version |
| 155 | info --version") |
| 156 | marionette))) |
| 157 | |
| 158 | (test-equal "special files" |
| 159 | '#$special-files |
| 160 | (marionette-eval |
| 161 | '(begin |
| 162 | (use-modules (ice-9 match)) |
| 163 | |
| 164 | (map (match-lambda |
| 165 | ((file target) |
| 166 | (list file (readlink file)))) |
| 167 | '#$special-files)) |
| 168 | marionette)) |
| 169 | |
| 170 | (test-assert "accounts" |
| 171 | (let ((users (marionette-eval '(begin |
| 172 | (use-modules (ice-9 match)) |
| 173 | (let loop ((result '())) |
| 174 | (match (getpw) |
| 175 | (#f (reverse result)) |
| 176 | (x (loop (cons x result)))))) |
| 177 | marionette))) |
| 178 | (lset= equal? |
| 179 | (map (lambda (user) |
| 180 | (list (passwd:name user) |
| 181 | (passwd:dir user))) |
| 182 | users) |
| 183 | (list |
| 184 | #$@(map (lambda (account) |
| 185 | `(list ,(user-account-name account) |
| 186 | ,(user-account-home-directory account))) |
| 187 | (operating-system-user-accounts os)))))) |
| 188 | |
| 189 | (test-assert "shepherd services" |
| 190 | (let ((services (marionette-eval |
| 191 | '(begin |
| 192 | (use-modules (gnu services herd)) |
| 193 | |
| 194 | (map (compose car live-service-provision) |
| 195 | (current-services))) |
| 196 | marionette))) |
| 197 | (lset= eq? |
| 198 | (pk 'services services) |
| 199 | '(root #$@(operating-system-shepherd-service-names os))))) |
| 200 | |
| 201 | (test-equal "/var/log/messages is not world-readable" |
| 202 | #o640 ;<https://bugs.gnu.org/40405> |
| 203 | (begin |
| 204 | (wait-for-file "/var/log/messages" marionette |
| 205 | #:read 'get-u8) |
| 206 | (marionette-eval '(stat:perms (lstat "/var/log/messages")) |
| 207 | marionette))) |
| 208 | |
| 209 | (test-assert "homes" |
| 210 | (let ((homes |
| 211 | '#$(map user-account-home-directory |
| 212 | (filter user-account-create-home-directory? |
| 213 | (operating-system-user-accounts os))))) |
| 214 | (marionette-eval |
| 215 | `(begin |
| 216 | (use-modules (gnu services herd) (srfi srfi-1)) |
| 217 | |
| 218 | ;; Home directories are supposed to exist once 'user-homes' |
| 219 | ;; has been started. |
| 220 | (start-service 'user-homes) |
| 221 | |
| 222 | (every (lambda (home) |
| 223 | (and (file-exists? home) |
| 224 | (file-is-directory? home))) |
| 225 | ',homes)) |
| 226 | marionette))) |
| 227 | |
| 228 | (test-assert "skeletons in home directories" |
| 229 | (let ((users+homes |
| 230 | '#$(filter-map (lambda (account) |
| 231 | (and (user-account-create-home-directory? |
| 232 | account) |
| 233 | (not (user-account-system? account)) |
| 234 | (list (user-account-name account) |
| 235 | (user-account-home-directory |
| 236 | account)))) |
| 237 | (operating-system-user-accounts os)))) |
| 238 | (marionette-eval |
| 239 | `(begin |
| 240 | (use-modules (guix build utils) (srfi srfi-1) |
| 241 | (ice-9 ftw) (ice-9 match)) |
| 242 | |
| 243 | (every (match-lambda |
| 244 | ((user home) |
| 245 | ;; Make sure HOME has all the skeletons... |
| 246 | (and (null? (lset-difference string=? |
| 247 | (scandir "/etc/skel/") |
| 248 | (scandir home))) |
| 249 | |
| 250 | ;; ... and that everything is user-owned. |
| 251 | (let* ((pw (getpwnam user)) |
| 252 | (uid (passwd:uid pw)) |
| 253 | (gid (passwd:gid pw)) |
| 254 | (st (lstat home))) |
| 255 | (define (user-owned? file) |
| 256 | (= uid (stat:uid (lstat file)))) |
| 257 | |
| 258 | (and (= uid (stat:uid st)) |
| 259 | (eq? 'directory (stat:type st)) |
| 260 | (every user-owned? |
| 261 | (find-files home |
| 262 | #:directories? #t))))))) |
| 263 | ',users+homes)) |
| 264 | marionette))) |
| 265 | |
| 266 | (test-equal "permissions on /root" |
| 267 | #o700 |
| 268 | (let ((root-home #$(any (lambda (account) |
| 269 | (and (zero? (user-account-uid account)) |
| 270 | (user-account-home-directory |
| 271 | account))) |
| 272 | (operating-system-user-accounts os)))) |
| 273 | (stat:perms (marionette-eval `(stat ,root-home) marionette)))) |
| 274 | |
| 275 | (test-equal "ownership and permissions of /var/empty" |
| 276 | '(0 0 #o555) |
| 277 | (let ((st (marionette-eval `(stat "/var/empty") marionette))) |
| 278 | (list (stat:uid st) (stat:gid st) |
| 279 | (stat:perms st)))) |
| 280 | |
| 281 | (test-equal "no extra home directories" |
| 282 | '() |
| 283 | |
| 284 | ;; Make sure the home directories that are not supposed to be |
| 285 | ;; created are indeed not created. |
| 286 | (let ((nonexistent |
| 287 | '#$(filter-map (lambda (user) |
| 288 | (and (not |
| 289 | (user-account-create-home-directory? |
| 290 | user)) |
| 291 | (user-account-home-directory user))) |
| 292 | (operating-system-user-accounts os)))) |
| 293 | (marionette-eval |
| 294 | `(begin |
| 295 | (use-modules (srfi srfi-1)) |
| 296 | |
| 297 | ;; Note: Do not flag "/var/empty". |
| 298 | (filter file-exists? |
| 299 | ',(remove (cut string-prefix? "/var/" <>) |
| 300 | nonexistent))) |
| 301 | marionette))) |
| 302 | |
| 303 | (test-equal "login on tty1" |
| 304 | "root\n" |
| 305 | (begin |
| 306 | ;; XXX: On desktop, GDM3 will switch to TTY7. If this happens |
| 307 | ;; after we switched to TTY1, we won't be able to login. Make |
| 308 | ;; sure to wait long enough before switching to TTY1. |
| 309 | (when #$desktop? |
| 310 | (sleep 30)) |
| 311 | |
| 312 | (marionette-control "sendkey ctrl-alt-f1" marionette) |
| 313 | ;; Wait for the 'term-tty1' service to be running (using |
| 314 | ;; 'start-service' is the simplest and most reliable way to do |
| 315 | ;; that.) |
| 316 | (marionette-eval |
| 317 | '(begin |
| 318 | (use-modules (gnu services herd)) |
| 319 | (start-service 'term-tty1)) |
| 320 | marionette) |
| 321 | |
| 322 | ;; Now we can type. |
| 323 | (let ((password #$root-password)) |
| 324 | (if password |
| 325 | (begin |
| 326 | (marionette-type "root\n" marionette) |
| 327 | (wait-for-screen-text marionette |
| 328 | (lambda (text) |
| 329 | (string-contains text "Password")) |
| 330 | #:ocrad |
| 331 | #$(file-append ocrad "/bin/ocrad")) |
| 332 | (marionette-type (string-append password "\n\n") |
| 333 | marionette)) |
| 334 | (marionette-type "root\n\n" marionette))) |
| 335 | (marionette-type "id -un > logged-in\n" marionette) |
| 336 | |
| 337 | ;; It can take a while before the shell commands are executed. |
| 338 | (marionette-eval '(use-modules (rnrs io ports)) marionette) |
| 339 | (wait-for-file "/root/logged-in" marionette |
| 340 | #:read 'get-string-all))) |
| 341 | |
| 342 | (test-equal "getlogin on tty1" |
| 343 | "\"root\"" |
| 344 | (begin |
| 345 | ;; Assume we logged in in the previous test and type. |
| 346 | (marionette-type "guile -c '(write (getlogin))' > /root/login-id.tmp\n" |
| 347 | marionette) |
| 348 | (marionette-type "mv /root/login-id{.tmp,}\n" |
| 349 | marionette) |
| 350 | |
| 351 | ;; It can take a while before the shell commands are executed. |
| 352 | (marionette-eval '(use-modules (rnrs io ports)) marionette) |
| 353 | (wait-for-file "/root/login-id" marionette |
| 354 | #:read 'get-string-all))) |
| 355 | |
| 356 | ;; There should be one utmpx entry for the user logged in on tty1. |
| 357 | (test-equal "utmpx entry" |
| 358 | '(("root" "tty1" #f)) |
| 359 | (marionette-eval |
| 360 | '(begin |
| 361 | (use-modules (guix build syscalls) |
| 362 | (srfi srfi-1)) |
| 363 | |
| 364 | (filter-map (lambda (entry) |
| 365 | (and (equal? (login-type USER_PROCESS) |
| 366 | (utmpx-login-type entry)) |
| 367 | (list (utmpx-user entry) (utmpx-line entry) |
| 368 | (utmpx-host entry)))) |
| 369 | (utmpx-entries))) |
| 370 | marionette)) |
| 371 | |
| 372 | ;; Likewise for /var/log/wtmp (used by 'last'). |
| 373 | (test-assert "wtmp entry" |
| 374 | (match (marionette-eval |
| 375 | '(begin |
| 376 | (use-modules (guix build syscalls) |
| 377 | (srfi srfi-1)) |
| 378 | |
| 379 | (define (entry->list entry) |
| 380 | (list (utmpx-user entry) (utmpx-line entry) |
| 381 | (utmpx-host entry) (utmpx-login-type entry))) |
| 382 | |
| 383 | (call-with-input-file "/var/log/wtmp" |
| 384 | (lambda (port) |
| 385 | (let loop ((result '())) |
| 386 | (if (eof-object? (peek-char port)) |
| 387 | (map entry->list (reverse result)) |
| 388 | (loop (cons (read-utmpx port) result))))))) |
| 389 | marionette) |
| 390 | (((users lines hosts types) ..1) |
| 391 | (every (lambda (type) |
| 392 | (eqv? type (login-type LOGIN_PROCESS))) |
| 393 | types)))) |
| 394 | |
| 395 | (test-assert "host name resolution" |
| 396 | (match (marionette-eval |
| 397 | '(begin |
| 398 | ;; Wait for nscd or our requests go through it. |
| 399 | (use-modules (gnu services herd)) |
| 400 | (start-service 'nscd) |
| 401 | |
| 402 | (list (getaddrinfo "localhost") |
| 403 | (getaddrinfo #$(operating-system-host-name os)))) |
| 404 | marionette) |
| 405 | ((((? vector?) ..1) ((? vector?) ..1)) |
| 406 | #t) |
| 407 | (x |
| 408 | (pk 'failure x #f)))) |
| 409 | |
| 410 | (test-equal "nscd invalidate action" |
| 411 | '(#t) ;one value, #t |
| 412 | (marionette-eval '(with-shepherd-action 'nscd ('invalidate "hosts") |
| 413 | result |
| 414 | result) |
| 415 | marionette)) |
| 416 | |
| 417 | ;; FIXME: The 'invalidate' action can't reliably obtain the exit |
| 418 | ;; code of 'nscd' so skip this test. |
| 419 | (test-skip 1) |
| 420 | (test-equal "nscd invalidate action, wrong table" |
| 421 | '(#f) ;one value, #f |
| 422 | (marionette-eval '(with-shepherd-action 'nscd ('invalidate "xyz") |
| 423 | result |
| 424 | result) |
| 425 | marionette)) |
| 426 | |
| 427 | (test-equal "host not found" |
| 428 | #f |
| 429 | (marionette-eval |
| 430 | '(false-if-exception (getaddrinfo "does-not-exist")) |
| 431 | marionette)) |
| 432 | |
| 433 | (test-equal "locale" |
| 434 | "en_US.utf8" |
| 435 | (marionette-eval '(let ((before (setlocale LC_ALL "en_US.utf8"))) |
| 436 | (setlocale LC_ALL before)) |
| 437 | marionette)) |
| 438 | |
| 439 | (test-eq "/run/current-system is a GC root" |
| 440 | 'success! |
| 441 | (marionette-eval '(begin |
| 442 | ;; Make sure the (guix …) modules are found. |
| 443 | (eval-when (expand load eval) |
| 444 | (set! %load-path |
| 445 | (append (map (lambda (package) |
| 446 | (string-append package |
| 447 | "/share/guile/site/" |
| 448 | (effective-version))) |
| 449 | '#$guix&co) |
| 450 | %load-path))) |
| 451 | |
| 452 | (use-modules (srfi srfi-34) (guix store)) |
| 453 | |
| 454 | (let ((system (readlink "/run/current-system"))) |
| 455 | (guard (c ((store-protocol-error? c) |
| 456 | (and (file-exists? system) |
| 457 | 'success!))) |
| 458 | (with-store store |
| 459 | (delete-paths store (list system)) |
| 460 | #f)))) |
| 461 | marionette)) |
| 462 | |
| 463 | ;; This symlink is currently unused, but better have it point to the |
| 464 | ;; right place. See |
| 465 | ;; <https://lists.gnu.org/archive/html/guix-devel/2016-08/msg01641.html>. |
| 466 | (test-equal "/var/guix/gcroots/profiles is a valid symlink" |
| 467 | "/var/guix/profiles" |
| 468 | (marionette-eval '(readlink "/var/guix/gcroots/profiles") |
| 469 | marionette)) |
| 470 | |
| 471 | (test-equal "guix-daemon set-http-proxy action" |
| 472 | '(#t) ;one value, #t |
| 473 | (marionette-eval '(with-shepherd-action 'guix-daemon |
| 474 | ('set-http-proxy "http://localhost:8118") |
| 475 | result |
| 476 | result) |
| 477 | marionette)) |
| 478 | |
| 479 | (test-equal "guix-daemon set-http-proxy action, clear" |
| 480 | '(#t) ;one value, #t |
| 481 | (marionette-eval '(with-shepherd-action 'guix-daemon |
| 482 | ('set-http-proxy) |
| 483 | result |
| 484 | result) |
| 485 | marionette)) |
| 486 | |
| 487 | (test-assert "screendump" |
| 488 | (begin |
| 489 | (marionette-control (string-append "screendump " #$output |
| 490 | "/tty1.ppm") |
| 491 | marionette) |
| 492 | (file-exists? "tty1.ppm"))) |
| 493 | |
| 494 | (test-assert "screen text" |
| 495 | (let ((text (marionette-screen-text marionette |
| 496 | #:ocrad |
| 497 | #$(file-append ocrad |
| 498 | "/bin/ocrad")))) |
| 499 | ;; Check whether the welcome message and shell prompt are |
| 500 | ;; displayed. Note: OCR confuses "y" and "V" for instance, so |
| 501 | ;; we cannot reliably match the whole text. |
| 502 | (and (string-contains text "This is the GNU") |
| 503 | (string-contains text |
| 504 | (string-append |
| 505 | "root@" |
| 506 | #$(operating-system-host-name os)))))) |
| 507 | |
| 508 | (test-end) |
| 509 | (exit (= (test-runner-fail-count (test-runner-current)) 0))))) |
| 510 | |
| 511 | (gexp->derivation name test)) |
| 512 | |
| 513 | (define %test-basic-os |
| 514 | (system-test |
| 515 | (name "basic") |
| 516 | (description |
| 517 | "Instrument %SIMPLE-OS, run it in a VM, and run a series of basic |
| 518 | functionality tests.") |
| 519 | (value |
| 520 | (let* ((os (marionette-operating-system |
| 521 | %simple-os |
| 522 | #:imported-modules '((gnu services herd) |
| 523 | (guix combinators)))) |
| 524 | (vm (virtual-machine os))) |
| 525 | ;; XXX: Add call to 'virtualized-operating-system' to get the exact same |
| 526 | ;; set of services as the OS produced by |
| 527 | ;; 'system-qemu-image/shared-store-script'. |
| 528 | (run-basic-test (virtualized-operating-system os '()) |
| 529 | #~(list #$vm)))))) |
| 530 | |
| 531 | \f |
| 532 | ;;; |
| 533 | ;;; Halt. |
| 534 | ;;; |
| 535 | |
| 536 | (define (run-halt-test vm) |
| 537 | ;; As reported in <http://bugs.gnu.org/26931>, running tmux would previously |
| 538 | ;; lead the 'stop' method of 'user-processes' to an infinite loop, with the |
| 539 | ;; tmux server process as a zombie that remains in the list of processes. |
| 540 | ;; This test reproduces this scenario. |
| 541 | (define test |
| 542 | (with-imported-modules '((gnu build marionette)) |
| 543 | #~(begin |
| 544 | (use-modules (gnu build marionette)) |
| 545 | |
| 546 | (define marionette |
| 547 | (make-marionette '(#$vm))) |
| 548 | |
| 549 | (define ocrad |
| 550 | #$(file-append ocrad "/bin/ocrad")) |
| 551 | |
| 552 | ;; Wait for tty1 and log in. |
| 553 | (marionette-eval '(begin |
| 554 | (use-modules (gnu services herd)) |
| 555 | (start-service 'term-tty1)) |
| 556 | marionette) |
| 557 | (marionette-type "root\n" marionette) |
| 558 | |
| 559 | ;; Start tmux and wait for it to be ready. |
| 560 | (marionette-type "tmux new-session 'echo 1 > /ready; bash'\n" |
| 561 | marionette) |
| 562 | (wait-for-file "/ready" marionette) |
| 563 | |
| 564 | ;; Make sure to stop the test after a while. |
| 565 | (sigaction SIGALRM (lambda _ |
| 566 | (format (current-error-port) |
| 567 | "FAIL: Time is up, but VM still running.\n") |
| 568 | (primitive-exit 1))) |
| 569 | (alarm 10) |
| 570 | |
| 571 | ;; Get debugging info. |
| 572 | (marionette-eval '(current-output-port |
| 573 | (open-file "/dev/console" "w0")) |
| 574 | marionette) |
| 575 | (marionette-eval '(system* #$(file-append procps "/bin/ps") |
| 576 | "-eo" "pid,ppid,stat,comm") |
| 577 | marionette) |
| 578 | |
| 579 | ;; See if 'halt' actually works. |
| 580 | (marionette-eval '(system* "/run/current-system/profile/sbin/halt") |
| 581 | marionette) |
| 582 | |
| 583 | ;; If we reach this line, that means the VM was properly stopped in |
| 584 | ;; a timely fashion. |
| 585 | (alarm 0) |
| 586 | (call-with-output-file #$output |
| 587 | (lambda (port) |
| 588 | (display "success!" port)))))) |
| 589 | |
| 590 | (gexp->derivation "halt" test)) |
| 591 | |
| 592 | (define %test-halt |
| 593 | (system-test |
| 594 | (name "halt") |
| 595 | (description |
| 596 | "Use the 'halt' command and make sure it succeeds and does not get stuck |
| 597 | in a loop. See <http://bugs.gnu.org/26931>.") |
| 598 | (value |
| 599 | (let ((os (marionette-operating-system |
| 600 | (operating-system |
| 601 | (inherit %simple-os) |
| 602 | (packages (cons tmux %base-packages))) |
| 603 | #:imported-modules '((gnu services herd) |
| 604 | (guix combinators))))) |
| 605 | (run-halt-test (virtual-machine os)))))) |
| 606 | |
| 607 | \f |
| 608 | ;;; |
| 609 | ;;; Cleanup of /tmp, /var/run, etc. |
| 610 | ;;; |
| 611 | |
| 612 | (define %cleanup-os |
| 613 | (simple-operating-system |
| 614 | (simple-service 'dirty-things |
| 615 | boot-service-type |
| 616 | (let ((script (plain-file |
| 617 | "create-utf8-file.sh" |
| 618 | (string-append |
| 619 | "echo $0: dirtying /tmp...\n" |
| 620 | "set -e; set -x\n" |
| 621 | "touch /witness\n" |
| 622 | "exec touch /tmp/λαμβδα")))) |
| 623 | (with-imported-modules '((guix build utils)) |
| 624 | #~(begin |
| 625 | (setenv "PATH" |
| 626 | #$(file-append coreutils "/bin")) |
| 627 | (invoke #$(file-append bash "/bin/sh") |
| 628 | #$script))))))) |
| 629 | |
| 630 | (define (run-cleanup-test name) |
| 631 | (define os |
| 632 | (marionette-operating-system %cleanup-os |
| 633 | #:imported-modules '((gnu services herd) |
| 634 | (guix combinators)))) |
| 635 | (define test |
| 636 | (with-imported-modules '((gnu build marionette)) |
| 637 | #~(begin |
| 638 | (use-modules (gnu build marionette) |
| 639 | (srfi srfi-64) |
| 640 | (ice-9 match)) |
| 641 | |
| 642 | (define marionette |
| 643 | (make-marionette (list #$(virtual-machine os)))) |
| 644 | |
| 645 | (mkdir #$output) |
| 646 | (chdir #$output) |
| 647 | |
| 648 | (test-begin "cleanup") |
| 649 | |
| 650 | (test-assert "dirty service worked" |
| 651 | (marionette-eval '(file-exists? "/witness") marionette)) |
| 652 | |
| 653 | (test-equal "/tmp cleaned up" |
| 654 | '("." "..") |
| 655 | (marionette-eval '(begin |
| 656 | (use-modules (ice-9 ftw)) |
| 657 | (scandir "/tmp")) |
| 658 | marionette)) |
| 659 | |
| 660 | (test-end) |
| 661 | (exit (= (test-runner-fail-count (test-runner-current)) 0))))) |
| 662 | |
| 663 | (gexp->derivation "cleanup" test)) |
| 664 | |
| 665 | (define %test-cleanup |
| 666 | ;; See <https://bugs.gnu.org/26353>. |
| 667 | (system-test |
| 668 | (name "cleanup") |
| 669 | (description "Make sure the 'cleanup' service can remove files with |
| 670 | non-ASCII names from /tmp.") |
| 671 | (value (run-cleanup-test name)))) |
| 672 | |
| 673 | \f |
| 674 | ;;; |
| 675 | ;;; Mcron. |
| 676 | ;;; |
| 677 | |
| 678 | (define %mcron-os |
| 679 | ;; System with an mcron service, with one mcron job for "root" and one mcron |
| 680 | ;; job for an unprivileged user. |
| 681 | (let ((job1 #~(job '(next-second '(0 5 10 15 20 25 30 35 40 45 50 55)) |
| 682 | (lambda () |
| 683 | (unless (file-exists? "witness") |
| 684 | (call-with-output-file "witness" |
| 685 | (lambda (port) |
| 686 | (display (list (getuid) (getgid)) port))))))) |
| 687 | (job2 #~(job next-second-from |
| 688 | (lambda () |
| 689 | (call-with-output-file "witness" |
| 690 | (lambda (port) |
| 691 | (display (list (getuid) (getgid)) port)))) |
| 692 | #:user "alice")) |
| 693 | (job3 #~(job next-second-from ;to test $PATH |
| 694 | "touch witness-touch"))) |
| 695 | (simple-operating-system |
| 696 | (service mcron-service-type |
| 697 | (mcron-configuration (jobs (list job1 job2 job3))))))) |
| 698 | |
| 699 | (define (run-mcron-test name) |
| 700 | (define os |
| 701 | (marionette-operating-system |
| 702 | %mcron-os |
| 703 | #:imported-modules '((gnu services herd) |
| 704 | (guix combinators)))) |
| 705 | |
| 706 | (define test |
| 707 | (with-imported-modules '((gnu build marionette)) |
| 708 | #~(begin |
| 709 | (use-modules (gnu build marionette) |
| 710 | (srfi srfi-64) |
| 711 | (ice-9 match)) |
| 712 | |
| 713 | (define marionette |
| 714 | (make-marionette (list #$(virtual-machine os)))) |
| 715 | |
| 716 | (mkdir #$output) |
| 717 | (chdir #$output) |
| 718 | |
| 719 | (test-begin "mcron") |
| 720 | |
| 721 | (test-assert "service running" |
| 722 | (marionette-eval |
| 723 | '(begin |
| 724 | (use-modules (gnu services herd)) |
| 725 | (start-service 'mcron)) |
| 726 | marionette)) |
| 727 | |
| 728 | ;; Make sure root's mcron job runs, has its cwd set to "/root", and |
| 729 | ;; runs with the right UID/GID. |
| 730 | (test-equal "root's job" |
| 731 | '(0 0) |
| 732 | (wait-for-file "/root/witness" marionette)) |
| 733 | |
| 734 | ;; Likewise for Alice's job. We cannot know what its GID is since |
| 735 | ;; it's chosen by 'groupadd', but it's strictly positive. |
| 736 | (test-assert "alice's job" |
| 737 | (match (wait-for-file "/home/alice/witness" marionette) |
| 738 | ((1000 gid) |
| 739 | (>= gid 100)))) |
| 740 | |
| 741 | ;; Last, the job that uses a command; allows us to test whether |
| 742 | ;; $PATH is sane. |
| 743 | (test-equal "root's job with command" |
| 744 | "" |
| 745 | (wait-for-file "/root/witness-touch" marionette |
| 746 | #:read '(@ (ice-9 rdelim) read-string))) |
| 747 | |
| 748 | ;; Make sure the 'schedule' action is accepted. |
| 749 | (test-equal "schedule action" |
| 750 | '(#t) ;one value, #t |
| 751 | (marionette-eval '(with-shepherd-action 'mcron ('schedule) result |
| 752 | result) |
| 753 | marionette)) |
| 754 | |
| 755 | (test-end) |
| 756 | (exit (= (test-runner-fail-count (test-runner-current)) 0))))) |
| 757 | |
| 758 | (gexp->derivation name test)) |
| 759 | |
| 760 | (define %test-mcron |
| 761 | (system-test |
| 762 | (name "mcron") |
| 763 | (description "Make sure the mcron service works as advertised.") |
| 764 | (value (run-mcron-test name)))) |
| 765 | |
| 766 | \f |
| 767 | ;;; |
| 768 | ;;; Avahi and NSS-mDNS. |
| 769 | ;;; |
| 770 | |
| 771 | (define %avahi-os |
| 772 | (operating-system |
| 773 | (inherit %simple-os) |
| 774 | (name-service-switch %mdns-host-lookup-nss) |
| 775 | (services (cons* (service avahi-service-type |
| 776 | (avahi-configuration (debug? #t))) |
| 777 | (dbus-service) |
| 778 | (service dhcp-client-service-type) ;needed for multicast |
| 779 | |
| 780 | ;; Enable heavyweight debugging output. |
| 781 | (modify-services (operating-system-user-services |
| 782 | %simple-os) |
| 783 | (nscd-service-type config |
| 784 | => (nscd-configuration |
| 785 | (inherit config) |
| 786 | (debug-level 3) |
| 787 | (log-file "/dev/console"))) |
| 788 | (syslog-service-type config |
| 789 | => |
| 790 | (syslog-configuration |
| 791 | (inherit config) |
| 792 | (config-file |
| 793 | (plain-file |
| 794 | "syslog.conf" |
| 795 | "*.* /dev/console\n"))))))))) |
| 796 | |
| 797 | (define (run-nss-mdns-test) |
| 798 | ;; Test resolution of '.local' names via libc. Start the marionette service |
| 799 | ;; *after* nscd. Failing to do that, libc will try to connect to nscd, |
| 800 | ;; fail, then never try again (see '__nss_not_use_nscd_hosts' in libc), |
| 801 | ;; leading to '.local' resolution failures. |
| 802 | (define os |
| 803 | (marionette-operating-system |
| 804 | %avahi-os |
| 805 | #:requirements '(nscd) |
| 806 | #:imported-modules '((gnu services herd) |
| 807 | (guix combinators)))) |
| 808 | |
| 809 | (define mdns-host-name |
| 810 | (string-append (operating-system-host-name os) |
| 811 | ".local")) |
| 812 | |
| 813 | (define test |
| 814 | (with-imported-modules '((gnu build marionette)) |
| 815 | #~(begin |
| 816 | (use-modules (gnu build marionette) |
| 817 | (srfi srfi-1) |
| 818 | (srfi srfi-64) |
| 819 | (ice-9 match)) |
| 820 | |
| 821 | (define marionette |
| 822 | (make-marionette (list #$(virtual-machine os)))) |
| 823 | |
| 824 | (mkdir #$output) |
| 825 | (chdir #$output) |
| 826 | |
| 827 | (test-begin "avahi") |
| 828 | |
| 829 | (test-assert "nscd PID file is created" |
| 830 | (marionette-eval |
| 831 | '(begin |
| 832 | (use-modules (gnu services herd)) |
| 833 | (start-service 'nscd)) |
| 834 | marionette)) |
| 835 | |
| 836 | (test-assert "nscd is listening on its socket" |
| 837 | (marionette-eval |
| 838 | ;; XXX: Work around a race condition in nscd: nscd creates its |
| 839 | ;; PID file before it is listening on its socket. |
| 840 | '(let ((sock (socket PF_UNIX SOCK_STREAM 0))) |
| 841 | (let try () |
| 842 | (catch 'system-error |
| 843 | (lambda () |
| 844 | (connect sock AF_UNIX "/var/run/nscd/socket") |
| 845 | (close-port sock) |
| 846 | (format #t "nscd is ready~%") |
| 847 | #t) |
| 848 | (lambda args |
| 849 | (format #t "waiting for nscd...~%") |
| 850 | (usleep 500000) |
| 851 | (try))))) |
| 852 | marionette)) |
| 853 | |
| 854 | (test-assert "avahi is running" |
| 855 | (marionette-eval |
| 856 | '(begin |
| 857 | (use-modules (gnu services herd)) |
| 858 | (start-service 'avahi-daemon)) |
| 859 | marionette)) |
| 860 | |
| 861 | (test-assert "network is up" |
| 862 | (marionette-eval |
| 863 | '(begin |
| 864 | (use-modules (gnu services herd)) |
| 865 | (start-service 'networking)) |
| 866 | marionette)) |
| 867 | |
| 868 | (test-equal "avahi-resolve-host-name" |
| 869 | 0 |
| 870 | (marionette-eval |
| 871 | '(system* |
| 872 | "/run/current-system/profile/bin/avahi-resolve-host-name" |
| 873 | "-v" #$mdns-host-name) |
| 874 | marionette)) |
| 875 | |
| 876 | (test-equal "avahi-browse" |
| 877 | 0 |
| 878 | (marionette-eval |
| 879 | '(system* "/run/current-system/profile/bin/avahi-browse" "-avt") |
| 880 | marionette)) |
| 881 | |
| 882 | (test-assert "getaddrinfo .local" |
| 883 | ;; Wait for the 'avahi-daemon' service and perform a resolution. |
| 884 | (match (marionette-eval |
| 885 | '(getaddrinfo #$mdns-host-name) |
| 886 | marionette) |
| 887 | (((? vector? addrinfos) ..1) |
| 888 | (pk 'getaddrinfo addrinfos) |
| 889 | (and (any (lambda (ai) |
| 890 | (= AF_INET (addrinfo:fam ai))) |
| 891 | addrinfos) |
| 892 | (any (lambda (ai) |
| 893 | (= AF_INET6 (addrinfo:fam ai))) |
| 894 | addrinfos))))) |
| 895 | |
| 896 | (test-assert "gethostbyname .local" |
| 897 | (match (pk 'gethostbyname |
| 898 | (marionette-eval '(gethostbyname #$mdns-host-name) |
| 899 | marionette)) |
| 900 | ((? vector? result) |
| 901 | (and (string=? (hostent:name result) #$mdns-host-name) |
| 902 | (= (hostent:addrtype result) AF_INET))))) |
| 903 | |
| 904 | |
| 905 | (test-end) |
| 906 | (exit (= (test-runner-fail-count (test-runner-current)) 0))))) |
| 907 | |
| 908 | (gexp->derivation "nss-mdns" test)) |
| 909 | |
| 910 | (define %test-nss-mdns |
| 911 | (system-test |
| 912 | (name "nss-mdns") |
| 913 | (description |
| 914 | "Test Avahi's multicast-DNS implementation, and in particular, test its |
| 915 | glibc name service switch (NSS) module.") |
| 916 | (value (run-nss-mdns-test)))) |