[gnunet-scheme] branch master updated (b643d2a -> fba3c95)

[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 b643d2a  tests/cadet: Test read-writability.
     new e784890  cadet/client: Allow opening channels.
     new fba3c95  examples/web: Stub a form for connecting via CADET.

The 2 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:
 examples/web.scm            | 29 +++++++++++++++--
 gnu/gnunet/cadet/client.scm | 77 +++++++++++++++++++++++++++++++++++++--------
 2 files changed, 90 insertions(+), 16 deletions(-)

diff --git a/examples/web.scm b/examples/web.scm
index c73094b..d598118 100644
--- a/examples/web.scm
+++ b/examples/web.scm
@@ -96,6 +96,20 @@ for success is used."
            (input (@ (type "text") (id "put-data") (name "data")))))
     (input (@ (type "submit") (value "Put it into the DHT")))))
 
+(define cadet-start-chat-form
+  `(form
+    (@ (action "/start-cadet-chat") (method "post"))
+    (ul (li (label (@ (for "cadet-start-peer"))
+                  "Identity of remote peer to connect to")
+           (input (@ (type "text") (id "cadet-start-peer") (name "peer"))))
+       (li (label (@ (for "cadet-port-name"))
+                  "Name of the port to connect to (as a string)")
+           (input (@ (type "text") (id "cadet-port-name") (name "port")))))
+    (input (@ (type "submit") (value "Connect!")))))
+
+(define (cadet-chat-forms)
+  `(p "TODO!"))
+
 (define (estimate->html estimate)
   `(dl (dt "Timestamp")
        (dd ,(number->string (nse:estimate:timestamp estimate)))
@@ -206,11 +220,12 @@ merely a race?")))
   (slice-copy! slice s)
   s)
 
-(define (url-handler dht-server server request body)
+(define (url-handler dht-server nse-server cadet-server request body)
   (match (uri-path (request-uri request))
     ("/" (respond/html
          `(div (p "A few links")
                (ul (li (a (@ (href "/network-size")) "network size"))
+                   (li (a (@ (href "/cadet-chat")) "basic chatting via CADET"))
                    (li (a (@ (href "/search-dht")) "search the DHT")
                        (li (a (@ (href "/put-dht")) "add things to the 
DHT")))))))
     ("/reload" ; TODO form with PUT request?
@@ -218,10 +233,17 @@ merely a race?")))
      (respond/html "reloaded!"))
     ("/network-size"
      (respond/html
-      (let ((current-estimate (nse:estimate server)))
+      (let ((current-estimate (nse:estimate nse-server)))
        (if current-estimate
            (estimate->html current-estimate)
            '(p "No etimate yet")))))
+    ("/cadet-chat"
+     (respond/html `(div (p "You can only connect to a chat here, not start 
new ones")
+                        (p "Run gnunet-cadet --open-port=PORT to run a new 
chat!")
+                        (p "Connect to a chat!")
+                        ,cadet-start-chat-form
+                        (p "participate in a chat!")
+                        ,@(cadet-chat-forms))))
     ("/search-dht" ; TODO check method and Content-Type, validation ...
      (if (pk 'b body)
         (process-search-dht dht-server (urlencoded->alist body))
@@ -237,10 +259,11 @@ merely a race?")))
 (define (start config)
   (define nse-server (nse:connect config))
   (define dht-server (dht:connect config))
+  (define cadet-server (dht:connect config))
   (define impl (lookup-server-impl 'fiberized))
   (define server (open-server impl `(#:port 8089)))
   (define (url-handler* request body)
-    (url-handler dht-server nse-server request body))
+    (url-handler dht-server nse-server cadet-server request body))
   (let loop ()
     (let-values (((client request body)
                  (read-client impl server)))
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.