[gnunet-scheme] 03/04: tests/cadet: Verify the messages are actually ever sent.

[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 12c457f4471449262e2a459f850ecbfbb9e4a9cb
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Thu Aug 25 20:52:28 2022 +0200

    tests/cadet: Verify the messages are actually ever sent.
    
    The atomics will be simplified in the next commit.
    
    * tests/cadet.scm
    ("data is properly sent in response to acknowledgements, in-order"):
    Add 'synchronize' to some places in the list. In response to that,
    verify that as messages are sent as possible. Set #:hz and #:parallelism
    as required by the code. Add an indicator for a lack of hanging.
---
 tests/cadet.scm | 48 ++++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 42 insertions(+), 6 deletions(-)

diff --git a/tests/cadet.scm b/tests/cadet.scm
index 1878f14..1c60458 100644
--- a/tests/cadet.scm
+++ b/tests/cadet.scm
@@ -272,11 +272,21 @@
   ;;
   ;; 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))))
+             ($list
+              ($choose
+               ;; 'error': we aren't generating functions, so it will
+               ;; be unused.
+               (error ($arbitrary-lift vector
+                                       ;; Number of messages to send
+                                       $natural
+                                       ;; Number of acknowledgements to send
+                                       $natural))
+               ;; 'synchronize': Verify that the messages are going to the
+               ;; server.  This is not done after every round, because that
+               ;; would reduce the amount of concurrency and hence the scope
+               ;; of the test.
+               (error ($const 'synchronize))))))
+    (pk 'iter) ; indicate it's not hanging
     (let ((server-channel (make-channel)))
       (call-with-services/fibers
        `(("cadet" .
@@ -330,6 +340,26 @@
                   (values)))
         (let loop ((remaining messages+acknowledgements))
           (match remaining
+            (('synchronize . remaining)
+             ;; Check that all the messages that could be sent have been sent
+             ;; (no corking was requested, and the previous loop simulated
+             ;; passage of some time).
+             (let loop ((old-to-be-sent +inf.0))
+               (define new-to-be-sent
+                 (- (min total-acknowledgements/non-atomic n-added/non-atomic) 
n-sent))
+               (assert (<= 0 new-to-be-sent))
+               (assert (< new-to-be-sent old-to-be-sent)) ; bail out if no 
progress is made
+               (when (< 0 new-to-be-sent)
+                 ;; Give the various fibers a chance to process the messages. 
The allowed
+                 ;; amount of context switched is proportional to the number 
of messages
+                 ;; that still need to be sent. The number 16 is an 
over-approximation,
+                 ;; the exact value doesn't matter to this test.
+                 (let loop* ((n (* 16 (+ 1 new-to-be-sent))))
+                   (when (> n 0)
+                     (yield-current-task)
+                     (loop* (- n 1))))
+                 (loop new-to-be-sent)))
+             (loop remaining))
             ((#(n-new-messages n-new-acknowledgements) . remaining)
              (put-message server-channel n-new-acknowledgements)
              (set! total-acknowledgements/non-atomic
@@ -348,6 +378,12 @@
                      (#true (loop remaining)))))
             (()
              (put-message server-channel 'stop)
-             #true))))))))) ; done!
+             #true)))) ; done!
+       ;; yield-current-task in a loop only works when singly-threaded.
+       ;; The code manipulating the counters above plays a bit loose with 
concurrency
+       ;; concerns, hence both #:hz 0 and #:parallelism 1 is required to avoid
+       ;; potential false positives.
+       #:hz 0
+       #:parallelism 1)))))
 
 (test-end "CADET")

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