[gnunet-scheme] 02/03: tests: Support disconnecting the DHT simulation.

[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 d9ca07c3822a729a657314c3212ec93db76da51f
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Tue Feb 15 17:38:26 2022 +0000

    tests: Support disconnecting the DHT simulation.
    
    This will be used by the test introduced by the following commit.
    
    * tests/distributed-hash-table.scm (simulate-dht-service): Add
      optional 'explode' argument.  Close the message queue when
      signalled.
---
 tests/distributed-hash-table.scm | 19 +++++++++++++------
 1 file changed, 13 insertions(+), 6 deletions(-)

diff --git a/tests/distributed-hash-table.scm b/tests/distributed-hash-table.scm
index 74efce7..9137521 100644
--- a/tests/distributed-hash-table.scm
+++ b/tests/distributed-hash-table.scm
@@ -46,6 +46,7 @@
        (srfi srfi-64)
        (fibers conditions)
        (fibers channels)
+       (fibers operations)
        (fibers timers) ; sleep
        (tests utils))
 
@@ -435,10 +436,10 @@
 
 ;; TODO: would be nice to turn this in a real service
 ;; (gnu gnunet dht service).
-(define (simulate-dht-service)
+(define* (simulate-dht-service #:optional (explode (make-condition)))
   "Simulate a DHT service, remembering all insertions and ignoring expiration
 and replication.  Cancellation is ignored (TODO).  Only a single client is
-supported."
+supported.  When @var{explode} is signalled, the connection is closed."
   (define (slice->bv slice)
     (define bv (make-bytevector (slice-length slice)))
     (define bv/slice (bv-slice/read-write bv))
@@ -453,13 +454,21 @@ supported."
   ;;   --> (list of value . interested mq channels)
   (define table (make-hash-table))
   (define table-channel (make-channel))
+  (define mq)
+  (define mq-defined (make-condition))
   (define (handle-table spawn-fiber)
     (define (put-message/async channel message)
       (assert (channel? channel))
       (spawn-fiber
        (lambda ()
         (put-message channel message))))
-    (match (get-message table-channel)
+    (match (perform-operation
+           (choice-operation (get-operation table-channel)
+                             (wrap-operation (wait-operation explode)
+                                             (lambda () 'explode))))
+      ('explode
+       (wait mq-defined)
+       (close-queue! mq))
       (('start-get! query response-channel)
        (let* ((key (query->key query))
              (old (hash-ref table key '(() . ())))
@@ -488,9 +497,7 @@ supported."
     (handle-table spawn-fiber))
   (lambda (port spawn-fiber)
     (spawn-fiber (lambda () (handle-table spawn-fiber)))
-    (let^ ((! mq #false) ; not yet defined
-          (! mq-defined (make-condition))
-          (! (simple-message-handler type* handle!*)
+    (let^ ((! (simple-message-handler type* handle!*)
              (message-handler
               (type type*)
               ((interpose foo) foo)

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