diff options
Diffstat (limited to 'gnu/tests')
| -rw-r--r-- | gnu/tests/base.scm | 119 | ||||
| -rw-r--r-- | gnu/tests/install.scm | 65 | ||||
| -rw-r--r-- | gnu/tests/messaging.scm | 194 | ||||
| -rw-r--r-- | gnu/tests/web.scm | 146 |
4 files changed, 518 insertions, 6 deletions
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index 6370d6951b..000a4ddecb 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -77,10 +77,17 @@ 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." + (define special-files + (service-parameters + (fold-services (operating-system-services os) + #:target-type special-files-service-type))) + (define test - (with-imported-modules '((gnu build marionette)) + (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) @@ -118,6 +125,18 @@ 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)) @@ -144,6 +163,63 @@ info --version") (pk 'services services) '(root #$@(operating-system-shepherd-service-names os))))) + (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)) + + ;; Home directories are supposed to exist once 'user-homes' + ;; has been started. + (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 (srfi srfi-1) (ice-9 ftw) + (ice-9 match)) + + (every (match-lambda + ((user home) + ;; Make sure HOME has all the skeletons... + (and (null? (lset-difference string=? + (scandir "/etc/skel/") + (scandir home))) + + ;; ... and that everything is user-owned. + (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 "login on tty1" "root\n" (begin @@ -176,6 +252,45 @@ info --version") (apply throw args))))) marionette))) + ;; There should be one utmpx entry for the user logged in on tty1. + (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)) + + ;; Likewise for /var/log/wtmp (used by 'last'). + (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 diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index ae54154c5c..b104efcfd5 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,6 +35,7 @@ #:use-module (guix utils) #:export (%test-installed-os %test-separate-store-os + %test-separate-home-os %test-raid-root-os %test-encrypted-os %test-btrfs-root-os)) @@ -218,7 +219,6 @@ IMAGE, a disk image. The QEMU VM is has access to MEMORY-SIZE MiB of RAM." "-no-reboot" "-m" #$(number->string memory-size) "-drive" "file=disk.img,if=virtio"))))) - (define %test-installed-os (system-test (name "installed-os") @@ -234,6 +234,64 @@ build (current-guix) and then store a couple of full system images.") ;;; +;;; Separate /home. +;;; + +(define-os-with-source (%separate-home-os %separate-home-os-source) + ;; The OS we want to install. + (use-modules (gnu) (gnu tests) (srfi srfi-1)) + + (operating-system + (host-name "liberigilo") + (timezone "Europe/Paris") + (locale "en_US.utf8") + + (bootloader (grub-configuration (device "/dev/vdb"))) + (kernel-arguments '("console=ttyS0")) + (file-systems (cons* (file-system + (device "my-root") + (title 'label) + (mount-point "/") + (type "ext4")) + (file-system + (device "none") + (title 'device) + (type "tmpfs") + (mount-point "/home") + (type "tmpfs")) + %base-file-systems)) + (users (cons* (user-account + (name "alice") + (group "users") + (home-directory "/home/alice")) + (user-account + (name "charlie") + (group "users") + (home-directory "/home/charlie")) + %base-user-accounts)) + (services (cons (service marionette-service-type + (marionette-configuration + (imported-modules '((gnu services herd) + (guix combinators))))) + %base-services)))) + +(define %test-separate-home-os + (system-test + (name "separate-home-os") + (description + "Test basic functionality of an installed OS with a separate /home +partition. In particular, home directories must be correctly created (see +<https://bugs.gnu.org/21108>).") + (value + (mlet* %store-monad ((image (run-install %separate-home-os + %separate-home-os-source + #:script + %simple-installation-script)) + (command (qemu-command/writable-image image))) + (run-basic-test %separate-home-os command "separate-home-os"))))) + + +;;; ;;; Separate /gnu/store partition. ;;; @@ -257,8 +315,7 @@ build (current-guix) and then store a couple of full system images.") (device "store-fs") (title 'label) (mount-point "/gnu") - (type "ext4") - (needed-for-boot? #t)) ;definitely! + (type "ext4")) %base-file-systems)) (users %base-user-accounts) (services (cons (service marionette-service-type diff --git a/gnu/tests/messaging.scm b/gnu/tests/messaging.scm new file mode 100644 index 0000000000..b0c8254ce0 --- /dev/null +++ b/gnu/tests/messaging.scm @@ -0,0 +1,194 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu tests messaging) + #:use-module (gnu tests) + #:use-module (gnu system) + #:use-module (gnu system grub) + #:use-module (gnu system file-systems) + #:use-module (gnu system shadow) + #:use-module (gnu system vm) + #:use-module (gnu services) + #:use-module (gnu services base) + #:use-module (gnu services messaging) + #:use-module (gnu services networking) + #:use-module (gnu packages messaging) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) + #:export (%test-prosody)) + +(define %base-os + (operating-system + (host-name "komputilo") + (timezone "Europe/Berlin") + (locale "en_US.UTF-8") + + (bootloader (grub-configuration (device "/dev/sdX"))) + (file-systems %base-file-systems) + (firmware '()) + (users %base-user-accounts) + (services (cons (dhcp-client-service) + %base-services)))) + +(define (os-with-service service) + "Return a test operating system that runs SERVICE." + (operating-system + (inherit %base-os) + (services (cons service + (operating-system-user-services %base-os))))) + +(define (run-xmpp-test name xmpp-service pid-file create-account) + "Run a test of an OS running XMPP-SERVICE, which writes its PID to PID-FILE." + (mlet* %store-monad ((os -> (marionette-operating-system + (os-with-service xmpp-service) + #:imported-modules '((gnu services herd)))) + (command (system-qemu-image/shared-store-script + os #:graphic? #f)) + (username -> "alice") + (server -> "localhost") + (jid -> (string-append username "@" server)) + (password -> "correct horse battery staple") + (port -> 15222) + (message -> "hello world") + (witness -> "/tmp/freetalk-witness")) + + (define script.ft + (scheme-file + "script.ft" + #~(begin + (define (handle-received-message time from nickname message) + (define (touch file-name) + (call-with-output-file file-name (const #t))) + (when (equal? message #$message) + (touch #$witness))) + (add-hook! ft-message-receive-hook handle-received-message) + + (ft-set-jid! #$jid) + (ft-set-password! #$password) + (ft-set-server! #$server) + (ft-set-port! #$port) + (ft-set-sslconn! #f) + (ft-connect-blocking) + (ft-send-message #$jid #$message) + + (ft-set-daemon) + (ft-main-loop)))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-64)) + + (define marionette + ;; Enable TCP forwarding of the guest's port 5222. + (make-marionette (list #$command "-net" + (string-append "user,hostfwd=tcp::" + (number->string #$port) + "-:5222")))) + + (define (guest-wait-for-file file) + ;; Wait until FILE exists in the guest; 'read' its content and + ;; return it. + (marionette-eval + `(let loop ((i 10)) + (cond ((file-exists? ,file) + (call-with-input-file ,file read)) + ((> i 0) + (begin + (sleep 1)) + (loop (- i 1))) + (else + (error "file didn't show up" ,file)))) + marionette)) + + (define (host-wait-for-file file) + ;; Wait until FILE exists in the host. + (let loop ((i 60)) + (cond ((file-exists? file) + #t) + ((> i 0) + (begin + (sleep 1)) + (loop (- i 1))) + (else + (error "file didn't show up" file))))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "xmpp") + + ;; Wait for XMPP service to be up and running. + (test-eq "service running" + 'running! + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'xmpp-daemon) + 'running!) + marionette)) + + ;; Check XMPP service's PID. + (test-assert "service process id" + (let ((pid (number->string (guest-wait-for-file #$pid-file)))) + (marionette-eval `(file-exists? (string-append "/proc/" ,pid)) + marionette))) + + ;; Alice sends an XMPP message to herself, with Freetalk. + (test-assert "client-to-server communication" + (let ((freetalk-bin (string-append #$freetalk "/bin/freetalk"))) + (marionette-eval '(system* #$create-account #$jid #$password) + marionette) + ;; Freetalk requires write access to $HOME. + (setenv "HOME" "/tmp") + (system* freetalk-bin "-s" #$script.ft) + (host-wait-for-file #$witness))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation name test))) + +(define %create-prosody-account + (program-file + "create-account" + #~(begin + (use-modules (ice-9 match)) + (match (command-line) + ((command jid password) + (let ((password-input (format #f "\"~a~%~a\"" password password)) + (prosodyctl #$(file-append prosody "/bin/prosodyctl"))) + (system (string-join + `("echo" ,password-input "|" ,prosodyctl "adduser" ,jid) + " ")))))))) + +(define %test-prosody + (let* ((config (prosody-configuration + (virtualhosts + (list + (virtualhost-configuration + (domain "localhost"))))))) + (system-test + (name "prosody") + (description "Connect to a running Prosody daemon.") + (value (run-xmpp-test name + (service prosody-service-type config) + (prosody-configuration-pidfile config) + %create-prosody-account))))) diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm new file mode 100644 index 0000000000..bae0e8fad7 --- /dev/null +++ b/gnu/tests/web.scm @@ -0,0 +1,146 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu tests web) + #:use-module (gnu tests) + #:use-module (gnu system) + #:use-module (gnu system grub) + #:use-module (gnu system file-systems) + #:use-module (gnu system shadow) + #:use-module (gnu system vm) + #:use-module (gnu services) + #:use-module (gnu services base) + #:use-module (gnu services web) + #:use-module (gnu services networking) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) + #:export (%test-nginx)) + +(define %index.html-contents + ;; Contents of the /index.html file served by nginx. + "Hello, nginx!") + +(define %make-http-root + ;; Create our server root in /srv. + #~(begin + (mkdir "/srv") + (call-with-output-file "/srv/index.html" + (lambda (port) + (display #$%index.html-contents port))))) + +(define %nginx-servers + ;; Server blocks. + (list (nginx-server-configuration + (root "/srv") + (http-port 8042) + (https-port #f) + (ssl-certificate #f) + (ssl-certificate-key #f)))) + +(define %nginx-os + ;; Operating system under test. + (operating-system + (host-name "komputilo") + (timezone "Europe/Berlin") + (locale "en_US.utf8") + + (bootloader (grub-configuration (device "/dev/sdX"))) + (file-systems %base-file-systems) + (firmware '()) + (users %base-user-accounts) + (services (cons* (dhcp-client-service) + (service nginx-service-type + (nginx-configuration + (log-directory "/var/log/nginx") + (server-blocks %nginx-servers))) + (simple-service 'make-http-root activation-service-type + %make-http-root) + %base-services)))) + +(define* (run-nginx-test #:optional (http-port 8042)) + "Run tests in %NGINX-OS, which has nginx running and listening on +HTTP-PORT." + (mlet* %store-monad ((os -> (marionette-operating-system + %nginx-os + #:imported-modules '((gnu services herd) + (guix combinators)))) + (command (system-qemu-image/shared-store-script + os #:graphic? #f))) + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (srfi srfi-11) (srfi srfi-64) + (gnu build marionette) + (web uri) + (web client) + (web response)) + + (define marionette + ;; Forward the guest's HTTP-PORT, where nginx is listening, to + ;; port 8080 in the host. + (make-marionette (list #$command "-net" + (string-append + "user,hostfwd=tcp::8080-:" + #$(number->string http-port))))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "nginx") + + ;; Wait for nginx to be up and running. + (test-eq "service running" + 'running! + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'nginx) + 'running!) + marionette)) + + ;; Make sure the PID file is created. + (test-assert "PID file" + (marionette-eval + '(file-exists? "/var/run/nginx/pid") + marionette)) + + ;; Retrieve the index.html file we put in /srv. + (test-equal "http-get" + '(200 #$%index.html-contents) + (let-values (((response text) + (http-get "http://localhost:8080/index.html" + #:decode-body? #t))) + (list (response-code response) text))) + + ;; There should be a log file in here. + (test-assert "log file" + (marionette-eval + '(file-exists? "/var/log/nginx/access.log") + marionette)) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "nginx-test" test))) + +(define %test-nginx + (system-test + (name "nginx") + (description "Connect to a running NGINX server.") + (value (run-nginx-test)))) |