[gnunet-scheme] branch master updated (2ea2981 -> 1a21216)

[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 2ea2981  doc: Document 'copy-query' and 'copy-insertion'.
     new 584362a  dht/client: Remove addressed TODO.
     new 8c59b20  dht/client: Remove another addressed TODO.
     new ef62b63  dht/client: Remove yet another addressed TODO.
     new f95e002  dht/client: Explain why the connection:interrupted code is 
correct.
     new 77edd7b  dht/client: Correct call to 'maybe-send-control-message!*'.
     new 68f3250  dht/client: Handle ill-formed messages correctly.
     new 84e2ec1  tests/distributed-hash-table: Test reconnecting and callbacks.
     new 1a21216  doc: Fix typo.

The 8 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:
 doc/scheme-gnunet.tm             |  2 +-
 gnu/gnunet/dht/client.scm        | 36 +++++++++++++--------
 tests/distributed-hash-table.scm | 68 ++++++++++++++++++++++++++++++++++++++++
 tests/utils.scm                  | 23 +++++++++-----
 4 files changed, 107 insertions(+), 22 deletions(-)

diff --git a/doc/scheme-gnunet.tm b/doc/scheme-gnunet.tm
index 4fe4656..a70ae35 100644
--- a/doc/scheme-gnunet.tm
+++ b/doc/scheme-gnunet.tm
@@ -1082,7 +1082,7 @@
 
   <\explain>
     <scm|(connect <var|config> <var|#:connected> <var|#:disconnected>
-    <var|#:spawn-fiber>)><subindex|connect|DHT>
+    <var|#:spawn>)><subindex|connect|DHT>
   <|explain>
     Connect to the DHT service, using the configuration <var|config>. The
     connection is made asynchronuously; the optional thunk <var|connected> is
diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index c89a16c..95aedc8 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -202,8 +202,6 @@ appropriate exception."
       ;; size of the would-be path (in octets)
       (size malformed-path-size))
 
-    ;; TODO: use the data structures below and test them
-
     ;; An key-value entry in the DHT.
     (define-record-type (<datum> make-datum datum?)
       (fields (immutable type datum-type)
@@ -268,7 +266,6 @@ be tested if an object is an insertion object with the 
predicate
           (%make (validate-datum datum)
                  (bound-replication-level desired-replication-level))))))
 
-    ;; TODO: test and document
     (define (copy-insertion old)
       "Make a copy of the insertion @var{old}, such that modifications to the
 slices in @var{old} do not impact the new insertion."
@@ -773,8 +770,8 @@ code automatically tries to reconnect, so @var{connected} 
can be called after
                 TODO-error-reporting/2)))))
       ;; TODO: abstract duplication in (gnu gnunet nse client)
       (define mq-defined (make-condition))
