[gnunet-scheme] 02/42: nse/client: Extract the reconnection loop.

[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 acadf72b500ad6155b6283891cf4650263940a20
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Wed Sep 7 22:18:20 2022 +0200

    nse/client: Extract the reconnection loop.
    
    Let's unify NSE, CADET and DHT more.
    
    * gnu/gnunet/nse/client.scm (reconnect): Extract NSE-independents parts
    into ...
    * gnu/gnunet/server.scm (primitive-reconnect,make-reconnector): These
    two new procedures.
---
 gnu/gnunet/nse/client.scm | 166 +++++++++++++++++++++-------------------------
 gnu/gnunet/server.scm     |  63 ++++++++++++++++--
 2 files changed, 134 insertions(+), 95 deletions(-)

diff --git a/gnu/gnunet/nse/client.scm b/gnu/gnunet/nse/client.scm
index 9487497..34622ca 100644
--- a/gnu/gnunet/nse/client.scm
+++ b/gnu/gnunet/nse/client.scm
@@ -36,10 +36,8 @@
          disconnect!
          estimate)
   (import (only (rnrs base)
-               begin define quote lambda case values expt = else apply
+               begin define quote lambda values expt = apply
                and >= let or nan?)
-         (only (rnrs control)
-               when unless)
          (only (rnrs records syntactic)
                define-record-type)
           (only (ice-9 atomic)
@@ -48,20 +46,12 @@
                match)
           (only (fibers)
                spawn-fiber)
-         (only (fibers conditions)
-               make-condition wait wait-operation signal-condition!)
-         (only (fibers operations)
-               choice-operation perform-operation wrap-operation)
-         (only (fibers channels)
-               get-operation)
          (only (gnu extractor enum)
                symbol-value value->index)
          (only (guile)
-               define* const)
+               define*)
          (only (gnu gnunet concurrency lost-and-found)
-               make-lost-and-found <losable>
-               losable-lost-and-found
-               collect-lost-and-found-operation)
+               losable-lost-and-found)
          (only (gnu gnunet util struct)
                /:message-header)
          (only (gnu gnunet utils bv-slice)
@@ -72,18 +62,15 @@
                message-handler
                message-handlers)
           (only (gnu gnunet mq)
-               send-message! close-queue!)
-          (only (gnu gnunet mq-impl stream)
-               connect/fibers)
-         (only (gnu gnunet mq error-reporting)
-               report-error)
+               send-message!)
           (gnu gnunet message protocols)
          (only (gnu gnunet server)
                <server> make-disconnect!
                server-terminal-condition
                server-control-channel
                make-error-handler
-               handle-control-message!)
+               handle-control-message!
+               make-reconnector)
           (only (gnu gnunet nse struct)
                /:msg:nse:estimate))
   (begin
@@ -136,73 +123,72 @@ timestamp."
       (make-disconnect! 'network-size server:nse?))
 
     ;; See 'connect'.  TODO: gc test fails
-    (define* (reconnect terminal-condition config
-                       control-channel lost-and-found
-                       estimate/box
-                       #:key
-                       updated connected disconnected spawn #:rest rest)
-      (define (handle-estimate! estimate-slice)
-       (define estimate
-         (%make-estimate
-          (read% /:msg:nse:estimate '(size-estimate) estimate-slice)
-          (read% /:msg:nse:estimate '(std-deviation) estimate-slice)
-          (read% /:msg:nse:estimate '(timestamp) estimate-slice)))
-       (atomic-box-set! estimate/box estimate)
-       (updated estimate))
-      (define handlers
-       (message-handlers
-        (message-handler
-         (type (symbol-value message-type msg:nse:estimate))
-         ((interpose code) code)
-         ((well-formed? slice)
-          (and (= (slice-length slice)
-                  (sizeof /:msg:nse:estimate '()))
-               ;; XXX: there is no test verifying these two expressions
-               ;; are present
-               (>= (read% /:msg:nse:estimate '(size-estimate) slice) 0)
-               ;; See <https://bugs.gnunet.org/view.php?id=7021#c18399> for
-               ;; situations in which the deviation can be infinite or NaN.
-               (let ((stddev
-                      (read% /:msg:nse:estimate '(std-deviation) slice)))
-                 (or (>= stddev 0)
-                     (nan? stddev)))))
-         ((handle! slice) (handle-estimate! slice)))))
-      (define (send-start!)
-       ;; The service only starts sending estimates once
-       ;; /:msg:nse:start is sent.
-       (define s (make-slice/read-write (sizeof /:message-header '())))
-       (set%! /:message-header '(size) s (sizeof /:message-header '()))
-       (set%! /:message-header '(type) s
-              (value->index (symbol-value message-type msg:nse:start)))
-       (send-message! mq s))
-      (define error-handler
-       (make-error-handler connected disconnected terminal-condition
-                           control-channel))
-      (define mq (connect/fibers config "nse" handlers error-handler
-                                #:spawn spawn))
+    (define* (handle-estimate! estimate-slice estimate/box updated)
+      (define estimate
+       (%make-estimate
+        (read% /:msg:nse:estimate '(size-estimate) estimate-slice)
+        (read% /:msg:nse:estimate '(std-deviation) estimate-slice)
+        (read% /:msg:nse:estimate '(timestamp) estimate-slice)))
+      (atomic-box-set! estimate/box estimate)
+      (updated estimate))
+
+    (define* (make-message-handlers #:key estimate/box updated
+                                   #:allow-other-keys)
+      (message-handlers
+       (message-handler
+       (type (symbol-value message-type msg:nse:estimate))
+       ((interpose code) code)
+       ((well-formed? slice)
+        (and (= (slice-length slice)
+                (sizeof /:msg:nse:estimate '()))
+             ;; XXX: there is no test verifying these two expressions
+             ;; are present
+             (>= (read% /:msg:nse:estimate '(size-estimate) slice) 0)
+             ;; See <https://bugs.gnunet.org/view.php?id=7021#c18399> for
+             ;; situations in which the deviation can be infinite or NaN.
+             (let ((stddev
+                    (read% /:msg:nse:estimate '(std-deviation) slice)))
+               (or (>= stddev 0)
+                   (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 (send-start! message-queue)
+      ;; The service only starts sending estimates once
+      ;; /:msg:nse:start is sent.
+      (define s (make-slice/read-write (sizeof /:message-header '())))
+      (set%! /:message-header '(size) s (sizeof /:message-header '()))
+      (set%! /:message-header '(type) s
+            (value->index (symbol-value message-type msg:nse:start)))
+      (send-message! message-queue s))
+
+    (define* (control-message-handler message control control*
+                                     #:key message-queue terminal-condition
+                                     #:allow-other-keys #:rest state)
       (define (k/reconnect!)
-       (apply reconnect terminal-condition config control-channel 
lost-and-found estimate/box rest))
-      (define loop-operation
-       (choice-operation
-        (get-operation control-channel)
-        (wrap-operation (collect-lost-and-found-operation lost-and-found)
-                        (lambda (ourself) 'lost)))) ; it will only be 
performed once, so no need to recompute it
-      (define (control)
-       "The main event loop."
-       (control* (perform-operation loop-operation)))
-      (define (control* message)
-       (match message
-         (('resend-old-operations!)
-          (send-start!)
-          (control)) ; continue
-         ('lost
-          ;; We lost ourselves, that means the server became unreachable.
-          ;; The presence of this line is tested by the "garbage collectable"
-          ;; test.
-          (control* '(disconnect!)))
-         (rest (handle-control-message! message mq terminal-condition 
k/reconnect!))))
-      ;; Start main the event loop.
-      (control))
+       (apply reconnect state))
+      (match message
+        (('resend-old-operations!)
+        (send-start! message-queue)
+        (apply control state)) ; 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))
+       (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"))
 
     (define* (connect config #:key (updated values) (connected values)
                      (disconnected values) (spawn spawn-fiber))
@@ -218,10 +204,12 @@ shortly after calling @var{disconnected}.
 
 The procedures @var{updated}, @var{connected} and @var{disconnected} are 
optional."
       (define server (%make-server))
-      (spawn-procedure spawn (server-terminal-condition server) config
-                      (server-control-channel server)
-                      (losable-lost-and-found server)
-                      (server-estimate/box 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)
+                      #:estimate/box (server-estimate/box server)
                       #:updated updated
                       #:connected connected
                       #:disconnected disconnected
diff --git a/gnu/gnunet/server.scm b/gnu/gnunet/server.scm
index e1dd031..ab9f6c6 100644
--- a/gnu/gnunet/server.scm
+++ b/gnu/gnunet/server.scm
@@ -24,16 +24,20 @@
          make-error-handler
          <server> server-terminal-condition server-control-channel
          make-disconnect!
-         handle-control-message!)
+         handle-control-message!
+         make-reconnector)
   (import (only (rnrs base)
-               begin define case else apply values quote lambda
-               if error list let and)
+               begin define cons case else apply values quote lambda
+               if error list let and append)
          (only (rnrs records syntactic)
                define-record-type)
+         (only (fibers)
+               spawn-fiber)
          (only (fibers conditions)
                make-condition wait-operation signal-condition!)
          (only (fibers channels)
-               make-channel put-operation put-message get-message)
+               make-channel put-operation get-operation put-message
+               get-message)
          (only (fibers operations)
                choice-operation perform-operation wrap-operation)
          (only (gnu gnunet concurrency lost-and-found)
@@ -43,8 +47,12 @@
                close-queue!)
          (only (gnu gnunet mq error-reporting)
                report-error)
+          (only (gnu gnunet mq-impl stream)
+               connect/fibers)
          (only (ice-9 match)
-               match))
+               match)
+         (only (guile)
+               lambda* define*))
   (begin
     ;; Define them here to avoid creating these objects multiple times.
     (define thunk-false (lambda () #false))
@@ -184,4 +192,47 @@ TODO: maybe 'lost'"
         (values))
        (('reconnect!)
         ;; Restart the loop with a new message queue.
-        (k/reconnect!))))))
+        (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))
+      (define message-queue
+       (connect/fibers config service-name handlers error-handler
+                       #:spawn spawn))
+      (define loop-operation
+       (choice-operation
+        (get-operation control-channel)
+        (wrap-operation
+         ;; TODO: wasn't it required to recreate this operation each
+         ;; time something was found?
+         (collect-lost-and-found-operation lost-and-found)
+         (lambda (lost) (cons 'lost lost)))))
+      (define* (control* message #:key control-message-handler
+                        #:allow-other-keys #:rest state)
+       ;; 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)
+       "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)))

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