[gnunet-scheme] 141/324: mq: Return the envelope after enqueueing and add more tests.

[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 e219c36fbbb5e469609af87b86d21f0dd7a6b1ce
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Tue Jun 15 20:31:30 2021 +0200

    mq: Return the envelope after enqueueing and add more tests.
    
    If envelopes weren't returned, envelopes would be uncancellable.
    
    * gnu/gnunet/mq.scm
      (send-message!): Return the envelope. Document the envelope is
      returned. Note that the envelope could be enqueued and sent
      even if it isn't returned.
    * test/mq.scm
      (mhp, mhv, mq): Define helper variables.
      ("when injecting, handled message is eq?")
      ("non-zero types ok")
      ("verifier & handler only called once")
      ("missing header error")
      ("[prop] wrong header size error")
      ("returned envelope and sent envelope are equal")
      ("message might be enqueued & sent but not returned"): New tests
      for message queues.
---
 gnu/gnunet/mq.scm |  11 ++-
 tests/mq.scm      | 201 +++++++++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 209 insertions(+), 3 deletions(-)

diff --git a/gnu/gnunet/mq.scm b/gnu/gnunet/mq.scm
index 779d031..89d5f6e 100644
--- a/gnu/gnunet/mq.scm
+++ b/gnu/gnunet/mq.scm
@@ -254,7 +254,13 @@ and when @code{try-send-again!} and @code{send-message!} 
are not being
 used concurrently on the same message queue.
 
 When the message has been irrevocabily sent, the thunk @var{notify-sent!}
-will be called."
+will be called.
+
+After normal execution, the message envelope is returned,
+but in case of an exception (for example, an out-of-memory exception during
+the handling of a @code{&overly-full-queue-warning}), it is possible
+the envelope isn't returned even though it has been enqueued and it might
+perhaps be sent."
       (define (cancel!)
        (assert (and #f "cancel! not yet implemented")))
       (assert (and (slice? message)
@@ -285,7 +291,8 @@ will be called."
                         ;; TODO: consider
                         ;; (@ (gnu gnunet mq) send!) here and elsewhere.
                         (make-who-condition 'send-message!)))))
-        (try-send-again! mq))))
+        (try-send-again! mq)
+        envelope)))
 
     (define (try-send-again! mq)
       "Try to send messages in the queue @var{mq} that were not yet sent.
diff --git a/tests/mq.scm b/tests/mq.scm
index a9a3644..25038b1 100644
--- a/tests/mq.scm
+++ b/tests/mq.scm
@@ -26,11 +26,15 @@
 (use-modules (ice-9 control)
             (fibers conditions)
             (fibers)
+            (srfi srfi-1)
             (srfi srfi-26)
+            (srfi srfi-39)
             (srfi srfi-43)
             (srfi srfi-64)
             (srfi srfi-111)
             ((rnrs base) #:select (assert mod))
+            ((rnrs exceptions) #:select (guard))
+            ((rnrs conditions) #:select (condition-who))
             ((rnrs arithmetic bitwise)
              #:select (bitwise-ior))
             (gnu gnunet netstruct syntactic)
@@ -45,7 +49,10 @@
             (gnu gnunet message protocols)
             (gnu gnunet mq)
             (gnu gnunet mq envelope)
-            (gnu gnunet mq handler))
+            (gnu gnunet mq handler)
+            (quickcheck property)
+            (quickcheck)
+            (quickcheck arbitrary))
 
 ;; The client code sends the numbers 0 to
 ;; NUM_TRANSMISSIONS-1 over the message queue.
@@ -494,3 +501,195 @@ with @code{x}."
       (try-send-again! mq)
       (vector-set! results N_THREAD (received/thread)))
     (array-missing (results->array results))))
+
+
+
+;; Test message injection / handling (no exceptions).
+
+(define mhp (vector-unfold (lambda (_) (make-parameter #f)) 4))
+(define mhv (vector-unfold (lambda (_) (make-parameter #f)) 4))
+(define mh (apply message-handlers
+                  (map (lambda (i)
+                         (make-message-handler i (lambda (p) (p))
+                                               (lambda _
+                                                 (apply ((vector-ref mhv i)) 
_))
+                                               (lambda _
+                                                 (apply ((vector-ref mhp i)) 
_))))
+                       (iota (vector-length mhp)))))
+
+;; FWIW, passing #f is not really allowed.
+(define mq (make-message-queue mh #f #f))
+
+(test-eq "when injecting, handled message is eq?"
+  #t
+  (let ((m (make-slice/read-write 40))) ; could as wel have been 20
+    (set%! /:message-header '(size)
+          (slice-slice m 0 (sizeof /:message-header '())) 40)
+    (let/ec ec
+      (parameterize (((vector-ref mhp 0)
+                      (lambda (x)
+                        (ec (eq? x m))))
+                     ((vector-ref mhv 0)
+                      (lambda (x)
+                        (assert (eq? x m))
+                        #t)))
+        (inject-message! mq m)
+        'unreachable))))
+
+(test-eq "non-zero types ok"
+  #t
+  (let ((s (make-slice/read-write (sizeof /:message-header '()))))
+    (set%! /:message-header '(type) s 3)
+    (set%! /:message-header '(size) s (sizeof /:message-header '()))
+    (let/ec ec
+      (parameterize (((vector-ref mhp 3)
+                      (lambda (x)
+                        (ec (eq? x s))))
+                     ((vector-ref mhv 3)
+                      (lambda (x)
+                        (assert (eq? s x))
+                        #t)))
+        (inject-message! mq s)
+        'unreachable))))
+
+(test-equal "verifier & handler only called once"
+  '(1 . 1)
+  (let ((hcount 0)
+        (vcount 0)
+        (s (make-slice/read-write (sizeof /:message-header '()))))
+    (set%! /:message-header '(size) s (sizeof /:message-header '()))
+    (parameterize (((vector-ref mhp 0)
+                    (lambda (x)
+                      (set! hcount (+ 1 hcount))
+                      (assert (eq? x s))
+                      (values)))
+                   ((vector-ref mhv 0)
+                    (lambda (x)
+                      (set! vcount (+ 1 vcount))
+                      (assert (eq? x s))
+                      #t)))
+      (inject-message! mq s)
+      (cons hcount vcount))))
+
+
+
+;; Test message injection (exceptions)
+(test-equal "missing header error"
+  (map (lambda (i)
+        `(missing-header-error (size . ,i)
+                               (who  . inject-message!)))
+       (iota (sizeof /:message-header '())))
+  (map (lambda (i)
+        (guard (e ((missing-header-error? e)
+                   `(missing-header-error
+                     (size . ,(missing-header-error-received-size e))
+                     (who . ,(condition-who e)))))
+          (inject-message! mq (make-slice/read-write i))
+          'unreachable))
+       (iota (sizeof /:message-header '()))))
+
+(test-assert "[prop] wrong header size error"
+  (quickcheck
+   (property ((%real-length $natural)
+             (supposed-length $natural))
+     (let* ((real-length (+ (sizeof /:message-header '())
+                           %real-length))
+           (supposed-length (if (= real-length supposed-length)
+                                (+ 1 supposed-length)
+                                supposed-length))
+           (s (make-slice/read-write real-length))
+           (sheader (slice-slice s 0 (sizeof /:message-header '()))))
+       (set%! /:message-header '(size)
+             (slice-slice s 0 (sizeof /:message-header '()))
+             supposed-length)
+       (guard (e ((size-mismatch-error? e)
+                 (equal? `(,(size-mismatch-error-expected-size e)
+                           ,(size-mismatch-error-received-size e)
+                           ,(condition-who e))
+                         `(,supposed-length
+                           ,real-length
+                           inject-message!))))
+        (inject-message! mq s)
+        #f)))))
+
+;; TODO: what if the message is (otherwise) malformed?
+
+
+
+;; Test the following part of the send-message! docstring:
+;; ‘After normal execution, the message envelope is returned,
+;; but in case of an exception (for example, an out-of-memory exception
+;; during the handling of a @code{&overly-full-queue-warning}), it is
+;; possible the envelope isn't returned even though it has been enqueued
+;; and it might perhaps be sent.
+(test-assert "returned envelope and sent envelope are equal"
+  (let* ((returned-values #f)
+        (sent-values #f)
+        (sender
+         (make-one-by-one-sender
+          (lambda envelope-arguments
+            (assert (eq? sent-values #f))
+            (set! sent-values envelope-arguments)
+            (values))))
+        (mq (make-message-queue #f #f sender))
+        (msg (index->dummy #xdeadbeef)))
+    (call-with-values
+       (lambda () (send-message! mq msg))
+      (lambda return-values
+       (set! returned-values return-values)))
+    (and (equal? sent-values returned-values)
+        (= (length sent-values) 1)
+        (every envelope? sent-values))))
+
+;; Strictly speaking, this test is allowed to fail
+;; (as it is only ‘might’, not ‘it must be possible’),
+;; but it seems a good idea to check our understanding is correct.
+(test-assert "message might be enqueued & sent but not returned"
+  (let* ((enqueued? #f)
+        (flush? (make-parameter #f))
+        (sender/flush
+         (make-one-by-one-sender
+          (lambda (envelope)
+            (set! enqueued? envelope)
+            (values))))
+        (sender/hold
+         (lambda _ (values)))
+        (sender (make-sender/choice flush? sender/hold
+                                    sender/flush))
+        (mq (make-message-queue #f #f sender))
+        (msg (index->dummy 0))
+        (exceptional #f)
+        (enveloped #f))
+    (with-exception-handler
+       (lambda (_)
+         (assert exceptional)
+         (assert (envelope? enqueued?))
+         (assert (not enveloped)))
+      (lambda ()
+       (with-exception-handler
+           (lambda (e)
+             (if (overly-full-queue-warning? e)
+                 (begin
+                   (set! exceptional #t)
+                   (parameterize ((flush? #t))
+                     (try-send-again! mq)
+                     ;; At least in the current implementation,
+                     ;; this holds.
+                     ;;
+                     ;; In a different implementation, the
+                     ;; envelope could be enqueued after
+                     ;; checking the queue length.
+                     (assert enqueued?))
+                   (throw 'out-of-memory))
+                 (raise-exception e #:continuable? #t)))
+         (lambda ()
+           (call-with-values
+               (lambda ()
+                 (parameterize ((%suspicious-length 0))
+                   (send-message! mq msg)))
+             (lambda args (set! enveloped args))))
+         #:unwind? #f))
+      #:unwind? #t
+      #:unwind-for-type 'out-of-memory)
+    (and enqueued? exceptional
+        (not enveloped))))

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