-      (define (error-handler error . arguments)
-       (case error
+      (define (error-handler key . arguments)
+       (case key
          ((connection:connected)
           (connected)
           (wait mq-defined)
@@ -789,27 +786,40 @@ code automatically tries to reconnect, so @var{connected} 
can be called after
                     (hash-map->list (lambda (x handle) handle)
                                     id->operation-map))
           (values))
-         ;; TODO: signal (and wait for) current fibers to stop?
          ((input:regular-end-of-file input:premature-end-of-file)
           (disconnected)
           ;; Tell the event loop that it is time to restart,
           ;; unless it is already stopping.
-          (maybe-send-control-message!* terminal-condition 'reconnect!))
-         ;; TODO: is this cargo-copying from (gnu gnunet nse client)
-         ;; correct?
+          (maybe-send-control-message!* terminal-condition control-channel 
'reconnect!))
+         ;; 'control' closed the queue and will exit, nothing to do here!
+         ;;
+         ;; Tested by "(DHT) close, not connected --> all fibers stop,
+         ;; no callbacks called" in tests/distributed-hash-table.scm.
          ((connection:interrupted)
           (values))
          (else
-          ;; TODO: does 'disconnected' need to be called here,
-          ;; does 'disconnect!' need to be sent to the control channel?
-          (apply report-error error arguments)
-          (close-queue! mq))))
+          ;; Some unknown problem, let 'control' report the error,
+          ;; disconnect and stop reconnecting.  The first two happen
+          ;; in no particular order.
+          (apply maybe-send-control-message!* terminal-condition
+                 control-channel 'oops! key arguments)
+          (values))))
       (define mq (connect/fibers config "dht" handlers error-handler
                                 #:spawn spawn))
       (signal-condition! mq-defined)
       (define (control)
        "The main event loop."
        (match (perform-operation (get-operation control-channel))
+         (('oops! key . arguments)
+          ;; Some unknown error, report it (report-error) and close
+          ;; the queue (close-queue!).  'connected' will be called
+          ;; from the 'input:regular-end-of-file' case in 'error-handler'.
+          ;;
+          ;; The error reporting and closing happen in no particular order.
+          (signal-condition! terminal-condition)
+          (apply report-error key arguments)
+          (close-queue! mq)
+          (values))
          (('disconnect!)
           ;; Ignore future requests instead of blocking.
           (signal-condition! terminal-condition)
diff --git a/tests/distributed-hash-table.scm b/tests/distributed-hash-table.scm
index 193b295..79c7592 100644
--- a/tests/distributed-hash-table.scm
+++ b/tests/distributed-hash-table.scm
@@ -17,6 +17,7 @@
 ;; SPDX-License-Identifier: AGPL-3.0-or-later
 (define-module (test-distributed-hash-table))
 (import (ice-9 match)
+       (ice-9 binary-ports)
        (quickcheck)
        (quickcheck arbitrary)
        (quickcheck generator)
@@ -26,11 +27,13 @@
        (gnu gnunet dht struct)
        (gnu gnunet utils bv-slice)
        (gnu gnunet utils hat-let)
+       (gnu gnunet util struct)
        (gnu gnunet netstruct syntactic)
        (gnu gnunet hashcode struct)
        (gnu gnunet block)
        (gnu gnunet message protocols)
        (gnu gnunet mq)
+       (gnu gnunet mq error-reporting)
        (gnu gnunet mq handler)
        (gnu gnunet mq-impl stream)
        (gnu extractor enum)
@@ -42,6 +45,7 @@
        (srfi srfi-64)
        (fibers conditions)
        (fibers channels)
+       (fibers timers) ; sleep
        (tests utils))
 
 ;; Copied from tests/bv-slice.scm.
@@ -641,4 +645,68 @@ supported."
 (test-assert "(DHT) close, not connected --> all fibers stop, no callbacks 
called"
   (close-not-connected-no-fallbacks "dht" connect disconnect!))
 
+(define* (determine-reported-errors proc #:key (n-connections 1))
+  (call-with-spawner/wait*
+   (lambda (config spawn)
+     (define errors '())
+     (define currently-connected? #false)
+     (define times-connected 0)
+     (define finally-disconnected-c (make-condition))
+     (parameterize ((error-reporter (lambda foo
+                                     (assert (> times-connected 0))
+                                     (set! errors (cons foo errors)))))
+       (define (connected)
+        (assert (not currently-connected?))
+        (set! currently-connected? #true)
+        (set! times-connected (+ 1 times-connected))
+        (assert (<= times-connected n-connections)))
+       (define (disconnected)
+        (assert currently-connected?)
+        (set! currently-connected? #false)
+        (when (= times-connected n-connections)
+          (signal-condition! finally-disconnected-c)))
+       (define server
+        (connect config #:connected connected #:disconnected disconnected
+                 #:spawn spawn))
+       ;; Give 'error-reporter' a chance to be called too often
+       (sleep 0.001)
+       (wait finally-disconnected-c)
+       (and (not currently-connected?)
+           (= times-connected n-connections) errors)))
+   `(("dht" . ,proc))))
+
+(define (put-ill-formed-message port)
+  (define b (make-bytevector (sizeof /:message-header '())))
+  (define s (slice/write-only (bv-slice/read-write b)))
+  (set%! /:message-header '(type) s
+        (value->index (symbol-value message-type msg:dht:client:result)))
+  (set%! /:message-header '(size) s (slice-length s))
+  (put-bytevector port b))
+
+(test-equal "(DHT) ill-formed message from service --> all fibers stop, 
'connected' and 'disconnected' called"
+  `((logic:ill-formed
+     ,(value->index (symbol-value message-type msg:dht:client:result))))
+  (determine-reported-errors
+   (lambda (port spawn-fiber)
+     (put-ill-formed-message port)
+     (close-port port))))
+
+;; Allow reconnecting a few times and eventually ensure a permanent
+;; disconnecting to make the test terminate.
+(define n-connections 7)
+(test-equal "(DHT) end-of-file --> reconnect (all fibers eventually stop)"
+  `((logic:ill-formed
+     ,(value->index (symbol-value message-type msg:dht:client:result))))
+  (determine-reported-errors
+   (let ((i 0))
+     (lambda (port spawn-fiber)
+       (set! i (+ i 1))
+       (assert (<= i n-connections))
+       (when (= i n-connections)
+        (put-ill-formed-message port))
+       (close-port port)))
+   #:n-connections n-connections))
+
+;; TODO: would be nice to test that old requests are submitted again
+
 (test-end)
diff --git a/tests/utils.scm b/tests/utils.scm
index a117eca..962ea07 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -32,6 +32,7 @@
                             call-with-services/fibers
                             call-with-spawner
                             call-with-spawner/wait
+                            call-with-spawner/wait*
                             call-with-temporary-directory
                             make-nonblocking!
                             call-with-absent-service
@@ -148,21 +149,23 @@ the services and each tails is a list of a procedure 
accepting ports
 (define (call-with-services/fibers service-alist proc)
   (fibers:run-fibers (lambda () (call-with-services service-alist proc))))
 
-(define* (call-with-spawner proc . args)
+(define* (call-with-spawner* proc service-alist . args)
   (apply fibers:run-fibers
         (lambda ()
           (call-with-services
-           '()
-           (lambda (config spawn)
-             (proc spawn))))
+           service-alist
+           proc))
         args))
 
+(define (call-with-spawner proc . args)
+  (apply call-with-spawner* (lambda (config spawn) (proc spawn)) '() args))
+
 ;; When done, wait for every fiber to complete.
 ;; Somewhat racy, don't use outside tests.
-(define* (call-with-spawner/wait proc . args)
+(define* (call-with-spawner/wait* proc service-alist . args)
   (define h (make-weak-key-hash-table)) ; condition -> nothing in particular
-  (apply call-with-spawner
-        (lambda (spawn/not-waiting)
+  (apply call-with-spawner*
+        (lambda (config spawn/not-waiting)
           (define (spawn thunk)
             (define done-condition (make-condition))
             (hashq-set! h done-condition #f)
@@ -171,13 +174,17 @@ the services and each tails is a list of a procedure 
accepting ports
                (thunk)
                (signal-condition! done-condition))))
           (define-values return-values
-            (proc spawn))
+            (proc config spawn))
           ;; Make sure every fiber completes before returning.
           ;; XXX hash-for-each imposes a continuation barrier
           (for-each wait (hash-map->list (lambda (x y) x) h))
           (apply values return-values))
+        service-alist
         args))
 
+(define (call-with-spawner/wait proc . args)
+  (apply call-with-spawner/wait* (lambda (config spawn) (proc spawn)) '() 
args))
+
 (define (trivial-service-config what where)
   "Make a configuration where the socket location of the @var{what} service
 is @var{where}."

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