[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[gnunet-scheme] 04/04: nse/client: Rewrite in terms of (gnu gnunet serve
From: |
gnunet |
Subject: |
[gnunet-scheme] 04/04: nse/client: Rewrite in terms of (gnu gnunet server). |
Date: |
Wed, 27 Jul 2022 16:29:01 +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 5872cbb8fc55be7dad10dc110afced832a8fc628
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Wed Jul 27 16:28:26 2022 +0200
nse/client: Rewrite in terms of (gnu gnunet server).
---
gnu/gnunet/nse/client.scm | 150 +++++++++++++++++++++-------------------------
1 file changed, 69 insertions(+), 81 deletions(-)
diff --git a/gnu/gnunet/nse/client.scm b/gnu/gnunet/nse/client.scm
index e4986f1..e118359 100644
--- a/gnu/gnunet/nse/client.scm
+++ b/gnu/gnunet/nse/client.scm
@@ -30,7 +30,7 @@
estimate:number-peers
estimate:standard-deviation
estimate:timestamp
- server?
+ (rename (server:nse? server?))
connect
disconnect!
estimate)
@@ -43,12 +43,16 @@
define-record-type)
(only (ice-9 atomic)
make-atomic-box atomic-box-ref atomic-box-set!)
+ (only (ice-9 match)
+ match)
(only (fibers)
spawn-fiber)
(only (fibers conditions)
make-condition wait wait-operation signal-condition!)
(only (fibers operations)
- choice-operation perform-operation)
+ choice-operation perform-operation wrap-operation)
+ (only (fibers channels)
+ get-operation)
(only (gnu extractor enum)
symbol-value value->index)
(only (guile)
@@ -73,6 +77,11 @@
(only (gnu gnunet mq error-reporting)
report-error)
(gnu gnunet message protocols)
+ (only (gnu gnunet server)
+ <server> make-disconnect!
+ server-terminal-condition
+ server-control-channel
+ make-error-handler)
(only (gnu gnunet nse struct)
/:msg:nse:estimate))
(begin
@@ -84,23 +93,14 @@
(sealed #t)
(opaque #t))
- (define-record-type (<server> %make-server server?)
- (parent <losable>) ; for automatic fibers disposal when the <server> is
unreachable
+ (define-record-type (<server:nse> %make-server server:nse?)
+ (parent <server>) ; for automatic fibers disposal when the <server> is
unreachable
;; Atomic box of <estimate>
- (fields (immutable estimate/box server-estimate/box)
- ;; Atomic box of boolean. Initially #f. Set this
- ;; to #t before signalling request-close-condition.
- (immutable request-close?/box
- server-request-close?/box)
- (immutable request-close-condition
- server-request-close-condition))
+ (fields (immutable estimate/box server-estimate/box))
(protocol
(lambda (%make)
(lambda ()
- ((%make (make-lost-and-found))
- (make-atomic-box #false)
- (make-atomic-box #false)
- (make-condition))))))
+ ((%make) (make-atomic-box #false))))))
(define (estimate server)
"Return the current estimate of the number of peers on the network,
@@ -130,15 +130,13 @@ and possibly infinite."
timestamp."
(%estimate:timestamp estimate))
- (define (disconnect! server)
- "Asynchronuously disconnect from the NSE server 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)))
+ (define disconnect!
+ (make-disconnect! 'network-size server:nse?))
- ;; See 'connect'.
- (define* (reconnect estimate/box request-close?/box
request-close-condition config
- lost-and-found
+ ;; 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)
@@ -175,57 +173,44 @@ even if not connected. This is an idempotent operation."
(set%! /:message-header '(type) s
(value->index (symbol-value message-type msg:nse:start)))
(send-message! mq s))
- (define mq-defined (make-condition))
- (define mq-closed (make-condition))
- (define (error-handler error . arguments)
- (case error
- ((connection:connected)
- ;; Make sure the message queue is actually bound to the variable
- ;; @var{mq} before calling @code{send-start!}, as @code{send-start!}
- ;; uses @var{mq}.
- (wait mq-defined)
- (send-start!)
- (connected))
- ((input:regular-end-of-file input:premature-end-of-file)
- ;; Call 'reconnect' after 'disconnected'. Otherwise,
- ;; it is possible that 'connected' is called twice without
- ;; a call to 'disconnected' in-between, which would presumably
- ;; be confusing.
- (signal-condition! mq-closed)
- (disconnected)
- ;; Don't reconnect after 'close-queue!'. About races: it's not
- ;; paramount we stop reconnecting immediately, but we should stop
- ;; eventually after 'request-close?/box' is set and
- ;; 'request-close-condition' is signalled, and
'request-close-handler'
- ;; will take care of closing the new queue if it shouldn't have been
- ;; created.
- (unless (atomic-box-ref request-close?/box)
- (apply reconnect estimate/box request-close?/box
request-close-condition
- config lost-and-found rest)))
- ((connection:interrupted)
- (values))
- (else
- ;; Weirdness. Not much that can be done except report it and
- ;; try to reconnect. XXX untested code path, sleep a little?
- (apply report-error error arguments)
- (close-queue! mq))))
- ;; Only started after 'mq' is defined, so no need to wait for
- ;; 'mq-defined'.
- (define (request-close-handler)
- (perform-operation
- (choice-operation
- ;; We lost ourselves, that means the server became unreachable.
- ;; The presence of this line is tested by the "garbage collectable"
- ;; test.
- (collect-lost-and-found-operation lost-and-found)
- (wait-operation request-close-condition)
- ;; Make sure the fiber exits after a reconnect.
- (wait-operation mq-closed)))
- (close-queue! mq))
+ (define error-handler
+ (make-error-handler connected disconnected terminal-condition
+ control-channel))
(define mq (connect/fibers config "nse" handlers error-handler
#:spawn spawn))
- (signal-condition! mq-defined)
- (spawn request-close-handler))
+ (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
+ ;; TODO: deduplicate these things copied from (gnu gnunet dht client)
+ (('oops key . arguments)
+ (signal-condition! terminal-condition)
+ (apply report-error key arguments)
+ (close-queue! mq)
+ (values))
+ (('disconnect!)
+ (signal-condition! terminal-condition)
+ (close-queue! mq)
+ (values))
+ (('reconnect!)
+ (apply reconnect terminal-condition config control-channel
lost-and-found estimate/box rest))
+ ;; (TODO: Start of our own code)
+ (('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!)))))
+ ;; Start main the event loop.
+ (control))
(define* (connect config #:key (updated values) (connected values)
(disconnected values) (spawn spawn-fiber))
@@ -241,12 +226,15 @@ shortly after calling @var{disconnected}.
The procedures @var{updated}, @var{connected} and @var{disconnected} are
optional."
(define server (%make-server))
- (define estimate/box (make-atomic-box #f))
- (reconnect (server-estimate/box server)
- (server-request-close?/box server)
- (server-request-close-condition server)
- config
- (losable-lost-and-found server)
- #:updated updated #:connected connected #:disconnected
disconnected
- #:spawn spawn)
- server)))
+ (spawn-procedure spawn (server-terminal-condition server) config
+ (server-control-channel server)
+ (losable-lost-and-found server)
+ (server-estimate/box server)
+ #:updated updated
+ #:connected connected
+ #:disconnected disconnected
+ #:spawn spawn)
+ server)
+
+ (define (spawn-procedure spawn . rest)
+ (spawn (lambda () (apply reconnect rest))))))
--
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.