[gnunet-scheme] 03/04: dht/client: Automatically disconnect when unreachable.

[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 5705505a027869dc277c1dfb783f913c4da65d53
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Sat Feb 19 14:07:18 2022 +0000

    dht/client: Automatically disconnect when unreachable.
    
    * gnu/gnunet/dht/client.scm
      (<server>):  Make it a <losable>. Adjust constructor.
      (reconnect)[control]: Extract most functionality to ...
      (reconnect)[control*]: ... here.
      (reconnect)[handle-lost]: Move to ...
      (reconnect)[control*]<lost>: ... here, and handle server objects.
    * tests/utils.scm (garbage-collectable): New procedure.
    * tests/distributed-hash-table.scm
      ("put! sends one message to service, after connecting")
      (determine-reported-errors): Adjust for new behaviour.
      ("(DHT) garbage collectable"): New test.
---
 doc/distributed-hash-table.tm    |  4 ++++
 gnu/gnunet/dht/client.scm        | 32 ++++++++++++++++++++++----------
 tests/distributed-hash-table.scm |  5 +++++
 tests/utils.scm                  | 38 +++++++++++++++++++++++++++++++++++++-
 4 files changed, 68 insertions(+), 11 deletions(-)

diff --git a/doc/distributed-hash-table.tm b/doc/distributed-hash-table.tm
index 295a255..8c57e5d 100644
--- a/doc/distributed-hash-table.tm
+++ b/doc/distributed-hash-table.tm
@@ -31,6 +31,10 @@
     even if not connected. This is an idempotent operation.
   </explain>
 
+  Some time after the returned server object becomes unreachable, it will
+  automatically be disconnected. Active lingering operations and reachable
+  operations keeps the server object reachable. <todo|test this!>
+
   <section|Data in the DHT>
 
   To insert data into the DHT, the DHT service needs various information \U
diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index 9efd91a..1089424 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -581,12 +581,18 @@ currently unsupported."
     ;; Operations must be put in id->operation-map before sending them
     ;; to the service!
     (define-record-type (<server> %make-server server?)
+      (parent <losable>)
       ;; terminal-condition: a disconnect has been requested
       (fields (immutable terminal-condition server-terminal-condition)
              (immutable control-channel server-control-channel)
              (immutable lost-and-found server-lost-and-found)
              ;; Atomic box holding an unsigned 64-bit integer.
-             (immutable next-unique-id/box server-next-unique-id/box)))
+             (immutable next-unique-id/box server-next-unique-id/box))
+      (protocol (lambda (%make)
+                 (lambda (terminal-condition control-channel lost-and-found
+                                             next-unique-id/box)
+                   ((%make lost-and-found) terminal-condition control-channel
+                    lost-and-found next-unique-id/box)))))
 
     (define (maybe-send-control-message!* terminal-condition control-channel
                                          . message)
@@ -911,10 +917,6 @@ operation is cancelled, return @code{#false} instead."
       (define mq (connect/fibers config "dht" handlers error-handler
                                 #:spawn spawn))
       (signal-condition! mq-defined)
-      (define (handle-lost handle)
-       ;; TODO: monitoring operations, put operations ...
-       (match handle
-         ((? get? get) (process-stop-search get))))
       (define (process-stop-search get)
        ;; TODO: tests!
        ;; TODO: cancel outstanding messages to the DHT services for this
@@ -931,7 +933,9 @@ operation is cancelled, return @code{#false} instead."
                         (lambda (lost) (cons 'lost lost)))))
       (define (control)
        "The main event loop."
-       (match (perform-operation loop-operation)
+       (control* (perform-operation loop-operation)))
+      (define (control* message)
+       (match message
          (('oops! key . arguments)
           ;; Some unknown error, report it (report-error) and close
           ;; the queue (close-queue!).  'connected' will be called
@@ -1003,9 +1007,17 @@ operation is cancelled, return @code{#false} instead."
           ;; Continue!
           (control))
          ;; Some handles became unreachable and can be cancelled.
-         (('lost lost)
-          (for-each handle-lost lost)
-          ;; Continue!
-          (control))))
+         (('lost . lost)
+          (let loop ((lost lost))
+            (match lost
+              ;; Continue!
+              (() (control))
+              ((object . rest)
+               (match object
+                 ((? get? get)
+                  (process-stop-search get)
+                  (loop rest))
+                 ((? server? server)
+                  (control* '(disconnect!))))))))))
       ;; Start the main event loop.
       (spawn control))))
diff --git a/tests/distributed-hash-table.scm b/tests/distributed-hash-table.scm
index 5509390..0d752b6 100644
--- a/tests/distributed-hash-table.scm
+++ b/tests/distributed-hash-table.scm
@@ -574,6 +574,7 @@ supported.  When @var{explode} is signalled, the connection 
is closed."
             (connect config #:connected connected #:spawn spawn-fiber))
           (put! server i)
           (wait message-received)
+          (pk 'server server) ; keep 'server' reachable
           (assert connected?)
           (assert message)
           (let^ ((<-- (insertion _)
@@ -662,6 +663,8 @@ supported.  When @var{explode} is signalled, the connection 
is closed."
 
 (test-assert "(DHT) close, not connected --> all fibers stop, no callbacks 
called"
   (close-not-connected-no-fallbacks "dht" connect disconnect!))
+(test-assert "(DHT) garbage collectable"
+  (garbage-collectable "dht" connect))
 
 (define* (determine-reported-errors proc #:key (n-connections 1) (n-errors 1))
   (call-with-spawner/wait*
@@ -697,6 +700,8 @@ supported.  When @var{explode} is signalled, the connection 
is closed."
        ;; order, so we have to wait for both.
        (wait finally-disconnected-c)
        (wait all-errors-c)
+       ;; keep 'server' reachable long enough.
+       (pk server)
        (and (not currently-connected?)
            (= times-connected n-connections) errors)))
    `(("dht" . ,proc))))
diff --git a/tests/utils.scm b/tests/utils.scm
index 274de3a..47875a0 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -18,6 +18,7 @@
 (define-module (tests utils)
   #:use-module (srfi srfi-8)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 weak-vector)
   #:use-module ((rnrs hashtables) #:prefix #{rnrs:}#)
   #:use-module ((rnrs arithmetic bitwise)
                #:select (bitwise-ior))
@@ -38,7 +39,8 @@
                             call-with-absent-service
                             trivial-service-config
                             #{don't-call-me}#
-                            close-not-connected-no-fallbacks))
+                            close-not-connected-no-fallbacks
+                            garbage-collectable))
 
 (define (make-nonblocking! sock)
   (fcntl sock F_SETFL
@@ -226,3 +228,37 @@ callbacks were not called.  Also verify that all spawned 
fibers exit."
        (disconnect! server)
        (sleep 0.001)
        #t)))))
+
+(define* (garbage-collectable service connect)
+  "Try to connect to the @var{service} service in an an environment where
+the service daemon is down.  Verify that the @var{connected} and
+@var{disconnected} callbacks were not called.  Also verify that all spawned
+fiber exit and the fibers do not keep a reference to the service object."
+  (define (test)
+    (call-with-spawner/wait
+     (lambda (spawn)
+       (call-with-absent-service
+       service
+       (lambda (config)
+         (define reference
+           (weak-vector
+            (connect config #:spawn spawn #:connected #{don't-call-me}#
+                     #:disconnected #{don't-call-me}#)))
+         ;; Sleep to give the client fibers a chance to mistakenly
+         ;; call a callback and to allow the fibers to actually stop.
+         (let loop ((delay 0.0005))
+           (pk 'loop delay)
+           (gc)
+           (pk 'gced)
+           (sleep delay)
+           (if (weak-vector-ref reference 0)
+               ;; not yet collected, try again later.
+               (and (< delay 2.) (loop (* 2 delay)))
+               #true))))))) ; it was collected!
+  (define n-trials 32)
+  (let loop ((successes 0)
+            (trials 0))
+    (pk successes trials)
+    (if (>= trials n-trials)
+       (>= (/ successes trials) (if (conservative-gc?) 8/10 1))
+       (loop (if (test) (+ 1 successes) successes) (+ 1 trials)))))

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