tests: Use 'virtual-machine' records instead of monadic procedures.
* gnu/tests/base.scm (%test-basic-os): Use 'let*' instead of 'mlet*' and 'virtual-machine' instead of 'system-qemu-image/shared-store-script'. (run-mcron-test): Likewise. (run-nss-mdns-test): Likewise. * gnu/tests/dict.scm (run-dicod-test): Likewise. * gnu/tests/mail.scm (run-opensmtpd-test): Likewise. (run-exim-test): Likewise. * gnu/tests/messaging.scm (run-xmpp-test): Likewise. * gnu/tests/networking.scm (run-inetd-test): Likewise. * gnu/tests/nfs.scm (run-nfs-test): Likewise. * gnu/tests/ssh.scm (run-ssh-test): Likewise. * gnu/tests/web.scm (run-nginx-test): Likewise.master
parent
ed419fa0c5
commit
8b113790fa
|
@ -34,7 +34,6 @@
|
||||||
#:use-module (gnu packages package-management)
|
#:use-module (gnu packages package-management)
|
||||||
#:use-module (guix gexp)
|
#:use-module (guix gexp)
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (guix monads)
|
|
||||||
#:use-module (guix packages)
|
#:use-module (guix packages)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:export (run-basic-test
|
#:export (run-basic-test
|
||||||
|
@ -393,17 +392,16 @@ info --version")
|
||||||
"Instrument %SIMPLE-OS, run it in a VM, and run a series of basic
|
"Instrument %SIMPLE-OS, run it in a VM, and run a series of basic
|
||||||
functionality tests.")
|
functionality tests.")
|
||||||
(value
|
(value
|
||||||
(mlet* %store-monad ((os -> (marionette-operating-system
|
(let* ((os (marionette-operating-system
|
||||||
%simple-os
|
%simple-os
|
||||||
#:imported-modules '((gnu services herd)
|
#:imported-modules '((gnu services herd)
|
||||||
(guix combinators))))
|
(guix combinators))))
|
||||||
(run (system-qemu-image/shared-store-script
|
(vm (virtual-machine os)))
|
||||||
os #:graphic? #f)))
|
|
||||||
;; XXX: Add call to 'virtualized-operating-system' to get the exact same
|
;; XXX: Add call to 'virtualized-operating-system' to get the exact same
|
||||||
;; set of services as the OS produced by
|
;; set of services as the OS produced by
|
||||||
;; 'system-qemu-image/shared-store-script'.
|
;; 'system-qemu-image/shared-store-script'.
|
||||||
(run-basic-test (virtualized-operating-system os '())
|
(run-basic-test (virtualized-operating-system os '())
|
||||||
#~(list #$run))))))
|
#~(list #$vm))))))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
|
@ -430,60 +428,60 @@ functionality tests.")
|
||||||
(mcron-service (list job1 job2 job3)))))
|
(mcron-service (list job1 job2 job3)))))
|
||||||
|
|
||||||
(define (run-mcron-test name)
|
(define (run-mcron-test name)
|
||||||
(mlet* %store-monad ((os -> (marionette-operating-system
|
(define os
|
||||||
%mcron-os
|
(marionette-operating-system
|
||||||
#:imported-modules '((gnu services herd)
|
%mcron-os
|
||||||
(guix combinators))))
|
#:imported-modules '((gnu services herd)
|
||||||
(command (system-qemu-image/shared-store-script
|
(guix combinators))))
|
||||||
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
|
(define test
|
||||||
(make-marionette (list #$command)))
|
(with-imported-modules '((gnu build marionette))
|
||||||
|
#~(begin
|
||||||
|
(use-modules (gnu build marionette)
|
||||||
|
(srfi srfi-64)
|
||||||
|
(ice-9 match))
|
||||||
|
|
||||||
(mkdir #$output)
|
(define marionette
|
||||||
(chdir #$output)
|
(make-marionette (list #$(virtual-machine os))))
|
||||||
|
|
||||||
(test-begin "mcron")
|
(mkdir #$output)
|
||||||
|
(chdir #$output)
|
||||||
|
|
||||||
(test-eq "service running"
|
(test-begin "mcron")
|
||||||
'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
|
(test-eq "service running"
|
||||||
;; runs with the right UID/GID.
|
'running!
|
||||||
(test-equal "root's job"
|
(marionette-eval
|
||||||
'(0 0)
|
'(begin
|
||||||
(wait-for-file "/root/witness" marionette))
|
(use-modules (gnu services herd))
|
||||||
|
(start-service 'mcron)
|
||||||
|
'running!)
|
||||||
|
marionette))
|
||||||
|
|
||||||
;; Likewise for Alice's job. We cannot know what its GID is since
|
;; Make sure root's mcron job runs, has its cwd set to "/root", and
|
||||||
;; it's chosen by 'groupadd', but it's strictly positive.
|
;; runs with the right UID/GID.
|
||||||
(test-assert "alice's job"
|
(test-equal "root's job"
|
||||||
(match (wait-for-file "/home/alice/witness" marionette)
|
'(0 0)
|
||||||
((1000 gid)
|
(wait-for-file "/root/witness" marionette))
|
||||||
(>= gid 100))))
|
|
||||||
|
|
||||||
;; Last, the job that uses a command; allows us to test whether
|
;; Likewise for Alice's job. We cannot know what its GID is since
|
||||||
;; $PATH is sane. (Note that 'marionette-eval' stringifies objects
|
;; it's chosen by 'groupadd', but it's strictly positive.
|
||||||
;; that don't have a read syntax, hence the string.)
|
(test-assert "alice's job"
|
||||||
(test-equal "root's job with command"
|
(match (wait-for-file "/home/alice/witness" marionette)
|
||||||
"#<eof>"
|
((1000 gid)
|
||||||
(wait-for-file "/root/witness-touch" marionette))
|
(>= gid 100))))
|
||||||
|
|
||||||
(test-end)
|
;; Last, the job that uses a command; allows us to test whether
|
||||||
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
;; $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))
|
||||||
|
|
||||||
(gexp->derivation name test)))
|
(test-end)
|
||||||
|
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
||||||
|
|
||||||
|
(gexp->derivation name test))
|
||||||
|
|
||||||
(define %test-mcron
|
(define %test-mcron
|
||||||
(system-test
|
(system-test
|
||||||
|
@ -526,102 +524,102 @@ functionality tests.")
|
||||||
;; *after* nscd. Failing to do that, libc will try to connect to nscd,
|
;; *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),
|
;; fail, then never try again (see '__nss_not_use_nscd_hosts' in libc),
|
||||||
;; leading to '.local' resolution failures.
|
;; leading to '.local' resolution failures.
|
||||||
(mlet* %store-monad ((os -> (marionette-operating-system
|
(define os
|
||||||
%avahi-os
|
(marionette-operating-system
|
||||||
#:requirements '(nscd)
|
%avahi-os
|
||||||
#:imported-modules '((gnu services herd)
|
#:requirements '(nscd)
|
||||||
(guix combinators))))
|
#:imported-modules '((gnu services herd)
|
||||||
(run (system-qemu-image/shared-store-script
|
(guix combinators))))
|
||||||
os #:graphic? #f)))
|
|
||||||
(define mdns-host-name
|
|
||||||
(string-append (operating-system-host-name os)
|
|
||||||
".local"))
|
|
||||||
|
|
||||||
(define test
|
(define mdns-host-name
|
||||||
(with-imported-modules '((gnu build marionette))
|
(string-append (operating-system-host-name os)
|
||||||
#~(begin
|
".local"))
|
||||||
(use-modules (gnu build marionette)
|
|
||||||
(srfi srfi-1)
|
|
||||||
(srfi srfi-64)
|
|
||||||
(ice-9 match))
|
|
||||||
|
|
||||||
(define marionette
|
(define test
|
||||||
(make-marionette (list #$run)))
|
(with-imported-modules '((gnu build marionette))
|
||||||
|
#~(begin
|
||||||
|
(use-modules (gnu build marionette)
|
||||||
|
(srfi srfi-1)
|
||||||
|
(srfi srfi-64)
|
||||||
|
(ice-9 match))
|
||||||
|
|
||||||
(mkdir #$output)
|
(define marionette
|
||||||
(chdir #$output)
|
(make-marionette (list #$(virtual-machine os))))
|
||||||
|
|
||||||
(test-begin "avahi")
|
(mkdir #$output)
|
||||||
|
(chdir #$output)
|
||||||
|
|
||||||
(test-assert "wait for services"
|
(test-begin "avahi")
|
||||||
(marionette-eval
|
|
||||||
'(begin
|
|
||||||
(use-modules (gnu services herd))
|
|
||||||
|
|
||||||
(start-service 'nscd)
|
(test-assert "wait for services"
|
||||||
|
(marionette-eval
|
||||||
|
'(begin
|
||||||
|
(use-modules (gnu services herd))
|
||||||
|
|
||||||
;; XXX: Work around a race condition in nscd: nscd creates its
|
(start-service 'nscd)
|
||||||
;; 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.
|
;; XXX: Work around a race condition in nscd: nscd creates its
|
||||||
(start-service 'avahi-daemon)
|
;; PID file before it is listening on its socket.
|
||||||
(start-service 'networking)
|
(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)))))
|
||||||
|
|
||||||
#t)
|
;; Wait for the other useful things.
|
||||||
marionette))
|
(start-service 'avahi-daemon)
|
||||||
|
(start-service 'networking)
|
||||||
|
|
||||||
(test-equal "avahi-resolve-host-name"
|
#t)
|
||||||
0
|
marionette))
|
||||||
(marionette-eval
|
|
||||||
'(system*
|
|
||||||
"/run/current-system/profile/bin/avahi-resolve-host-name"
|
|
||||||
"-v" #$mdns-host-name)
|
|
||||||
marionette))
|
|
||||||
|
|
||||||
(test-equal "avahi-browse"
|
(test-equal "avahi-resolve-host-name"
|
||||||
0
|
0
|
||||||
(marionette-eval
|
(marionette-eval
|
||||||
'(system* "avahi-browse" "-avt")
|
'(system*
|
||||||
marionette))
|
"/run/current-system/profile/bin/avahi-resolve-host-name"
|
||||||
|
"-v" #$mdns-host-name)
|
||||||
|
marionette))
|
||||||
|
|
||||||
(test-assert "getaddrinfo .local"
|
(test-equal "avahi-browse"
|
||||||
;; Wait for the 'avahi-daemon' service and perform a resolution.
|
0
|
||||||
(match (marionette-eval
|
(marionette-eval
|
||||||
'(getaddrinfo #$mdns-host-name)
|
'(system* "avahi-browse" "-avt")
|
||||||
marionette)
|
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"
|
(test-assert "getaddrinfo .local"
|
||||||
(match (pk 'gethostbyname
|
;; Wait for the 'avahi-daemon' service and perform a resolution.
|
||||||
(marionette-eval '(gethostbyname #$mdns-host-name)
|
(match (marionette-eval
|
||||||
marionette))
|
'(getaddrinfo #$mdns-host-name)
|
||||||
((? vector? result)
|
marionette)
|
||||||
(and (string=? (hostent:name result) #$mdns-host-name)
|
(((? vector? addrinfos) ..1)
|
||||||
(= (hostent:addrtype result) AF_INET)))))
|
(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)
|
(test-end)
|
||||||
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
||||||
|
|
||||||
(gexp->derivation "nss-mdns" test)))
|
(gexp->derivation "nss-mdns" test))
|
||||||
|
|
||||||
(define %test-nss-mdns
|
(define %test-nss-mdns
|
||||||
(system-test
|
(system-test
|
||||||
|
|
|
@ -27,7 +27,6 @@
|
||||||
#:use-module (gnu packages wordnet)
|
#:use-module (gnu packages wordnet)
|
||||||
#:use-module (guix gexp)
|
#:use-module (guix gexp)
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (guix monads)
|
|
||||||
#:use-module (guix packages)
|
#:use-module (guix packages)
|
||||||
#:use-module (guix modules)
|
#:use-module (guix modules)
|
||||||
#:export (%test-dicod))
|
#:export (%test-dicod))
|
||||||
|
@ -54,86 +53,90 @@
|
||||||
|
|
||||||
(define* (run-dicod-test)
|
(define* (run-dicod-test)
|
||||||
"Run tests of 'dicod-service-type'."
|
"Run tests of 'dicod-service-type'."
|
||||||
(mlet* %store-monad ((os -> (marionette-operating-system
|
(define os
|
||||||
%dicod-os
|
(marionette-operating-system
|
||||||
#:imported-modules
|
%dicod-os
|
||||||
(source-module-closure '((gnu services herd)))))
|
#:imported-modules
|
||||||
(command (system-qemu-image/shared-store-script
|
(source-module-closure '((gnu services herd)))))
|
||||||
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
|
(define vm
|
||||||
(socket PF_INET SOCK_STREAM 0))
|
(virtual-machine
|
||||||
|
(operating-system os)
|
||||||
|
(port-forwardings '((8000 . 2628)))))
|
||||||
|
|
||||||
(mkdir #$output)
|
(define test
|
||||||
(chdir #$output)
|
(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)))
|
||||||
|
|
||||||
(test-begin "dicod")
|
(define %dico-socket
|
||||||
|
(socket PF_INET SOCK_STREAM 0))
|
||||||
|
|
||||||
;; Wait for the service to be started.
|
(mkdir #$output)
|
||||||
(test-eq "service is running"
|
(chdir #$output)
|
||||||
'running!
|
|
||||||
(marionette-eval
|
|
||||||
'(begin
|
|
||||||
(use-modules (gnu services herd))
|
|
||||||
(start-service 'dicod)
|
|
||||||
'running!)
|
|
||||||
marionette))
|
|
||||||
|
|
||||||
;; Wait until dicod is actually listening.
|
(test-begin "dicod")
|
||||||
;; 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"
|
;; Wait for the service to be started.
|
||||||
(let ((addr (make-socket-address AF_INET INADDR_LOOPBACK 8000)))
|
(test-eq "service is running"
|
||||||
(connect %dico-socket addr)
|
'running!
|
||||||
(read-line %dico-socket 'concat)))
|
(marionette-eval
|
||||||
|
'(begin
|
||||||
|
(use-modules (gnu services herd))
|
||||||
|
(start-service 'dicod)
|
||||||
|
'running!)
|
||||||
|
marionette))
|
||||||
|
|
||||||
(test-equal "CLIENT"
|
;; Wait until dicod is actually listening.
|
||||||
"250 ok\r\n"
|
;; TODO: Use a PID file instead.
|
||||||
(begin
|
(test-assert "connect inside"
|
||||||
(display "CLIENT \"GNU Guile\"\r\n" %dico-socket)
|
(marionette-eval
|
||||||
(read-line %dico-socket 'concat)))
|
'(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 "DEFINE"
|
(test-assert "connect"
|
||||||
(begin
|
(let ((addr (make-socket-address AF_INET INADDR_LOOPBACK 8000)))
|
||||||
(display "DEFINE ! hello\r\n" %dico-socket)
|
(connect %dico-socket addr)
|
||||||
(display "QUIT\r\n" %dico-socket)
|
(read-line %dico-socket 'concat)))
|
||||||
(let ((result (read-string %dico-socket)))
|
|
||||||
(and (string-contains result "gcide")
|
|
||||||
(string-contains result "hello")
|
|
||||||
result))))
|
|
||||||
|
|
||||||
(test-end)
|
(test-equal "CLIENT"
|
||||||
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
"250 ok\r\n"
|
||||||
|
(begin
|
||||||
|
(display "CLIENT \"GNU Guile\"\r\n" %dico-socket)
|
||||||
|
(read-line %dico-socket 'concat)))
|
||||||
|
|
||||||
(gexp->derivation "dicod" test)))
|
(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
|
(define %test-dicod
|
||||||
(system-test
|
(system-test
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2016 Sou Bunnbu <iyzsong@member.fsf.org>
|
;;; Copyright © 2016 Sou Bunnbu <iyzsong@member.fsf.org>
|
||||||
;;; Copyright © 2017 Carlo Zancanaro <carlo@zancanaro.id.au>
|
;;; Copyright © 2017 Carlo Zancanaro <carlo@zancanaro.id.au>
|
||||||
|
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -25,7 +26,6 @@
|
||||||
#:use-module (gnu services mail)
|
#:use-module (gnu services mail)
|
||||||
#:use-module (gnu services networking)
|
#:use-module (gnu services networking)
|
||||||
#:use-module (guix gexp)
|
#:use-module (guix gexp)
|
||||||
#:use-module (guix monads)
|
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (ice-9 ftw)
|
#:use-module (ice-9 ftw)
|
||||||
#:export (%test-opensmtpd
|
#:export (%test-opensmtpd
|
||||||
|
@ -44,105 +44,105 @@ accept from any for local deliver to mbox
|
||||||
|
|
||||||
(define (run-opensmtpd-test)
|
(define (run-opensmtpd-test)
|
||||||
"Return a test of an OS running OpenSMTPD service."
|
"Return a test of an OS running OpenSMTPD service."
|
||||||
(mlet* %store-monad ((command (system-qemu-image/shared-store-script
|
(define vm
|
||||||
(marionette-operating-system
|
(virtual-machine
|
||||||
%opensmtpd-os
|
(operating-system (marionette-operating-system
|
||||||
#:imported-modules '((gnu services herd)))
|
%opensmtpd-os
|
||||||
#:graphic? #f)))
|
#:imported-modules '((gnu services herd))))
|
||||||
(define test
|
(port-forwardings '((1025 . 25)))))
|
||||||
(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
|
(define test
|
||||||
(make-marionette
|
(with-imported-modules '((gnu build marionette))
|
||||||
;; Enable TCP forwarding of the guest's port 25.
|
#~(begin
|
||||||
'(#$command "-net" "user,hostfwd=tcp::1025-:25")))
|
(use-modules (rnrs base)
|
||||||
|
(srfi srfi-64)
|
||||||
|
(ice-9 rdelim)
|
||||||
|
(ice-9 regex)
|
||||||
|
(gnu build marionette))
|
||||||
|
|
||||||
(define (read-reply-code port)
|
(define marionette
|
||||||
"Read a SMTP reply from PORT and return its reply code."
|
(make-marionette '(#$vm)))
|
||||||
(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)
|
(define (read-reply-code port)
|
||||||
(chdir #$output)
|
"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))))
|
||||||
|
|
||||||
(test-begin "opensmptd")
|
(mkdir #$output)
|
||||||
|
(chdir #$output)
|
||||||
|
|
||||||
(test-assert "service is running"
|
(test-begin "opensmptd")
|
||||||
(marionette-eval
|
|
||||||
'(begin
|
|
||||||
(use-modules (gnu services herd))
|
|
||||||
(start-service 'smtpd)
|
|
||||||
#t)
|
|
||||||
marionette))
|
|
||||||
|
|
||||||
(test-assert "mbox is empty"
|
(test-assert "service is running"
|
||||||
(marionette-eval
|
(marionette-eval
|
||||||
'(and (file-exists? "/var/mail")
|
'(begin
|
||||||
(not (file-exists? "/var/mail/root")))
|
(use-modules (gnu services herd))
|
||||||
marionette))
|
(start-service 'smtpd)
|
||||||
|
#t)
|
||||||
|
marionette))
|
||||||
|
|
||||||
(test-eq "accept an email"
|
(test-assert "mbox is empty"
|
||||||
#t
|
(marionette-eval
|
||||||
(let* ((smtp (socket AF_INET SOCK_STREAM 0))
|
'(and (file-exists? "/var/mail")
|
||||||
(addr (make-socket-address AF_INET INADDR_LOOPBACK 1025)))
|
(not (file-exists? "/var/mail/root")))
|
||||||
(connect smtp addr)
|
marionette))
|
||||||
;; 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"
|
(test-eq "accept an email"
|
||||||
(marionette-eval
|
#t
|
||||||
'(begin
|
(let* ((smtp (socket AF_INET SOCK_STREAM 0))
|
||||||
(use-modules (ice-9 popen)
|
(addr (make-socket-address AF_INET INADDR_LOOPBACK 1025)))
|
||||||
(ice-9 rdelim))
|
(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))
|
||||||
|
|
||||||
(define (queue-empty?)
|
(test-assert "mail arrived"
|
||||||
(eof-object?
|
(marionette-eval
|
||||||
(read-line
|
'(begin
|
||||||
(open-input-pipe "smtpctl show queue"))))
|
(use-modules (ice-9 popen)
|
||||||
|
(ice-9 rdelim))
|
||||||
|
|
||||||
(let wait ()
|
(define (queue-empty?)
|
||||||
(if (queue-empty?)
|
(eof-object?
|
||||||
(file-exists? "/var/mail/root")
|
(read-line
|
||||||
(begin (sleep 1) (wait)))))
|
(open-input-pipe "smtpctl show queue"))))
|
||||||
marionette))
|
|
||||||
|
|
||||||
(test-end)
|
(let wait ()
|
||||||
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
(if (queue-empty?)
|
||||||
|
(file-exists? "/var/mail/root")
|
||||||
|
(begin (sleep 1) (wait)))))
|
||||||
|
marionette))
|
||||||
|
|
||||||
(gexp->derivation "opensmtpd-test" test)))
|
(test-end)
|
||||||
|
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
||||||
|
|
||||||
|
(gexp->derivation "opensmtpd-test" test))
|
||||||
|
|
||||||
(define %test-opensmtpd
|
(define %test-opensmtpd
|
||||||
(system-test
|
(system-test
|
||||||
|
@ -179,100 +179,100 @@ acl_check_data:
|
||||||
|
|
||||||
(define (run-exim-test)
|
(define (run-exim-test)
|
||||||
"Return a test of an OS running an Exim service."
|
"Return a test of an OS running an Exim service."
|
||||||
(mlet* %store-monad ((command (system-qemu-image/shared-store-script
|
(define vm
|
||||||
(marionette-operating-system
|
(virtual-machine
|
||||||
%exim-os
|
(operating-system (marionette-operating-system
|
||||||
#:imported-modules '((gnu services herd)))
|
%exim-os
|
||||||
#:graphic? #f)))
|
#:imported-modules '((gnu services herd))))
|
||||||
(define test
|
(port-forwardings '((1025 . 25)))))
|
||||||
(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
|
(define test
|
||||||
(make-marionette
|
(with-imported-modules '((gnu build marionette)
|
||||||
;; Enable TCP forwarding of the guest's port 25.
|
(ice-9 ftw))
|
||||||
'(#$command "-net" "user,hostfwd=tcp::1025-:25")))
|
#~(begin
|
||||||
|
(use-modules (rnrs base)
|
||||||
|
(srfi srfi-64)
|
||||||
|
(ice-9 ftw)
|
||||||
|
(ice-9 rdelim)
|
||||||
|
(ice-9 regex)
|
||||||
|
(gnu build marionette))
|
||||||
|
|
||||||
(define (read-reply-code port)
|
(define marionette
|
||||||
"Read a SMTP reply from PORT and return its reply code."
|
(make-marionette '(#$vm)))
|
||||||
(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 (read-reply-code port)
|
||||||
(define addr (make-socket-address AF_INET INADDR_LOOPBACK 1025))
|
"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)
|
(define smtp (socket AF_INET SOCK_STREAM 0))
|
||||||
(chdir #$output)
|
(define addr (make-socket-address AF_INET INADDR_LOOPBACK 1025))
|
||||||
|
|
||||||
(test-begin "exim")
|
(mkdir #$output)
|
||||||
|
(chdir #$output)
|
||||||
|
|
||||||
(test-assert "service is running"
|
(test-begin "exim")
|
||||||
(marionette-eval
|
|
||||||
'(begin
|
|
||||||
(use-modules (gnu services herd))
|
|
||||||
(start-service 'exim)
|
|
||||||
#t)
|
|
||||||
marionette))
|
|
||||||
|
|
||||||
(sleep 1) ;; give the service time to start talking
|
(test-assert "service is running"
|
||||||
|
(marionette-eval
|
||||||
|
'(begin
|
||||||
|
(use-modules (gnu services herd))
|
||||||
|
(start-service 'exim)
|
||||||
|
#t)
|
||||||
|
marionette))
|
||||||
|
|
||||||
(connect smtp addr)
|
(sleep 1) ;; give the service time to start talking
|
||||||
;; 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"
|
(connect smtp addr)
|
||||||
1
|
;; Be greeted.
|
||||||
(marionette-eval
|
(test-eq "greeting received"
|
||||||
'(begin
|
220 (read-reply-code smtp))
|
||||||
(use-modules (ice-9 ftw))
|
;; Greet the server.
|
||||||
(length (scandir "/var/spool/exim/msglog"
|
(write-line "EHLO somehost" smtp)
|
||||||
(lambda (x) (not (string-prefix? "." x))))))
|
(test-eq "greeting successful"
|
||||||
marionette))
|
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-end)
|
(test-eq "the email is received"
|
||||||
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
1
|
||||||
|
(marionette-eval
|
||||||
|
'(begin
|
||||||
|
(use-modules (ice-9 ftw))
|
||||||
|
(length (scandir "/var/spool/exim/msglog"
|
||||||
|
(lambda (x) (not (string-prefix? "." x))))))
|
||||||
|
marionette))
|
||||||
|
|
||||||
(gexp->derivation "exim-test" test)))
|
(test-end)
|
||||||
|
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
||||||
|
|
||||||
|
(gexp->derivation "exim-test" test))
|
||||||
|
|
||||||
(define %test-exim
|
(define %test-exim
|
||||||
(system-test
|
(system-test
|
||||||
|
|
|
@ -1,5 +1,6 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
|
;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
|
||||||
|
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
@ -26,108 +27,109 @@
|
||||||
#:use-module (gnu packages messaging)
|
#:use-module (gnu packages messaging)
|
||||||
#:use-module (guix gexp)
|
#:use-module (guix gexp)
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (guix monads)
|
|
||||||
#:export (%test-prosody))
|
#:export (%test-prosody))
|
||||||
|
|
||||||
(define (run-xmpp-test name xmpp-service pid-file create-account)
|
(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."
|
"Run a test of an OS running XMPP-SERVICE, which writes its PID to PID-FILE."
|
||||||
(mlet* %store-monad ((os -> (marionette-operating-system
|
(define os
|
||||||
(simple-operating-system (dhcp-client-service)
|
(marionette-operating-system
|
||||||
xmpp-service)
|
(simple-operating-system (dhcp-client-service)
|
||||||
#:imported-modules '((gnu services herd))))
|
xmpp-service)
|
||||||
(command (system-qemu-image/shared-store-script
|
#:imported-modules '((gnu services herd))))
|
||||||
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
|
(define port 15222)
|
||||||
(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)
|
(define vm
|
||||||
(ft-set-password! #$password)
|
(virtual-machine
|
||||||
(ft-set-server! #$server)
|
(operating-system os)
|
||||||
(ft-set-port! #$port)
|
(port-forwardings `((,port . 5222)))))
|
||||||
(ft-set-sslconn! #f)
|
|
||||||
(ft-connect-blocking)
|
|
||||||
(ft-send-message #$jid #$message)
|
|
||||||
|
|
||||||
(ft-set-daemon)
|
(define username "alice")
|
||||||
(ft-main-loop))))
|
(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 test
|
(define script.ft
|
||||||
(with-imported-modules '((gnu build marionette))
|
(scheme-file
|
||||||
#~(begin
|
"script.ft"
|
||||||
(use-modules (gnu build marionette)
|
#~(begin
|
||||||
(srfi srfi-64))
|
(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)
|
||||||
|
|
||||||
(define marionette
|
(ft-set-jid! #$jid)
|
||||||
;; Enable TCP forwarding of the guest's port 5222.
|
(ft-set-password! #$password)
|
||||||
(make-marionette (list #$command "-net"
|
(ft-set-server! #$server)
|
||||||
(string-append "user,hostfwd=tcp::"
|
(ft-set-port! #$port)
|
||||||
(number->string #$port)
|
(ft-set-sslconn! #f)
|
||||||
"-:5222"))))
|
(ft-connect-blocking)
|
||||||
|
(ft-send-message #$jid #$message)
|
||||||
|
|
||||||
(define (host-wait-for-file file)
|
(ft-set-daemon)
|
||||||
;; Wait until FILE exists in the host.
|
(ft-main-loop))))
|
||||||
(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)
|
(define test
|
||||||
(chdir #$output)
|
(with-imported-modules '((gnu build marionette))
|
||||||
|
#~(begin
|
||||||
|
(use-modules (gnu build marionette)
|
||||||
|
(srfi srfi-64))
|
||||||
|
|
||||||
(test-begin "xmpp")
|
(define marionette
|
||||||
|
(make-marionette (list #$vm)))
|
||||||
|
|
||||||
;; Wait for XMPP service to be up and running.
|
(define (host-wait-for-file file)
|
||||||
(test-eq "service running"
|
;; Wait until FILE exists in the host.
|
||||||
'running!
|
(let loop ((i 60))
|
||||||
(marionette-eval
|
(cond ((file-exists? file)
|
||||||
'(begin
|
#t)
|
||||||
(use-modules (gnu services herd))
|
((> i 0)
|
||||||
(start-service 'xmpp-daemon)
|
(begin
|
||||||
'running!)
|
(sleep 1))
|
||||||
marionette))
|
(loop (- i 1)))
|
||||||
|
(else
|
||||||
|
(error "file didn't show up" file)))))
|
||||||
|
|
||||||
;; Check XMPP service's PID.
|
(mkdir #$output)
|
||||||
(test-assert "service process id"
|
(chdir #$output)
|
||||||
(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-begin "xmpp")
|
||||||
(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)
|
;; Wait for XMPP service to be up and running.
|
||||||
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
(test-eq "service running"
|
||||||
|
'running!
|
||||||
|
(marionette-eval
|
||||||
|
'(begin
|
||||||
|
(use-modules (gnu services herd))
|
||||||
|
(start-service 'xmpp-daemon)
|
||||||
|
'running!)
|
||||||
|
marionette))
|
||||||
|
|
||||||
(gexp->derivation name test)))
|
;; 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
|
(define %create-prosody-account
|
||||||
(program-file
|
(program-file
|
||||||
|
|
|
@ -74,60 +74,61 @@ done" ))))))))))
|
||||||
(define* (run-inetd-test)
|
(define* (run-inetd-test)
|
||||||
"Run tests in %INETD-OS, where the inetd service provides an echo service on
|
"Run tests in %INETD-OS, where the inetd service provides an echo service on
|
||||||
port 7, and a dict service on port 2628."
|
port 7, and a dict service on port 2628."
|
||||||
(mlet* %store-monad ((os -> (marionette-operating-system %inetd-os))
|
(define os
|
||||||
(command (system-qemu-image/shared-store-script
|
(marionette-operating-system %inetd-os))
|
||||||
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"))))
|
|
||||||
|
|
||||||
(mkdir #$output)
|
(define vm
|
||||||
(chdir #$output)
|
(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.
|
(mkdir #$output)
|
||||||
(test-assert "PID file"
|
(chdir #$output)
|
||||||
(marionette-eval
|
|
||||||
'(file-exists? "/var/run/inetd.pid")
|
|
||||||
marionette))
|
|
||||||
|
|
||||||
;; Test the echo service.
|
(test-begin "inetd")
|
||||||
(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 the dict service
|
;; Make sure the PID file is created.
|
||||||
(test-equal "dict response"
|
(test-assert "PID file"
|
||||||
"GNU Guix is a package management tool for the GNU system."
|
(marionette-eval
|
||||||
(let ((dict (socket PF_INET SOCK_STREAM 0))
|
'(file-exists? "/var/run/inetd.pid")
|
||||||
(addr (make-socket-address AF_INET INADDR_LOOPBACK 8628)))
|
marionette))
|
||||||
(connect dict addr)
|
|
||||||
(display "DEFINE Guix\n" dict)
|
|
||||||
(let ((response (read-line dict)))
|
|
||||||
(close dict)
|
|
||||||
response)))
|
|
||||||
|
|
||||||
(test-end)
|
;; Test the echo service.
|
||||||
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
(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
|
(define %test-inetd
|
||||||
(system-test
|
(system-test
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
;;; GNU Guix --- Functional package management for GNU
|
;;; 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 © 2016 John Darrington <jmd@gnu.org>
|
||||||
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
|
||||||
;;;
|
;;;
|
||||||
|
@ -55,75 +55,75 @@
|
||||||
|
|
||||||
(define (run-nfs-test name socket)
|
(define (run-nfs-test name socket)
|
||||||
"Run a test of an OS running RPC-SERVICE, which should create SOCKET."
|
"Run a test of an OS running RPC-SERVICE, which should create SOCKET."
|
||||||
(mlet* %store-monad ((os -> (marionette-operating-system
|
(define os
|
||||||
%base-os
|
(marionette-operating-system
|
||||||
#:imported-modules '((gnu services herd)
|
%base-os
|
||||||
(guix combinators))))
|
#:imported-modules '((gnu services herd)
|
||||||
(command (system-qemu-image/shared-store-script
|
(guix combinators))))
|
||||||
os #:graphic? #f)))
|
|
||||||
(define test
|
|
||||||
(with-imported-modules '((gnu build marionette))
|
|
||||||
#~(begin
|
|
||||||
(use-modules (gnu build marionette)
|
|
||||||
(srfi srfi-64))
|
|
||||||
|
|
||||||
(define marionette
|
(define test
|
||||||
(make-marionette (list #$command)))
|
(with-imported-modules '((gnu build marionette))
|
||||||
|
#~(begin
|
||||||
|
(use-modules (gnu build marionette)
|
||||||
|
(srfi srfi-64))
|
||||||
|
|
||||||
(define (wait-for-socket file)
|
(define marionette
|
||||||
;; Wait until SOCKET exists in the guest
|
(make-marionette (list #$(virtual-machine os))))
|
||||||
(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)
|
(define (wait-for-socket file)
|
||||||
(chdir #$output)
|
;; 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))
|
||||||
|
|
||||||
(test-begin "rpc-daemon")
|
(mkdir #$output)
|
||||||
|
(chdir #$output)
|
||||||
|
|
||||||
;; Wait for the rpcbind daemon to be up and running.
|
(test-begin "rpc-daemon")
|
||||||
(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.
|
;; Wait for the rpcbind daemon to be up and running.
|
||||||
(test-assert "RPC socket exists"
|
(test-eq "RPC service running"
|
||||||
(and
|
'running!
|
||||||
(wait-for-socket #$socket)
|
(marionette-eval
|
||||||
(marionette-eval
|
'(begin
|
||||||
'(begin
|
(use-modules (gnu services herd))
|
||||||
(use-modules (gnu services herd)
|
(start-service 'rpcbind-daemon)
|
||||||
(srfi srfi-1))
|
'running!)
|
||||||
|
marionette))
|
||||||
|
|
||||||
(live-service-running
|
;; Check the socket file and that the service is still running.
|
||||||
(find (lambda (live)
|
(test-assert "RPC socket exists"
|
||||||
(memq 'rpcbind-daemon
|
(and
|
||||||
(live-service-provision live)))
|
(wait-for-socket #$socket)
|
||||||
(current-services))))
|
(marionette-eval
|
||||||
marionette)))
|
'(begin
|
||||||
|
(use-modules (gnu services herd)
|
||||||
|
(srfi srfi-1))
|
||||||
|
|
||||||
(test-assert "Probe RPC daemon"
|
(live-service-running
|
||||||
(marionette-eval
|
(find (lambda (live)
|
||||||
'(zero? (system* "rpcinfo" "-p"))
|
(memq 'rpcbind-daemon
|
||||||
marionette))
|
(live-service-provision live)))
|
||||||
|
(current-services))))
|
||||||
|
marionette)))
|
||||||
|
|
||||||
(test-end)
|
(test-assert "Probe RPC daemon"
|
||||||
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
(marionette-eval
|
||||||
|
'(zero? (system* "rpcinfo" "-p"))
|
||||||
|
marionette))
|
||||||
|
|
||||||
(gexp->derivation name test)))
|
(test-end)
|
||||||
|
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
||||||
|
|
||||||
|
(gexp->derivation name test))
|
||||||
|
|
||||||
(define %test-nfs
|
(define %test-nfs
|
||||||
(system-test
|
(system-test
|
||||||
|
|
|
@ -27,7 +27,6 @@
|
||||||
#:use-module (gnu packages ssh)
|
#:use-module (gnu packages ssh)
|
||||||
#:use-module (guix gexp)
|
#:use-module (guix gexp)
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (guix monads)
|
|
||||||
#:export (%test-openssh
|
#:export (%test-openssh
|
||||||
%test-dropbear))
|
%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.
|
empty-password logins.
|
||||||
|
|
||||||
When SFTP? is true, run an SFTP server test."
|
When SFTP? is true, run an SFTP server test."
|
||||||
(mlet* %store-monad ((os -> (marionette-operating-system
|
(define os
|
||||||
(simple-operating-system
|
(marionette-operating-system
|
||||||
(dhcp-client-service)
|
(simple-operating-system (dhcp-client-service) ssh-service)
|
||||||
ssh-service)
|
#:imported-modules '((gnu services herd)
|
||||||
#:imported-modules '((gnu services herd)
|
(guix combinators))))
|
||||||
(guix combinators))))
|
(define vm
|
||||||
(command (system-qemu-image/shared-store-script
|
(virtual-machine
|
||||||
os #:graphic? #f)))
|
(operating-system os)
|
||||||
(define test
|
(port-forwardings '((2222 . 22)))))
|
||||||
(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)
|
(define test
|
||||||
(srfi srfi-26)
|
(with-imported-modules '((gnu build marionette))
|
||||||
(srfi srfi-64)
|
#~(begin
|
||||||
(ice-9 match)
|
(eval-when (expand load eval)
|
||||||
(ssh session)
|
;; Prepare to use Guile-SSH.
|
||||||
(ssh auth)
|
(set! %load-path
|
||||||
(ssh channel)
|
(cons (string-append #+guile2.0-ssh "/share/guile/site/"
|
||||||
(ssh sftp))
|
(effective-version))
|
||||||
|
%load-path)))
|
||||||
|
|
||||||
(define marionette
|
(use-modules (gnu build marionette)
|
||||||
;; Enable TCP forwarding of the guest's port 22.
|
(srfi srfi-26)
|
||||||
(make-marionette (list #$command "-net"
|
(srfi srfi-64)
|
||||||
"user,hostfwd=tcp::2222-:22")))
|
(ice-9 match)
|
||||||
|
(ssh session)
|
||||||
|
(ssh auth)
|
||||||
|
(ssh channel)
|
||||||
|
(ssh sftp))
|
||||||
|
|
||||||
(define (make-session-for-test)
|
(define marionette
|
||||||
"Make a session with predefined parameters for a test."
|
;; Enable TCP forwarding of the guest's port 22.
|
||||||
(make-session #:user "root"
|
(make-marionette (list #$vm)))
|
||||||
#:port 2222
|
|
||||||
#:host "localhost"
|
|
||||||
#:log-verbosity 'protocol))
|
|
||||||
|
|
||||||
(define (call-with-connected-session proc)
|
(define (make-session-for-test)
|
||||||
"Call the one-argument procedure PROC with a freshly created and
|
"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
|
connected SSH session object, return the result of the procedure call. The
|
||||||
session is disconnected when the PROC is finished."
|
session is disconnected when the PROC is finished."
|
||||||
(let ((session (make-session-for-test)))
|
(let ((session (make-session-for-test)))
|
||||||
(dynamic-wind
|
(dynamic-wind
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let ((result (connect! session)))
|
(let ((result (connect! session)))
|
||||||
(unless (equal? result 'ok)
|
(unless (equal? result 'ok)
|
||||||
(error "Could not connect to a server"
|
(error "Could not connect to a server"
|
||||||
session result))))
|
session result))))
|
||||||
(lambda () (proc session))
|
(lambda () (proc session))
|
||||||
(lambda () (disconnect! session)))))
|
(lambda () (disconnect! session)))))
|
||||||
|
|
||||||
(define (call-with-connected-session/auth proc)
|
(define (call-with-connected-session/auth proc)
|
||||||
"Make an authenticated session. We should be able to connect as
|
"Make an authenticated session. We should be able to connect as
|
||||||
root with an empty password."
|
root with an empty password."
|
||||||
(call-with-connected-session
|
(call-with-connected-session
|
||||||
(lambda (session)
|
(lambda (session)
|
||||||
;; Try the simple authentication methods. Dropbear requires
|
;; Try the simple authentication methods. Dropbear requires
|
||||||
;; 'none' when there are no passwords, whereas OpenSSH accepts
|
;; 'none' when there are no passwords, whereas OpenSSH accepts
|
||||||
;; 'password' with an empty password.
|
;; 'password' with an empty password.
|
||||||
(let loop ((methods (list (cut userauth-password! <> "")
|
(let loop ((methods (list (cut userauth-password! <> "")
|
||||||
(cut userauth-none! <>))))
|
(cut userauth-none! <>))))
|
||||||
(match methods
|
(match methods
|
||||||
(()
|
(()
|
||||||
(error "all the authentication methods failed"))
|
(error "all the authentication methods failed"))
|
||||||
((auth rest ...)
|
((auth rest ...)
|
||||||
(match (pk 'auth (auth session))
|
(match (pk 'auth (auth session))
|
||||||
('success
|
('success
|
||||||
(proc session))
|
(proc session))
|
||||||
('denied
|
('denied
|
||||||
(loop rest)))))))))
|
(loop rest)))))))))
|
||||||
|
|
||||||
(mkdir #$output)
|
(mkdir #$output)
|
||||||
(chdir #$output)
|
(chdir #$output)
|
||||||
|
|
||||||
(test-begin "ssh-daemon")
|
(test-begin "ssh-daemon")
|
||||||
|
|
||||||
;; Wait for sshd to be up and running.
|
;; Wait for sshd to be up and running.
|
||||||
(test-eq "service running"
|
(test-eq "service running"
|
||||||
'running!
|
'running!
|
||||||
(marionette-eval
|
(marionette-eval
|
||||||
'(begin
|
'(begin
|
||||||
(use-modules (gnu services herd))
|
(use-modules (gnu services herd))
|
||||||
(start-service 'ssh-daemon)
|
(start-service 'ssh-daemon)
|
||||||
'running!)
|
'running!)
|
||||||
marionette))
|
marionette))
|
||||||
|
|
||||||
;; Check sshd's PID file.
|
;; Check sshd's PID file.
|
||||||
(test-equal "sshd PID"
|
(test-equal "sshd PID"
|
||||||
(wait-for-file #$pid-file marionette)
|
(wait-for-file #$pid-file marionette)
|
||||||
(marionette-eval
|
(marionette-eval
|
||||||
'(begin
|
'(begin
|
||||||
(use-modules (gnu services herd)
|
(use-modules (gnu services herd)
|
||||||
(srfi srfi-1))
|
(srfi srfi-1))
|
||||||
|
|
||||||
(live-service-running
|
(live-service-running
|
||||||
(find (lambda (live)
|
(find (lambda (live)
|
||||||
(memq 'ssh-daemon
|
(memq 'ssh-daemon
|
||||||
(live-service-provision live)))
|
(live-service-provision live)))
|
||||||
(current-services))))
|
(current-services))))
|
||||||
marionette))
|
marionette))
|
||||||
|
|
||||||
;; Connect to the guest over SSH. Make sure we can run a shell
|
;; Connect to the guest over SSH. Make sure we can run a shell
|
||||||
;; command there.
|
;; command there.
|
||||||
(test-equal "shell command"
|
(test-equal "shell command"
|
||||||
'hello
|
'hello
|
||||||
(call-with-connected-session/auth
|
(call-with-connected-session/auth
|
||||||
(lambda (session)
|
(lambda (session)
|
||||||
;; FIXME: 'get-server-public-key' segfaults.
|
;; FIXME: 'get-server-public-key' segfaults.
|
||||||
;; (get-server-public-key session)
|
;; (get-server-public-key session)
|
||||||
(let ((channel (make-channel session)))
|
(let ((channel (make-channel session)))
|
||||||
(channel-open-session channel)
|
(channel-open-session channel)
|
||||||
(channel-request-exec channel "echo hello > /root/witness")
|
(channel-request-exec channel "echo hello > /root/witness")
|
||||||
(and (zero? (channel-get-exit-status channel))
|
(and (zero? (channel-get-exit-status channel))
|
||||||
(wait-for-file "/root/witness" marionette))))))
|
(wait-for-file "/root/witness" marionette))))))
|
||||||
|
|
||||||
;; Connect to the guest over SFTP. Make sure we can write and
|
;; Connect to the guest over SFTP. Make sure we can write and
|
||||||
;; read a file there.
|
;; read a file there.
|
||||||
(unless #$sftp?
|
(unless #$sftp?
|
||||||
(test-skip 1))
|
(test-skip 1))
|
||||||
(test-equal "SFTP file writing and reading"
|
(test-equal "SFTP file writing and reading"
|
||||||
'hello
|
'hello
|
||||||
(call-with-connected-session/auth
|
(call-with-connected-session/auth
|
||||||
(lambda (session)
|
(lambda (session)
|
||||||
(let ((sftp-session (make-sftp-session session))
|
(let ((sftp-session (make-sftp-session session))
|
||||||
(witness "/root/sftp-witness"))
|
(witness "/root/sftp-witness"))
|
||||||
(call-with-remote-output-file sftp-session witness
|
(call-with-remote-output-file sftp-session witness
|
||||||
(cut display "hello" <>))
|
(cut display "hello" <>))
|
||||||
(call-with-remote-input-file sftp-session witness
|
(call-with-remote-input-file sftp-session witness
|
||||||
read)))))
|
read)))))
|
||||||
|
|
||||||
(test-end)
|
(test-end)
|
||||||
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
||||||
|
|
||||||
(gexp->derivation name test)))
|
(gexp->derivation name test))
|
||||||
|
|
||||||
(define %test-openssh
|
(define %test-openssh
|
||||||
(system-test
|
(system-test
|
||||||
|
|
|
@ -27,7 +27,6 @@
|
||||||
#:use-module (gnu services networking)
|
#:use-module (gnu services networking)
|
||||||
#:use-module (guix gexp)
|
#:use-module (guix gexp)
|
||||||
#:use-module (guix store)
|
#:use-module (guix store)
|
||||||
#:use-module (guix monads)
|
|
||||||
#:export (%test-nginx))
|
#:export (%test-nginx))
|
||||||
|
|
||||||
(define %index.html-contents
|
(define %index.html-contents
|
||||||
|
@ -65,68 +64,68 @@
|
||||||
(define* (run-nginx-test #:optional (http-port 8042))
|
(define* (run-nginx-test #:optional (http-port 8042))
|
||||||
"Run tests in %NGINX-OS, which has nginx running and listening on
|
"Run tests in %NGINX-OS, which has nginx running and listening on
|
||||||
HTTP-PORT."
|
HTTP-PORT."
|
||||||
(mlet* %store-monad ((os -> (marionette-operating-system
|
(define os
|
||||||
%nginx-os
|
(marionette-operating-system
|
||||||
#:imported-modules '((gnu services herd)
|
%nginx-os
|
||||||
(guix combinators))))
|
#:imported-modules '((gnu services herd)
|
||||||
(command (system-qemu-image/shared-store-script
|
(guix combinators))))
|
||||||
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
|
(define vm
|
||||||
;; Forward the guest's HTTP-PORT, where nginx is listening, to
|
(virtual-machine
|
||||||
;; port 8080 in the host.
|
(operating-system os)
|
||||||
(make-marionette (list #$command "-net"
|
(port-forwardings `((8080 . ,http-port)))))
|
||||||
(string-append
|
|
||||||
"user,hostfwd=tcp::8080-:"
|
|
||||||
#$(number->string http-port)))))
|
|
||||||
|
|
||||||
(mkdir #$output)
|
(define test
|
||||||
(chdir #$output)
|
(with-imported-modules '((gnu build marionette))
|
||||||
|
#~(begin
|
||||||
|
(use-modules (srfi srfi-11) (srfi srfi-64)
|
||||||
|
(gnu build marionette)
|
||||||
|
(web uri)
|
||||||
|
(web client)
|
||||||
|
(web response))
|
||||||
|
|
||||||
(test-begin "nginx")
|
(define marionette
|
||||||
|
(make-marionette (list #$vm)))
|
||||||
|
|
||||||
;; Wait for nginx to be up and running.
|
(mkdir #$output)
|
||||||
(test-eq "service running"
|
(chdir #$output)
|
||||||
'running!
|
|
||||||
(marionette-eval
|
|
||||||
'(begin
|
|
||||||
(use-modules (gnu services herd))
|
|
||||||
(start-service 'nginx)
|
|
||||||
'running!)
|
|
||||||
marionette))
|
|
||||||
|
|
||||||
;; Make sure the PID file is created.
|
(test-begin "nginx")
|
||||||
(test-assert "PID file"
|
|
||||||
(marionette-eval
|
|
||||||
'(file-exists? "/var/run/nginx/pid")
|
|
||||||
marionette))
|
|
||||||
|
|
||||||
;; Retrieve the index.html file we put in /srv.
|
;; Wait for nginx to be up and running.
|
||||||
(test-equal "http-get"
|
(test-eq "service running"
|
||||||
'(200 #$%index.html-contents)
|
'running!
|
||||||
(let-values (((response text)
|
(marionette-eval
|
||||||
(http-get "http://localhost:8080/index.html"
|
'(begin
|
||||||
#:decode-body? #t)))
|
(use-modules (gnu services herd))
|
||||||
(list (response-code response) text)))
|
(start-service 'nginx)
|
||||||
|
'running!)
|
||||||
|
marionette))
|
||||||
|
|
||||||
;; There should be a log file in here.
|
;; Make sure the PID file is created.
|
||||||
(test-assert "log file"
|
(test-assert "PID file"
|
||||||
(marionette-eval
|
(marionette-eval
|
||||||
'(file-exists? "/var/log/nginx/access.log")
|
'(file-exists? "/var/run/nginx/pid")
|
||||||
marionette))
|
marionette))
|
||||||
|
|
||||||
(test-end)
|
;; Retrieve the index.html file we put in /srv.
|
||||||
(exit (= (test-runner-fail-count (test-runner-current)) 0)))))
|
(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)))
|
||||||
|
|
||||||
(gexp->derivation "nginx-test" test)))
|
;; 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
|
(define %test-nginx
|
||||||
(system-test
|
(system-test
|
||||||
|
|
Reference in New Issue