[gnunet-scheme] 02/02: cadet/client: Unstub connection/disconnection code.

[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 0d3930c8f65a56697a288afed2e18e9c43820add
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Mon Feb 21 11:14:18 2022 +0000

    cadet/client: Unstub connection/disconnection code.
    
    * gnu/gnunet/cadet/client.scm
      (maybe-send-control-message!*,maybe-send-control-message,spawn-procedure)
      (reconnect): New proceedures.
      (<server>): New record type.
    * tests/cadet.scm: New test file.
    * Makefile.am (SCM_TESTS): Register new tests.
---
 Makefile.am                 |   1 +
 gnu/gnunet/cadet/client.scm | 111 ++++++++++++++++++++++++++++++++++++++++++--
 tests/cadet.scm             |  28 +++++++++++
 3 files changed, 137 insertions(+), 3 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index dc4b207..594698e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -193,6 +193,7 @@ SCM_TESTS = \
   tests/config-expand.scm \
   tests/config-db.scm \
   tests/config-fs.scm \
+  tests/cadet.scm \
   tests/crypto.scm \
   tests/distributed-hash-table.scm \
   tests/form.scm \
diff --git a/gnu/gnunet/cadet/client.scm b/gnu/gnunet/cadet/client.scm
index a930f55..94ac640 100644
--- a/gnu/gnunet/cadet/client.scm
+++ b/gnu/gnunet/cadet/client.scm
@@ -20,12 +20,117 @@
          make-cadet-address cadet-address? cadet-address-peer 
cadet-address-port
          channel? open-channel! close-channel!
          port? open-port! close-port!)
-  (import (only (rnrs base) begin define assert))
+  (import (only (gnu gnunet concurrency lost-and-found)
+               make-lost-and-found collect-lost-and-found-operation)
+         (only (gnu gnunet mq handler) message-handlers)
+         (only (gnu gnunet mq) close-queue!)
+         (only (gnu gnunet mq-impl stream) connect/fibers)
+         (only (rnrs base)
+               begin define lambda assert quote cons apply values
+               case else)
+         (only (rnrs records syntactic) define-record-type)
+         (only (ice-9 match) match)
+         (only (guile) define*)
+         (only (fibers) spawn-fiber)
+         (only (fibers channels) get-operation put-operation make-channel)
+         (only (fibers conditions) make-condition wait-operation
+               signal-condition!)
+         (only (fibers operations)
+               wrap-operation choice-operation perform-operation))
   (begin
+    ;; TODO: deduplicate these three procedures with (gnu gnunet dht client)
+    (define (maybe-send-control-message!* terminal-condition control-channel
+                                         . message)
+      (perform-operation
+       (choice-operation
+       (wait-operation terminal-condition)
+       (put-operation control-channel message))))
+    (define (maybe-send-control-message! server . message)
+      (apply maybe-send-control-message!* (server-terminal-condition server)
+            (server-control-channel server) message))
+    (define (disconnect! server)
+      (maybe-send-control-message! server 'disconnect!))
+
+    (define-record-type (<server> %make-server server?)
+      (parent <losable>)
+      (fields (immutable lost-and-found server-lost-and-found)
+             (immutable terminal-condition server-terminal-condition)
+             (immutable control-channel server-control-channel))
+      (protocol (lambda (%make)
+                 (lambda ()
+                   (define lost-and-found (make-lost-and-found))
+                   ((%make lost-and-found) lost-and-found (make-condition)
+                    (make-channel))))))
+
+    (define* (connect config #:key (connected values) (disconnected values)
+                     (spawn spawn-fiber))
+      "Asynchronuously connect to the CADET service, using the configuration
+@var{config}, returning a CADET server object."
+      (define server (%make-server))
+      (spawn-procedure spawn config
+                      (server-terminal-condition server)
+                      (server-control-channel server)
+                      connected disconnected spawn
+                      (server-lost-and-found server))
+      server)
+
+    ;; TODO: reduce duplication with (gnu gnunet dht client)
+    (define (spawn-procedure spawn . rest)
+      (spawn (lambda () (apply reconnect rest))))
+    (define (disconnect! server)
+      (maybe-send-control-message! server 'disconnect!))
+
+    (define (reconnect config terminal-condition control-channel
+                      connected disconnected spawn
+                      lost-and-found)
+      (define loop-operation
+       (choice-operation
+        (get-operation control-channel)
+        (wrap-operation (collect-lost-and-found-operation lost-and-found)
+                        (lambda (lost) (cons 'lost lost)))))
+      (define handlers (message-handlers)) ; TODO
+      ;; TODO: abstract duplication in (gnu gnunet dht client)
+      (define (error-handler key . arguments)
+       (case key
+         ((connection:connected)
+          (connected)
+          (maybe-send-control-message!* terminal-condition control-channel
+                                        'resend-old-operations!)
+          (values))
+         ((input:regular-end-of-file input:premature-end-of-file)
+          (disconnected)
+          (maybe-send-control-message!* terminal-condition control-channel 
'reconnect!))
+         ((connection:interrupted)
+          (values))
+         (else
+          (apply maybe-send-control-message!* terminal-condition
+                 control-channel 'oops! key arguments)
+          (values))))
+      (define mq (connect/fibers config "cadet" handlers error-handler
+                                #:spawn spawn))
+      (define (control)
+       "The main event loop."
+       (control* (perform-operation loop-operation)))
+      (define (control* message)
+       (match message
+         (('disconnect!)
+          ;; Ignore future requests instead of blocking.
+          (signal-condition! terminal-condition)
+          ;; Close networking ports.
+          (close-queue! mq)
+          ;; And the fibers of the <server> object are now done!
+          (values))
+         (('lost . lost)
+          (match lost
+            (() (control))
+            ((object . rest)
+             (match object
+               ((? server? lost) (control* '(disconnect!)))))))))
+      ;; Start the main event loop.
+      (control))
+
     (define (stub . foo)
       (error "todo"))
-    (define connect stub)
-    (define disconnect! stub)
     (define make-cadet-address stub)
     (define cadet-address? stub)
     (define cadet-address-peer stub)
diff --git a/tests/cadet.scm b/tests/cadet.scm
new file mode 100644
index 0000000..b509ccf
--- /dev/null
+++ b/tests/cadet.scm
@@ -0,0 +1,28 @@
+;; This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
+;; Copyright © 2022 GNUnet e.V.
+;;
+;; scheme-GNUnet is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Affero General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; scheme-GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL-3.0-or-later
+(define-module (test-distributed-hash-table))
+(import (gnu gnunet cadet client)
+       (srfi srfi-64)
+       (tests utils))
+
+(test-begin "CADET")
+(test-assert "(CADET) close, not connected --> all fibers stop, no callbacks 
called"
+  (close-not-connected-no-fallbacks "cadet" connect disconnect!))
+(test-assert "(CADET) garbage collectable"
+  (garbage-collectable "cadet" connect))
+(test-end "CADET")

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