Merge branch 'master' into core-updates

1 files changed, 100 insertions, 98 deletions

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