diff options
Diffstat (limited to 'gnu/tests')
| -rw-r--r-- | gnu/tests/docker.scm | 19 | ||||
| -rw-r--r-- | gnu/tests/mail.scm | 178 | ||||
| -rw-r--r-- | gnu/tests/singularity.scm | 137 | ||||
| -rw-r--r-- | gnu/tests/web.scm | 164 |
4 files changed, 488 insertions, 10 deletions
diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm index 3cd3a27884..f2674cdbe8 100644 --- a/gnu/tests/docker.scm +++ b/gnu/tests/docker.scm @@ -101,7 +101,7 @@ inside %DOCKER-OS." marionette)) (test-equal "Load docker image and run it" - "hello world" + '("hello world" "hi!") (marionette-eval `(begin (define slurp @@ -117,12 +117,16 @@ inside %DOCKER-OS." (repository&tag (string-drop raw-line (string-length "Loaded image: "))) - (response (slurp - ,(string-append #$docker-cli "/bin/docker") - "run" "--entrypoint" "bin/Guile" - repository&tag - "/aa.scm"))) - response)) + (response1 (slurp + ,(string-append #$docker-cli "/bin/docker") + "run" "--entrypoint" "bin/Guile" + repository&tag + "/aa.scm")) + (response2 (slurp ;default entry point + ,(string-append #$docker-cli "/bin/docker") + "run" repository&tag + "-c" "(display \"hi!\")"))) + (list response1 response2))) marionette)) (test-end) @@ -161,6 +165,7 @@ standard output device and then enters a new line.") (tarball (docker-image "docker-pack" profile #:symlinks '(("/bin/Guile" -> "bin/guile") ("aa.scm" -> "a.scm")) + #:entry-point "bin/guile" #:localstatedir? #t))) (run-docker-test tarball))) diff --git a/gnu/tests/mail.scm b/gnu/tests/mail.scm index 33aa4d3437..10e5be71d8 100644 --- a/gnu/tests/mail.scm +++ b/gnu/tests/mail.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> +;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +26,7 @@ #:use-module (gnu system) #:use-module (gnu system vm) #:use-module (gnu services) + #:use-module (gnu services getmail) #:use-module (gnu services mail) #:use-module (gnu services networking) #:use-module (guix gexp) @@ -32,7 +34,8 @@ #:use-module (ice-9 ftw) #:export (%test-opensmtpd %test-exim - %test-dovecot)) + %test-dovecot + %test-getmail)) (define %opensmtpd-os (simple-operating-system @@ -394,3 +397,176 @@ Subject: Hello Nice to meet you!") (name "dovecot") (description "Connect to a running Dovecot server.") (value (run-dovecot-test)))) + +(define %getmail-os + (simple-operating-system + (service dhcp-client-service-type) + (service dovecot-service-type + (dovecot-configuration + (disable-plaintext-auth? #f) + (ssl? "no") + (auth-mechanisms '("anonymous" "plain")) + (auth-anonymous-username "alice") + (mail-location + (string-append "maildir:~/Maildir" + ":INBOX=~/Maildir/INBOX" + ":LAYOUT=fs")))) + (service getmail-service-type + (list + (getmail-configuration + (name 'test) + (user "alice") + (directory "/var/lib/getmail/alice") + (idle '("TESTBOX")) + (rcfile + (getmail-configuration-file + (retriever + (getmail-retriever-configuration + (type "SimpleIMAPRetriever") + (server "localhost") + (username "alice") + (port 143) + (extra-parameters + '((password . "testpass") + (mailboxes . ("TESTBOX")))))) + (destination + (getmail-destination-configuration + (type "Maildir") + (path "/home/alice/TestMaildir/"))) + (options + (getmail-options-configuration + (read-all #f)))))))))) + +(define (run-getmail-test) + "Return a test of an OS running Getmail service." + (define vm + (virtual-machine + (operating-system (marionette-operating-system + %getmail-os + #:imported-modules '((gnu services herd)))) + (port-forwardings '((8143 . 143))))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette) + (ice-9 iconv) + (ice-9 rdelim) + (rnrs base) + (rnrs bytevectors) + (srfi srfi-64)) + + (define marionette + (make-marionette '(#$vm))) + + (define* (message-length message #:key (encoding "iso-8859-1")) + (bytevector-length (string->bytevector message encoding))) + + (define message "From: test@example.com\n\ +Subject: Hello Nice to meet you!") + + (mkdir #$output) + (chdir #$output) + + (test-begin "getmail") + + ;; Wait for dovecot to be up and running. + (test-assert "dovecot running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'dovecot)) + marionette)) + + (test-assert "set password for alice" + (marionette-eval + '(system "echo -e \"testpass\ntestpass\" | passwd alice") + marionette)) + + ;; Wait for getmail to be up and running. + (test-assert "getmail-test running" + (marionette-eval + '(let* ((pw (getpw "alice")) + (uid (passwd:uid pw)) + (gid (passwd:gid pw))) + (use-modules (gnu services herd)) + + (for-each + (lambda (dir) + (mkdir dir) + (chown dir uid gid)) + '("/home/alice/TestMaildir" + "/home/alice/TestMaildir/cur" + "/home/alice/TestMaildir/new" + "/home/alice/TestMaildir/tmp" + "/home/alice/TestMaildir/TESTBOX" + "/home/alice/TestMaildir/TESTBOX/cur" + "/home/alice/TestMaildir/TESTBOX/new" + "/home/alice/TestMaildir/TESTBOX/tmp")) + + (start-service 'getmail-test)) + marionette)) + + ;; Check Dovecot service's PID. + (test-assert "service process id" + (let ((pid + (number->string (wait-for-file "/var/run/dovecot/master.pid" + marionette)))) + (marionette-eval `(file-exists? (string-append "/proc/" ,pid)) + marionette))) + + (test-assert "accept an email" + (let ((imap (socket AF_INET SOCK_STREAM 0)) + (addr (make-socket-address AF_INET INADDR_LOOPBACK 8143))) + (connect imap addr) + ;; Be greeted. + (read-line imap) ;OK + ;; Authenticate + (write-line "a AUTHENTICATE ANONYMOUS" imap) + (read-line imap) ;+ + (write-line "c2lyaGM=" imap) + (read-line imap) ;OK + ;; Create a TESTBOX mailbox + (write-line "a CREATE TESTBOX" imap) + (read-line imap) ;OK + ;; Append a message to a TESTBOX mailbox + (write-line (format #f "a APPEND TESTBOX {~a}" + (number->string (message-length message))) + imap) + (read-line imap) ;+ + (write-line message imap) + (read-line imap) ;OK + ;; Logout + (write-line "a LOGOUT" imap) + (close imap) + #t)) + + (sleep 1) + + (test-assert "mail arrived" + (string-contains + (marionette-eval + '(begin + (use-modules (ice-9 ftw) + (ice-9 match)) + (let ((TESTBOX/new "/home/alice/TestMaildir/new/")) + (match (scandir TESTBOX/new) + (("." ".." message-file) + (call-with-input-file + (string-append TESTBOX/new message-file) + get-string-all))))) + marionette) + message)) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "getmail-test" test)) + +(define %test-getmail + (system-test + (name "getmail") + (description "Connect to a running Getmail server.") + (value (run-getmail-test)))) + +%getmail-os diff --git a/gnu/tests/singularity.scm b/gnu/tests/singularity.scm new file mode 100644 index 0000000000..668043a0bc --- /dev/null +++ b/gnu/tests/singularity.scm @@ -0,0 +1,137 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 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 singularity) + #:use-module (gnu tests) + #:use-module (gnu system) + #:use-module (gnu system vm) + #:use-module (gnu system shadow) + #:use-module (gnu services) + #:use-module (gnu services docker) + #:use-module (gnu packages bash) + #:use-module (gnu packages guile) + #:use-module (gnu packages linux) ;singularity + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix grafts) + #:use-module (guix monads) + #:use-module (guix packages) + #:use-module (guix profiles) + #:use-module (guix scripts pack) + #:export (%test-singularity)) + +(define %singularity-os + (simple-operating-system + (service singularity-service-type) + (simple-service 'guest-account + account-service-type + (list (user-account (name "guest") (uid 1000) (group "guest")) + (user-group (name "guest") (id 1000)))))) + +(define (run-singularity-test image) + "Load IMAGE, a Squashfs image, as a Singularity image and run it inside +%SINGULARITY-OS." + (define os + (marionette-operating-system %singularity-os)) + + (define singularity-exec + #~(begin + (use-modules (ice-9 popen) (rnrs io ports)) + + (let* ((pipe (open-pipe* OPEN_READ + #$(file-append singularity + "/bin/singularity") + "exec" #$image "/bin/guile" + "-c" "(display \"hello, world\")")) + (str (get-string-all pipe)) + (status (close-pipe pipe))) + (and (zero? status) + (string=? str "hello, world"))))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (srfi srfi-11) (srfi srfi-64) + (gnu build marionette)) + + (define marionette + (make-marionette (list #$(virtual-machine os)))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "singularity") + + (test-assert "singularity exec /bin/guile (as root)" + (marionette-eval '#$singularity-exec + marionette)) + + (test-equal "singularity exec /bin/guile (unprivileged)" + 0 + (marionette-eval + `(begin + (use-modules (ice-9 match)) + + (match (primitive-fork) + (0 + (dynamic-wind + (const #f) + (lambda () + (setgid 1000) + (setuid 1000) + (execl #$(program-file "singularity-exec-test" + #~(exit #$singularity-exec)) + "test")) + (lambda () + (primitive-exit 127)))) + (pid + (cdr (waitpid pid))))) + marionette)) + + (test-equal "singularity run" ;test the entry point + 42 + (marionette-eval + `(status:exit-val + (system* #$(file-append singularity "/bin/singularity") + "run" #$image "-c" "(exit 42)")) + marionette)) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "singularity-test" test)) + +(define (build-tarball&run-singularity-test) + (mlet* %store-monad + ((_ (set-grafting #f)) + (guile (set-guile-for-build (default-guile))) + ;; 'singularity exec' insists on having /bin/sh in the image. + (profile (profile-derivation (packages->manifest + (list bash-minimal guile-2.2)) + #:hooks '() + #:locales? #f)) + (tarball (squashfs-image "singularity-pack" profile + #:entry-point "bin/guile" + #:symlinks '(("/bin" -> "bin"))))) + (run-singularity-test tarball))) + +(define %test-singularity + (system-test + (name "singularity") + (description "Test Singularity container of Guix.") + (value (build-tarball&run-singularity-test)))) diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm index 319655396a..7c1c0aa511 100644 --- a/gnu/tests/web.scm +++ b/gnu/tests/web.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> -;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> +;;; Copyright © 2017, 2019 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2017, 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Pierre-Antoine Rouby <pierre-antoine.rouby@inria.fr> ;;; Copyright © 2018 Marius Bakke <mbakke@fastmail.com> @@ -28,15 +28,29 @@ #:use-module (gnu system vm) #:use-module (gnu services) #:use-module (gnu services web) + #:use-module (gnu services databases) + #:use-module (gnu services getmail) #:use-module (gnu services networking) + #:use-module (gnu services shepherd) + #:use-module (gnu services mail) + #:use-module (gnu packages databases) + #:use-module (gnu packages patchutils) + #:use-module (gnu packages python) + #:use-module (gnu packages web) + #:use-module (guix packages) + #:use-module (guix modules) + #:use-module (guix records) #:use-module (guix gexp) #:use-module (guix store) + #:use-module (guix utils) + #:use-module (ice-9 match) #:export (%test-httpd %test-nginx %test-varnish %test-php-fpm %test-hpcguix-web - %test-tailon)) + %test-tailon + %test-patchwork)) (define %index.html-contents ;; Contents of the /index.html file. @@ -498,3 +512,149 @@ HTTP-PORT." (name "tailon") (description "Connect to a running Tailon server.") (value (run-tailon-test)))) + + +;;; +;;; Patchwork +;;; + +(define patchwork-initial-database-setup-service + (match-lambda + (($ <patchwork-database-configuration> + engine name user password host port) + + (define start-gexp + #~(lambda () + (let ((pid (primitive-fork)) + (postgres (getpwnam "postgres"))) + (if (eq? pid 0) + (dynamic-wind + (const #t) + (lambda () + (setgid (passwd:gid postgres)) + (setuid (passwd:uid postgres)) + (primitive-exit + (if (and + (zero? + (system* #$(file-append postgresql "/bin/createuser") + #$user)) + (zero? + (system* #$(file-append postgresql "/bin/createdb") + "-O" #$user #$name))) + 0 + 1))) + (lambda () + (primitive-exit 1))) + (zero? (cdr (waitpid pid))))))) + + (shepherd-service + (requirement '(postgres)) + (provision '(patchwork-postgresql-user-and-database)) + (start start-gexp) + (stop #~(const #f)) + (respawn? #f) + (documentation "Setup patchwork database."))))) + +(define (patchwork-os patchwork) + (simple-operating-system + (service dhcp-client-service-type) + (service httpd-service-type + (httpd-configuration + (config + (httpd-config-file + (listen '("8080")))))) + (service postgresql-service-type) + (service patchwork-service-type + (patchwork-configuration + (patchwork patchwork) + (domain "localhost") + (settings-module + (patchwork-settings-module + (allowed-hosts (list domain)) + (default-from-email ""))) + (getmail-retriever-config + (getmail-retriever-configuration + (type "SimpleIMAPSSLRetriever") + (server "imap.example.com") + (port 993) + (username "username") + (password "password") + (extra-parameters + '((mailboxes . ("INBOX")))))))) + (simple-service 'patchwork-database-setup + shepherd-root-service-type + (list + (patchwork-initial-database-setup-service + (patchwork-database-configuration)))))) + +(define (run-patchwork-test patchwork) + "Run tests in %NGINX-OS, which has nginx running and listening on +HTTP-PORT." + (define os + (marionette-operating-system + (patchwork-os patchwork) + #:imported-modules '((gnu services herd) + (guix combinators)))) + + (define forwarded-port 8080) + + (define vm + (virtual-machine + (operating-system os) + (port-forwardings `((8080 . ,forwarded-port))))) + + (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 + (make-marionette (list #$vm))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "patchwork") + + (test-assert "patchwork-postgresql-user-and-service started" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (match (start-service 'patchwork-postgresql-user-and-database) + (#f #f) + (('service response-parts ...) + (match (assq-ref response-parts 'running) + ((#t) #t) + ((pid) (number? pid)))))) + marionette)) + + (test-assert "httpd running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'httpd)) + marionette)) + + (test-equal "http-get" + 200 + (let-values + (((response text) + (http-get #$(simple-format + #f "http://localhost:~A/" forwarded-port) + #:decode-body? #t))) + (response-code response))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "patchwork-test" test)) + +(define %test-patchwork + (system-test + (name "patchwork") + (description "Connect to a running Patchwork service.") + (value (run-patchwork-test patchwork)))) |