[gnunet-scheme] 06/42: server: Bring the reconnect loop state into a single structure.

[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 a2b1ee82ff134cf0cf444ee06d6f5424b62664d5
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Thu Sep 8 20:58:18 2022 +0200

    server: Bring the reconnect loop state into a single structure.
    
    Makes the API less complicated ...
    Next step: include #:estimate/box + #:updated as well.
    
    * gnu/gnunet/nse/client.scm
    
(make-message-handlers,make-error-handler*,control-message-handler,connect,spawn-procedure):
    Adjust for new API.
    (reconnect): Delete.
    * gnu/gnunet/server.scm (<loop>): New record type.
    (<primitive-reconnect): Use new record type.
---
 gnu/gnunet/nse/client.scm | 64 ++++++++++++++++++++------------------
 gnu/gnunet/server.scm     | 78 ++++++++++++++++++++++++++++-------------------
 2 files changed, 82 insertions(+), 60 deletions(-)

diff --git a/gnu/gnunet/nse/client.scm b/gnu/gnunet/nse/client.scm
index 34622ca..07d5baa 100644
--- a/gnu/gnunet/nse/client.scm
+++ b/gnu/gnunet/nse/client.scm
@@ -70,7 +70,10 @@
                server-control-channel
                make-error-handler
                handle-control-message!
-               make-reconnector)
+               primitive-reconnect
+               make-loop
+               loop:connected loop:disconnected
+               loop:control-channel loop:terminal-condition)
           (only (gnu gnunet nse struct)
                /:msg:nse:estimate))
   (begin
@@ -132,7 +135,7 @@ timestamp."
       (atomic-box-set! estimate/box estimate)
       (updated estimate))
 
-    (define* (make-message-handlers #:key estimate/box updated
+    (define* (make-message-handlers _ #:key estimate/box updated
                                    #:allow-other-keys)
       (message-handlers
        (message-handler
@@ -152,11 +155,10 @@ timestamp."
                    (nan? stddev)))))
        ((handle! slice) (handle-estimate! slice estimate/box updated)))))
 
-    (define* (make-error-handler* #:key connected disconnected
-                                 terminal-condition control-channel
-                                 #:allow-other-keys)
-      (make-error-handler connected disconnected terminal-condition
-                         control-channel))
+    (define* (make-error-handler* state . rest)
+      (make-error-handler (loop:connected state) (loop:disconnected state)
+                         (loop:terminal-condition state)
+                         (loop:control-channel state)))
 
     (define (send-start! message-queue)
       ;; The service only starts sending estimates once
@@ -168,27 +170,26 @@ timestamp."
       (send-message! message-queue s))
 
     (define* (control-message-handler message control control*
-                                     #:key message-queue terminal-condition
-                                     #:allow-other-keys #:rest state)
+                                     loop
+                                     #:key message-queue
+                                     updated
+                                     estimate/box
+                                     #:allow-other-keys
+                                     #:rest rest)
       (define (k/reconnect!)
-       (apply reconnect state))
+       (primitive-reconnect loop #:updated updated #:estimate/box 
estimate/box))
       (match message
         (('resend-old-operations!)
         (send-start! message-queue)
-        (apply control state)) ; continue
+        (apply control loop rest)) ; continue
        (('lost . _)
         ;; We lost ourselves, that means the server became unreachable.
         ;; The presence of this line is tested by the "garbage collectable"
         ;; test.
-        (apply control* '(disconnect!) state))
+        (apply control* '(disconnect!) loop rest))
        (rest
-        (handle-control-message! message message-queue terminal-condition 
k/reconnect!))))
-
-    (define reconnect
-      (make-reconnector #:make-message-handlers make-message-handlers
-                       #:make-error-handler* make-error-handler*
-                       #:control-message-handler control-message-handler
-                       #:service-name "nse"))
+        (handle-control-message! message message-queue
+                                 (loop:terminal-condition loop) 
k/reconnect!))))
 
     (define* (connect config #:key (updated values) (connected values)
                      (disconnected values) (spawn spawn-fiber))
@@ -204,17 +205,22 @@ shortly after calling @var{disconnected}.
 
 The procedures @var{updated}, @var{connected} and @var{disconnected} are 
optional."
       (define server (%make-server))
-      (spawn-procedure spawn
-                      #:terminal-condition (server-terminal-condition server)
-                      #:config config
-                      #:control-channel (server-control-channel server)
-                      #:lost-and-found (losable-lost-and-found server)
+      (define loop
+       (make-loop #:make-message-handlers make-message-handlers
+                  #:make-error-handler* make-error-handler*
+                  #:control-message-handler control-message-handler
+                  #:service-name "nse"
+                  #:terminal-condition (server-terminal-condition server)
+                  #:configuration config
+                  #:control-channel (server-control-channel server)
+                  #:lost-and-found (losable-lost-and-found server)
+                  #:connected connected
+                  #:disconnected disconnected
+                  #:spawn spawn))
+      (spawn-procedure spawn loop
                       #:estimate/box (server-estimate/box server)
-                      #:updated updated
-                      #:connected connected
-                      #:disconnected disconnected
-                      #:spawn spawn)
+                      #:updated updated)
       server)
 
     (define (spawn-procedure spawn . rest)
-      (spawn (lambda () (apply reconnect rest))))))
+      (spawn (lambda () (apply primitive-reconnect rest))))))
diff --git a/gnu/gnunet/server.scm b/gnu/gnunet/server.scm
index ab9f6c6..44c034b 100644
--- a/gnu/gnunet/server.scm
+++ b/gnu/gnunet/server.scm
@@ -25,7 +25,10 @@
          <server> server-terminal-condition server-control-channel
          make-disconnect!
          handle-control-message!
-         make-reconnector)
+         <loop> make-loop
+         loop:connected loop:disconnected loop:terminal-condition
+         loop:control-channel
+         primitive-reconnect)
   (import (only (rnrs base)
                begin define cons case else apply values quote lambda
                if error list let and append)
@@ -162,6 +165,34 @@ asynchronuous request; it won't be fulfilled immediately."
                   (list name type? server))))
       disconnect!)
 
