[gnunet-scheme] 04/04: nse/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 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.