[gnunet-scheme] 01/02: cadet/client: Allow opening channels.

[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 e78489010955713a707401e8303ceb707c4f47f6
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Mon Mar 7 20:21:37 2022 +0000

    cadet/client: Allow opening channels.
    
    Actually sending and receiving things over channels will be left for
    later commits.
    
    * gnu/gnunet/cadet/client.scm (<channel>): New record type.
      (connect)[control]: Rename to ...
      (connect)[control*]: ... this, and change signature.
      (connect)[control*]{open-channel!}: New case.
      (connect)[control*]{lost}: Stub <channel> handling.
      (send-local-channel-create!,open-channel!,close-channel!): New
      procedures.
---
 gnu/gnunet/cadet/client.scm | 77 +++++++++++++++++++++++++++++++++++++--------
 1 file changed, 64 insertions(+), 13 deletions(-)

diff --git a/gnu/gnunet/cadet/client.scm b/gnu/gnunet/cadet/client.scm
index d14fe66..5d8716a 100644
--- a/gnu/gnunet/cadet/client.scm
+++ b/gnu/gnunet/cadet/client.scm
@@ -50,7 +50,7 @@
          (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) close-queue! send-message!)
          (only (gnu gnunet server)
                maybe-send-control-message!* make-error-handler)
          (only (gnu gnunet hashcode struct)
@@ -68,7 +68,7 @@
                let^)
          (only (rnrs base)
                begin define lambda assert quote cons apply values
-               case else = define-syntax + expt -)
+               case else = define-syntax + expt - let* let and)
          (only (rnrs records syntactic) define-record-type)
          (only (ice-9 match) match)
          (only (guile) define*)
@@ -97,6 +97,22 @@
                    ((%make lost-and-found) lost-and-found (make-condition)
                     (make-channel))))))
 
+    (define-record-type (<channel> %make-channel channel?)
+      (parent <losable>)
+      (fields (immutable server channel-server) ; <server>
+             (immutable destination channel-address) ; <cadet-address>
+             (immutable options channel-options)
+             ;; Initially #false, when no channel number has been chosen yet
+             ;; by the client.  When the control loop accepts the <channel>,
+             ;; a channel number is assigned.  After a reconnect, channel
+             ;; numbers are reset.
+             (mutable channel-number channel-channel-number
+                      set-channel-channel-number!))
+      (protocol (lambda (%make)
+                 (lambda (server destination options)
+                   ((%make (server-lost-and-found server)) server
+                    destination options #false)))))
+
     (define* (connect config #:key (connected values) (disconnected values)
                      (spawn spawn-fiber))
       "Asynchronuously connect to the CADET service, using the configuration
@@ -129,10 +145,15 @@
                            control-channel))
       (define mq (connect/fibers config "cadet" handlers error-handler
                                 #:spawn spawn))
-      (define (control)
+      (define (control next-free-channel-number)
        "The main event loop."
-       (control* (perform-operation loop-operation)))
-      (define (control* message)
+       (control* next-free-channel-number
+                 (perform-operation loop-operation)))
+      (define (control* next-free-channel-number message)
+       (define (continue)
+         (control next-free-channel-number))
+       (define (continue* message)
+         (control* next-free-channel-number message))
        (match message
          (('disconnect!)
           ;; Ignore future requests instead of blocking.
@@ -141,14 +162,27 @@
           (close-queue! mq)
           ;; And the fibers of the <server> object are now done!
           (values))
+         (('open-channel! channel)
+          (let* ((channel-number next-free-channel-number)
+                 ;; TODO: handle overflow, and respect bounds
+                 (next-free-channel-number (+ 1 next-free-channel-number)))
+            (set-channel-channel-number! channel channel-number)
+            (send-local-channel-create! mq channel)
+            (control next-free-channel-number)))
+         (('close-channel! channel) TODO)
          (('lost . lost)
-          (match lost
-            (() (control))
-            ((object . rest)
-             (match object
-               ((? server? lost) (control* '(disconnect!)))))))))
+          (let loop ((lost lost))
+            (match lost
+              (() (continue))
+              ((object . rest)
+               (match object
+                 ((? channel? lost)
+                  TODO
+                  (loop rest))
+                 ((? server? lost)
+                  (continue* '(disconnect!))))))))))
       ;; Start the main event loop.
-      (control))
+      (control 0))
 
     (define-record-type (<cadet-address> make-cadet-address cadet-address?)
       (fields (immutable peer cadet-address-peer)
@@ -186,6 +220,11 @@ the CADET addresss @var{cadet-address}, using the channel 
number
       (set* '(options) options)
       s)
 
+    (define (send-local-channel-create! mq channel)
+      (send-message!
+       mq (construct-local-channel-create
+          (channel-address channel) (channel-channel-number channel))))
+
     (define (analyse-local-channel-create message)
       "Return the CADET address, channel number and options corresponding to
 the @code{/:msg:cadet:channel:create} message @var{message}."
@@ -280,8 +319,20 @@ message @var{message}."
     (define (stub . foo)
       (error "todo"))
     (define channel? stub)
-    (define open-channel! stub)
-    (define close-channel! stub)
+
+    ;; TODO: callbacks, message queue, actually test it
+    (define* (open-channel! server address)
+      (assert (and (server? server) (cadet-address? address)))
+      (define channel (%make-channel server address 0))
+      (maybe-send-control-message! server 'open-channel! channel)
+      channel)
+
+    ;; TODO: call when mq is closed, maybe unify closing the message queue
+    ;; and the channel?
+    (define (close-channel! channel)
+      (assert (channel? channel))
+      (maybe-send-control-message! (channel-server channel) 'close-channel!
+                                  channel))
     (define port? stub)
     (define open-port! stub)
     (define close-port! stub)))

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