diff options
| -rw-r--r-- | gnu/tests/base.scm | 310 | ||||
| -rw-r--r-- | gnu/tests/dict.scm | 165 | ||||
| -rw-r--r-- | gnu/tests/mail.scm | 388 | ||||
| -rw-r--r-- | gnu/tests/messaging.scm | 198 | ||||
| -rw-r--r-- | gnu/tests/networking.scm | 95 | ||||
| -rw-r--r-- | gnu/tests/nfs.scm | 140 | ||||
| -rw-r--r-- | gnu/tests/ssh.scm | 268 | ||||
| -rw-r--r-- | gnu/tests/web.scm | 125 |
8 files changed, 846 insertions, 843 deletions
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm index 8389b67f68..6132aa96ef 100644 --- a/gnu/tests/base.scm +++ b/gnu/tests/base.scm @@ -34,7 +34,6 @@ #:use-module (gnu packages package-management) #:use-module (guix gexp) #:use-module (guix store) - #:use-module (guix monads) #:use-module (guix packages) #:use-module (srfi srfi-1) #:export (run-basic-test @@ -393,17 +392,16 @@ info --version") "Instrument %SIMPLE-OS, run it in a VM, and run a series of basic functionality tests.") (value - (mlet* %store-monad ((os -> (marionette-operating-system - %simple-os - #:imported-modules '((gnu services herd) - (guix combinators)))) - (run (system-qemu-image/shared-store-script - os #:graphic? #f))) + (let* ((os (marionette-operating-system + %simple-os + #:imported-modules '((gnu services herd) + (guix combinators)))) + (vm (virtual-machine os))) ;; XXX: Add call to 'virtualized-operating-system' to get the exact same ;; set of services as the OS produced by ;; 'system-qemu-image/shared-store-script'. (run-basic-test (virtualized-operating-system os '()) - #~(list #$run)))))) + #~(list #$vm)))))) ;;; @@ -430,60 +428,60 @@ functionality tests.") (mcron-service (list job1 job2 job3))))) (define (run-mcron-test name) - (mlet* %store-monad ((os -> (marionette-operating-system - %mcron-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 (gnu build marionette) - (srfi srfi-64) - (ice-9 match)) - - (define marionette - (make-marionette (list #$command))) - - (mkdir #$output) - (chdir #$output) - - (test-begin "mcron") - - (test-eq "service running" - 'running! - (marionette-eval - '(begin - (use-modules (gnu services herd)) - (start-service 'mcron) - 'running!) - marionette)) - - ;; Make sure root's mcron job runs, has its cwd set to "/root", and - ;; runs with the right UID/GID. - (test-equal "root's job" - '(0 0) - (wait-for-file "/root/witness" marionette)) - - ;; Likewise for Alice's job. We cannot know what its GID is since - ;; it's chosen by 'groupadd', but it's strictly positive. - (test-assert "alice's job" - (match (wait-for-file "/home/alice/witness" marionette) - ((1000 gid) - (>= gid 100)))) - - ;; Last, the job that uses a command; allows us to test whether - ;; $PATH is sane. (Note that 'marionette-eval' stringifies objects - ;; that don't have a read syntax, hence the string.) - (test-equal "root's job with command" - "#<eof>" - (wait-for-file "/root/witness-touch" marionette)) - - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0))))) - - (gexp->derivation name test))) + (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-eq "service running" + 'running! + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'mcron) + 'running!) + marionette)) + + ;; Make sure root's mcron job runs, has its cwd set to "/root", and + ;; runs with the right UID/GID. + (test-equal "root's job" + '(0 0) + (wait-for-file "/root/witness" marionette)) + + ;; Likewise for Alice's job. We cannot know what its GID is since + ;; it's chosen by 'groupadd', but it's strictly positive. + (test-assert "alice's job" + (match (wait-for-file "/home/alice/witness" marionette) + ((1000 gid) + (>= gid 100)))) + + ;; Last, the job that uses a command; allows us to test whether + ;; $PATH is sane. (Note that 'marionette-eval' stringifies objects + ;; that don't have a read syntax, hence the string.) + (test-equal "root's job with command" + "#<eof>" + (wait-for-file "/root/witness-touch" marionette)) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation name test)) (define %test-mcron (system-test @@ -526,102 +524,102 @@ functionality tests.") ;; *after* nscd. Failing to do that, libc will try to connect to nscd, ;; fail, then never try again (see '__nss_not_use_nscd_hosts' in libc), ;; leading to '.local' resolution failures. - (mlet* %store-monad ((os -> (marionette-operating-system - %avahi-os - #:requirements '(nscd) - #:imported-modules '((gnu services herd) - (guix combinators)))) - (run (system-qemu-image/shared-store-script - os #:graphic? #f))) - (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 #$run))) - - (mkdir #$output) - (chdir #$output) - - (test-begin "avahi") - - (test-assert "wait for services" - (marionette-eval - '(begin - (use-modules (gnu services herd)) + (define os + (marionette-operating-system + %avahi-os + #:requirements '(nscd) + #:imported-modules '((gnu services herd) + (guix combinators)))) - (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) - 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)) + (define mdns-host-name + (string-append (operating-system-host-name os) + ".local")) - (test-equal "avahi-browse" - 0 - (marionette-eval - '(system* "avahi-browse" "-avt") - marionette)) - - (test-assert "getaddrinfo .local" - ;; Wait for the 'avahi-daemon' service and perform a resolution. - (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 + (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 "wait for services" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + + (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) + 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* "avahi-browse" "-avt") + marionette)) + + (test-assert "getaddrinfo .local" + ;; Wait for the 'avahi-daemon' service and perform a resolution. + (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 diff --git a/gnu/tests/dict.scm b/gnu/tests/dict.scm index 16b6edbd9e..b9c741e3e0 100644 --- a/gnu/tests/dict.scm +++ b/gnu/tests/dict.scm @@ -27,7 +27,6 @@ #:use-module (gnu packages wordnet) #:use-module (guix gexp) #:use-module (guix store) - #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix modules) #:export (%test-dicod)) @@ -54,86 +53,90 @@ (define* (run-dicod-test) "Run tests of 'dicod-service-type'." - (mlet* %store-monad ((os -> (marionette-operating-system - %dicod-os - #:imported-modules - (source-module-closure '((gnu services herd))))) - (command (system-qemu-image/shared-store-script - os #:graphic? #f))) - (define test - (with-imported-modules '((gnu build marionette)) - #~(begin - (use-modules (ice-9 rdelim) - (ice-9 regex) - (srfi srfi-64) - (gnu build marionette)) - (define marionette - ;; Forward the guest's DICT port to local port 8000. - (make-marionette (list #$command "-net" - "user,hostfwd=tcp::8000-:2628"))) - - (define %dico-socket - (socket PF_INET SOCK_STREAM 0)) - - (mkdir #$output) - (chdir #$output) - - (test-begin "dicod") - - ;; Wait for the service to be started. - (test-eq "service is running" - 'running! - (marionette-eval - '(begin - (use-modules (gnu services herd)) - (start-service 'dicod) - 'running!) - marionette)) - - ;; Wait until dicod is actually listening. - ;; TODO: Use a PID file instead. - (test-assert "connect inside" - (marionette-eval - '(begin - (use-modules (ice-9 rdelim)) - (let ((sock (socket PF_INET SOCK_STREAM 0))) - (let loop ((i 0)) - (pk 'try i) - (catch 'system-error - (lambda () - (connect sock AF_INET INADDR_LOOPBACK 2628)) - (lambda args - (pk 'connection-error args) - (when (< i 20) - (sleep 1) - (loop (+ 1 i)))))) - (read-line sock 'concat))) - marionette)) - - (test-assert "connect" - (let ((addr (make-socket-address AF_INET INADDR_LOOPBACK 8000))) - (connect %dico-socket addr) - (read-line %dico-socket 'concat))) - - (test-equal "CLIENT" - "250 ok\r\n" - (begin - (display "CLIENT \"GNU Guile\"\r\n" %dico-socket) - (read-line %dico-socket 'concat))) - - (test-assert "DEFINE" - (begin - (display "DEFINE ! hello\r\n" %dico-socket) - (display "QUIT\r\n" %dico-socket) - (let ((result (read-string %dico-socket))) - (and (string-contains result "gcide") - (string-contains result "hello") - result)))) - - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0))))) - - (gexp->derivation "dicod" test))) + (define os + (marionette-operating-system + %dicod-os + #:imported-modules + (source-module-closure '((gnu services herd))))) + + (define vm + (virtual-machine + (operating-system os) + (port-forwardings '((8000 . 2628))))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (ice-9 rdelim) + (ice-9 regex) + (srfi srfi-64) + (gnu build marionette)) + (define marionette + ;; Forward the guest's DICT port to local port 8000. + (make-marionette (list #$vm))) + + (define %dico-socket + (socket PF_INET SOCK_STREAM 0)) + + (mkdir #$output) + (chdir #$output) + + (test-begin "dicod") + + ;; Wait for the service to be started. + (test-eq "service is running" + 'running! + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'dicod) + 'running!) + marionette)) + + ;; Wait until dicod is actually listening. + ;; TODO: Use a PID file instead. + (test-assert "connect inside" + (marionette-eval + '(begin + (use-modules (ice-9 rdelim)) + (let ((sock (socket PF_INET SOCK_STREAM 0))) + (let loop ((i 0)) + (pk 'try i) + (catch 'system-error + (lambda () + (connect sock AF_INET INADDR_LOOPBACK 2628)) + (lambda args + (pk 'connection-error args) + (when (< i 20) + (sleep 1) + (loop (+ 1 i)))))) + (read-line sock 'concat))) + marionette)) + + (test-assert "connect" + (let ((addr (make-socket-address AF_INET INADDR_LOOPBACK 8000))) + (connect %dico-socket addr) + (read-line %dico-socket 'concat))) + + (test-equal "CLIENT" + "250 ok\r\n" + (begin + (display "CLIENT \"GNU Guile\"\r\n" %dico-socket) + (read-line %dico-socket 'concat))) + + (test-assert "DEFINE" + (begin + (display "DEFINE ! hello\r\n" %dico-socket) + (display "QUIT\r\n" %dico-socket) + (let ((result (read-string %dico-socket))) + (and (string-contains result "gcide") + (string-contains result "hello") + result)))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "dicod" test)) (define %test-dicod (system-test diff --git a/gnu/tests/mail.scm b/gnu/tests/mail.scm index 247f4f667f..312df9b1cd 100644 --- a/gnu/tests/mail.scm +++ b/gnu/tests/mail.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Sou Bunnbu <iyzsong@member.fsf.org> ;;; Copyright © 2017 Carlo Zancanaro <carlo@zancanaro.id.au> +;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,7 +26,6 @@ #:use-module (gnu services mail) #:use-module (gnu services networking) #:use-module (guix gexp) - #:use-module (guix monads) #:use-module (guix store) #:use-module (ice-9 ftw) #:export (%test-opensmtpd @@ -44,105 +44,105 @@ accept from any for local deliver to mbox (define (run-opensmtpd-test) "Return a test of an OS running OpenSMTPD service." - (mlet* %store-monad ((command (system-qemu-image/shared-store-script - (marionette-operating-system - %opensmtpd-os - #:imported-modules '((gnu services herd))) - #:graphic? #f))) - (define test - (with-imported-modules '((gnu build marionette)) - #~(begin - (use-modules (rnrs base) - (srfi srfi-64) - (ice-9 rdelim) - (ice-9 regex) - (gnu build marionette)) - - (define marionette - (make-marionette - ;; Enable TCP forwarding of the guest's port 25. - '(#$command "-net" "user,hostfwd=tcp::1025-:25"))) - - (define (read-reply-code port) - "Read a SMTP reply from PORT and return its reply code." - (let* ((line (read-line port)) - (mo (string-match "([0-9]+)([ -]).*" line)) - (code (string->number (match:substring mo 1))) - (finished? (string= " " (match:substring mo 2)))) - (if finished? - code - (read-reply-code port)))) - - (mkdir #$output) - (chdir #$output) - - (test-begin "opensmptd") - - (test-assert "service is running" - (marionette-eval - '(begin - (use-modules (gnu services herd)) - (start-service 'smtpd) - #t) - marionette)) - - (test-assert "mbox is empty" - (marionette-eval - '(and (file-exists? "/var/mail") - (not (file-exists? "/var/mail/root"))) - marionette)) - - (test-eq "accept an email" - #t - (let* ((smtp (socket AF_INET SOCK_STREAM 0)) - (addr (make-socket-address AF_INET INADDR_LOOPBACK 1025))) - (connect smtp addr) - ;; Be greeted. - (read-reply-code smtp) ;220 - ;; Greet the server. - (write-line "EHLO somehost" smtp) - (read-reply-code smtp) ;250 - ;; Set sender email. - (write-line "MAIL FROM: <someone>" smtp) - (read-reply-code smtp) ;250 - ;; Set recipient email. - (write-line "RCPT TO: <root>" smtp) - (read-reply-code smtp) ;250 - ;; Send message. - (write-line "DATA" smtp) - (read-reply-code smtp) ;354 - (write-line "Subject: Hello" smtp) - (newline smtp) - (write-line "Nice to meet you!" smtp) - (write-line "." smtp) - (read-reply-code smtp) ;250 - ;; Say goodbye. - (write-line "QUIT" smtp) - (read-reply-code smtp) ;221 - (close smtp) - #t)) - - (test-assert "mail arrived" - (marionette-eval - '(begin - (use-modules (ice-9 popen) - (ice-9 rdelim)) - - (define (queue-empty?) - (eof-object? - (read-line - (open-input-pipe "smtpctl show queue")))) - - (let wait () - (if (queue-empty?) - (file-exists? "/var/mail/root") - (begin (sleep 1) (wait))))) - marionette)) - - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0))))) - - (gexp->derivation "opensmtpd-test" test))) + (define vm + (virtual-machine + (operating-system (marionette-operating-system + %opensmtpd-os + #:imported-modules '((gnu services herd)))) + (port-forwardings '((1025 . 25))))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (rnrs base) + (srfi srfi-64) + (ice-9 rdelim) + (ice-9 regex) + (gnu build marionette)) + + (define marionette + (make-marionette '(#$vm))) + + (define (read-reply-code port) + "Read a SMTP reply from PORT and return its reply code." + (let* ((line (read-line port)) + (mo (string-match "([0-9]+)([ -]).*" line)) + (code (string->number (match:substring mo 1))) + (finished? (string= " " (match:substring mo 2)))) + (if finished? + code + (read-reply-code port)))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "opensmptd") + + (test-assert "service is running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'smtpd) + #t) + marionette)) + + (test-assert "mbox is empty" + (marionette-eval + '(and (file-exists? "/var/mail") + (not (file-exists? "/var/mail/root"))) + marionette)) + + (test-eq "accept an email" + #t + (let* ((smtp (socket AF_INET SOCK_STREAM 0)) + (addr (make-socket-address AF_INET INADDR_LOOPBACK 1025))) + (connect smtp addr) + ;; Be greeted. + (read-reply-code smtp) ;220 + ;; Greet the server. + (write-line "EHLO somehost" smtp) + (read-reply-code smtp) ;250 + ;; Set sender email. + (write-line "MAIL FROM: <someone>" smtp) + (read-reply-code smtp) ;250 + ;; Set recipient email. + (write-line "RCPT TO: <root>" smtp) + (read-reply-code smtp) ;250 + ;; Send message. + (write-line "DATA" smtp) + (read-reply-code smtp) ;354 + (write-line "Subject: Hello" smtp) + (newline smtp) + (write-line "Nice to meet you!" smtp) + (write-line "." smtp) + (read-reply-code smtp) ;250 + ;; Say goodbye. + (write-line "QUIT" smtp) + (read-reply-code smtp) ;221 + (close smtp) + #t)) + + (test-assert "mail arrived" + (marionette-eval + '(begin + (use-modules (ice-9 popen) + (ice-9 rdelim)) + + (define (queue-empty?) + (eof-object? + (read-line + (open-input-pipe "smtpctl show queue")))) + + (let wait () + (if (queue-empty?) + (file-exists? "/var/mail/root") + (begin (sleep 1) (wait))))) + marionette)) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "opensmtpd-test" test)) (define %test-opensmtpd (system-test @@ -179,100 +179,100 @@ acl_check_data: (define (run-exim-test) "Return a test of an OS running an Exim service." - (mlet* %store-monad ((command (system-qemu-image/shared-store-script - (marionette-operating-system - %exim-os - #:imported-modules '((gnu services herd))) - #:graphic? #f))) - (define test - (with-imported-modules '((gnu build marionette) - (ice-9 ftw)) - #~(begin - (use-modules (rnrs base) - (srfi srfi-64) - (ice-9 ftw) - (ice-9 rdelim) - (ice-9 regex) - (gnu build marionette)) - - (define marionette - (make-marionette - ;; Enable TCP forwarding of the guest's port 25. - '(#$command "-net" "user,hostfwd=tcp::1025-:25"))) - - (define (read-reply-code port) - "Read a SMTP reply from PORT and return its reply code." - (let* ((line (read-line port)) - (mo (string-match "([0-9]+)([ -]).*" line)) - (code (string->number (match:substring mo 1))) - (finished? (string= " " (match:substring mo 2)))) - (if finished? - code - (read-reply-code port)))) - - (define smtp (socket AF_INET SOCK_STREAM 0)) - (define addr (make-socket-address AF_INET INADDR_LOOPBACK 1025)) - - (mkdir #$output) - (chdir #$output) - - (test-begin "exim") - - (test-assert "service is running" - (marionette-eval - '(begin - (use-modules (gnu services herd)) - (start-service 'exim) - #t) - marionette)) - - (sleep 1) ;; give the service time to start talking - - (connect smtp addr) - ;; Be greeted. - (test-eq "greeting received" - 220 (read-reply-code smtp)) - ;; Greet the server. - (write-line "EHLO somehost" smtp) - (test-eq "greeting successful" - 250 (read-reply-code smtp)) - ;; Set sender email. - (write-line "MAIL FROM: test@example.com" smtp) - (test-eq "sender set" - 250 (read-reply-code smtp)) ;250 - ;; Set recipient email. - (write-line "RCPT TO: root@komputilo" smtp) - (test-eq "recipient set" - 250 (read-reply-code smtp)) ;250 - ;; Send message. - (write-line "DATA" smtp) - (test-eq "data begun" - 354 (read-reply-code smtp)) ;354 - (write-line "Subject: Hello" smtp) - (newline smtp) - (write-line "Nice to meet you!" smtp) - (write-line "." smtp) - (test-eq "message sent" - 250 (read-reply-code smtp)) ;250 - ;; Say goodbye. - (write-line "QUIT" smtp) - (test-eq "quit successful" - 221 (read-reply-code smtp)) ;221 - (close smtp) - - (test-eq "the email is received" - 1 - (marionette-eval - '(begin - (use-modules (ice-9 ftw)) - (length (scandir "/var/spool/exim/msglog" - (lambda (x) (not (string-prefix? "." x)))))) - marionette)) - - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0))))) - - (gexp->derivation "exim-test" test))) + (define vm + (virtual-machine + (operating-system (marionette-operating-system + %exim-os + #:imported-modules '((gnu services herd)))) + (port-forwardings '((1025 . 25))))) + + (define test + (with-imported-modules '((gnu build marionette) + (ice-9 ftw)) + #~(begin + (use-modules (rnrs base) + (srfi srfi-64) + (ice-9 ftw) + (ice-9 rdelim) + (ice-9 regex) + (gnu build marionette)) + + (define marionette + (make-marionette '(#$vm))) + + (define (read-reply-code port) + "Read a SMTP reply from PORT and return its reply code." + (let* ((line (read-line port)) + (mo (string-match "([0-9]+)([ -]).*" line)) + (code (string->number (match:substring mo 1))) + (finished? (string= " " (match:substring mo 2)))) + (if finished? + code + (read-reply-code port)))) + + (define smtp (socket AF_INET SOCK_STREAM 0)) + (define addr (make-socket-address AF_INET INADDR_LOOPBACK 1025)) + + (mkdir #$output) + (chdir #$output) + + (test-begin "exim") + + (test-assert "service is running" + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'exim) + #t) + marionette)) + + (sleep 1) ;; give the service time to start talking + + (connect smtp addr) + ;; Be greeted. + (test-eq "greeting received" + 220 (read-reply-code smtp)) + ;; Greet the server. + (write-line "EHLO somehost" smtp) + (test-eq "greeting successful" + 250 (read-reply-code smtp)) + ;; Set sender email. + (write-line "MAIL FROM: test@example.com" smtp) + (test-eq "sender set" + 250 (read-reply-code smtp)) ;250 + ;; Set recipient email. + (write-line "RCPT TO: root@komputilo" smtp) + (test-eq "recipient set" + 250 (read-reply-code smtp)) ;250 + ;; Send message. + (write-line "DATA" smtp) + (test-eq "data begun" + 354 (read-reply-code smtp)) ;354 + (write-line "Subject: Hello" smtp) + (newline smtp) + (write-line "Nice to meet you!" smtp) + (write-line "." smtp) + (test-eq "message sent" + 250 (read-reply-code smtp)) ;250 + ;; Say goodbye. + (write-line "QUIT" smtp) + (test-eq "quit successful" + 221 (read-reply-code smtp)) ;221 + (close smtp) + + (test-eq "the email is received" + 1 + (marionette-eval + '(begin + (use-modules (ice-9 ftw)) + (length (scandir "/var/spool/exim/msglog" + (lambda (x) (not (string-prefix? "." x)))))) + marionette)) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "exim-test" test)) (define %test-exim (system-test diff --git a/gnu/tests/messaging.scm b/gnu/tests/messaging.scm index b76b8e8434..0ba0c839de 100644 --- a/gnu/tests/messaging.scm +++ b/gnu/tests/messaging.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org> +;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,108 +27,109 @@ #:use-module (gnu packages messaging) #:use-module (guix gexp) #:use-module (guix store) - #:use-module (guix monads) #:export (%test-prosody)) (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 - (simple-operating-system (dhcp-client-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 (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 (wait-for-file #$pid-file - marionette)))) - (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 os + (marionette-operating-system + (simple-operating-system (dhcp-client-service) + xmpp-service) + #:imported-modules '((gnu services herd)))) + + (define port 15222) + + (define vm + (virtual-machine + (operating-system os) + (port-forwardings `((,port . 5222))))) + + (define username "alice") + (define server "localhost") + (define jid (string-append username "@" server)) + (define password "correct horse battery staple") + (define message "hello world") + (define 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 + (make-marionette (list #$vm))) + + (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 (wait-for-file #$pid-file + marionette)))) + (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 diff --git a/gnu/tests/networking.scm b/gnu/tests/networking.scm index cfcb490874..aeee105a1c 100644 --- a/gnu/tests/networking.scm +++ b/gnu/tests/networking.scm @@ -74,60 +74,61 @@ done" )))))))))) (define* (run-inetd-test) "Run tests in %INETD-OS, where the inetd service provides an echo service on port 7, and a dict service on port 2628." - (mlet* %store-monad ((os -> (marionette-operating-system %inetd-os)) - (command (system-qemu-image/shared-store-script - os #:graphic? #f))) - (define test - (with-imported-modules '((gnu build marionette)) - #~(begin - (use-modules (ice-9 rdelim) - (srfi srfi-64) - (gnu build marionette)) - (define marionette - ;; Forward guest ports 7 and 2628 to host ports 8007 and 8628. - (make-marionette (list #$command "-net" - (string-append - "user" - ",hostfwd=tcp::8007-:7" - ",hostfwd=tcp::8628-:2628")))) + (define os + (marionette-operating-system %inetd-os)) - (mkdir #$output) - (chdir #$output) + (define vm + (virtual-machine + (operating-system os) + (port-forwardings `((8007 . 7) + (8628 . 2628))))) - (test-begin "inetd") + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (ice-9 rdelim) + (srfi srfi-64) + (gnu build marionette)) + (define marionette + (make-marionette (list #$vm))) - ;; Make sure the PID file is created. - (test-assert "PID file" - (marionette-eval - '(file-exists? "/var/run/inetd.pid") - marionette)) + (mkdir #$output) + (chdir #$output) - ;; Test the echo service. - (test-equal "echo response" - "Hello, Guix!" - (let ((echo (socket PF_INET SOCK_STREAM 0)) - (addr (make-socket-address AF_INET INADDR_LOOPBACK 8007))) - (connect echo addr) - (display "Hello, Guix!\n" echo) - (let ((response (read-line echo))) - (close echo) - response))) + (test-begin "inetd") - ;; Test the dict service - (test-equal "dict response" - "GNU Guix is a package management tool for the GNU system." - (let ((dict (socket PF_INET SOCK_STREAM 0)) - (addr (make-socket-address AF_INET INADDR_LOOPBACK 8628))) - (connect dict addr) - (display "DEFINE Guix\n" dict) - (let ((response (read-line dict))) - (close dict) - response))) + ;; Make sure the PID file is created. + (test-assert "PID file" + (marionette-eval + '(file-exists? "/var/run/inetd.pid") + marionette)) - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + ;; Test the echo service. + (test-equal "echo response" + "Hello, Guix!" + (let ((echo (socket PF_INET SOCK_STREAM 0)) + (addr (make-socket-address AF_INET INADDR_LOOPBACK 8007))) + (connect echo addr) + (display "Hello, Guix!\n" echo) + (let ((response (read-line echo))) + (close echo) + response))) - (gexp->derivation "inetd-test" test))) + ;; Test the dict service + (test-equal "dict response" + "GNU Guix is a package management tool for the GNU system." + (let ((dict (socket PF_INET SOCK_STREAM 0)) + (addr (make-socket-address AF_INET INADDR_LOOPBACK 8628))) + (connect dict addr) + (display "DEFINE Guix\n" dict) + (let ((response (read-line dict))) + (close dict) + response))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation "inetd-test" test)) (define %test-inetd (system-test diff --git a/gnu/tests/nfs.scm b/gnu/tests/nfs.scm index 9e1ac1d55a..2e666b2c08 100644 --- a/gnu/tests/nfs.scm +++ b/gnu/tests/nfs.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> ;;; Copyright © 2016 John Darrington <jmd@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; @@ -55,75 +55,75 @@ (define (run-nfs-test name socket) "Run a test of an OS running RPC-SERVICE, which should create SOCKET." - (mlet* %store-monad ((os -> (marionette-operating-system - %base-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 (gnu build marionette) - (srfi srfi-64)) - - (define marionette - (make-marionette (list #$command))) - - (define (wait-for-socket file) - ;; Wait until SOCKET exists in the guest - (marionette-eval - `(let loop ((i 10)) - (cond ((and (file-exists? ,file) - (eq? 'socket (stat:type (stat ,file)))) - #t) - ((> i 0) - (sleep 1) - (loop (- i 1))) - (else - (error "Socket didn't show up: " ,file)))) - marionette)) - - (mkdir #$output) - (chdir #$output) - - (test-begin "rpc-daemon") - - ;; Wait for the rpcbind daemon to be up and running. - (test-eq "RPC service running" - 'running! - (marionette-eval - '(begin - (use-modules (gnu services herd)) - (start-service 'rpcbind-daemon) - 'running!) - marionette)) - - ;; Check the socket file and that the service is still running. - (test-assert "RPC socket exists" - (and - (wait-for-socket #$socket) - (marionette-eval - '(begin - (use-modules (gnu services herd) - (srfi srfi-1)) - - (live-service-running - (find (lambda (live) - (memq 'rpcbind-daemon - (live-service-provision live))) - (current-services)))) - marionette))) - - (test-assert "Probe RPC daemon" - (marionette-eval - '(zero? (system* "rpcinfo" "-p")) - marionette)) - - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0))))) - - (gexp->derivation name test))) + (define os + (marionette-operating-system + %base-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)) + + (define marionette + (make-marionette (list #$(virtual-machine os)))) + + (define (wait-for-socket file) + ;; Wait until SOCKET exists in the guest + (marionette-eval + `(let loop ((i 10)) + (cond ((and (file-exists? ,file) + (eq? 'socket (stat:type (stat ,file)))) + #t) + ((> i 0) + (sleep 1) + (loop (- i 1))) + (else + (error "Socket didn't show up: " ,file)))) + marionette)) + + (mkdir #$output) + (chdir #$output) + + (test-begin "rpc-daemon") + + ;; Wait for the rpcbind daemon to be up and running. + (test-eq "RPC service running" + 'running! + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'rpcbind-daemon) + 'running!) + marionette)) + + ;; Check the socket file and that the service is still running. + (test-assert "RPC socket exists" + (and + (wait-for-socket #$socket) + (marionette-eval + '(begin + (use-modules (gnu services herd) + (srfi srfi-1)) + + (live-service-running + (find (lambda (live) + (memq 'rpcbind-daemon + (live-service-provision live))) + (current-services)))) + marionette))) + + (test-assert "Probe RPC daemon" + (marionette-eval + '(zero? (system* "rpcinfo" "-p")) + marionette)) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation name test)) (define %test-nfs (system-test diff --git a/gnu/tests/ssh.scm b/gnu/tests/ssh.scm index 9c83a9cd48..05a8d35476 100644 --- a/gnu/tests/ssh.scm +++ b/gnu/tests/ssh.scm @@ -27,7 +27,6 @@ #:use-module (gnu packages ssh) #:use-module (guix gexp) #:use-module (guix store) - #:use-module (guix monads) #:export (%test-openssh %test-dropbear)) @@ -37,142 +36,143 @@ SSH-SERVICE must be configured to listen on port 22 and to allow for root and empty-password logins. When SFTP? is true, run an SFTP server test." - (mlet* %store-monad ((os -> (marionette-operating-system - (simple-operating-system - (dhcp-client-service) - ssh-service) - #: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 - (eval-when (expand load eval) - ;; Prepare to use Guile-SSH. - (set! %load-path - (cons (string-append #+guile2.0-ssh "/share/guile/site/" - (effective-version)) - %load-path))) - - (use-modules (gnu build marionette) - (srfi srfi-26) - (srfi srfi-64) - (ice-9 match) - (ssh session) - (ssh auth) - (ssh channel) - (ssh sftp)) - - (define marionette - ;; Enable TCP forwarding of the guest's port 22. - (make-marionette (list #$command "-net" - "user,hostfwd=tcp::2222-:22"))) - - (define (make-session-for-test) - "Make a session with predefined parameters for a test." - (make-session #:user "root" - #:port 2222 - #:host "localhost" - #:log-verbosity 'protocol)) - - (define (call-with-connected-session proc) - "Call the one-argument procedure PROC with a freshly created and + (define os + (marionette-operating-system + (simple-operating-system (dhcp-client-service) ssh-service) + #:imported-modules '((gnu services herd) + (guix combinators)))) + (define vm + (virtual-machine + (operating-system os) + (port-forwardings '((2222 . 22))))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (eval-when (expand load eval) + ;; Prepare to use Guile-SSH. + (set! %load-path + (cons (string-append #+guile2.0-ssh "/share/guile/site/" + (effective-version)) + %load-path))) + + (use-modules (gnu build marionette) + (srfi srfi-26) + (srfi srfi-64) + (ice-9 match) + (ssh session) + (ssh auth) + (ssh channel) + (ssh sftp)) + + (define marionette + ;; Enable TCP forwarding of the guest's port 22. + (make-marionette (list #$vm))) + + (define (make-session-for-test) + "Make a session with predefined parameters for a test." + (make-session #:user "root" + #:port 2222 + #:host "localhost" + #:log-verbosity 'protocol)) + + (define (call-with-connected-session proc) + "Call the one-argument procedure PROC with a freshly created and connected SSH session object, return the result of the procedure call. The session is disconnected when the PROC is finished." - (let ((session (make-session-for-test))) - (dynamic-wind - (lambda () - (let ((result (connect! session))) - (unless (equal? result 'ok) - (error "Could not connect to a server" - session result)))) - (lambda () (proc session)) - (lambda () (disconnect! session))))) - - (define (call-with-connected-session/auth proc) - "Make an authenticated session. We should be able to connect as + (let ((session (make-session-for-test))) + (dynamic-wind + (lambda () + (let ((result (connect! session))) + (unless (equal? result 'ok) + (error "Could not connect to a server" + session result)))) + (lambda () (proc session)) + (lambda () (disconnect! session))))) + + (define (call-with-connected-session/auth proc) + "Make an authenticated session. We should be able to connect as root with an empty password." - (call-with-connected-session - (lambda (session) - ;; Try the simple authentication methods. Dropbear requires - ;; 'none' when there are no passwords, whereas OpenSSH accepts - ;; 'password' with an empty password. - (let loop ((methods (list (cut userauth-password! <> "") - (cut userauth-none! <>)))) - (match methods - (() - (error "all the authentication methods failed")) - ((auth rest ...) - (match (pk 'auth (auth session)) - ('success - (proc session)) - ('denied - (loop rest))))))))) - - (mkdir #$output) - (chdir #$output) - - (test-begin "ssh-daemon") - - ;; Wait for sshd to be up and running. - (test-eq "service running" - 'running! - (marionette-eval - '(begin - (use-modules (gnu services herd)) - (start-service 'ssh-daemon) - 'running!) - marionette)) - - ;; Check sshd's PID file. - (test-equal "sshd PID" - (wait-for-file #$pid-file marionette) - (marionette-eval - '(begin - (use-modules (gnu services herd) - (srfi srfi-1)) - - (live-service-running - (find (lambda (live) - (memq 'ssh-daemon - (live-service-provision live))) - (current-services)))) - marionette)) - - ;; Connect to the guest over SSH. Make sure we can run a shell - ;; command there. - (test-equal "shell command" - 'hello - (call-with-connected-session/auth - (lambda (session) - ;; FIXME: 'get-server-public-key' segfaults. - ;; (get-server-public-key session) - (let ((channel (make-channel session))) - (channel-open-session channel) - (channel-request-exec channel "echo hello > /root/witness") - (and (zero? (channel-get-exit-status channel)) - (wait-for-file "/root/witness" marionette)))))) - - ;; Connect to the guest over SFTP. Make sure we can write and - ;; read a file there. - (unless #$sftp? - (test-skip 1)) - (test-equal "SFTP file writing and reading" - 'hello - (call-with-connected-session/auth - (lambda (session) - (let ((sftp-session (make-sftp-session session)) - (witness "/root/sftp-witness")) - (call-with-remote-output-file sftp-session witness - (cut display "hello" <>)) - (call-with-remote-input-file sftp-session witness - read))))) - - (test-end) - (exit (= (test-runner-fail-count (test-runner-current)) 0))))) - - (gexp->derivation name test))) + (call-with-connected-session + (lambda (session) + ;; Try the simple authentication methods. Dropbear requires + ;; 'none' when there are no passwords, whereas OpenSSH accepts + ;; 'password' with an empty password. + (let loop ((methods (list (cut userauth-password! <> "") + (cut userauth-none! <>)))) + (match methods + (() + (error "all the authentication methods failed")) + ((auth rest ...) + (match (pk 'auth (auth session)) + ('success + (proc session)) + ('denied + (loop rest))))))))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "ssh-daemon") + + ;; Wait for sshd to be up and running. + (test-eq "service running" + 'running! + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'ssh-daemon) + 'running!) + marionette)) + + ;; Check sshd's PID file. + (test-equal "sshd PID" + (wait-for-file #$pid-file marionette) + (marionette-eval + '(begin + (use-modules (gnu services herd) + (srfi srfi-1)) + + (live-service-running + (find (lambda (live) + (memq 'ssh-daemon + (live-service-provision live))) + (current-services)))) + marionette)) + + ;; Connect to the guest over SSH. Make sure we can run a shell + ;; command there. + (test-equal "shell command" + 'hello + (call-with-connected-session/auth + (lambda (session) + ;; FIXME: 'get-server-public-key' segfaults. + ;; (get-server-public-key session) + (let ((channel (make-channel session))) + (channel-open-session channel) + (channel-request-exec channel "echo hello > /root/witness") + (and (zero? (channel-get-exit-status channel)) + (wait-for-file "/root/witness" marionette)))))) + + ;; Connect to the guest over SFTP. Make sure we can write and + ;; read a file there. + (unless #$sftp? + (test-skip 1)) + (test-equal "SFTP file writing and reading" + 'hello + (call-with-connected-session/auth + (lambda (session) + (let ((sftp-session (make-sftp-session session)) + (witness "/root/sftp-witness")) + (call-with-remote-output-file sftp-session witness + (cut display "hello" <>)) + (call-with-remote-input-file sftp-session witness + read))))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation name test)) (define %test-openssh (system-test diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm index bc7e3b89a9..3fa272c676 100644 --- a/gnu/tests/web.scm +++ b/gnu/tests/web.scm @@ -27,7 +27,6 @@ #:use-module (gnu services networking) #:use-module (guix gexp) #:use-module (guix store) - #:use-module (guix monads) #:export (%test-nginx)) (define %index.html-contents @@ -65,68 +64,68 @@ (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 os + (marionette-operating-system + %nginx-os + #:imported-modules '((gnu services herd) + (guix combinators)))) + + (define vm + (virtual-machine + (operating-system os) + (port-forwardings `((8080 . ,http-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 "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 |