;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;;
;;; This file is part of GNU Guix.
;;;
#: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 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))
\f
(define* (run-basic-test os command #:optional (name "basic")
- #:key initialization)
+ #: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."
+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))
version)
(string-prefix? architecture %host-type)))))
+ ;; Shepherd reads the config file *before* binding its control
+ ;; socket, so /var/run/shepherd/socket might not exist yet when the
+ ;; 'marionette' service is started.
+ (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
+ ;; Make sure services can no longer read from stdin once the
+ ;; system has booted.
+ (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"
;; Is everything in $PATH?
(zero? (marionette-eval '(system "
(#f (reverse result))
(x (loop (cons x result))))))
marionette)))
- (lset= string=?
- (map passwd:name users)
+ (lset= equal?
+ (map (lambda (user)
+ (list (passwd:name user)
+ (passwd:dir user)))
+ users)
(list
- #$@(map user-account-name
+ #$@(map (lambda (account)
+ `(list ,(user-account-name account)
+ ,(user-account-home-directory account)))
(operating-system-user-accounts os))))))
(test-assert "shepherd services"
(pk 'services services)
'(root #$@(operating-system-shepherd-service-names os)))))
+ (test-equal "/var/log/messages is not world-readable"
+ #o640 ;<https://bugs.gnu.org/40405>
+ (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
(operating-system-user-accounts os))))
(marionette-eval
`(begin
- (use-modules (srfi srfi-1) (ice-9 ftw)
- (ice-9 match))
+ (use-modules (guix build utils) (srfi srfi-1)
+ (ice-9 ftw) (ice-9 match))
(every (match-lambda
((user home)
(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"
'()
(test-equal "login on tty1"
"root\n"
(begin
+ ;; XXX: On desktop, GDM3 will switch to TTY7. If this happens
+ ;; after we switched to TTY1, we won't be able to login. Make
+ ;; sure to wait long enough before switching to TTY1.
+ (when #$desktop?
+ (sleep 30))
+
(marionette-control "sendkey ctrl-alt-f1" marionette)
;; Wait for the 'term-tty1' service to be running (using
;; 'start-service' is the simplest and most reliable way to do
marionette)
;; Now we can type.
- (marionette-type "root\n\nid -un > logged-in\n" 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)
;; It can take a while before the shell commands are executed.
(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
+ ;; Assume we logged in in the previous test and type.
+ (marionette-type "guile -c '(write (getlogin))' > /root/login-id.tmp\n"
+ marionette)
+ (marionette-type "mv /root/login-id{.tmp,}\n"
+ marionette)
+
+ ;; It can take a while before the shell commands are executed.
+ (marionette-eval '(use-modules (rnrs io ports)) marionette)
+ (wait-for-file "/root/login-id" marionette
+ #:read 'get-string-all)))
+
;; There should be one utmpx entry for the user logged in on tty1.
(test-equal "utmpx entry"
'(("root" "tty1" #f))
(x
(pk 'failure x #f))))
+ (test-equal "nscd invalidate action"
+ '(#t) ;one value, #t
+ (marionette-eval '(with-shepherd-action 'nscd ('invalidate "hosts")
+ result
+ result)
+ marionette))
+
+ ;; FIXME: The 'invalidate' action can't reliably obtain the exit
+ ;; code of 'nscd' so skip this test.
+ (test-skip 1)
+ (test-equal "nscd invalidate action, wrong table"
+ '(#f) ;one value, #f
+ (marionette-eval '(with-shepherd-action 'nscd ('invalidate "xyz")
+ result
+ result)
+ marionette))
+
(test-equal "host not found"
#f
(marionette-eval
'success!
(marionette-eval '(begin
;; Make sure the (guix …) modules are found.
- (add-to-load-path
- #+(file-append guix "/share/guile/site/2.2"))
+ (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 ((nix-protocol-error? c)
+ (guard (c ((store-protocol-error? c)
(and (file-exists? system)
'success!)))
(with-store store
(marionette-eval '(readlink "/var/guix/gcroots/profiles")
marionette))
+ (test-equal "guix-daemon set-http-proxy action"
+ '(#t) ;one value, #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) ;one value, #t
+ (marionette-eval '(with-shepherd-action 'guix-daemon
+ ('set-http-proxy)
+ result
+ result)
+ marionette))
(test-assert "screendump"
(begin
(run-halt-test (virtual-machine os))))))
\f
+;;;
+;;; Cleanup of /tmp, /var/run, etc.
+;;;
+
+(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
+ ;; See <https://bugs.gnu.org/26353>.
+ (system-test
+ (name "cleanup")
+ (description "Make sure the 'cleanup' service can remove files with
+non-ASCII names from /tmp.")
+ (value (run-cleanup-test name))))
+
+\f
;;;
;;; Mcron.
;;;
(job3 #~(job next-second-from ;to test $PATH
"touch witness-touch")))
(simple-operating-system
- (mcron-service (list job1 job2 job3)))))
+ (service mcron-service-type
+ (mcron-configuration (jobs (list job1 job2 job3)))))))
(define (run-mcron-test name)
(define os
(test-begin "mcron")
- (test-eq "service running"
- 'running!
+ (test-assert "service running"
(marionette-eval
'(begin
(use-modules (gnu services herd))
- (start-service 'mcron)
- 'running!)
+ (start-service 'mcron))
marionette))
;; Make sure root's mcron job runs, has its cwd set to "/root", and
(wait-for-file "/root/witness-touch" marionette
#:read '(@ (ice-9 rdelim) read-string)))
+ ;; Make sure the 'schedule' action is accepted.
+ (test-equal "schedule action"
+ '(#t) ;one value, #t
+ (marionette-eval '(with-shepherd-action 'mcron ('schedule) result
+ result)
+ marionette))
+
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
(operating-system
(inherit %simple-os)
(name-service-switch %mdns-host-lookup-nss)
- (services (cons* (avahi-service #:debug? #t)
+ (services (cons* (service avahi-service-type
+ (avahi-configuration (debug? #t)))
(dbus-service)
- (dhcp-client-service) ;needed for multicast
+ (service dhcp-client-service-type) ;needed for multicast
;; Enable heavyweight debugging output.
(modify-services (operating-system-user-services
(test-begin "avahi")
- (test-assert "wait for services"
+ (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
+ ;; XXX: Work around a race condition in nscd: nscd creates its
+ ;; PID file before it is listening on its socket.
+ '(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))
- (start-service 'nscd)
-
- ;; XXX: Work around a race condition in nscd: nscd creates its
- ;; PID file before it is listening on its socket.
- (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~%"))
- (lambda args
- (format #t "waiting for nscd...~%")
- (usleep 500000)
- (try)))))
-
- ;; Wait for the other useful things.
- (start-service 'avahi-daemon)
- (start-service 'networking)
-
- #t)
+ (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"
HCoop / jackhill / guix / guix.git / blobdiff