[gnunet-scheme] 02/02: dht/client: Support disconnecting and reconnecting.

[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 0b7dcf4ba638830e71ce893732982ee8dc036065
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Wed Feb 2 21:51:22 2022 +0000

    dht/client: Support disconnecting and reconnecting.
    
    Reconnecting is currently untested.
    
    * doc/scheme-gnunet.tm (Accessing the DHT): Document 'connect' and
      'disconnect!'.
    * gnu/gnunet/dht/client.scm (<server>): Replace 'request-close?/box'
      and 'request-close-condition' by 'terminal-condition'.
      (maybe-send-control-message!*): New procedure, extracted from ...
      (maybe-send-control-message): ... here.
      (disconnect!): Tweak documentation.  Send a control message.
      (connect): Add 'disconnected' argument.  Pass it to 'reconnect'.
      Adjust call to '%make-server' for new fields.  Tweak documentation.
      (reconnect): Add 'disconnected' argument.
      
(reconnect)[error-handler]<input:regular-end-of-file,input:premature-end-of-file>:
      Call 'disconnected'.  Send a control message instead of directly 
reconnecting.
      (reconnect)[control]<disconnect!,reconnect!>: New cases.
    * tests/distributed-hash-table.scm
      ("(DHT) close, not connected --> all fibers stop, no callbacks called"):
      New test case.
    * tests/network-size.scm (make-nse-config, "close, not connected -->
      all fibers stop, no callbacks called"): Extract some functionality to ...
    * tests/utils.scm (trivial-service-config, call-with-absent-service)
      (close-not-connected-no-fallbacks): ... here.
---
 doc/scheme-gnunet.tm             | 22 ++++++++++-
 gnu/gnunet/dht/client.scm        | 82 ++++++++++++++++++++++++++--------------
 tests/distributed-hash-table.scm |  4 ++
 tests/network-size.scm           | 31 +++------------
 tests/utils.scm                  | 51 ++++++++++++++++++++++++-
 5 files changed, 132 insertions(+), 58 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 fac95f9..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
@@ -782,15 +792,17 @@ 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)
-          (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 mq (connect/fibers config "dht" handlers error-handler
@@ -799,15 +811,29 @@ even if not connected.  This is an idempotent operation."
       (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.