server: Unify loop spawning.

Reduces duplication and imports.

* gnu/gnunet/server.scm (spawn-server-loop): New procedure.
* gnu/gnunet/nse/client.scm (<loop>): Give a default value to 'default'.
(connect): Remove default value of 'updated', as it is unused.  Also
use spawn-server-loop.
* gnu/gnunet/dht/client.scm (connect): Likewise
* gnu/gnunet/cadet/client.scm (connect): Likewise

4 files changed, 45 insertions, 71 deletions

diff --git a/gnu/gnunet/cadet/client.scm b/gnu/gnunet/cadet/client.scm
index 7de91fb..7772cd5 100644
--- a/gnu/gnunet/cadet/client.scm
+++ b/gnu/gnunet/cadet/client.scm
@@ -69,7 +69,7 @@
                 server-terminal-condition
                 server-control-channel
                 handle-control-message!
-                make-loop run-loop server->loop-arguments loop:control-channel
+                make-loop run-loop spawn-server-loop loop:control-channel
                 loop:terminal-condition)
           (only (gnu gnunet hashcode struct)
                 /hashcode:512)
@@ -88,7 +88,7 @@
           (only (rnrs base)
                 begin define lambda assert quote cons apply values
                 case else = define-syntax + expt - let and >
-                not if <)
+                not if < append list)
           (only (rnrs control)
                 when)
           (only (pfds bbtrees)
@@ -148,23 +148,17 @@
 
     (define empty-bbtree (make-bbtree <))
 
-    (define* (connect config #:key (connected values) (disconnected values)
-                      (spawn spawn-fiber))
+    (define* (connect config #:key connected disconnected spawn #:rest r)
       "Asynchronuously connect to the CADET service, using the configuration
 @var{config}, returning a CADET server object."
-      (define server (%make-server))
-      (define loop
-        (apply make-loop
-               #:make-message-handlers make-message-handlers
-               #:control-message-handler control-message-handler
-               #:service-name "cadet"
-               #:configuration config
-               #:connected connected
-               #:disconnected disconnected
-               #:spawn spawn
-               (server->loop-arguments server)))
-      (spawn (lambda () (run-loop loop empty-bbtree %minimum-local-channel-id)))
-      server)
+      (apply spawn-server-loop (%make-server)
+             #:make-message-handlers make-message-handlers
+             #:control-message-handler control-message-handler
+             #:service-name "cadet"
+             #:configuration config
+             #:initial-extra-loop-arguments
+             (list empty-bbtree %minimum-local-channel-id)
+             r))
 
     ;; channel-number->channel-map:
     ;;   A 'bbtree' from channel numbers to their corresponding
diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index bd0feb4..d4c32eb 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -77,17 +77,14 @@
           (gnu gnunet hashcode struct)
           (gnu gnunet mq)
           (gnu gnunet mq handler)
-          (gnu gnunet mq-impl stream)
           (gnu gnunet mq envelope)
           (only (gnu gnunet server)
                 maybe-send-control-message! maybe-send-control-message!*
                 maybe-ask* answer
                 <server> server-terminal-condition server-control-channel
                 make-disconnect! handle-control-message!
-                make-loop loop:control-channel loop:connected
-                loop:disconnected loop:configuration loop:service-name
-                loop:spawner loop:terminal-condition loop:lost-and-found
-                loop:control-channel run-loop server->loop-arguments)
+                loop:terminal-condition loop:control-channel
+                run-loop spawn-server-loop)
           (only (guile)
                 pk define-syntax-rule define* lambda* error
                 ->bool and=>)
@@ -102,16 +99,7 @@
                 bbtree-delete make-bbtree bbtree-ref)
           (only (gnu extractor enum)
                 symbol-value)
-          (only (fibers)
-                spawn-fiber)
-          (only (fibers conditions)
-                make-condition signal-condition! wait-operation wait)
-          (only (fibers operations)
-                perform-operation choice-operation wrap-operation)
-          (only (fibers channels)
-                put-operation get-operation put-message)
           (only (gnu gnunet concurrency lost-and-found)
-                make-lost-and-found collect-lost-and-found-operation
                 losable-lost-and-found)
           (gnu gnunet dht struct)
           (only (gnu gnunet message protocols)
@@ -130,7 +118,7 @@
                 quote case else values apply let cond if > eq?
                 <= expt assert exact? integer? lambda for-each
                 not expt min max div-and-mod positive? define-syntax
-                vector cons)
+                vector cons append list)
           (only (rnrs control)
                 unless when)
           (only (rnrs records syntactic)
@@ -744,27 +732,19 @@ message header is assumed to be correct."
       (make-disconnect! 'distributed-hash-table ; for error messages
                         server:dht?))
 
