[gnunet-scheme] branch master updated (ce8e5f2 -> 14d5c4e)

[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 ce8e5f2  tests: Test cancelling a DHT search within a search callback.
     new bc436e9  dht/client: Only access 'id->operation-map' from 'control'.
     new 31776e5  dht/client: Make a distinction between old and new operations.
     new eac44bf  dht/client: Actually remove old operations from the hash 
table.
     new 1533dd8  dht/client: Continue after cancellation.
     new 14d5c4e  dht/client: Test idempotency of cancelling searches.

The 5 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:
 gnu/gnunet/dht/client.scm        | 58 ++++++++++++++++++++++++++++++++--------
 tests/distributed-hash-table.scm | 20 +++++++++++++-
 2 files changed, 66 insertions(+), 12 deletions(-)

diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index 395c5ae..a5be707 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -79,7 +79,7 @@
          (only (guile)
                pk define-syntax-rule define* lambda* error
                make-hash-table hashq-set! hashq-remove! hashv-set! hashv-ref
-               hash-map->list)
+               hashv-remove! hash-clear! hash-map->list)
          (only (ice-9 atomic)
                make-atomic-box atomic-box-ref atomic-box-set!)
          (only (ice-9 match)
@@ -91,9 +91,9 @@
          (only (fibers conditions)
                make-condition signal-condition! wait-operation wait)
          (only (fibers operations)
-               perform-operation choice-operation)
+               perform-operation choice-operation wrap-operation)
          (only (fibers channels)
-               make-channel put-operation get-operation)
+               make-channel put-operation get-operation get-message 
put-message)
          (only (gnu gnunet mq error-reporting)
                report-error)
          (gnu gnunet dht struct)
@@ -111,7 +111,8 @@
                and >= = quote * / + - define begin ... let*
                quote case else values apply let cond if >
                <= expt assert exact? integer? lambda for-each
