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

[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 5d04749  tests/utils: Allow changing fibers defaults in 
call-with-services/fibers.
     new 28f0c33  cadet/client: Correct multiplicity of return values.
     new 310f715  tests/cadet: Partially test the 'acknowledgement' mechanism.

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:
 gnu/gnunet/cadet/client.scm |  15 ++++--
 tests/cadet.scm             | 129 +++++++++++++++++++++++++++++++++++++++++---
 2 files changed, 132 insertions(+), 12 deletions(-)

diff --git a/gnu/gnunet/cadet/client.scm b/gnu/gnunet/cadet/client.scm
index f3dd477..aa9d738 100644
--- a/gnu/gnunet/cadet/client.scm
+++ b/gnu/gnunet/cadet/client.scm
@@ -87,7 +87,7 @@
          (only (rnrs base)
                begin define lambda assert quote cons apply values
                case else = define-syntax + expt - let* let and >
-               not)
+               not if)
          (only (rnrs control)
                unless)
          (only (rnrs hashtables)
@@ -241,8 +241,13 @@
             ;; 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)))
+            (if (> (channel-allow-send channel) 0)
+                ;; (unless ...) and (when ...) can return *unspecified*,
+                ;; but (gnu gnunet mq) expects no return values. Detected
+                ;; by the "data is properly sent in response to 
acknowledgements, in-order"
+                ;; test.
+                (values)
+                (stop)))
           (define (decrement!)
             (set-channel-allow-send! channel
                                      (- (channel-allow-send channel) 1)))
@@ -486,7 +491,9 @@ received, it is passed to the appropriate handler."
        (maybe-send-control-message! server
                                     'send-channel-stuff!
                                     message-queue
-                                    (force channel-promise))))
+                                    (force channel-promise))
+       ;; the #true or #false return value does not appear relevant here
+       (values)))
 
     ;; TODO: call when mq is closed, maybe unify closing the message queue
     ;; and the channel?
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.