123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921 |
- (define-module (gnu tests base)
- #:use-module (gnu tests)
- #:use-module (gnu system)
- #:use-module (gnu system shadow)
- #:use-module (gnu system nss)
- #:use-module (gnu system vm)
- #:use-module (gnu services)
- #:use-module (gnu services base)
- #:use-module (gnu services dbus)
- #:use-module (gnu services avahi)
- #:use-module (gnu services mcron)
- #:use-module (gnu services shepherd)
- #:use-module (gnu services networking)
- #:use-module (gnu packages base)
- #:use-module (gnu packages bash)
- #:use-module (gnu packages imagemagick)
- #:use-module (gnu packages ocr)
- #:use-module (gnu packages package-management)
- #:use-module (gnu packages linux)
- #:use-module (gnu packages tmux)
- #:use-module (guix gexp)
- #:use-module (guix store)
- #:use-module (guix monads)
- #:use-module (guix packages)
- #:use-module (srfi srfi-1)
- #:use-module (ice-9 match)
- #:export (run-basic-test
- %test-basic-os
- %test-halt
- %test-cleanup
- %test-mcron
- %test-nss-mdns))
- (define %simple-os
- (simple-operating-system))
- (define* (run-basic-test os command #:optional (name "basic")
- #:key
- initialization
- root-password
- desktop?)
- "Return a derivation called NAME that tests basic features of the OS started
- using COMMAND, a gexp that evaluates to a list of strings. Compare some
- properties of running system to what's declared in OS, an <operating-system>.
- When INITIALIZATION is true, it must be a one-argument procedure that is
- passed a gexp denoting the marionette, and it must return gexp that is
- inserted before the first test. This is used to introduce an extra
- initialization step, such as entering a LUKS passphrase.
- When ROOT-PASSWORD is true, enter it as the root password when logging in.
- Otherwise assume that there is no password for root."
- (define special-files
- (service-value
- (fold-services (operating-system-services os)
- #:target-type special-files-service-type)))
- (define guix&co
- (match (package-transitive-propagated-inputs guix)
- (((labels packages) ...)
- (cons guix packages))))
- (define test
- (with-imported-modules '((gnu build marionette)
- (guix build syscalls))
- #~(begin
- (use-modules (gnu build marionette)
- (guix build syscalls)
- (srfi srfi-1)
- (srfi srfi-26)
- (srfi srfi-64)
- (ice-9 match))
- (define marionette
- (make-marionette #$command))
- (mkdir #$output)
- (chdir #$output)
- (test-begin "basic")
- #$(and initialization
- (initialization #~marionette))
- (test-assert "uname"
- (match (marionette-eval '(uname) marionette)
- (#("Linux" host-name version _ architecture)
- (and (string=? host-name
- #$(operating-system-host-name os))
- (string-prefix? #$(package-version
- (operating-system-kernel os))
- version)
- (string-prefix? architecture %host-type)))))
-
-
-
- (test-assert "shepherd socket ready"
- (marionette-eval
- `(begin
- (use-modules (gnu services herd))
- (let loop ((i 10))
- (cond ((file-exists? (%shepherd-socket-file))
- #t)
- ((> i 0)
- (sleep 1)
- (loop (- i 1)))
- (else
- #f))))
- marionette))
- (test-eq "stdin is /dev/null"
- 'eof
-
-
- (marionette-eval
- `(begin
- (use-modules (gnu services herd))
- (start 'user-processes)
- ((@@ (gnu services herd) eval-there)
- '(let ((result (read (current-input-port))))
- (if (eof-object? result)
- 'eof
- result))))
- marionette))
- (test-assert "shell and user commands"
-
- (zero? (marionette-eval '(system "
- . /etc/profile
- set -e -x
- guix --version
- ls --version
- grep --version
- info --version")
- marionette)))
- (test-equal "special files"
- '#$special-files
- (marionette-eval
- '(begin
- (use-modules (ice-9 match))
- (map (match-lambda
- ((file target)
- (list file (readlink file))))
- '#$special-files))
- marionette))
- (test-assert "accounts"
- (let ((users (marionette-eval '(begin
- (use-modules (ice-9 match))
- (let loop ((result '()))
- (match (getpw)
- (#f (reverse result))
- (x (loop (cons x result))))))
- marionette)))
- (lset= equal?
- (map (lambda (user)
- (list (passwd:name user)
- (passwd:dir user)))
- users)
- (list
- #$@(map (lambda (account)
- `(list ,(user-account-name account)
- ,(user-account-home-directory account)))
- (operating-system-user-accounts os))))))
- (test-assert "shepherd services"
- (let ((services (marionette-eval
- '(begin
- (use-modules (gnu services herd))
- (map (compose car live-service-provision)
- (current-services)))
- marionette)))
- (lset= eq?
- (pk 'services services)
- '(root #$@(operating-system-shepherd-service-names os)))))
- (test-equal "/var/log/messages is not world-readable"
- #o640
- (begin
- (wait-for-file "/var/log/messages" marionette
- #:read 'get-u8)
- (marionette-eval '(stat:perms (lstat "/var/log/messages"))
- marionette)))
- (test-assert "homes"
- (let ((homes
- '#$(map user-account-home-directory
- (filter user-account-create-home-directory?
- (operating-system-user-accounts os)))))
- (marionette-eval
- `(begin
- (use-modules (gnu services herd) (srfi srfi-1))
-
-
- (start-service 'user-homes)
- (every (lambda (home)
- (and (file-exists? home)
- (file-is-directory? home)))
- ',homes))
- marionette)))
- (test-assert "skeletons in home directories"
- (let ((users+homes
- '#$(filter-map (lambda (account)
- (and (user-account-create-home-directory?
- account)
- (not (user-account-system? account))
- (list (user-account-name account)
- (user-account-home-directory
- account))))
- (operating-system-user-accounts os))))
- (marionette-eval
- `(begin
- (use-modules (guix build utils) (srfi srfi-1)
- (ice-9 ftw) (ice-9 match))
- (every (match-lambda
- ((user home)
-
- (and (null? (lset-difference string=?
- (scandir "/etc/skel/")
- (scandir home)))
-
- (let* ((pw (getpwnam user))
- (uid (passwd:uid pw))
- (gid (passwd:gid pw))
- (st (lstat home)))
- (define (user-owned? file)
- (= uid (stat:uid (lstat file))))
- (and (= uid (stat:uid st))
- (eq? 'directory (stat:type st))
- (every user-owned?
- (find-files home
- #:directories? #t)))))))
- ',users+homes))
- marionette)))
- (test-equal "permissions on /root"
- #o700
- (let ((root-home #$(any (lambda (account)
- (and (zero? (user-account-uid account))
- (user-account-home-directory
- account)))
- (operating-system-user-accounts os))))
- (stat:perms (marionette-eval `(stat ,root-home) marionette))))
- (test-equal "ownership and permissions of /var/empty"
- '(0 0 #o555)
- (let ((st (marionette-eval `(stat "/var/empty") marionette)))
- (list (stat:uid st) (stat:gid st)
- (stat:perms st))))
- (test-equal "no extra home directories"
- '()
-
-
- (let ((nonexistent
- '#$(filter-map (lambda (user)
- (and (not
- (user-account-create-home-directory?
- user))
- (user-account-home-directory user)))
- (operating-system-user-accounts os))))
- (marionette-eval
- `(begin
- (use-modules (srfi srfi-1))
-
- (filter file-exists?
- ',(remove (cut string-prefix? "/var/" <>)
- nonexistent)))
- marionette)))
- (test-equal "login on tty1"
- "root\n"
- (begin
-
-
-
- (when #$desktop?
- (sleep 30))
- (marionette-control "sendkey ctrl-alt-f1" marionette)
-
-
-
- (marionette-eval
- '(begin
- (use-modules (gnu services herd))
- (start-service 'term-tty1))
- marionette)
-
- (let ((password #$root-password))
- (if password
- (begin
- (marionette-type "root\n" marionette)
- (wait-for-screen-text marionette
- (lambda (text)
- (string-contains text "Password"))
- #:ocrad
- #$(file-append ocrad "/bin/ocrad"))
- (marionette-type (string-append password "\n\n")
- marionette))
- (marionette-type "root\n\n" marionette)))
- (marionette-type "id -un > logged-in\n" marionette)
-
- (marionette-eval '(use-modules (rnrs io ports)) marionette)
- (wait-for-file "/root/logged-in" marionette
- #:read 'get-string-all)))
- (test-equal "getlogin on tty1"
- "\"root\""
- (begin
-
- (marionette-type "guile -c '(write (getlogin))' > /root/login-id.tmp\n"
- marionette)
- (marionette-type "mv /root/login-id{.tmp,}\n"
- marionette)
-
- (marionette-eval '(use-modules (rnrs io ports)) marionette)
- (wait-for-file "/root/login-id" marionette
- #:read 'get-string-all)))
-
- (test-equal "utmpx entry"
- '(("root" "tty1" #f))
- (marionette-eval
- '(begin
- (use-modules (guix build syscalls)
- (srfi srfi-1))
- (filter-map (lambda (entry)
- (and (equal? (login-type USER_PROCESS)
- (utmpx-login-type entry))
- (list (utmpx-user entry) (utmpx-line entry)
- (utmpx-host entry))))
- (utmpx-entries)))
- marionette))
-
- (test-assert "wtmp entry"
- (match (marionette-eval
- '(begin
- (use-modules (guix build syscalls)
- (srfi srfi-1))
- (define (entry->list entry)
- (list (utmpx-user entry) (utmpx-line entry)
- (utmpx-host entry) (utmpx-login-type entry)))
- (call-with-input-file "/var/log/wtmp"
- (lambda (port)
- (let loop ((result '()))
- (if (eof-object? (peek-char port))
- (map entry->list (reverse result))
- (loop (cons (read-utmpx port) result)))))))
- marionette)
- (((users lines hosts types) ..1)
- (every (lambda (type)
- (eqv? type (login-type LOGIN_PROCESS)))
- types))))
- (test-assert "host name resolution"
- (match (marionette-eval
- '(begin
-
- (use-modules (gnu services herd))
- (start-service 'nscd)
- (list (getaddrinfo "localhost")
- (getaddrinfo #$(operating-system-host-name os))))
- marionette)
- ((((? vector?) ..1) ((? vector?) ..1))
- #t)
- (x
- (pk 'failure x #f))))
- (test-equal "nscd invalidate action"
- '(#t)
- (marionette-eval '(with-shepherd-action 'nscd ('invalidate "hosts")
- result
- result)
- marionette))
-
-
- (test-skip 1)
- (test-equal "nscd invalidate action, wrong table"
- '(#f)
- (marionette-eval '(with-shepherd-action 'nscd ('invalidate "xyz")
- result
- result)
- marionette))
- (test-equal "host not found"
- #f
- (marionette-eval
- '(false-if-exception (getaddrinfo "does-not-exist"))
- marionette))
- (test-equal "locale"
- "en_US.utf8"
- (marionette-eval '(let ((before (setlocale LC_ALL "en_US.utf8")))
- (setlocale LC_ALL before))
- marionette))
- (test-eq "/run/current-system is a GC root"
- 'success!
- (marionette-eval '(begin
-
- (eval-when (expand load eval)
- (set! %load-path
- (append (map (lambda (package)
- (string-append package
- "/share/guile/site/"
- (effective-version)))
- '#$guix&co)
- %load-path)))
- (use-modules (srfi srfi-34) (guix store))
- (let ((system (readlink "/run/current-system")))
- (guard (c ((store-protocol-error? c)
- (and (file-exists? system)
- 'success!)))
- (with-store store
- (delete-paths store (list system))
- #f))))
- marionette))
-
-
-
- (test-equal "/var/guix/gcroots/profiles is a valid symlink"
- "/var/guix/profiles"
- (marionette-eval '(readlink "/var/guix/gcroots/profiles")
- marionette))
- (test-equal "guix-daemon set-http-proxy action"
- '(#t)
- (marionette-eval '(with-shepherd-action 'guix-daemon
- ('set-http-proxy "http://localhost:8118")
- result
- result)
- marionette))
- (test-equal "guix-daemon set-http-proxy action, clear"
- '(#t)
- (marionette-eval '(with-shepherd-action 'guix-daemon
- ('set-http-proxy)
- result
- result)
- marionette))
- (test-assert "screendump"
- (begin
- (marionette-control (string-append "screendump " #$output
- "/tty1.ppm")
- marionette)
- (file-exists? "tty1.ppm")))
- (test-assert "screen text"
- (let ((text (marionette-screen-text marionette
- #:ocrad
- #$(file-append ocrad
- "/bin/ocrad"))))
-
-
-
- (and (string-contains text "This is the GNU")
- (string-contains text
- (string-append
- "root@"
- #$(operating-system-host-name os))))))
- (test-end)
- (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
- (gexp->derivation name test))
- (define %test-basic-os
- (system-test
- (name "basic")
- (description
- "Instrument %SIMPLE-OS, run it in a VM, and run a series of basic
- functionality tests.")
- (value
- (let* ((os (marionette-operating-system
- %simple-os
- #:imported-modules '((gnu services herd)
- (guix combinators))))
- (vm (virtual-machine os)))
-
-
-
- (run-basic-test (virtualized-operating-system os '())
- #~(list #$vm))))))
- (define (run-halt-test vm)
-
-
-
-
- (define test
- (with-imported-modules '((gnu build marionette))
- #~(begin
- (use-modules (gnu build marionette))
- (define marionette
- (make-marionette '(#$vm)))
- (define ocrad
- #$(file-append ocrad "/bin/ocrad"))
-
- (marionette-eval '(begin
- (use-modules (gnu services herd))
- (start-service 'term-tty1))
- marionette)
- (marionette-type "root\n" marionette)
- (wait-for-screen-text marionette
- (lambda (text)
- (string-contains text "root@komputilo"))
- #:ocrad ocrad)
-
- (marionette-type "tmux new-session 'echo 1 > /ready; bash'\n"
- marionette)
- (wait-for-file "/ready" marionette)
-
- (sigaction SIGALRM (lambda _
- (format (current-error-port)
- "FAIL: Time is up, but VM still running.\n")
- (primitive-exit 1)))
- (alarm 10)
-
- (marionette-eval '(current-output-port
- (open-file "/dev/console" "w0"))
- marionette)
- (marionette-eval '(system* #$(file-append procps "/bin/ps")
- "-eo" "pid,ppid,stat,comm")
- marionette)
-
- (marionette-eval '(system* "/run/current-system/profile/sbin/halt")
- marionette)
-
-
- (alarm 0)
- (call-with-output-file #$output
- (lambda (port)
- (display "success!" port))))))
- (gexp->derivation "halt" test))
- (define %test-halt
- (system-test
- (name "halt")
- (description
- "Use the 'halt' command and make sure it succeeds and does not get stuck
- in a loop. See <http://bugs.gnu.org/26931>.")
- (value
- (let ((os (marionette-operating-system
- (operating-system
- (inherit %simple-os)
- (packages (cons tmux %base-packages)))
- #:imported-modules '((gnu services herd)
- (guix combinators)))))
- (run-halt-test (virtual-machine os))))))
- (define %cleanup-os
- (simple-operating-system
- (simple-service 'dirty-things
- boot-service-type
- (let ((script (plain-file
- "create-utf8-file.sh"
- (string-append
- "echo $0: dirtying /tmp...\n"
- "set -e; set -x\n"
- "touch /witness\n"
- "exec touch /tmp/λαμβδα"))))
- (with-imported-modules '((guix build utils))
- #~(begin
- (setenv "PATH"
- #$(file-append coreutils "/bin"))
- (invoke #$(file-append bash "/bin/sh")
- #$script)))))))
- (define (run-cleanup-test name)
- (define os
- (marionette-operating-system %cleanup-os
- #:imported-modules '((gnu services herd)
- (guix combinators))))
- (define test
- (with-imported-modules '((gnu build marionette))
- #~(begin
- (use-modules (gnu build marionette)
- (srfi srfi-64)
- (ice-9 match))
- (define marionette
- (make-marionette (list #$(virtual-machine os))))
- (mkdir #$output)
- (chdir #$output)
- (test-begin "cleanup")
- (test-assert "dirty service worked"
- (marionette-eval '(file-exists? "/witness") marionette))
- (test-equal "/tmp cleaned up"
- '("." "..")
- (marionette-eval '(begin
- (use-modules (ice-9 ftw))
- (scandir "/tmp"))
- marionette))
- (test-end)
- (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
- (gexp->derivation "cleanup" test))
- (define %test-cleanup
-
- (system-test
- (name "cleanup")
- (description "Make sure the 'cleanup' service can remove files with
- non-ASCII names from /tmp.")
- (value (run-cleanup-test name))))
- (define %mcron-os
-
-
- (let ((job1 #~(job '(next-second '(0 5 10 15 20 25 30 35 40 45 50 55))
- (lambda ()
- (unless (file-exists? "witness")
- (call-with-output-file "witness"
- (lambda (port)
- (display (list (getuid) (getgid)) port)))))))
- (job2 #~(job next-second-from
- (lambda ()
- (call-with-output-file "witness"
- (lambda (port)
- (display (list (getuid) (getgid)) port))))
- #:user "alice"))
- (job3 #~(job next-second-from
- "touch witness-touch")))
- (simple-operating-system
- (service mcron-service-type
- (mcron-configuration (jobs (list job1 job2 job3)))))))
- (define (run-mcron-test name)
- (define os
- (marionette-operating-system
- %mcron-os
- #:imported-modules '((gnu services herd)
- (guix combinators))))
- (define test
- (with-imported-modules '((gnu build marionette))
- #~(begin
- (use-modules (gnu build marionette)
- (srfi srfi-64)
- (ice-9 match))
- (define marionette
- (make-marionette (list #$(virtual-machine os))))
- (mkdir #$output)
- (chdir #$output)
- (test-begin "mcron")
- (test-assert "service running"
- (marionette-eval
- '(begin
- (use-modules (gnu services herd))
- (start-service 'mcron))
- marionette))
-
-
- (test-equal "root's job"
- '(0 0)
- (wait-for-file "/root/witness" marionette))
-
-
- (test-assert "alice's job"
- (match (wait-for-file "/home/alice/witness" marionette)
- ((1000 gid)
- (>= gid 100))))
-
-
- (test-equal "root's job with command"
- ""
- (wait-for-file "/root/witness-touch" marionette
- #:read '(@ (ice-9 rdelim) read-string)))
-
- (test-equal "schedule action"
- '(#t)
- (marionette-eval '(with-shepherd-action 'mcron ('schedule) result
- result)
- marionette))
- (test-end)
- (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
- (gexp->derivation name test))
- (define %test-mcron
- (system-test
- (name "mcron")
- (description "Make sure the mcron service works as advertised.")
- (value (run-mcron-test name))))
- (define %avahi-os
- (operating-system
- (inherit %simple-os)
- (name-service-switch %mdns-host-lookup-nss)
- (services (cons* (service avahi-service-type
- (avahi-configuration (debug? #t)))
- (dbus-service)
- (service dhcp-client-service-type)
-
- (modify-services (operating-system-user-services
- %simple-os)
- (nscd-service-type config
- => (nscd-configuration
- (inherit config)
- (debug-level 3)
- (log-file "/dev/console")))
- (syslog-service-type config
- =>
- (syslog-configuration
- (inherit config)
- (config-file
- (plain-file
- "syslog.conf"
- "*.* /dev/console\n")))))))))
- (define (run-nss-mdns-test)
-
-
-
-
- (define os
- (marionette-operating-system
- %avahi-os
- #:requirements '(nscd)
- #:imported-modules '((gnu services herd)
- (guix combinators))))
- (define mdns-host-name
- (string-append (operating-system-host-name os)
- ".local"))
- (define test
- (with-imported-modules '((gnu build marionette))
- #~(begin
- (use-modules (gnu build marionette)
- (srfi srfi-1)
- (srfi srfi-64)
- (ice-9 match))
- (define marionette
- (make-marionette (list #$(virtual-machine os))))
- (mkdir #$output)
- (chdir #$output)
- (test-begin "avahi")
- (test-assert "nscd PID file is created"
- (marionette-eval
- '(begin
- (use-modules (gnu services herd))
- (start-service 'nscd))
- marionette))
- (test-assert "nscd is listening on its socket"
- (marionette-eval
-
-
- '(let ((sock (socket PF_UNIX SOCK_STREAM 0)))
- (let try ()
- (catch 'system-error
- (lambda ()
- (connect sock AF_UNIX "/var/run/nscd/socket")
- (close-port sock)
- (format #t "nscd is ready~%")
- #t)
- (lambda args
- (format #t "waiting for nscd...~%")
- (usleep 500000)
- (try)))))
- marionette))
- (test-assert "avahi is running"
- (marionette-eval
- '(begin
- (use-modules (gnu services herd))
- (start-service 'avahi-daemon))
- marionette))
- (test-assert "network is up"
- (marionette-eval
- '(begin
- (use-modules (gnu services herd))
- (start-service 'networking))
- marionette))
- (test-equal "avahi-resolve-host-name"
- 0
- (marionette-eval
- '(system*
- "/run/current-system/profile/bin/avahi-resolve-host-name"
- "-v" #$mdns-host-name)
- marionette))
- (test-equal "avahi-browse"
- 0
- (marionette-eval
- '(system* "/run/current-system/profile/bin/avahi-browse" "-avt")
- marionette))
- (test-assert "getaddrinfo .local"
-
- (match (marionette-eval
- '(getaddrinfo #$mdns-host-name)
- marionette)
- (((? vector? addrinfos) ..1)
- (pk 'getaddrinfo addrinfos)
- (and (any (lambda (ai)
- (= AF_INET (addrinfo:fam ai)))
- addrinfos)
- (any (lambda (ai)
- (= AF_INET6 (addrinfo:fam ai)))
- addrinfos)))))
- (test-assert "gethostbyname .local"
- (match (pk 'gethostbyname
- (marionette-eval '(gethostbyname #$mdns-host-name)
- marionette))
- ((? vector? result)
- (and (string=? (hostent:name result) #$mdns-host-name)
- (= (hostent:addrtype result) AF_INET)))))
- (test-end)
- (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
- (gexp->derivation "nss-mdns" test))
- (define %test-nss-mdns
- (system-test
- (name "nss-mdns")
- (description
- "Test Avahi's multicast-DNS implementation, and in particular, test its
- glibc name service switch (NSS) module.")
- (value (run-nss-mdns-test))))
|