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 grub)
  23   #:use-module (gnu system file-systems)
  24   #:use-module (gnu system shadow)
  25   #:use-module (gnu system vm)
  26   #:use-module (gnu services)
  27   #:use-module (gnu services base)
  28   #:use-module (gnu services messaging)
  29   #:use-module (gnu services networking)
  30   #:use-module (gnu packages messaging)
  31   #:use-module (guix gexp)
  32   #:use-module (guix store)
  33   #:use-module (guix monads)
  34   #:export (%test-prosody))
  35
  36 (define %base-os
  37   (operating-system
  38     (host-name "komputilo")
  39     (timezone "Europe/Berlin")
  40     (locale "en_US.UTF-8")
  41
  42     (bootloader (grub-configuration (device "/dev/sdX")))
  43     (file-systems %base-file-systems)
  44     (firmware '())
  45     (users %base-user-accounts)
  46     (services (cons (dhcp-client-service)
  47                     %base-services))))
  48
  49 (define (os-with-service service)
  50   "Return a test operating system that runs SERVICE."
  51   (operating-system
  52     (inherit %base-os)
  53     (services (cons service
  54                     (operating-system-user-services %base-os)))))
  55
  56 (define (run-xmpp-test name xmpp-service pid-file create-account)
  57   "Run a test of an OS running XMPP-SERVICE, which writes its PID to PID-FILE."
  58   (mlet* %store-monad ((os -> (marionette-operating-system
  59                                (os-with-service xmpp-service)
  60                                #:imported-modules '((gnu services herd))))
  61                        (command (system-qemu-image/shared-store-script
  62                                  os #:graphic? #f))
  63                        (username -> "alice")
  64                        (server -> "localhost")
  65                        (jid -> (string-append username "@" server))
  66                        (password -> "correct horse battery staple")
  67                        (port -> 15222)
  68                        (message -> "hello world")
  69                        (witness -> "/tmp/freetalk-witness"))
  70
  71     (define script.ft
  72       (scheme-file
  73        "script.ft"
  74        #~(begin
  75            (define (handle-received-message time from nickname message)
  76              (define (touch file-name)
  77                (call-with-output-file file-name (const #t)))
  78              (when (equal? message #$message)
  79                (touch #$witness)))
  80            (add-hook! ft-message-receive-hook handle-received-message)
  81
  82            (ft-set-jid! #$jid)
  83            (ft-set-password! #$password)
  84            (ft-set-server! #$server)
  85            (ft-set-port! #$port)
  86            (ft-set-sslconn! #f)
  87            (ft-connect-blocking)
  88            (ft-send-message #$jid #$message)
  89
  90            (ft-set-daemon)
  91            (ft-main-loop))))
  92
  93     (define test
  94       (with-imported-modules '((gnu build marionette))
  95         #~(begin
  96             (use-modules (gnu build marionette)
  97                          (srfi srfi-64))
  98
  99             (define marionette
 100               ;; Enable TCP forwarding of the guest's port 5222.
 101               (make-marionette (list #$command "-net"
 102                                      (string-append "user,hostfwd=tcp::"
 103                                                     (number->string #$port)
 104                                                     "-:5222"))))
 105
 106             (define (guest-wait-for-file file)
 107               ;; Wait until FILE exists in the guest; 'read' its content and
 108               ;; return it.
 109               (marionette-eval
 110                `(let loop ((i 10))
 111                   (cond ((file-exists? ,file)
 112                          (call-with-input-file ,file read))
 113                         ((> i 0)
 114                          (begin
 115                            (sleep 1))
 116                          (loop (- i 1)))
 117                         (else
 118                          (error "file didn't show up" ,file))))
 119                marionette))
 120
 121             (define (host-wait-for-file file)
 122               ;; Wait until FILE exists in the host.
 123               (let loop ((i 60))
 124                 (cond ((file-exists? file)
 125                        #t)
 126                       ((> i 0)
 127                        (begin
 128                          (sleep 1))
 129                        (loop (- i 1)))
 130                       (else
 131                        (error "file didn't show up" file)))))
 132
 133             (mkdir #$output)
 134             (chdir #$output)
 135
 136             (test-begin "xmpp")
 137
 138             ;; Wait for XMPP service to be up and running.
 139             (test-eq "service running"
 140               'running!
 141               (marionette-eval
 142                '(begin
 143                   (use-modules (gnu services herd))
 144                   (start-service 'xmpp-daemon)
 145                   'running!)
 146                marionette))
 147
 148             ;; Check XMPP service's PID.
 149             (test-assert "service process id"
 150               (let ((pid (number->string (guest-wait-for-file #$pid-file))))
 151                 (marionette-eval `(file-exists? (string-append "/proc/" ,pid))
 152                                  marionette)))
 153
 154             ;; Alice sends an XMPP message to herself, with Freetalk.
 155             (test-assert "client-to-server communication"
 156               (let ((freetalk-bin (string-append #$freetalk "/bin/freetalk")))
 157                 (marionette-eval '(system* #$create-account #$jid #$password)
 158                                  marionette)
 159                 ;; Freetalk requires write access to $HOME.
 160                 (setenv "HOME" "/tmp")
 161                 (system* freetalk-bin "-s" #$script.ft)
 162                 (host-wait-for-file #$witness)))
 163
 164             (test-end)
 165             (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 166
 167     (gexp->derivation name test)))
 168
 169 (define %create-prosody-account
 170   (program-file
 171    "create-account"
 172    #~(begin
 173        (use-modules (ice-9 match))
 174        (match (command-line)
 175          ((command jid password)
 176           (let ((password-input (format #f "\"~a~%~a\"" password password))
 177                 (prosodyctl #$(file-append prosody "/bin/prosodyctl")))
 178             (system (string-join
 179                      `("echo" ,password-input "|" ,prosodyctl "adduser" ,jid)
 180                      " "))))))))
 181
 182 (define %test-prosody
 183   (let* ((config (prosody-configuration
 184                   (virtualhosts
 185                    (list
 186                     (virtualhost-configuration
 187                      (domain "localhost")))))))
 188     (system-test
 189      (name "prosody")
 190      (description "Connect to a running Prosody daemon.")
 191      (value (run-xmpp-test name
 192                            (service prosody-service-type config)
 193                            (prosody-configuration-pidfile config)
 194                            %create-prosody-account)))))