[gnunet-scheme] branch master updated (5f2470b -> 7ffddc9)

[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 5f2470b  doc: Document (gnu gnunet concurrency lost-and-found).
     new 9650ee8  lost-and-found: Preserve the name of the post-GC hook.
     new 128be25  dht/client: Actually use the 'loop-operation'.
     new 5705505  dht/client: Automatically disconnect when unreachable.
     new 7ffddc9  NEWS: Document new DHT server object behaviour.

The 4 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:
 NEWS                                      |  2 ++
 doc/distributed-hash-table.tm             |  4 ++++
 gnu/gnunet/concurrency/lost-and-found.scm |  2 +-
 gnu/gnunet/dht/client.scm                 | 32 ++++++++++++++++++--------
 tests/distributed-hash-table.scm          |  5 ++++
 tests/utils.scm                           | 38 ++++++++++++++++++++++++++++++-
 6 files changed, 71 insertions(+), 12 deletions(-)

diff --git a/NEWS b/NEWS
index c166771..f0b56b2 100644
--- a/NEWS
+++ b/NEWS
@@ -11,6 +11,8 @@
    - DHT searches can now be stopped (‘cancelled’) with 'stop-get!'.
      Additionally, DHT searches are automatically cancelled when the
      search object becomes unreachable.
+   - DHT server objects are automatically disconnected when they become
+     unreachable (TODO: NSE server objects!)
 ** Documentation
    - The ‘message-symbol’ network structure property is now defined for DHT
      messages and documented in the manual.  The aim is to make the code
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/concurrency/lost-and-found.scm 
b/gnu/gnunet/concurrency/lost-and-found.scm
index 050bd4a..7465e7d 100644
--- a/gnu/gnunet/concurrency/lost-and-found.scm
+++ b/gnu/gnunet/concurrency/lost-and-found.scm
@@ -236,4 +236,4 @@ wakeups where the empty list is returned are possible."
        ;; "unreachable + gc -> moved into lost and found"
        (collect-lost)))
 
-    (add-hook! after-gc-hook (lambda () (collect-lost)))))
+    (add-hook! after-gc-hook collect-lost)))
diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index 59f07d7..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 (get-operation control-channel))
+       (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.