[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[gnunet-scheme] 02/42: nse/client: Extract the reconnection loop.
From: |
gnunet |
Subject: |
[gnunet-scheme] 02/42: nse/client: Extract the reconnection loop. |
Date: |
Sat, 10 Sep 2022 19:07:55 +0200 |
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.
- [gnunet-scheme] branch master updated (f5dc44e -> 58b0a65), gnunet, 2022/09/10
- [gnunet-scheme] 02/42: nse/client: Extract the reconnection loop.,
gnunet <=
- [gnunet-scheme] 06/42: server: Bring the reconnect loop state into a single structure., gnunet, 2022/09/10
- [gnunet-scheme] 09/42: server: Make #:message-queue a regular argument., gnunet, 2022/09/10
- [gnunet-scheme] 01/42: dht/server: Pass 'spawn' to connect/fibers., gnunet, 2022/09/10
- [gnunet-scheme] 10/42: server: Only accept a single 'state' argument., gnunet, 2022/09/10
- [gnunet-scheme] 08/42: nse/client: Simplify state passing with a new subtype of <loop>., gnunet, 2022/09/10
- [gnunet-scheme] 03/42: dht/client: Extract message handlers., gnunet, 2022/09/10
- [gnunet-scheme] 04/42: dht/client: Eliminate mutation from the control loop., gnunet, 2022/09/10
- [gnunet-scheme] 07/42: server: Rename 'primitive-reconnect' to 'run-loop'., gnunet, 2022/09/10
- [gnunet-scheme] 14/42: server: Deduplicate make-error-handler*., gnunet, 2022/09/10
- [gnunet-scheme] 19/42: cadet/client: Minimise imports., gnunet, 2022/09/10