[gnunet-scheme] 13/42: dht/client: Rewrite in terms of (gnu gnunet server).

[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 b409f0578e056383060a6a47d090cb3fd63e1218
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Thu Sep 8 22:26:39 2022 +0200

    dht/client: Rewrite in terms of (gnu gnunet server).
---
 gnu/gnunet/dht/client.scm | 272 ++++++++++++++++++++--------------------------
 1 file changed, 120 insertions(+), 152 deletions(-)

diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index ee2788b..e64c33f 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -87,7 +87,7 @@
                make-loop loop:control-channel loop:connected
                loop:disconnected loop:configuration loop:service-name
                loop:spawner loop:terminal-condition loop:lost-and-found
-               loop:control-channel)
+               loop:control-channel run-loop)
          (only (guile)
                pk define-syntax-rule define* lambda* error
                ->bool and=>)
@@ -744,6 +744,12 @@ message header is assumed to be correct."
       (make-disconnect! 'distributed-hash-table ; for error messages
                        server:dht?))
 
+    ;; TODO: duplicated from dht/nse
+    (define (make-error-handler* state _1 _2)
+      (make-error-handler (loop:connected state) (loop:disconnected state)
+                         (loop:terminal-condition state)
+                         (loop:control-channel state)))
+
     (define* (connect config #:key (connected values) (disconnected values)
                      (spawn spawn-fiber))
       "Connect to the DHT service, using the configuration @var{config}.  The
@@ -752,22 +758,22 @@ 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 old-id->operation-map empty-bbtree)
       (define server (make-server))
