[gnunet-scheme] 02/02: tests/cadet: Partially test the 'acknowledgement' mechanism.

[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 310f7152eab78621b7774c35c857efce5095838a
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Thu Aug 25 18:11:49 2022 +0200

    tests/cadet: Partially test the 'acknowledgement' mechanism.
    
    This detected a bug, see previous commit.
    
    * tests/cadet.scm
    (no-error-handler): Change invocation of 'error' to the RnRS 'error'
    instead of the Guile 'error'.
    (no-operation-message-handler/channel-create): Extract from ...
    ("data is not sent before an acknowledgement"): ... here.
    (no-operation-message-handler/local-data): New message handler.
    (acknowledgement): New variable.
    ("data is properly sent in response to acknowledgements, in-order"):
    New test.
---
 tests/cadet.scm | 129 ++++++++++++++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 121 insertions(+), 8 deletions(-)

diff --git a/tests/cadet.scm b/tests/cadet.scm
index 492eab5..5a59111 100644
--- a/tests/cadet.scm
+++ b/tests/cadet.scm
@@ -18,6 +18,8 @@
 (define-module (test-distributed-hash-table))
 (import (gnu gnunet cadet client)
        (gnu gnunet cadet network)
+       (only (gnu gnunet cadet struct)
+             %minimum-local-channel-id)
        (gnu gnunet utils bv-slice)
        (gnu gnunet utils hat-let)
        (gnu gnunet netstruct syntactic)
@@ -36,6 +38,7 @@
        (rnrs bytevectors)
        (only (fibers scheduler)
              yield-current-task)
+       (ice-9 atomic)
        (ice-9 match)
        (srfi srfi-8)
        (srfi srfi-64)
@@ -43,7 +46,12 @@
        (quickcheck)
        (quickcheck property)
        (quickcheck generator)
-       (quickcheck arbitrary))
+       (quickcheck arbitrary)
+       (rnrs base)
+       (only (fibers channels)
+             make-channel
+             get-message
+             put-message))
 
 (test-begin "CADET")
 (test-assert "(CADET) close, not connected --> all fibers stop, no callbacks 
called"
@@ -194,7 +202,23 @@
 
 (define (no-error-handler . _)
   (pk 'a _)
-  (error "oops"))
+  (error 'no-error-handler "oops"))
+
+(define no-operation-message-handler/channel-create
+  (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.
+
+(define no-operation-message-handler/local-data
+  (message-handler
+   (type (symbol-value message-type msg:cadet:local:data))
+   ;; TODO: make these optional
+   ((interpose exp) exp)
+   ((well-formed? s) #true) ; not tested here.
+   ((handle! s) (values)))) ; not tested here.
 
 (test-equal
  "data is not sent before an acknowledgement"
@@ -205,12 +229,7 @@
                    (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-operation-message-handler/channel-create)
                     no-error-handler #:spawn spawn-fiber))
                  (values))))
   (lambda (config spawn-fiber)
@@ -236,4 +255,98 @@
   #:hz 0
   #:parallelism 1))
 
+(define acknowledgement
+  ;; XXX: the implementation doesn't have to start at that number, it could
+  ;; start later, maybe avoid this implementation detail in the tests.
+  (construct-local-acknowledgement %minimum-local-channel-id))
+
+(test-assert
+ "data is properly sent in response to acknowledgements, in-order" ; TODO: is 
the in-order a requirement?
+ (quickcheck
+  ;; In each round, a number of messages are sent.
+  ;; At the same time (asynchronuously), some acknowledgements are sent.
+  ;;
+  ;; It is verified that, when there is a sufficient amount of 
acknowledgements,
+  ;; the messages are all sent to the service, that they aren't sent too early
+  ;; and that they are sent in-order.
+  ;;
+  ;; TODO: actually check the first once.
+  (property ((messages+acknowledgements
+             ($list ($arbitrary-lift vector
+                                     ;; Number of messages to send
+                                     $natural
+                                     ;; Number of acknowledgements to send
+                                     $natural))))
+    (let ((server-channel (make-channel)))
+      (call-with-services/fibers
+       `(("cadet" .
+         ,(lambda (port spawn-fiber)
+            (define message-queue
+              (port->message-queue port
+                                   (message-handlers
+                                    no-operation-message-handler/channel-create
+                                    no-operation-message-handler/local-data)
+                                   no-error-handler
+                                   #:spawn spawn-fiber))
+            (let loop ()
+              (match (get-message server-channel)
+                ((? integer? n)
+                 ;; Send a few acknowledgements.
+                 (let loop2 ((n n))
+                   (cond ((<= n 0)
+                          (loop))
+                         ((send-message! message-queue acknowledgement)
+                          (loop2 (- n 1))))))
+                ('stop (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))
+        (define n-added/non-atomic 0) ; how many messages have been added to 
the queue so far
+        (define n-added (make-atomic-box 0))
+        (define n-sent 0) ; how many of those messages have been irrevocably 
sent
+        (define total-acknowledgements
+          (make-atomic-box 0))
+        (define total-acknowledgements/non-atomic
+          0)
+        (define (make-notify-sent! i)
+          (lambda ()
+            ;; Verify that messages were sent in-order,
+            ;; by verifying that all the previous envelopes
+            ;; have been sent.
+            (assert (= n-sent i))
+            ;; TODO: this assumes messages aren't sent in parallel, maybe 
document that
+            ;; messages are sent sequentially.
+            (set! n-sent (+ n-sent 1))
+            ;; an additional check.
+            ;; Memory order: acquire.
+            (assert (<= n-sent (atomic-box-ref n-added)))
+            ;; Verify that the number of acknowledgements is respected.
+            ;; Memory order: acquire.
+            (assert (<= n-sent (atomic-box-ref total-acknowledgements)))
+                  (values)))
+        (let loop ((remaining messages+acknowledgements))
+          (match remaining
+            ((#(n-new-messages n-new-acknowledgements) . remaining)
+             (put-message server-channel n-new-acknowledgements)
+             (let loop2 ((k 0))
+               (cond ((< k n-new-messages)
+                      (set! total-acknowledgements/non-atomic
+                            (+ 1 total-acknowledgements/non-atomic))
+                      (set! n-added/non-atomic (+ 1 n-added/non-atomic))
+                      ;; Memory order: release
+                      (atomic-box-set! total-acknowledgements 
total-acknowledgements/non-atomic)
+                      ;; Memory order: release
+                      (atomic-box-set! n-added n-added/non-atomic)
+                      (send-message! message-queue message
+                                     #:notify-sent!
+                                     (make-notify-sent! (- n-added/non-atomic 
1)))
+                      (loop2 (+ k 1)))
+                     (#true (loop remaining)))))
+            (()
+             (put-message server-channel 'stop)
+             #true))))))))) ; done!
+
 (test-end "CADET")

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