[gnunet-scheme] branch master updated (dbb4430 -> 5872cbb)

[gnunet]

This is an automated email from the git hooks/post-receive script.

maxime-devos pushed a change to branch master
in repository gnunet-scheme.

    from dbb4430  dht/client: Move some code into (gnu gnunet server).
     new 447bda6  dht/client, server: Move maybe-send-control-message! to 
'server'.
     new 98e5740  dht/client: Extract disconnection to 'server'.
     new e4c9596  server: Copy useful comment from nse/client.
     new 5872cbb  nse/client: Rewrite in terms of (gnu gnunet server).

The 4 revisions listed above as "new" are entirely new to this
repository and will be described in separate emails.  The revisions
listed as "add" were already present in the repository and have only
been added to this reference.


Summary of changes:
 gnu/gnunet/dht/client.scm |  21 ++-----
 gnu/gnunet/nse/client.scm | 150 +++++++++++++++++++++-------------------------
 gnu/gnunet/server.scm     |  40 +++++++++++--
 3 files changed, 110 insertions(+), 101 deletions(-)

diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index 3db5863..0686ac3 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -79,8 +79,9 @@
          (gnu gnunet mq-impl stream)
          (gnu gnunet mq envelope)
          (only (gnu gnunet server)
-               maybe-send-control-message!* make-error-handler
-               <server> server-terminal-condition server-control-channel)
+               maybe-send-control-message! make-error-handler
+               <server> server-terminal-condition server-control-channel
+               make-disconnect!)
          (only (guile)
                pk define-syntax-rule define* lambda* error
                make-hash-table hashq-set! hashq-remove! hashv-set! hashv-ref
@@ -593,12 +594,6 @@ currently unsupported."
                     ;; Any ‘small’ natural number will do.
                     (make-atomic-box 0))))))
 
-    (define (maybe-send-control-message! server . message)
-      "Send @var{message} to the control channel of @var{server}, or don't
-do anything if @var{server} has been permanently disconnected."
-      (apply maybe-send-control-message!* (server-terminal-condition server)
-            (server-control-channel server) message))
-
     (define-record-type (<get> %make-get get?)
       (parent <losable>)
       (fields (immutable server get:server)
@@ -738,13 +733,9 @@ message header is assumed to be correct."
                  ...)
             (compare extra-size (* (+ field ...) (sizeof /dht:path-element 
'()))))))
 
-    ;; TODO reduce duplication with (gnu gnunet nse client) --- maybe introduce
-    ;; (gnu gnunet client) as in the C implementation?
-    (define (disconnect! server)
-      "Asynchronuously disconnect from the DHT service and stop reconnecting,
-even if not connected.  This is an idempotent operation.  This is an
-asynchronuous request; it won't be fulfilled immediately."
-      (maybe-send-control-message! server 'disconnect!))
+    (define disconnect!
+      (make-disconnect! 'distributed-hash-table ; for error messages
+                       server:dht?))
 
     (define* (connect config #:key (connected values) (disconnected values)
                      (spawn spawn-fiber))
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))))))
diff --git a/gnu/gnunet/server.scm b/gnu/gnunet/server.scm
index c9d6698..04de629 100644
--- a/gnu/gnunet/server.scm
+++ b/gnu/gnunet/server.scm
@@ -18,10 +18,13 @@
 
 ;; TODO: document
 (define-library (gnu gnunet server)
-  (export maybe-send-control-message!* make-error-handler
-         <server> server-terminal-condition server-control-channel)
+  (export maybe-send-control-message!* maybe-send-control-message!
+         make-error-handler
+         <server> server-terminal-condition server-control-channel
+         make-disconnect!)
   (import (only (rnrs base)
-               begin define case else apply values quote lambda)
+               begin define case else apply values quote lambda
+               if error list)
          (only (rnrs records syntactic)
                define-record-type)
          (only (fibers conditions)
@@ -47,6 +50,12 @@ This sends a @var{message} to @var{control-channel} or waits 
for
        (wait-operation terminal-condition)
        (put-operation control-channel message))))
 
+    (define (maybe-send-control-message! server . message)
+      "Send @var{message} to the control channel of @var{server}, or don't
+do anything if @var{server} has been permanently disconnected."
+      (apply maybe-send-control-message!* (server-terminal-condition server)
+            (server-control-channel server) message))
+
     (define (make-error-handler connected disconnected terminal-condition 
control-channel)
       (define (error-handler key . arguments)
        (case key
@@ -77,7 +86,7 @@ This sends a @var{message} to @var{control-channel} or waits 
for
       error-handler)
 
     (define-record-type (<server> %make-server server?)
-      (parent <losable>)
+      (parent <losable>) ; for automatic fibers disposal when the <server> is 
unreachable
       ;; terminal-condition: a disconnect has been requested.
       (fields (immutable terminal-condition server-terminal-condition)
              (immutable control-channel server-control-channel))
@@ -85,4 +94,25 @@ This sends a @var{message} to @var{control-channel} or waits 
for
                  (lambda ()
                    ((%make (make-lost-and-found))
                     (make-condition)
-                    (make-channel))))))))
+                    (make-channel))))))
+
+    (define (primitive-disconnect! server)
+      "Asynchronuously disconnect from the service and stop reconnecting,
+even if not connected.  This is an idempotent operation.  This is an
+asynchronuous request; it won't be fulfilled immediately.
+
+This maybe-sends @code{disconnect!} to the control channel."
+      (maybe-send-control-message! server 'disconnect!))
+
+    (define (make-disconnect! name type?)
+      ;; for backtrace purposes, 'lambda' is not used here.
+      (define (disconnect! server)
+       "Asynchronuously disconnect from the service and stop reconnecting,
+even if not connected.  This is an idempotent operation.  This is an
+asynchronuous request; it won't be fulfilled immediately."
+       (if (type? server)
+           (primitive-disconnect! server)
+           (error 'disconnect! ; TODO: test
+                  "wrong server object type"
+                  (list name type? server))))
+      disconnect!)))

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