-      ;; We could do @code{(spawn (lambda () (reconnect ...)))} here instead,
-      ;; but that causes ‘(DHT) garbage collectable’ to fail.
-      (spawn-procedure spawn old-id->operation-map
-                      (make-loop
-                       #:terminal-condition (server-terminal-condition server)
-                       #:configuration config
-                       #:service-name "dht"
-                       #:control-channel (server-control-channel server)
-                       #:lost-and-found (losable-lost-and-found server)
-                       #:connected connected
-                       #:disconnected disconnected #:spawn spawn))
+      (define loop
+       (make-loop
+        #:make-message-handlers make-message-handlers
+        #:make-error-handler* make-error-handler*
+        #:control-message-handler control-message-handler
+        #:terminal-condition (server-terminal-condition server)
+        #:configuration config
+        #:service-name "dht"
+        #:control-channel (server-control-channel server)
+        #:lost-and-found (losable-lost-and-found server)
+        #:spawn spawn
+        #:connected connected
+        #:disconnected disconnected #:spawn spawn))
+      (spawn (lambda () (run-loop loop empty-bbtree empty-bbtree)))
       server)
-    (define (spawn-procedure spawn . rest)
-      (spawn (lambda () (apply reconnect rest))))
 
     ;; TODO: put in new module?
     (define (make-weak-reference to)
@@ -780,14 +786,14 @@ code automatically tries to reconnect, so @var{connected} 
can be called after
          (weak-vector-ref reference 0)
          reference))
 
-    (define* (make-message-handlers #:key terminal-condition control-channel
-                                   #:allow-other-keys)
+    (define* (make-message-handlers loop _1 _2)
       (define (request-search-result-iterator unique-id)
        "Ask @code{control} what is the iterator for the get operation with
 unique id @var{unique-id}.  If there is no such get operation, or the get
 operation is cancelled, return @code{#false} instead."
        ;; TODO: is the 'terminal-condition' case needed?
-       (maybe-ask* terminal-condition control-channel
+       (maybe-ask* (loop:terminal-condition loop)
+                   (loop:control-channel loop)
                    'request-search-result-iterator
                    unique-id))
       (message-handlers
@@ -844,140 +850,102 @@ operation is cancelled, return @code{#false} instead."
               ;; TODO: wrong type (maybe a put handle?).
               TODO-error-reporting/2)))))
 
-    (define empty-bbtree (make-bbtree <))
-
-    (define (reconnect old-id->operation-map loop)
-      ;; The 'id->operation-map' holds get operations that have
-      ;; been communicated to the service.  The 'old-id->operation-map'
-      ;; is used for reconnecting and holds get operations that need
-      ;; to be communicated to the service again.  'old-id->operation-map'
-      ;; only shrinks, while 'id->operation-map' can both grow and shrink.
-      ;;
-      ;; To avoid races, 'id->operation-map' and 'old-id->operation-map'
-      ;; are only accessed from 'control'.
-      ;;
-      ;; To allow cancelling operations when they become unreachable, 
operations
-      ;; are wrapped in a weak reference (unless linger? is #true).  Otherwise,
-      ;; they won't ever become unreachable.  Keep in mind that, at least in
-      ;; Guile 3.0.7, weak references are broken when the object is returned
-      ;; from the guardian (and probably earlier) -- this seems to be a
-      ;; difficult to fix bug.
-      ;;
-      ;; This code is written to support both the correct and incorrect 
behaviour
-      ;; of guardians+weak vectors.
-      (define handlers
-       (make-message-handlers
-        #:terminal-condition (loop:terminal-condition loop)
-        #:control-channel (loop:control-channel loop)))
-      (define error-handler
-       (make-error-handler (loop:connected loop) (loop:disconnected loop)
-                           (loop:terminal-condition loop)
-                           (loop:control-channel loop)))
-      (define mq (connect/fibers (loop:configuration loop)
-                                (loop:service-name loop) handlers error-handler
-                                #:spawn (loop:spawner loop)))
-      (define (process-stop-search old-id->operation-map id->operation-map get)
-       ;; TODO: tests!
-       ;; TODO: cancel outstanding messages to the DHT services for this
-       ;; get operation (including the request to start searching), if
-       ;; any.
-       (let^ ((! old-id->operation-map
-                 (bbtree-delete old-id->operation-map (get:unique-id get)))
-              (? (not (bbtree-contains? id->operation-map (get:unique-id get)))
-                 (values old-id->operation-map id->operation-map))
-              (! id->operation-map
-                 (bbtree-delete id->operation-map (get:unique-id get))))
-             (send-stop-get! mq get)
-             (values old-id->operation-map id->operation-map)))
-      (define (k/reconnect! old-id->operation-map id->operation-map)
+    (define (process-stop-search old-id->operation-map id->operation-map
+                                message-queue get)
+      ;; TODO: tests!
+      ;; TODO: cancel outstanding messages to the DHT services for this
+      ;; get operation (including the request to start searching), if
+      ;; any.
+      (let^ ((! old-id->operation-map
+               (bbtree-delete old-id->operation-map (get:unique-id get)))
+            (? (not (bbtree-contains? id->operation-map (get:unique-id get)))
+               (values old-id->operation-map id->operation-map))
+            (! id->operation-map
+               (bbtree-delete id->operation-map (get:unique-id get))))
+           (send-stop-get! message-queue get)
+           (values old-id->operation-map id->operation-map)))
+
+    (define (control-message-handler message control control* message-queue 
loop
+                                    old-id->operation-map id->operation-map)
+      (define (continue/no-change)
+       (control loop old-id->operation-map id->operation-map))
+      (define (k/reconnect!)
        ;; Self-check to make sure no information will be lost.
        (assert (= (bbtree-size old-id->operation-map) 0))
-       (reconnect id->operation-map loop))
-      (define loop-operation
-       (choice-operation
-        (get-operation (loop:control-channel loop))
-        (wrap-operation (collect-lost-and-found-operation
-                         (loop:lost-and-found loop))
-                        (lambda (lost) (cons 'lost lost)))))
-      (define (control old-id->operation-map id->operation-map)
-       "The main event loop."
-       (control* old-id->operation-map id->operation-map
-                 (perform-operation loop-operation)))
-      (define (control* old-id->operation-map id->operation-map message)
-       (define (continue/no-change)
-         (control old-id->operation-map id->operation-map))
-       (match message
-         (('start-get! get)
-          ;; Register the new get operation, such that we remember
-          ;; where to send responses to.
-          (let ((id->operation-map
-                 (bbtree-set id->operation-map
-                             (get:unique-id get)
-                             ((if (get:linger? get)
-                                  make-strong-reference
-                                  make-weak-reference) get))))
-            ;; (Asynchronuously) send the GET message.
-            (send-get! mq get)
+       (run-loop loop id->operation-map empty-bbtree))
+      (match message
+        (('start-get! get)
+        ;; Register the new get operation, such that we remember
+        ;; where to send responses to.
+        (let ((id->operation-map
+               (bbtree-set id->operation-map
+                           (get:unique-id get)
+                           ((if (get:linger? get)
+                                make-strong-reference
+                                make-weak-reference) get))))
+          ;; (Asynchronuously) send the GET message.
+          (send-get! message-queue get)
+          ;; Continue!
+          (control loop old-id->operation-map id->operation-map)))
+       (('stop-search! get)
+        (let^ ((<-- (old-id->operation-map id->operation-map)
+                    (process-stop-search
+                     old-id->operation-map id->operation-map
+                     message-queue get)))
+              (control loop old-id->operation-map id->operation-map)))
+       (('put! put)
+        ;; Send the put operation to the DHT service.
+        (send-message! message-queue (put:message put))
+        (continue/no-change))
+       ;; Send by @code{request-search-result-iterator}.
+       (('request-search-result-iterator answer-box unique-id)
+        (answer answer-box
+                (and=> (bbtree-ref id->operation-map unique-id)
+                       dereference))
+        (continue/no-change))
+       (('resend-old-operations!)
+        ;; Restart old operations.  Only get operations need to be submitted
+        ;; again.
+        ;;
+        ;; TODO: restarting monitoring operations
+        (let ((id->operation-map
+               (bbtree-fold
+                (lambda (id reference id->operation-map)
+                  (let^ ((! get (dereference reference))
+                         ;; If the (weak) reference is broken, that means
+                         ;; the operation is unreachable, so then there is
+                         ;; no point to resending the get operation.
+                         (? (not get)
+                            id->operation-map)
+                         (! id->operation-map
+                            (bbtree-set id->operation-map id reference)))
+                        (send-get! message-queue get)
+                        id->operation-map))
+                id->operation-map
+                old-id->operation-map))
+              ;; Free some memory.
+              (old-id->operation-map empty-bbtree))
+          (control loop old-id->operation-map id->operation-map)))
+       ;; Some handles became unreachable and can be cancelled.
+       (('lost . lost)
+        (let next ((lost lost) (old-id->operation-map old-id->operation-map)
+                   (id->operation-map id->operation-map))
+          (match lost
             ;; Continue!
-            (control old-id->operation-map id->operation-map)))
-         (('stop-search! get)
-          (let^ ((<-- (old-id->operation-map id->operation-map)
-                      (process-stop-search
-                       old-id->operation-map id->operation-map get)))
-            (control old-id->operation-map id->operation-map)))
-         (('put! put)
-          ;; Send the put operation to the DHT service.
-          (send-message! mq (put:message put))
-          (continue/no-change))
-         ;; Send by @code{request-search-result-iterator}.
-         (('request-search-result-iterator answer-box unique-id)
-          (answer answer-box
-                  (and=> (bbtree-ref id->operation-map unique-id)
-                         dereference))
-          (continue/no-change))
-         (('resend-old-operations!)
-          ;; Restart old operations.  Only get operations need to be submitted
-          ;; again.
-          ;;
-          ;; TODO: restarting monitoring operations
-          (let ((id->operation-map
-                 (bbtree-fold
-                  (lambda (id reference id->operation-map)
-                    (let^ ((! get (dereference reference))
-                           ;; If the (weak) reference is broken, that means
-                           ;; the operation is unreachable, so then there is
-                           ;; no point to resending the get operation.
-                           (? (not get)
-                              id->operation-map)
-                           (! id->operation-map
-                              (bbtree-set id->operation-map id reference)))
-                          (send-get! mq get)
-                          id->operation-map))
-                  id->operation-map
-                  old-id->operation-map))
-                ;; Free some memory.
-                (old-id->operation-map empty-bbtree))
-            (control old-id->operation-map id->operation-map)))
-         ;; Some handles became unreachable and can be cancelled.
-         (('lost . lost)
-          (let loop ((lost lost) (old-id->operation-map old-id->operation-map)
-                     (id->operation-map id->operation-map))
-            (match lost
-              ;; Continue!
-              (() (control old-id->operation-map id->operation-map))
-              ((object . rest)
-               (match object
-                 ((? get? get)
-                  (let^ ((<-- (old-id->operation-map id->operation-map)
-                              (process-stop-search old-id->operation-map
-                                                   id->operation-map
-                                                   get)))
-                        (loop rest old-id->operation-map id->operation-map)))
-                 ((? server:dht? server)
-                  (control* old-id->operation-map id->operation-map
-                            '(disconnect!))))))))
-         (rest (handle-control-message!
-                rest mq (loop:terminal-condition loop)
-                (cut k/reconnect! old-id->operation-map id->operation-map)))))
-      ;; Start the main event loop.
-      (control old-id->operation-map empty-bbtree))))
+            (() (control loop old-id->operation-map id->operation-map))
+            ((object . rest)
+             (match object
+               ((? get? get)
+                (let^ ((<-- (old-id->operation-map id->operation-map)
+                            (process-stop-search old-id->operation-map
+                                                 id->operation-map
+                                                 message-queue get)))
+                      (next rest old-id->operation-map id->operation-map)))
+               ((? server:dht? server)
+                (control* '(disconnect!) loop old-id->operation-map
+                          id->operation-map)))))))
+       (rest (handle-control-message!
+              rest message-queue (loop:terminal-condition loop)
+              k/reconnect!))))
+
+    (define empty-bbtree (make-bbtree <))))

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