diff options
Diffstat (limited to 'gnu/tests/messaging.scm')
| -rw-r--r-- | gnu/tests/messaging.scm | 194 |
1 files changed, 194 insertions, 0 deletions
diff --git a/gnu/tests/messaging.scm b/gnu/tests/messaging.scm new file mode 100644 index 0000000000..b0c8254ce0 --- /dev/null +++ b/gnu/tests/messaging.scm @@ -0,0 +1,194 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (gnu tests messaging) + #:use-module (gnu tests) + #:use-module (gnu system) + #:use-module (gnu system grub) + #:use-module (gnu system file-systems) + #:use-module (gnu system shadow) + #:use-module (gnu system vm) + #:use-module (gnu services) + #:use-module (gnu services base) + #:use-module (gnu services messaging) + #:use-module (gnu services networking) + #:use-module (gnu packages messaging) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) + #:export (%test-prosody)) + +(define %base-os + (operating-system + (host-name "komputilo") + (timezone "Europe/Berlin") + (locale "en_US.UTF-8") + + (bootloader (grub-configuration (device "/dev/sdX"))) + (file-systems %base-file-systems) + (firmware '()) + (users %base-user-accounts) + (services (cons (dhcp-client-service) + %base-services)))) + +(define (os-with-service service) + "Return a test operating system that runs SERVICE." + (operating-system + (inherit %base-os) + (services (cons service + (operating-system-user-services %base-os))))) + +(define (run-xmpp-test name xmpp-service pid-file create-account) + "Run a test of an OS running XMPP-SERVICE, which writes its PID to PID-FILE." + (mlet* %store-monad ((os -> (marionette-operating-system + (os-with-service xmpp-service) + #:imported-modules '((gnu services herd)))) + (command (system-qemu-image/shared-store-script + os #:graphic? #f)) + (username -> "alice") + (server -> "localhost") + (jid -> (string-append username "@" server)) + (password -> "correct horse battery staple") + (port -> 15222) + (message -> "hello world") + (witness -> "/tmp/freetalk-witness")) + + (define script.ft + (scheme-file + "script.ft" + #~(begin + (define (handle-received-message time from nickname message) + (define (touch file-name) + (call-with-output-file file-name (const #t))) + (when (equal? message #$message) + (touch #$witness))) + (add-hook! ft-message-receive-hook handle-received-message) + + (ft-set-jid! #$jid) + (ft-set-password! #$password) + (ft-set-server! #$server) + (ft-set-port! #$port) + (ft-set-sslconn! #f) + (ft-connect-blocking) + (ft-send-message #$jid #$message) + + (ft-set-daemon) + (ft-main-loop)))) + + (define test + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-64)) + + (define marionette + ;; Enable TCP forwarding of the guest's port 5222. + (make-marionette (list #$command "-net" + (string-append "user,hostfwd=tcp::" + (number->string #$port) + "-:5222")))) + + (define (guest-wait-for-file file) + ;; Wait until FILE exists in the guest; 'read' its content and + ;; return it. + (marionette-eval + `(let loop ((i 10)) + (cond ((file-exists? ,file) + (call-with-input-file ,file read)) + ((> i 0) + (begin + (sleep 1)) + (loop (- i 1))) + (else + (error "file didn't show up" ,file)))) + marionette)) + + (define (host-wait-for-file file) + ;; Wait until FILE exists in the host. + (let loop ((i 60)) + (cond ((file-exists? file) + #t) + ((> i 0) + (begin + (sleep 1)) + (loop (- i 1))) + (else + (error "file didn't show up" file))))) + + (mkdir #$output) + (chdir #$output) + + (test-begin "xmpp") + + ;; Wait for XMPP service to be up and running. + (test-eq "service running" + 'running! + (marionette-eval + '(begin + (use-modules (gnu services herd)) + (start-service 'xmpp-daemon) + 'running!) + marionette)) + + ;; Check XMPP service's PID. + (test-assert "service process id" + (let ((pid (number->string (guest-wait-for-file #$pid-file)))) + (marionette-eval `(file-exists? (string-append "/proc/" ,pid)) + marionette))) + + ;; Alice sends an XMPP message to herself, with Freetalk. + (test-assert "client-to-server communication" + (let ((freetalk-bin (string-append #$freetalk "/bin/freetalk"))) + (marionette-eval '(system* #$create-account #$jid #$password) + marionette) + ;; Freetalk requires write access to $HOME. + (setenv "HOME" "/tmp") + (system* freetalk-bin "-s" #$script.ft) + (host-wait-for-file #$witness))) + + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + + (gexp->derivation name test))) + +(define %create-prosody-account + (program-file + "create-account" + #~(begin + (use-modules (ice-9 match)) + (match (command-line) + ((command jid password) + (let ((password-input (format #f "\"~a~%~a\"" password password)) + (prosodyctl #$(file-append prosody "/bin/prosodyctl"))) + (system (string-join + `("echo" ,password-input "|" ,prosodyctl "adduser" ,jid) + " ")))))))) + +(define %test-prosody + (let* ((config (prosody-configuration + (virtualhosts + (list + (virtualhost-configuration + (domain "localhost"))))))) + (system-test + (name "prosody") + (description "Connect to a running Prosody daemon.") + (value (run-xmpp-test name + (service prosody-service-type config) + (prosody-configuration-pidfile config) + %create-prosody-account))))) |