-    (define* (connect config #:key (connected values) (disconnected values)
-                      (spawn spawn-fiber))
+    (define* (connect config #:key connected disconnected spawn #:rest r)
       "Connect to the DHT service, using the configuration @var{config}.  The
 connection is made asynchronuously; the optional thunk @var{connected} is called
 when the connection has been made.  The connection can break; the optional thunk
 @var{disconnected} is called when it does. If the connection breaks, the client
 code automatically tries to reconnect, so @var{connected} can be called after
 @var{disconnected}.  This procedure returns a DHT server object."
-      (define server (make-server))
-      (define loop
-        (apply make-loop
-               #:make-message-handlers make-message-handlers
-               #:control-message-handler control-message-handler
-               #:configuration config
-               #:service-name "dht"
-               #:spawn spawn
-               #:connected connected
-               #:disconnected disconnected #:spawn spawn
-               (server->loop-arguments server)))
-      (spawn (lambda () (run-loop loop empty-bbtree empty-bbtree)))
-      server)
+      (apply spawn-server-loop (make-server)
+             #:make-message-handlers make-message-handlers
+             #:control-message-handler control-message-handler
+             #:configuration config
+             #:service-name "dht"
+             #:initial-extra-loop-arguments (list empty-bbtree empty-bbtree) r))
 
     ;; TODO: put in new module?
     (define (make-weak-reference to)
diff --git a/gnu/gnunet/nse/client.scm b/gnu/gnunet/nse/client.scm
index 0cc4300..126dedc 100644
--- a/gnu/gnunet/nse/client.scm
+++ b/gnu/gnunet/nse/client.scm
@@ -66,12 +66,8 @@
           (gnu gnunet message protocols)
           (only (gnu gnunet server)
                 <server> make-disconnect!
-                server-terminal-condition
-                server-control-channel
                 handle-control-message!
-                <loop> run-loop server->loop-arguments
-                loop:connected loop:disconnected
-                loop:control-channel loop:terminal-condition)
+                <loop> spawn-server-loop run-loop loop:terminal-condition)
           (only (gnu gnunet nse struct)
                 /:msg:nse:estimate))
   (begin
@@ -129,7 +125,8 @@ timestamp."
               (immutable estimate/box loop:estimate/box))
       (protocol
        (lambda (%make)
-         (lambda* (#:key updated estimate/box #:allow-other-keys #:rest r)
+         (lambda* (#:key (updated values) estimate/box #:allow-other-keys
+                   #:rest r)
            ((apply %make r) updated estimate/box)))))
 
     ;; See 'connect'.  TODO: gc test fails
@@ -187,8 +184,8 @@ timestamp."
          (handle-control-message! message message-queue
                                   (loop:terminal-condition loop) k/reconnect!))))
 
-    (define* (connect config #:key (updated values) (connected values)
-                      (disconnected values) (spawn spawn-fiber))
+    (define* (connect config #:key updated connected disconnected spawn
+                      #:rest r)
       "Connect to the NSE service in the background.
 
 When connected, the thunk @var{connected} is called and estimates
@@ -201,17 +198,9 @@ shortly after calling @var{disconnected}.
 
 The procedures @var{updated}, @var{connected} and @var{disconnected} are optional."
       (define server (%make-server))
-      (define loop
-        (apply make-loop:nse
-               #:make-message-handlers make-message-handlers
-               #:control-message-handler control-message-handler
-               #:service-name "nse"
-               #:configuration config
-               #:connected connected
-               #:disconnected disconnected
-               #:spawn spawn
-               #:estimate/box (server-estimate/box server)
-               #:updated updated
-               (server->loop-arguments server)))
-      (spawn (lambda () (run-loop loop)))
-      server)))
+      (apply spawn-server-loop server #:make-loop make-loop:nse
+             #:make-message-handlers make-message-handlers
+             #:control-message-handler control-message-handler
+             #:service-name "nse"
+             #:configuration config
+             #:estimate/box (server-estimate/box server) r))))
diff --git a/gnu/gnunet/server.scm b/gnu/gnunet/server.scm
index 2dbace8..425735e 100644
--- a/gnu/gnunet/server.scm
+++ b/gnu/gnunet/server.scm
@@ -28,7 +28,7 @@
           <loop> make-loop server->loop-arguments
           loop:connected loop:disconnected loop:terminal-condition
           loop:control-channel loop:configuration loop:service-name
-          loop:spawner loop:lost-and-found run-loop)
+          loop:spawner loop:lost-and-found run-loop spawn-server-loop)
   (import (only (rnrs base)
                 begin define cons case else apply values quote lambda
                 if error list let and append)
@@ -263,4 +263,15 @@ TODO: maybe 'lost'"
       (define (control state . rest)
         "The main event loop."
         (apply control* (perform-operation loop-operation) state rest))
-      (apply control state rest))))
+      (apply control state rest))
+
+    (define* (spawn-server-loop server #:key (make-loop make-loop)
+                                (initial-extra-loop-arguments '())
+                                (spawn spawn-fiber) #:allow-other-keys
+                                #:rest arguments)
+      "[TODO] and return @var{server}"
+      (define loop-arguments (append arguments (server->loop-arguments server)))
+      (spawn (lambda ()
+               (apply run-loop (apply make-loop loop-arguments)
+                      initial-extra-loop-arguments)))
+      server)))