[gnunet-scheme] 176/324: tests/utils: New utilities for tests.

[gnunet]

This is an automated email from the git hooks/post-receive script.

maxime-devos pushed a commit to branch master
in repository gnunet-scheme.

commit aeb4d31b176543ac46a219bb560d5344c1a98848
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Fri Aug 13 16:39:15 2021 +0200

    tests/utils: New utilities for tests.
    
    * tests/util.scm
      (call-with-temporary-directory)
      (call-with-services)
      (call-with-services/fibers): New procedure.
---
 tests/utils.scm | 83 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 82 insertions(+), 1 deletion(-)

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))))

-- 
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.