[gnunet-scheme] branch master updated (f9447cf -> 8751c9c)

[gnunet]

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

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

    from f9447cf  tests/distributed-hash-table: Fix spurious test failure.
     new 2e3530f  tests/distributed-hash-table: Report errors with Guile, not 
RnRS.
     new d9ca07c  tests: Support disconnecting the DHT simulation.
     new 8751c9c  tests: Test reconnecting and 'start-get!'.

The 3 revisions listed above as "new" are entirely new to this
repository and will be described in separate emails.  The revisions
listed as "add" were already present in the repository and have only
been added to this reference.


Summary of changes:
 tests/distributed-hash-table.scm | 68 ++++++++++++++++++++++++++++++++++++----
 1 file changed, 62 insertions(+), 6 deletions(-)

diff --git a/tests/distributed-hash-table.scm b/tests/distributed-hash-table.scm
index 90b8f73..1cf6777 100644
--- a/tests/distributed-hash-table.scm
+++ b/tests/distributed-hash-table.scm
@@ -46,9 +46,14 @@
        (srfi srfi-64)
        (fibers conditions)
        (fibers channels)
+       (fibers operations)
+       (fibers scheduler)
        (fibers timers) ; sleep
        (tests utils))
 
+;; Use the @code{error} from Guile, not RnRS.
+(define error (@ (guile) error))
+
 ;; Copied from tests/bv-slice.scm.
 (define-syntax-rule (test-missing-caps test-case what permitted required code)
   (test-equal test-case
@@ -432,10 +437,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))
@@ -450,13 +455,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 '(() . ())))
@@ -485,9 +498,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)
@@ -804,4 +815,49 @@ supported."
         (loop (+ n 1))))
      #true)))
 
+(test-assert "searches restarted after disconnect"
+  (let ((stop-first-server (make-condition))
+       (first-accepted (make-condition)))
+    (call-with-services/fibers
+     `(("dht" . ,(lambda args
+                  (if (signal-condition! first-accepted)
+                      (apply (simulate-dht-service stop-first-server) args)
+                      (apply (simulate-dht-service) args)))))
+     (lambda (config spawn-fiber)
+       (define connected/condition (make-condition))
+       (define disconnected/condition (make-condition))
+       (define (connected)
+        (signal-condition! connected/condition))
+       (define (disconnected)
+        (signal-condition! disconnected/condition))
+       (define server (connect config #:connected connected
+                              #:disconnected disconnected
+                              #:spawn spawn-fiber))
+       ;; Start a search
+       (define datum (make-a-datum))
+       (define found/condition (make-condition))
+       (define (found search-result)
+        (unless (datum=? datum (search-result->datum search-result))
+          (error "wrong search result"))
+        (unless (signal-condition! found/condition)
+          (error "multiple results")))
+       (define query (make-query (datum-type datum) (datum-key datum)))
+       (define search (start-get! server query found))
+       ;; Give @var{server} a chance to actually send the request.
+       ;; Removing the 'let loop' is possible, but would test some
+       ;; different code paths (TODO enveloppe confirmation/cancellation).
+       (wait connected/condition)
+       (wait first-accepted)
+       (let loop ((n 0))
+        (when (< n 100)
+          (yield-current-task)))
+       ;; Break the connection, letting @var{server} reconnect.
+       (signal-condition! stop-first-server)
+       (wait disconnected/condition)
+       ;; Insert the datum, such that @var{search} can complete (assuming
+       ;; that @var{server} remembered to start the search again!).
+       (put! server (datum->insertion datum))
+       (wait found/condition)
+       #true))))
+
 (test-end)

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