gnu/tests/messaging.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu tests messaging)
  20   #:use-module (gnu tests)
  21   #:use-module (gnu system)
  22   #:use-module (gnu system vm)
  23   #:use-module (gnu services)
  24   #:use-module (gnu services messaging)
  25   #:use-module (gnu services networking)
  26   #:use-module (gnu packages messaging)
  27   #:use-module (guix gexp)
  28   #:use-module (guix store)
  29   #:use-module (guix monads)
  30   #:export (%test-prosody))
  31
  32 (define (run-xmpp-test name xmpp-service pid-file create-account)
  33   "Run a test of an OS running XMPP-SERVICE, which writes its PID to PID-FILE."
  34   (mlet* %store-monad ((os -> (marionette-operating-system
  35                                (simple-operating-system (dhcp-client-service)
  36                                                         xmpp-service)
  37                                #:imported-modules '((gnu services herd))))
  38                        (command (system-qemu-image/shared-store-script
  39                                  os #:graphic? #f))
  40                        (username -> "alice")
  41                        (server -> "localhost")
  42                        (jid -> (string-append username "@" server))
  43                        (password -> "correct horse battery staple")
  44                        (port -> 15222)
  45                        (message -> "hello world")
  46                        (witness -> "/tmp/freetalk-witness"))
  47
  48     (define script.ft
  49       (scheme-file
  50        "script.ft"
  51        #~(begin
  52            (define (handle-received-message time from nickname message)
  53              (define (touch file-name)
  54                (call-with-output-file file-name (const #t)))
  55              (when (equal? message #$message)
  56                (touch #$witness)))
  57            (add-hook! ft-message-receive-hook handle-received-message)
  58
  59            (ft-set-jid! #$jid)
  60            (ft-set-password! #$password)
  61            (ft-set-server! #$server)
  62            (ft-set-port! #$port)
  63            (ft-set-sslconn! #f)
  64            (ft-connect-blocking)
  65            (ft-send-message #$jid #$message)
  66
  67            (ft-set-daemon)
  68            (ft-main-loop))))
  69
  70     (define test
  71       (with-imported-modules '((gnu build marionette))
  72         #~(begin
  73             (use-modules (gnu build marionette)
  74                          (srfi srfi-64))
  75
  76             (define marionette
  77               ;; Enable TCP forwarding of the guest's port 5222.
  78               (make-marionette (list #$command "-net"
  79                                      (string-append "user,hostfwd=tcp::"
  80                                                     (number->string #$port)
  81                                                     "-:5222"))))
  82
  83             (define (guest-wait-for-file file)
  84               ;; Wait until FILE exists in the guest; 'read' its content and
  85               ;; return it.
  86               (marionette-eval
  87                `(let loop ((i 10))
  88                   (cond ((file-exists? ,file)
  89                          (call-with-input-file ,file read))
  90                         ((> i 0)
  91                          (begin
  92                            (sleep 1))
  93                          (loop (- i 1)))
  94                         (else
  95                          (error "file didn't show up" ,file))))
  96                marionette))
  97
  98             (define (host-wait-for-file file)
  99               ;; Wait until FILE exists in the host.
 100               (let loop ((i 60))
 101                 (cond ((file-exists? file)
 102                        #t)
 103                       ((> i 0)
 104                        (begin
 105                          (sleep 1))
 106                        (loop (- i 1)))
 107                       (else
 108                        (error "file didn't show up" file)))))
 109
 110             (mkdir #$output)
 111             (chdir #$output)
 112
 113             (test-begin "xmpp")
 114
 115             ;; Wait for XMPP service to be up and running.
 116             (test-eq "service running"
 117               'running!
 118               (marionette-eval
 119                '(begin
 120                   (use-modules (gnu services herd))
 121                   (start-service 'xmpp-daemon)
 122                   'running!)
 123                marionette))
 124
 125             ;; Check XMPP service's PID.
 126             (test-assert "service process id"
 127               (let ((pid (number->string (guest-wait-for-file #$pid-file))))
 128                 (marionette-eval `(file-exists? (string-append "/proc/" ,pid))
 129                                  marionette)))
 130
 131             ;; Alice sends an XMPP message to herself, with Freetalk.
 132             (test-assert "client-to-server communication"
 133               (let ((freetalk-bin (string-append #$freetalk "/bin/freetalk")))
 134                 (marionette-eval '(system* #$create-account #$jid #$password)
 135                                  marionette)
 136                 ;; Freetalk requires write access to $HOME.
 137                 (setenv "HOME" "/tmp")
 138                 (system* freetalk-bin "-s" #$script.ft)
 139                 (host-wait-for-file #$witness)))
 140
 141             (test-end)
 142             (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 143
 144     (gexp->derivation name test)))
 145
 146 (define %create-prosody-account
 147   (program-file
 148    "create-account"
 149    #~(begin
 150        (use-modules (ice-9 match))
 151        (match (command-line)
 152          ((command jid password)
 153           (let ((password-input (format #f "\"~a~%~a\"" password password))
 154                 (prosodyctl #$(file-append prosody "/bin/prosodyctl")))
 155             (system (string-join
 156                      `("echo" ,password-input "|" ,prosodyctl "adduser" ,jid)
 157                      " "))))))))
 158
 159 (define %test-prosody
 160   (let* ((config (prosody-configuration
 161                   (virtualhosts
 162                    (list
 163                     (virtualhost-configuration
 164                      (domain "localhost")))))))
 165     (system-test
 166      (name "prosody")
 167      (description "Connect to a running Prosody daemon.")
 168      (value (run-xmpp-test name
 169                            (service prosody-service-type config)
 170                            (prosody-configuration-pidfile config)
 171                            %create-prosody-account)))))