tests/utils: New utilities for tests.

* tests/util.scm
  (call-with-temporary-directory)
  (call-with-services)
  (call-with-services/fibers): New procedure.

1 files changed, 82 insertions, 1 deletions

diff --git a/tests/utils.scm b/tests/utils.scm
index 0d91a9a..365fc40 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -17,8 +17,16 @@
 ;; SPDX-License-Identifier: AGPL3.0-or-later
 (define-module (tests utils)
   #:use-module (srfi srfi-8)
+  #:use-module (ice-9 match)
+  #:use-module ((rnrs hashtables) #:prefix #{rnrs:}#)
+  #:use-module ((rnrs arithmetic bitwise)
+                #:select (bitwise-ior))
   #:use-module ((rnrs base) #:select (assert))
-  #:export (conservative-gc? calls-in-tail-position?))
+  #:use-module ((fibers) #:prefix #{fibers:}#)
+  #:autoload (gnu gnunet config db) (hash->configuration)
+  #:export (conservative-gc? calls-in-tail-position?
+                             call-with-services
+                             call-with-services/fibers))
 
 ;; Current versions of guile (at least 3.0.5) use a conservative
 ;; garbage collector, so some tests concerning garbage collection
@@ -54,3 +62,76 @@ times."
 (assert (not (calls-in-tail-position? (lambda (thunk) (+ 1 (thunk))))))
 #;
 (assert (not (calls-in-tail-position? (lambda (thunk) (for-each thunk '("bla" "bla"))))))
+
+(define (call-with-temporary-directory proc)
+  (let ((file (mkdtemp (in-vicinity (or (getenv "TMPDIR") "/tmp")
+                                    "test-XXXXXX"))))
+    (with-exception-handler
+        (lambda (e)
+          (system* "rm" "-r" file)
+          (raise-exception e))
+      (lambda ()
+        (call-with-values
+            (lambda () (proc file))
+          (lambda the-values
+            (system* "rm" "-r" file)
+            (apply values the-values)))))))
+
+(define (call-with-services service-alist proc)
+  "Call the procedure @var{proc} with a configuration database
+and a procedure behaving like @code{spawn-fiber}, in an environment
+where the services listed in @var{service-alist} can
+be connected to.  The heads in @var{service-alist} are the names of
+the services and each tails is a list of a procedure accepting ports
+(connected to the client) and the procedure behaving like @code{spawn-fiber}."
+  (define %thread-table (make-hash-table))
+  (define (wrapped-spawn-fiber thunk)
+    (define o (list))
+    (hashq-set! %thread-table o 'running)
+    (fibers:spawn-fiber
+     (lambda ()
+       (with-exception-handler
+           (lambda (e)
+             (hashq-set! %thread-table o (cons 'exception e))
+             (raise-exception e))
+         thunk)))
+    (values))
+  ;; The hash function isn't very efficient but is sufficient.
+  (define config-hash (rnrs:make-hashtable (const 0) equal?))
+  (call-with-temporary-directory
+   (lambda (dir)
+     (define (start-service key+value)
+       (define where (in-vicinity dir (string-append (car key+value) ".sock")))
+       (rnrs:hashtable-set! config-hash (cons (car key+value) "UNIXPATH")
+                            where)
+       (wrapped-spawn-fiber
+        (lambda ()
+          (define sock (socket AF_UNIX SOCK_STREAM 0))
+          (bind sock AF_UNIX where)
+          (listen sock 40)
+          (fcntl sock F_SETFL
+                 (bitwise-ior (fcntl sock F_GETFL) O_NONBLOCK))
+          (let loop ()
+            (define client-sock
+              (car (accept sock (logior SOCK_NONBLOCK
+                                        SOCK_CLOEXEC))))
+            (wrapped-spawn-fiber
+             (lambda ()
+               ((cdr key+value) client-sock wrapped-spawn-fiber)))
+            (loop)))))
+     (for-each start-service service-alist)
+     (define config (hash->configuration config-hash))
+     (call-with-values
+         (lambda () (proc config wrapped-spawn-fiber))
+       (lambda results
+         ;; Make sure exceptions are visible
+         (hash-for-each (lambda (key value)
+                          (match value
+                            (('exception . e)
+                             (raise-exception e))
+                            ('running (values))))
+                        %thread-table)
+         (apply values results))))))
+
+(define (call-with-services/fibers service-alist proc)
+  (fibers:run-fibers (lambda () (call-with-services service-alist proc))))