[gnunet-scheme] branch master updated (d5c2c78 -> 5d04749)

[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 d5c2c78  examples/web: Implement the cadet-start-chat form.
     new f7d2467  cadet: Document open-channel!.
     new b674d12  tests/mq-stream: Yield the current fiber, not the 
kernel-level thread.
     new 99f8d53  mq/envelope: Allow testing if the envelope has been sent.
     new 512a103  tests/cadet: Test the use of the 'allow-send' counter a bit.
     new 5d04749  tests/utils: Allow changing fibers defaults in 
call-with-services/fibers.

The 5 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:
 doc/cadet.tm                | 24 ++++++++++++++++
 gnu/gnunet/cadet/client.scm |  6 ++++
 gnu/gnunet/mq/envelope.scm  |  7 ++++-
 tests/cadet.scm             | 70 +++++++++++++++++++++++++++++++++++++++++++++
 tests/mq-stream.scm         |  3 +-
 tests/utils.scm             |  5 ++--
 6 files changed, 111 insertions(+), 4 deletions(-)

diff --git a/doc/cadet.tm b/doc/cadet.tm
index 52bbad8..52e41fe 100644
--- a/doc/cadet.tm
+++ b/doc/cadet.tm
@@ -83,6 +83,30 @@
 
   <section|Connecting to an address>
 
+  <index|open-channel!>To connect to a CADET address, the <scm|open-channel!>
+  procedure is used:
+
+  <\explain>
+    <scm|(open-channel! <var|server> <var|address> <var|handlers>)>
+  <|explain>
+    Asynchronuously connect to the CADET address <var|address> via the CADET
+    server object <var|server>, returning a CADET channel object. When a
+    message is received, it is passed to the appropriate handler.
+
+    <todo|re-entrancy \U running open-channel! inside a #:connected
+    fallback?>
+
+    <todo|errors>
+
+    <todo|behaviour in case of blocking>
+  </explain>
+
+  To actually send and receive messages, the
+  <scm|channel-message-queue><index|channel-message-queue> can be used to
+  retrieve the <em|message queue> (see: <reference|message queue>) of the
+  channel and the procedure <scm|send-message!> can be used to send the
+  message to the message queue (see: <reference|send-message!>).
+
   <section|Performing I/O \U GNUnet style>
 
   <section|Performing I/O \U BSD style>
diff --git a/gnu/gnunet/cadet/client.scm b/gnu/gnunet/cadet/client.scm
index 868b461..f3dd477 100644
--- a/gnu/gnunet/cadet/client.scm
+++ b/gnu/gnunet/cadet/client.scm
@@ -238,6 +238,9 @@
          (let/ec
           stop
           (define (stop-if-exhausted)
+            ;; The mutation 'replace > by >=' is caught by
+            ;; "data is not sent before an acknowledgement"
+            ;; in form of a hang.
             (unless (> (channel-allow-send channel) 0)
               (stop)))
           (define (decrement!)
@@ -456,6 +459,9 @@ message @var{message}."
 
     ;; TODO: callbacks, message queue, actually test it
     (define* (open-channel! server address handlers)
+      "Asynchronuously connect to the cadet address @var{address} via the 
CADET server
+object @var{server}, returning a CADET channel object.  When a message is
+received, it is passed to the appropriate handler."
       (assert (and (server:cadet? server) (cadet-address? address)))
       (define error-handler stub)
       (define sender (make-channel-sender (delay channel)))
diff --git a/gnu/gnunet/mq/envelope.scm b/gnu/gnunet/mq/envelope.scm
index e3788af..14d8b66 100644
--- a/gnu/gnunet/mq/envelope.scm
+++ b/gnu/gnunet/mq/envelope.scm
@@ -1,5 +1,5 @@
 ;; This file is part of GNUnet.
-;; Copyright (C) 2012-2019, 2021 GNUnet e.V.
+;; Copyright © 2012-2019, 2021, 2022 GNUnet e.V.
 ;;
 ;; GNUnet is free software: you can redistribute it and/or modify it
 ;; under the terms of the GNU Affero General Public License as published
@@ -27,6 +27,7 @@
   (export <envelope> make-envelope envelope?
          attempt-cancel! attempt-irrevocable-sent!
          envelope-peek-cancelled?
+         envelope-peek-irrevocably-sent?
          ;; TODO find a better place
          (rename (bind-atomic-boxen %%bind-atomic-boxen)))
   (import (gnu gnunet utils hat-let)
@@ -73,6 +74,10 @@ When being marked as cancelled, the thunk @var{cancel!} is 
called."
       "Test whether @var{envelope} is currently cancelled (true / false)."
       (eq? #t (atomic-box-ref (%cancellation-state envelope))))
 
+    (define (envelope-peek-irrevocably-sent? envelope)
+      "Test whether @var{envelope} has been irrevocably sent (true / false)."
+      (eq? #false (atomic-box-ref (%cancellation-state envelope))))
+
     (define (%attempt-irrevocable-sent! envelope already-sent go cancelled)
       (bind-atomic-boxen
        ((state (%cancellation-state envelope) swap!))
diff --git a/tests/cadet.scm b/tests/cadet.scm
index 046f52b..492eab5 100644
--- a/tests/cadet.scm
+++ b/tests/cadet.scm
@@ -23,7 +23,19 @@
        (gnu gnunet netstruct syntactic)
        (gnu gnunet crypto struct)
        (gnu gnunet hashcode struct)
+       (gnu gnunet mq)
+       (only (gnu gnunet mq envelope)
+             envelope-peek-cancelled?
+             envelope-peek-irrevocably-sent?)
+       (gnu gnunet message protocols)
+       (gnu gnunet message protocols)
+       (gnu gnunet mq handler)
+       (gnu extractor enum)
+       (only (gnu gnunet mq-impl stream)
+             port->message-queue)
        (rnrs bytevectors)
+       (only (fibers scheduler)
+             yield-current-task)
        (ice-9 match)
        (srfi srfi-8)
        (srfi srfi-64)
@@ -166,4 +178,62 @@
 
 ;; header information will be tested elsewhere (TODO)
 
+
+
+;;;
+;;; Test client ↔ server communication
+;;;
+
+(define (no-operation . _)
+  (values))
+
+;; Some arbitrary (*) message and address.
+;; (*): TODO: size limits
+(define message (bv-slice/read-write #vu8(0 0 0 0)))
+(define address0 (make-cadet-address %peer-identity %port))
+
+(define (no-error-handler . _)
+  (pk 'a _)
+  (error "oops"))
+
+(test-equal
+ "data is not sent before an acknowledgement"
+ '(#false #false)
+ (call-with-services/fibers
+  `(("cadet" . ,(lambda (port spawn-fiber)
+                 (define message-queue
+                   (port->message-queue
+                    port
+                    (message-handlers
+                     (message-handler
+                      (type (symbol-value message-type 
msg:cadet:local:channel:create))
+                      ;; TODO: make these optional
+                      ((interpose exp) exp)
+                      ((well-formed? s) #true) ; not tested here.
+                      ((handle! s) (values)))) ; not tested here.
+                    no-error-handler #:spawn spawn-fiber))
+                 (values))))
+  (lambda (config spawn-fiber)
+    (define server (connect config #:spawn spawn-fiber))
+    (define channel
+      (open-channel! server address0 (message-handlers)))
+    (define message-queue
+      (channel-message-queue channel))
+    ;; Try to send something, the actual sending should be delayed indefinitely
+    ;; as the simulated server won't send an acknowledgement.  If it sent 
anyway,
+    ;; then the envelope is marked as irrevocably sent and the error handler is
+    ;; called because of a missing error handler for msg:cadet:local:data.
+    (define envelope (send-message! message-queue message))
+    ;; Give the other fibers a chance to mess up.
+    (let loop ((n 100))
+      (when (> n 0)
+       (yield-current-task)
+       (loop (- n 1))))
+    ;; Might as well test it hasn't been cancelled while we're at it.
+    (list (envelope-peek-cancelled? envelope)
+         (envelope-peek-irrevocably-sent? envelope)))
+  ;; These two options make yield-current-task more reliable
+  #:hz 0
+  #:parallelism 1))
+
 (test-end "CADET")
diff --git a/tests/mq-stream.scm b/tests/mq-stream.scm
index c15443e..50b257a 100644
--- a/tests/mq-stream.scm
+++ b/tests/mq-stream.scm
@@ -26,6 +26,7 @@
             (fibers conditions)
             (fibers operations)
             (fibers)
+            ((fibers scheduler) #:select (yield-current-task))
             ((rnrs arithmetic bitwise) #:select (bitwise-ior))
             (rnrs bytevectors)
             ((rnrs io ports) #:select (open-bytevector-input-port))
@@ -307,7 +308,7 @@
   ;; This allowed a bug in the use of 'connect' to be detected.
   (let loop ((n (* 8 (+ 1 (length (all-threads))))))
     (when (> n 0)
-      (yield)
+      (yield-current-task)
       (loop (- n 1)))))
 
 (test-assert "connect-unix, can connect when socket is already listening"
diff --git a/tests/utils.scm b/tests/utils.scm
index bdad806..ac43e6f 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -152,8 +152,9 @@ the services and each tails is a list of a procedure 
accepting ports
                        %thread-table)
         (apply values results))))))
 
-(define (call-with-services/fibers service-alist proc)
-  (fibers:run-fibers (lambda () (call-with-services service-alist proc))))
+(define (call-with-services/fibers service-alist proc . rest)
+  (apply fibers:run-fibers
+        (lambda () (call-with-services service-alist proc)) rest))
 
 (define* (call-with-spawner* proc service-alist . args)
   (apply fibers:run-fibers

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