[gnunet-scheme] branch master updated (57fd1ae -> 0b7dcf4)

[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 57fd1ae  dht/client: Simplify concurrency.
     new d62cdf1  dht/client: Remove unused 'request-close-handler'.
     new 0b7dcf4  dht/client: Support disconnecting and reconnecting.

The 2 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             | 22 +++++++++-
 gnu/gnunet/dht/client.scm        | 91 ++++++++++++++++++++++++----------------
 tests/distributed-hash-table.scm |  4 ++
 tests/network-size.scm           | 31 +++-----------
 tests/utils.scm                  | 51 +++++++++++++++++++++-
 5 files changed, 132 insertions(+), 67 deletions(-)

diff --git a/doc/scheme-gnunet.tm b/doc/scheme-gnunet.tm
index ae413c2..4cfe7ac 100644
--- a/doc/scheme-gnunet.tm
+++ b/doc/scheme-gnunet.tm
@@ -1054,8 +1054,26 @@
   GNUnet has a service that maintains a <em|distributed hash table>, mapping
   keys to values. The module <scm|(gnu gnunet dht client)> can be used to
   interact with the service. The connection can be made with the procedure
-  <scm|connect> <todo|document parameters>. It returns a <em|DHT server
-  object>. <todo|disconnection / reconnection>
+  <scm|connect>. It returns a <em|DHT server object>.
+
+  <\explain>
+    <scm|(connect <var|config> <var|#:connected> <var|#:disconnected>
+    <var|#:spawn-fiber>)>
+  <|explain>
+    Connect to the DHT service, using the configuration <var|config>. The
+    connection is made asynchronuously; the optional thunk <var|connected> is
+    called when the connection has been made. The connection can break; the
+    optional thunk <var|disconnected> is called when it does. If the
+    connection breaks, the client code automatically tries to reconnect, so
+    <var|connected> can be called after <var|disconnected>.
+  </explain>
+
+  <\explain>
+    <scm|(disconnect <var|server>)>
+  <|explain>
+    Asynchronuously disconnect from the DHT service and stop reconnecting,
+    even if not connected. This is an idempotent operation.
+  </explain>
 
   <section|Data in the DHT>
 
diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index 8e6527d..39f8d81 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -556,9 +556,8 @@ currently unsupported."
     ;; Operations must be put in id->operation-map before sending them
     ;; to the service!
     (define-record-type (<server> %make-server server?)
-      (fields (immutable request-close?/box server-request-close?/box)
-             (immutable request-close-condition
-                        server-request-close-condition)
+      ;; terminal-condition: a disconnect has been requested
+      (fields (immutable terminal-condition server-terminal-condition)
              (immutable control-channel server-control-channel)
              ;; Atomic box holding an unsigned 64-bit integer.
              (immutable next-unique-id/box server-next-unique-id/box)
@@ -566,14 +565,21 @@ currently unsupported."
              ;; <get> object.
              (immutable id->operation-map server-id->operation-map)))
 
+    (define (maybe-send-control-message!* terminal-condition control-channel
+                                         . message)
+      "See @code{maybe-send-control-message!}."
+      (perform-operation
+       (choice-operation
+       ;; Nothing to do when the <server> is permanently disconnected,
+       ;; or is being disconnected.
+       (wait-operation terminal-condition)
+       (put-operation control-channel message))))
+
     (define (maybe-send-control-message! server . message)
       "Send @var{message} to the control channel of @var{server}, or don't
 do anything if @var{server} has been permanently disconnected."
-      (perform-operation
-       (choice-operation
-       ;; Nothing to do when the permanently disconnected!
-       (wait-operation (server-request-close-condition server))
-       (put-operation (server-control-channel server) message))))
+      (apply maybe-send-control-message!* (server-terminal-condition server)
+            (server-control-channel server) message))
 
     (define-record-type (<get> %make-get get?)
       (fields (immutable server get:server)
@@ -683,31 +689,35 @@ message header is assumed to be correct."
     ;; (gnu gnunet client) as in the C implementation?
     (define (disconnect! server)
       "Asynchronuously disconnect from the DHT service and stop reconnecting,
-even if not connected.  This is an idempotent operation."
-      (atomic-box-set! (server-request-close?/box server) #t)
-      (signal-condition! (server-request-close-condition server)))
+even if not connected.  This is an idempotent operation.  This is an
+asynchronuous request; it won't be fulfilled immediately."
+      (maybe-send-control-message! server 'disconnect!))
 
-    (define* (connect config #:key (connected values)
+    (define* (connect config #:key (connected values) (disconnected values)
                      (spawn spawn-fiber))
-      "Connect to the DHT service in the background."
-      (define request-close?/box (make-atomic-box #f))
-      (define request-close-condition (make-condition))
+      "Connect to the DHT service, using the configuration @var{config}.  The
+connection is made asynchronuously; the optional thunk @var{connected} is 
called
+when the connection has been made.  The connection can break; the optional 
thunk
+@var{disconnected} is called when it does. If the connection breaks, the client
+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 control-channel (make-channel))
-      (reconnect request-close?/box request-close-condition config
+      (reconnect terminal-condition config
                 id->operation-map control-channel
                 #:connected connected
+                #:disconnected disconnected
                 #:spawn spawn)
-      (%make-server request-close?/box request-close-condition
-                   control-channel
+      (%make-server terminal-condition control-channel
                    ;; Any ‘small’ exact natural number will do.
                    (make-atomic-box 0)
                    id->operation-map))
 
-    (define* (reconnect request-close?/box request-close-condition config
+    (define* (reconnect terminal-condition config
                        id->operation-map control-channel
                        #:key (spawn spawn-fiber)
-                       connected
+                       connected disconnected
                        #:rest rest)
       (define handlers
        (message-handlers
@@ -763,7 +773,6 @@ even if not connected.  This is an idempotent operation."
                 ;; TODO: wrong type (maybe a put handle?).
                 TODO-error-reporting/2)))))
       ;; TODO: abstract duplication in (gnu gnunet nse client)
-      (define mq-closed (make-condition))
       (define mq-defined (make-condition))
       (define (error-handler error . arguments)
        (case error
@@ -783,40 +792,48 @@ even if not connected.  This is an idempotent operation."
           (values))
          ;; TODO: signal (and wait for) current fibers to stop?
          ((input:regular-end-of-file input:premature-end-of-file)
-          (signal-condition! mq-closed)
-          (unless (atomic-box-ref request-close?/box)
-            (apply reconnect
-                   request-close?/box request-close-condition
-                   config id->operation-map control-channel rest)))
+          (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?
          ((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))))
-      (define (request-close-handler)
-       (perform-operation
-        (choice-operation
-         (wait-operation request-close-condition)
-         ;; Make sure the fiber exits after a reconnect.
-         (wait-operation mq-closed)))
-       (close-queue! mq))
       (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))
+         (('disconnect!)
+          ;; Ignore future requests instead of blocking.
+          (signal-condition! terminal-condition)
+          ;; Close networking ports.
+          (close-queue! mq)
+          ;; And the fibers of the <server> object are now done!
+          (values))
+         (('reconnect!)
+          ;; Restart the loop with a new message queue.
+          (apply reconnect terminal-condition config id->operation-map
+                 control-channel rest))
          (('start-get! get)
           ;; Register the new get operation, such that we remember
           ;; where to send responses to.
           (hashv-set! id->operation-map (get:unique-id get) get)
-          ;; (Asynchronuously) send the GET message
-          (send-get! mq get))
+          ;; (Asynchronuously) send the GET message.
+          (send-get! mq get)
+          ;; Continue!
+          (control))
          (('put! put)
           ;; Send the put operation to the DHT service.
-          (send-message! mq (put:message put))))
-       (control))
+          (send-message! mq (put:message put))
+          ;; Continue!
+          (control))))
       ;; Start the main event loop.
       (spawn control))))
diff --git a/tests/distributed-hash-table.scm b/tests/distributed-hash-table.scm
index c249256..7f3c6f2 100644
--- a/tests/distributed-hash-table.scm
+++ b/tests/distributed-hash-table.scm
@@ -366,6 +366,7 @@
 ;;;
 ;;;  * [x] insertion (@code{put!})
 ;;;  * [x] retrieval (@code{start-get!})
+;;;  * [x] disconnecting
 ;;;  * [ ] monitoring
 ;;;
 ;;; In the following contexts:
@@ -599,4 +600,7 @@ supported."
      (wait pong)
      #true)))
 
+(test-assert "(DHT) close, not connected --> all fibers stop, no callbacks 
called"
+  (close-not-connected-no-fallbacks "dht" connect disconnect!))
+
 (test-end)
diff --git a/tests/network-size.scm b/tests/network-size.scm
index 1c8d4da..0b27d29 100644
--- a/tests/network-size.scm
+++ b/tests/network-size.scm
@@ -1,5 +1,5 @@
 ;; This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
-;; Copyright (C) 2021 GNUnet e.V.
+;; Copyright © 2021, 2022 GNUnet e.V.
 ;;
 ;; scheme-GNUnet is free software: you can redistribute it and/or modify it
 ;; under the terms of the GNU Affero General Public License as published
@@ -271,31 +271,10 @@
        (assert connected?)
        #t))))
 
-(define (make-nse-config where)
-  "Make a configuration where the socket location of the NSE service
-is @var{where}."
-  (define config (hash->configuration
-                 (rnrs:make-hashtable hash-key key=?)))
-  (set-value! identity config "nse" "UNIXPATH" where)
-  config)
-
 (test-assert "close, not connected --> all fibers stop, no callbacks called"
-  (call-with-spawner/wait
-   (lambda (spawn)
-     (call-with-temporary-directory
-      (lambda (somewhere)
-       (define where (in-vicinity somewhere "sock.et"))
-       (define config (make-nse-config where))
-       (define (#{don't-call-me}# . rest)
-         (error "oops ~a" rest))
-       (define server (nse:connect config #:spawn spawn
-                                   #:connected #{don't-call-me}#
-                                   #:disconnected #{don't-call-me}#
-                                   #:updated #{don't-call-me}#))
-       (sleep 0.001)
-       (nse:disconnect! server)
-       (sleep 0.001)
-       #t)))))
+  (close-not-connected-no-fallbacks
+   "nse" nse:connect nse:disconnect!
+   #:rest (list #:disconnected #{don't-call-me}#)))
 
 (test-assert "close, connected --> all fibers stop, two callbacks called"
   (call-with-spawner/wait
@@ -303,7 +282,7 @@ is @var{where}."
      (call-with-temporary-directory
       (lambda (somewhere)
        (define where (in-vicinity somewhere "sock.et"))
-       (define config (make-nse-config where))
+       (define config (trivial-service-config "nse" where))
        (define (#{don't-call-me}# . rest)
          (error "oops ~a" rest))
        (define connected? #f)
diff --git a/tests/utils.scm b/tests/utils.scm
index 36a4306..a117eca 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -1,5 +1,5 @@
 ;; This file is part of scheme-GNUnet.
-;; Copyright (C) 2021 GNUnet e.V.
+;; Copyright © 2021, 2022 GNUnet e.V.
 ;;
 ;; scheme-GNUnet is free software: you can redistribute it and/or modify it
 ;; under the terms of the GNU Affero General Public License as published
@@ -24,6 +24,7 @@
   #:use-module ((rnrs base) #:select (assert))
   #:use-module ((fibers) #:prefix #{fibers:}#)
   #:autoload (fibers conditions) (make-condition signal-condition! wait)
+  #:autoload (fibers timers) (sleep)
   #:autoload (gnu gnunet config db)
   (hash->configuration hash-key key=? set-value!)
   #:export (conservative-gc? calls-in-tail-position?
@@ -32,7 +33,11 @@
                             call-with-spawner
                             call-with-spawner/wait
                             call-with-temporary-directory
-                            make-nonblocking!))
+                            make-nonblocking!
+                            call-with-absent-service
+                            trivial-service-config
+                            #{don't-call-me}#
+                            close-not-connected-no-fallbacks))
 
 (define (make-nonblocking! sock)
   (fcntl sock F_SETFL
@@ -172,3 +177,45 @@ the services and each tails is a list of a procedure 
accepting ports
           (for-each wait (hash-map->list (lambda (x y) x) h))
           (apply values return-values))
         args))
+
+(define (trivial-service-config what where)
+  "Make a configuration where the socket location of the @var{what} service
+is @var{where}."
+  (define config (hash->configuration
+                 (rnrs:make-hashtable hash-key key=?)))
+  (set-value! identity config what "UNIXPATH" where)
+  config)
+
+(define (call-with-absent-service what proc)
+  "Call @var{proc} with a configuration in which the @var{what} service
+cannot be connected to."
+  (call-with-temporary-directory
+   (lambda (somewhere)
+     ;; Something like "/dev/this-file-does-not-exist" would do as well.
+     (define where (in-vicinity somewhere "sock.et"))
+     (define config (trivial-service-config what where))
+     (proc config))))
+
+(define (#{don't-call-me}# . rest)
+  (error "oops ~a" rest))
+
+(define* (close-not-connected-no-fallbacks service connect disconnect!
+                                          #:key (rest '()))
+  "Try to connect to the @var{service} service in an environment where
+the service daemon is down.  Verify that the 'connected' and 'disconnected'
+callbacks were not called.  Also verify that all spawned fibers exit."
+  (call-with-spawner/wait
+   (lambda (spawn)
+     (call-with-absent-service
+      service
+      (lambda (config)
+       (define server (apply connect config #:spawn spawn
+                             #:connected #{don't-call-me}#
+                             #:disconnected #{don't-call-me}#
+                             rest))
+       ;; Sleep to give the client fibers a chance to mistakenly
+       ;; call a callback.
+       (sleep 0.001)
+       (disconnect! server)
+       (sleep 0.001)
+       #t)))))

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