[gnunet-scheme] 04/05: tests/cadet: Test the use of the 'allow-send' counter a bit.

[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 512a10317fc2330b8d2e15501890726ae271532b
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Mon Aug 22 22:09:58 2022 +0200

    tests/cadet: Test the use of the 'allow-send' counter a bit.
    
    * tests/cadet.scm
    (no-operation,message,address0): New variables.
    ("data is not sent before an acknowledgement"): New test.
    * gnu/gnunet/cadet/client.scm
    (reconnect)[control*]{send-channel-stuff!}<stop-if-exhausted>: Add
    reference to new test.
---
 gnu/gnunet/cadet/client.scm |  3 ++
 tests/cadet.scm             | 70 +++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 73 insertions(+)

diff --git a/gnu/gnunet/cadet/client.scm b/gnu/gnunet/cadet/client.scm
index 1718a77..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!)
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")

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