-               not expt min max div-and-mod positive? define-syntax)
+               not expt min max div-and-mod positive? define-syntax
+               vector)
          (only (rnrs control)
                unless when)
          (only (rnrs records syntactic)
@@ -732,10 +733,10 @@ when the connection has been made.  The connection can 
break; the optional thunk
 code automatically tries to reconnect, so @var{connected} can be called after
 @var{disconnected}.  This procedure returns a DHT server object."
       (define terminal-condition (make-condition))
-      (define id->operation-map (make-hash-table))
+      (define old-id->operation-map (make-hash-table))
       (define control-channel (make-channel))
       (reconnect terminal-condition config
-                id->operation-map control-channel
+                old-id->operation-map control-channel
                 #:connected connected
                 #:disconnected disconnected
                 #:spawn spawn)
@@ -745,10 +746,35 @@ code automatically tries to reconnect, so @var{connected} 
can be called after
 
     ;; TODO(id->operation-map): Hash tables are thread-unsafe.
     (define* (reconnect terminal-condition config
-                       id->operation-map control-channel
+                       old-id->operation-map control-channel
                        #:key (spawn spawn-fiber)
                        connected disconnected
                        #:rest rest)
+      ;; The 'id->operation-map' holds get operations that have
+      ;; been communicated to the service.  The 'old-id->operation-map'
+      ;; is used for reconnecting and holds get operations that need
+      ;; to be communicated to the service again.  'old-id->operation-map'
+      ;; only shrinks, while 'id->operation-map' can both grow and shrink.
+      (define id->operation-map (make-hash-table))
+      (define (request-search-result-iterator unique-id)
+       "Ask @code{control} what is the iterator for the get operation with
+unique id @var{unique-id}.  If there is no such get operation, or the get
+operation is cancelled, return @code{#false} instead."
+       ;; It is possible to look at id->operation-map directly instead,
+       ;; but hash tables are thread-unsafe.
+       ;; TODO: reduce allocations
+       (define response-channel (make-channel))
+       (perform-operation
+        (choice-operation
+         ;; TODO: is this case needed?
+         (wrap-operation (wait-operation terminal-condition)
+                         (lambda () #false))
+         (wrap-operation
+          (put-operation control-channel
+                         (vector 'request-search-result-iterator unique-id
+                                 response-channel))
+          (lambda ()
+            (get-message response-channel))))))
       (define handlers
        (message-handlers
         (message-handler
@@ -791,7 +817,7 @@ code automatically tries to reconnect, so @var{connected} 
can be called after
           (let^ ((<-- (search-result unique-id)
                       ;; TODO: maybe verify the type and key?
                       (analyse-client-result slice))
-                 (! handle (hashv-ref id->operation-map unique-id))
+                 (! handle (request-search-result-iterator unique-id))
                  (? (not handle)
                     ;; Where did this unique id come from?
                     (pk 'unique-id unique-id)
@@ -814,11 +840,13 @@ code automatically tries to reconnect, so @var{connected} 
can be called after
           ;;
           ;; TODO: restarting monitoring operations
           (for-each (lambda (get)
+                      (hashv-set! id->operation-map (get:unique-id get) get)
                       (send-get! mq get))
                     ;; XXX: @code{hash-for-each} forms a continuation barrier,
                     ;; so turn the hash table into a list before iterating.
                     (hash-map->list (lambda (x handle) handle)
-                                    id->operation-map))
+                                    old-id->operation-map))
+          (hash-clear! old-id->operation-map)
           (values))
          ((input:regular-end-of-file input:premature-end-of-file)
           (disconnected)
@@ -879,13 +907,21 @@ code automatically tries to reconnect, so @var{connected} 
can be called after
           ;; TODO: cancel outstanding messages to the DHT services for this
           ;; get operation (including the request to start searching), if
           ;; any.
+          (hashv-remove! old-id->operation-map (get:unique-id get))
           (when (hashv-ref id->operation-map (get:unique-id get))
-            (hashv-set! id->operation-map (get:unique-id get) #false)
-            (send-stop-get! mq get)))
+            (hashv-remove! id->operation-map (get:unique-id get))
+            (send-stop-get! mq get))
+          ;; Continue!
+          (control))
          (('put! put)
           ;; Send the put operation to the DHT service.
           (send-message! mq (put:message put))
           ;; Continue!
+          (control))
+         ;; Send by @code{request-search-result-iterator}.
+         (#('request-search-result-iterator unique-id response-channel)
+          (put-message response-channel (hashv-ref id->operation-map 
unique-id))
+          ;; Continue!
           (control))))
       ;; Start the main event loop.
       (spawn control))))
diff --git a/tests/distributed-hash-table.scm b/tests/distributed-hash-table.scm
index 84787bc..9671a46 100644
--- a/tests/distributed-hash-table.scm
+++ b/tests/distributed-hash-table.scm
@@ -434,7 +434,7 @@
 ;; (gnu gnunet dht service).
 (define (simulate-dht-service)
   "Simulate a DHT service, remembering all insertions and ignoring expiration
-and replication.  Cancellation is not supported.  Only a single client is
+and replication.  Cancellation is ignored (TODO).  Only a single client is
 supported."
   (define (slice->bv slice)
     (define bv (make-bytevector (slice-length slice)))
@@ -521,6 +521,10 @@ supported."
                 (simple-message-handler
                  (symbol-value message-type msg:dht:client:put)
                  handle/put!)
+                ;; TODO: handle properly
+                (simple-message-handler
+                 (symbol-value message-type msg:dht:client:get:stop)
+                 (lambda (slice) (values)))
                 (simple-message-handler
                  (symbol-value message-type msg:dht:client:get)
                  handle/start-get!))))
@@ -778,4 +782,18 @@ supported."
      (wait done)
      #true)))
 
+(test-assert "cancelling a search multiple times does not hang"
+  (call-with-services/fibers
+   `(("dht" . ,(simulate-dht-service)))
+   (lambda (config spawn-fiber)
+     (define server (connect config))
+     (define datum (make-a-datum))
+     (define query (make-query (datum-type datum) (datum-key datum)))
+     (define search (start-get! server query (lambda (foo) (values))))
+     (let loop ((n 0))
+       (when (< n 40)
+        (stop-get! search)
+        (loop (+ n 1))))
+     #true)))
+
 (test-end)

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