gnu/tests/base.scm

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