+    
+    ;; Originally, lots of keyword arguments were passed, but having a single
+    ;; structure with all the persistent state is more convenient.
+    (define-record-type (<loop> make-loop loop?)
+      (fields (immutable service-name loop:service-name)
+             (immutable control-message-handler loop:control-message-handler)
+             (immutable make-message-handlers loop:message-handlers-maker)
+             (immutable make-error-handler loop:error-handler*-maker)
+             (immutable configuration loop:configuration)
+             (immutable spawn loop:spawner) ; like spawn-fiber
+             ;; string (e.g. "dht", "cadet", ...)
+             (immutable terminal-condition loop:terminal-condition) ; condition
+             (immutable control-channel loop:control-channel) ; <channel>
+             (immutable lost-and-found loop:lost-and-found)
+             (immutable connected loop:connected)
+             (immutable disconnected loop:disconnected))
+      (protocol
+       (lambda (%make)
+        (lambda* (#:key service-name control-message-handler
+                  make-message-handlers make-error-handler* configuration
+                  (spawn spawn-fiber) terminal-condition control-channel
+                  lost-and-found connected disconnected
+                  #:allow-other-keys)
+         (%make service-name control-message-handler
+                make-message-handlers make-error-handler* configuration
+                spawn terminal-condition control-channel
+                lost-and-found connected disconnected)))))
+
     (define (handle-control-message! message mq terminal-condition 
k/reconnect!)
       "The following messages are handled:
 
@@ -195,44 +226,29 @@ TODO: maybe 'lost'"
         (k/reconnect!))))
 
     ;; TODO: document, check types
-    (define* (primitive-reconnect #:key
-                                 config
-                                 service-name ; string (e.g. "dht", "cadet", 
...)
-                                 control-channel
-                                 lost-and-found
-                                 (spawn spawn-fiber)
-                                 make-message-handlers
-                                 make-error-handler*
-                                 #:allow-other-keys #:rest rest)
-      (define handlers (apply make-message-handlers rest))
-      (define error-handler (apply make-error-handler* rest))
+    ;; state: <loop>
+    (define (primitive-reconnect state . rest)
+      (define handlers (apply (loop:message-handlers-maker state) state rest))
+      (define error-handler (apply (loop:error-handler*-maker state) state 
rest))
       (define message-queue
-       (connect/fibers config service-name handlers error-handler
-                       #:spawn spawn))
+       (connect/fibers (loop:configuration state) (loop:service-name state)
+                       handlers error-handler
+                       #:spawn (loop:spawner state)))
       (define loop-operation
        (choice-operation
-        (get-operation control-channel)
+        (get-operation (loop:control-channel state))
         (wrap-operation
          ;; TODO: wasn't it required to recreate this operation each
          ;; time something was found?
-         (collect-lost-and-found-operation lost-and-found)
+         (collect-lost-and-found-operation (loop:lost-and-found state))
          (lambda (lost) (cons 'lost lost)))))
-      (define* (control* message #:key control-message-handler
-                        #:allow-other-keys #:rest state)
+      (define (control* message state . rest)
        ;; Let @var{control-message-handler} handle the message.
        ;; It can decide to continue with @var{control} or @var{control*},
        ;; in continuation-passing style.
-       (apply control-message-handler message control control* state))
-      (define (control . state)
+       (apply (loop:control-message-handler state) message
+              control control* state rest))
+      (define (control state . rest)
        "The main event loop."
-       (apply control* (perform-operation loop-operation) state))
-      (apply control #:message-queue message-queue rest))
-
-
-    (define* (make-reconnector #:key
-                              make-message-handlers make-error-handler*
-                              control-message-handler service-name
-                              #:rest arguments0)
-      (define (reconnect . arguments)
-       (apply primitive-reconnect (append arguments0 arguments)))
-      reconnect)))
+       (apply control* (perform-operation loop-operation) state rest))
+      (apply control state #:message-queue message-queue rest))))

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