[gnunet-scheme] 117/324: mq: Define envelope data type, again.

[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 08d98c025e7f50d1c6bafd94dfadd2c384fe8260
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Mon May 24 18:07:44 2021 +0200

    mq: Define envelope data type, again.
    
    The new envelope data type can be used without
    fibers or multi-threading.
    
    * Makefile.am (modules): Remove replaced
      gnu/gnunet/message/envelope.scm.
      (%.go: %.scm): Do not unset GUILE_LOAD_COMPILED_PATH as that
      would interfere with guile-pfds.
    * README.org (Modules): Remove the obsolete
      gnu/gnunet/message/envelope.scm.
      (Message queues): Document new envelope module. Adjust
      message queue blurb for the future.
    * gnu/gnunet/mq/envelope.scm: Define new envelope module.
    * gnu/gnunet/message/envelope.scm: Delete.
    * tests/envelope.scm: Test the new envelope module.
---
 Makefile.am                     |   8 +-
 README.org                      |  22 +-
 gnu/gnunet/message/envelope.scm | 139 ------------
 gnu/gnunet/mq/envelope.scm      | 195 +++++++++++++++++
 guix.scm                        |   4 +-
 tests/envelope.scm              | 468 ++++++++++++++++++++++++++++++----------
 6 files changed, 571 insertions(+), 265 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index bf1f3a8..51273bf 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -34,10 +34,10 @@ modules = \
   gnu/gnunet/scripts/guix-stuff.scm \
   \
   gnu/gnunet/message/protocols.scm \
-  gnu/gnunet/message/envelope.scm \
   \
   gnu/gnunet/concurrency/update.scm \
   \
+  gnu/gnunet/mq/envelope.scm \
   gnu/gnunet/mq/handler.scm \
   gnu/gnunet/mq/prio-prefs.scm \
   gnu/gnunet/mq/prio-prefs2.scm \
@@ -70,14 +70,14 @@ dist_guilesite_DATA = $(modules)
 if HAVE_GUILD
 nodist_guilesiteccache_DATA = $(modules:%.scm=%.go)
 
-# Unset 'GUILE_LOAD_COMPILED_PATH' so we can be sure that any .go file that we
-# load comes from the build directory.
+# Do not unset 'GUILE_LOAD_COMPILED_PATH', as guile-pfds as installed
+# in Guix does not have .scm files (but it does in Guile).
 # XXX: Use the C locale for when Guile lacks
 # 
<https://git.sv.gnu.org/cgit/guile.git/commit/?h=stable-2.0&id=e2c6bf3866d1186c60bacfbd4fe5037087ee5e3f>.
 %.go: %.scm
        $(AM_V_GUILEC)$(MKDIR_P) "`dirname "$@"`" ;                     \
        $(AM_V_P) && out=1 || out=- ;                                   \
-       unset GUILE_LOAD_COMPILED_PATH ; LC_ALL=C                       \
+       LC_ALL=C                                                        \
        builddir="$(top_builddir)"                                      \
        GUILE_AUTO_COMPILE=0                                            \
        $(GUILD) compile --target="$(host)"                             \
diff --git a/README.org b/README.org
index f6e8108..d2a6979 100644
--- a/README.org
+++ b/README.org
@@ -45,8 +45,6 @@
   + a nice Scheme interface to GNUnet!
 * Modules
   + gnu/gnunet/directory.scm: directory construction
-  + gnu/gnunet/message/envelope.scm: some program data around
-    message types (e.g. priority, notify-on-sent)
   + gnu/gnunet/concurrency/update.scm: a box with a value,
     that can be updated, resulting in a new box.  Updates
     can be waited upon.
@@ -63,11 +61,18 @@
      the ‘good’ tag.
 
 ** Message queues                                                      :spec:
-   Message queues have three parts: the input queue, the output
-   queue and the transport, that are respectively a read+close request
-   capability, a write+close request capability and a capability
-   for all the previous, reacting to a close request and injecting errors.
 
+   Message queues have a handler for normal incoming messages and for errors.
+   If a transport receives an incoming message, it should add it (‘inject’)
+   to the incoming messages, which may result in a message handler being
+   called. The user of the queue can also try to cancel sending a message
+   and will receive a notification when the message cannot be unsent anymore.
+
+   Message queues can be used concurrently. (TODO destruction)
+
+   + gnu/gnunet/mq/envelope.scm: a wrapper around a message, with a callback
+     for cancelling the sending of the message (if not too late) and a callback
+     for notifying it cannot be unsent anymore.
    + gnu/gnunet/mq/prio-prefs.scm: message priorities & preferences
 
      Preferences: is out-of-order allowed or not,
@@ -78,8 +83,9 @@
      Different message types may need need different
      capabilities; the interposition can be used to adjust
      the ambient authority appropriately.
-   + gnu/gnunet/mq/message-io.scm: like soft ports, but using
-     fibers channels and for messages.
+   + gnu/gnunet/mq/message-io.scm: SCRAPPED
+   + gnu/gnunet/mq.scm: the message queue itself!
+
    + TODO actual queues?  Maybe we don't need them?
    + TODO filling the queues
 ** Configuration                                                  :test:good:
diff --git a/gnu/gnunet/message/envelope.scm b/gnu/gnunet/message/envelope.scm
deleted file mode 100644
index 2849787..0000000
--- a/gnu/gnunet/message/envelope.scm
+++ /dev/null
@@ -1,139 +0,0 @@
-;; This file is part of scheme-GNUnet.
-;; Copyright (C) 2012-2019 GNUnet e.V.
-;; Copyright (C) 2021 Maxime Devos
-;;
-;; scheme-GNUnet is free software: you can redistribute it and/or modify it
-;; under the terms of the GNU Affero General Public License as published
-;; by the Free Software Foundation, either version 3 of the License,
-;; or (at your option) any later version.
-;;
-;; scheme-GNUnet is distributed in the hope that it will be useful, but
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-;; Affero General Public License for more details.
-;;
-;; You should have received a copy of the GNU Affero General Public License
-;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
-;;
-;; SPDX-License-Identifier: AGPL3.0-or-later
-
-;; Upstream GNUnet:
-;; @author Florian Dold
-;; @file util/mq.c
-;; @brief general purpose request queue
-;;
-;; Scheme-GNUnet:
-;; @author Maxime Devos
-;; @file gnu/gnunet/message/envelope.scm
-
-(define-library (gnu gnunet message envelope)
-  (export <envelope> make-envelope envelope?
-         <envelope/dll> make-envelope/dll envelope/dll?
-         envelope-message-slice envelope-priority
-         notify-sent! wait-sent-operation
-         envelope-dll-check envelope-dll
-         &double-notify-sent make-double-notify-sent
-         double-notify-sent?)
-  (import (gnu gnunet utils bv-slice)
-         (srfi srfi-26)
-         (rnrs base)
-         (ice-9 optargs)
-         (rnrs records syntactic)
-         (only (rnrs exceptions)
-               raise)
-         (only (fibers conditions)
-               make-condition
-               signal-condition!
-               wait-operation)
-         (only (rnrs conditions)
-               condition &violation
-               make-who-condition
-               make-message-condition
-               define-condition-type))
-  (begin
-    (define-record-type (<envelope> make-envelope envelope?)
-      (fields (immutable message-slice envelope-message-slice)
-             (immutable message-prio  envelope-priority)
-             ;; Signalled when the message has been sent.
-             (immutable message-sent envelope-message-sent-condition))
-      (protocol
-       (lambda (%make)
-        (lambda* (mh #:key (priority 0))
-          "Make a fresh message envelope for the message @var{mh}
-(a readable bytevector slice) and priority @var{priority}
-(a numeric value from @code{gnu gnunet util mq-enum})."
-          ;; FIXME also check if @var{mh} is large enough?
-          (assert (slice-readable? mh))
-          (assert (and (integer? priority)
-                       (exact? priority)
-                       (<= 0 priority)
-                       ;; XXX magic number
-                       (< priority 512)))
-          (%make mh priority (make-condition)))))
-      (sealed #f)
-      (opaque #t))
-
-    (define-condition-type &double-notify-sent &violation
-      make-double-notify-sent double-notify-sent?)
-
-    ;; See notify-sent!.
-    (define (notify-sent-condition)
-      (condition (make-double-notify-sent)
-                (make-who-condition 'notify-sent!)
-                (make-message-condition
-                 "notify-sent! was called twice on same envelope")))
-
-    (define (notify-sent! ev)
-      "Mark the envelope @var{ev} as sent.
-
-This is the responsibility of the transport.
-
-Conceptually, this should only be available to the message
-transport, but the only other potential user would be
-the message sender, so this shouldn't matter.
-
-It is an error to call more than one.  Currently,
-an appropriate @code{&double-notify-sent} is raised."
-      (if (signal-condition! (envelope-message-sent-condition ev))
-         (values)
-         (raise (notify-sent-condition))))
-
-    (define (wait-sent-operation ev)
-      "Return an operation for waiting until the envelope
-@var{ev} has been sent.  If the message has already been sent,
-this operation returns immediately."
-      (wait-operation (envelope-message-sent-condition ev)))
-
-    ;; XXX I doubt this will see any use.
-    (define-record-type (<envelope/dll> make-envelope/dll envelope/dll?)
-      (fields (immutable capability %envelope/dll-capability)
-             (mutable left %envelope/dll-previous
-                      %set-envelope/dll-previous!)
-             (mutable right %envelope/dll-next
-                      %set-envelope/dll-next!))
-      (protocol
-       (lambda (%make)
-        (lambda (cap . args)
-          "A variant of @code{make-envelope}, that organises envelopes
-in a linked list.  The capability @var{cap} will be required for accessing
-and modifying this list."
-          ((apply %make args) cap #f #f))))
-      (parent <envelope>)
-      (sealed #f)
-      (opaque #t))
-
-    (define (envelope-dll-check ev/dll cap)
-      "Verify whether the capability @var{cap} can be used
-for accessing the underlying DLL of the envelope @var{ev}.
-If not, raise an exception.  Otherwise, return truth."
-      ;; FIXME &bad-capability exception?
-      (assert (eq? (%envelope/dll-capability ev/dll) cap)))
-
-    (define (envelope-dll ev/dll cap)
-      "Return the DLL procedures of the DLL envelope @var{ev/dll},
-using the capability @var{cap}."
-      (envelope-dll-check ev/dll cap)
-      (values (cute %envelope/dll-previous ev/dll)
-             (cute %set-envelope/dll-previous! ev/dll <>)
-             (cute %envelope/dll-next ev/dll)
-             (cute %set-envelope/dll-next! ev/dll <>)))))
diff --git a/gnu/gnunet/mq/envelope.scm b/gnu/gnunet/mq/envelope.scm
new file mode 100644
index 0000000..e0c94a2
--- /dev/null
+++ b/gnu/gnunet/mq/envelope.scm
@@ -0,0 +1,195 @@
+;; This file is part of GNUnet.
+;; Copyright (C) 2012-2019 GNUnet e.V.
+;; Copyright (C) 2021 Maxime Devos (<maximedevos@telenet.be>)
+;;
+;; GNUnet is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Affero General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL3.0-or-later
+
+;; Author: Florian Dold
+;; Author: Maxime Devos
+;; C file: util/mq.c
+;; Scheme module: (gnu gnunet mq envelope)
+;;
+;; Limitation: the format of messages is still in flux,
+;; so no type checks there.
+(define-library (gnu gnunet mq envelope)
+  (export <envelope> make-envelope envelope?
+         attempt-cancel! attempt-irrevocable-sent!)
+  (import (gnu gnunet utils hat-let)
+         (only (guile) define* lambda* exact-integer?)
+         (only (ice-9 match) match)
+         (only (ice-9 atomic)
+               make-atomic-box atomic-box-ref
+               atomic-box-compare-and-swap!)
+         (only (rnrs base)
+               lambda assert letrec let begin define
+               syntax-rules let-syntax define-syntax
+               procedure? eq? >= = <= < if quote ...
+               identifier-syntax values and let*
+               vector vector-ref vector? vector-length)
+         (only (rnrs records syntactic) define-record-type))
+  (begin
+    (define-record-type (<envelope> make-envelope envelope?)
+      ;; Atomic box:
+      ;;    #t: cancelled
+      ;;    #f: to late to cancel, message has been irrevocabily sent!
+      ;;
+      ;;        (Unless you play tricks like pulling out the Ethernet
+      ;;        cable before the message is received by the router)
+      ;;    #(message prio notify-sent! cancel!)
+      (fields (immutable state %cancellation-state))
+      (protocol
+       (lambda (%make)
+        (lambda* (cancel! message #:key (priority 0) (notify-sent! values))
+          "Make a message envelope; i.e., a record containing the message
+(@var{message}, @var{priority}) and information on how to cancel the sending
+of the message (@var{cancel!}) and who should be notified when the message
+cannot be unsent anymore (@var{notify-sent!}).
+
+Once marked as cancelled or irrevocabily sent, the record drops its
+references to @var{message}, @var{cancel!} and @var{notify-sent!}.
+When being marked as cancelled, the thunk @var{cancel!} is called."
+          (assert (and (procedure? cancel!) (procedure? notify-sent!)
+                       (exact-integer? priority)
+                       (<= 0 priority 511)))
+          (%make (make-atomic-box
+                  (vector message priority notify-sent! cancel!)))))))
+
+    (define (%attempt-irrevocable-sent! envelope already-sent go cancelled)
+      (bind-atomic-boxen
+       ((state (%cancellation-state envelope) swap!))
+       (let spin ((old state))
+        (match old
+          ;; See comment at %attempt-cancel! for
+          ;; why we don't do #(message prio notify-sent! cancel!)
+          ((? vector?)
+           (if (eq? old (swap! old #f))
+               (let^ ((!! (= (vector-length old) 4))
+                      (! message (vector-ref old 0))
+                      (! prio (vector-ref old 1))
+                      (! notify-sent! (vector-ref old 2)))
+                     (notify-sent!)
+                     (go message prio))
+               (spin state)))
+          (#t (cancelled))
+          (#f (already-sent))))))
+
+    (define-syntax attempt-irrevocable-sent!
+      (syntax-rules (go cancelled already-sent)
+       "If @var{envelope} is not cancelled and has not yet been sent,
+mark the message as irrevocably sent, call the notify-sent callback and
+evaluate @var{exp/go} in an environment where the message @var{message}
+and its priority @var{priority} are bound.
+
+If the message has already been marked as irrevocabily sent,
+evaluate @var{exp/already-sent} instead. If the message is cancelled,
+evaluate @var{exp/cancelled} instead.
+
+Even if this operation (and perhaps @code{attempt-cancel!}) is used 
concurrently
+on the same @var{envelope}, whether by multi-threading, asynchronicities
+(via @code{system-async-mark}) or by recursion, the following properties hold:
+
+@begin itemize
+@item the notify-sent callback of @var{envelope} is called at most once
+@item the notify-sent callback is never called if @var{envelope} is cancelled
+  at any point in time
+@item likewise, the code in @var{exp/go} is at most evaluated once
+@end itemize"
+       ((_ envelope
+           ((go message priority) . exp/go)
+           ((cancelled) . exp/cancelled)
+           ((already-sent) . exp/already-sent))
+        (%attempt-irrevocable-sent! envelope
+                                    (lambda () . exp/already-sent)
+                                    (lambda (message priority) . exp/go)
+                                    (lambda () . exp/cancelled)))))
+
+    (define (%attempt-cancel! envelope now-cancelled already-cancelled
+                             already-sent)
+      (bind-atomic-boxen
+       ((state (%cancellation-state envelope) swap!))
+       (let spin ((old state))
+        (match old
+          ;; Do _not_ use #(message prio notify-sent! cancel!)
+          ;; here! Instead, delay the bounds check and accessing
+          ;; the elements of the vector after the swap!. That way:
+          ;;
+          ;; Premature optimisation.
+          ;;   We save a little time in case two threads try to concurrently
+          ;;   @var{state}.
+          ;;
+          ;; Meager excuse: self-healing (in case of memory corruption).
+          ;;   Suppose a cosmic ray flipped a few bits and now
+          ;;   @var{state} contains another vector, of different length.
+          ;;   Then by performing the swap before the bounds check,
+          ;;   the envelope is brought into a valid state. (And an
+          ;;   exception will still result.)
+          ((? vector?)
+           (if (eq? old (swap! old #t))
+               (let^ ((!! (= (vector-length old) 4))
+                      (! cancel! (vector-ref old 3)))
+                     (cancel!)
+                     (now-cancelled))
+               (spin state)))
+          (#t (already-cancelled))
+          ;; XXX maybe make the meager excuse less meager
+          ;; and add a 'default' case where @var{state} is
+          ;; set to #f when bad (and an exception is raised)?
+          ;; Seems like some dedicated exception types for
+          ;; memory corruption are required then ...
+          ;; And tests.
+          (#f (already-sent))))))
+
+    (define-syntax attempt-cancel!
+      (syntax-rules (now-cancelled already-cancelled already-sent)
+       "If @var{envelope} is not yet marked as cancelled or sent,
+mark it as cancelled, call the corresponding cancellation callback
+and evaluate @var{exp/now-cancelled}.
+
+If @var{envelope} is already marked as cancelled, do not mutate
+anything or call any callback and evaluate @var{exp/already-cancelled}.
+Likewise, if @var{envelope} is marked as irrevocably sent, evaluate
+@var{exp/already-sent} instead.
+
+If this operation is interrupted before @var{exp/now-cancelled} is
+evaluated, the envelope may be marked as cancelled even if the
+cancellation callback has not yet been called or has not yet returned.
+
+However, by tolerating this limitation, it can be (and is) guaranteed
+that the cancellation callback is called at most once. Likewise, the
+code in @var{exp/now-cancelled} is only be called at most once.
+Also, the cancellation callback and is never called (and 
@var{exp/now-cancelled}
+never evaluated) if @var{envelope} is marked as sent at any point in time."
+       ((_ envelope
+           ((now-cancelled) . exp/now-cancelled)
+           ((already-cancelled) . exp/already-cancelled)
+           ((already-sent) . exp/already-sent))
+        (%attempt-cancel! envelope
+                          (lambda () . exp/now-cancelled)
+                          (lambda () . exp/already-cancelled)
+                          (lambda () . exp/already-sent)))))
+
+    (define-syntax bind-atomic-boxen
+      (syntax-rules ()
+       ((_ () exp exp* ...)
+        (let () exp exp* ...))
+       ((_ ((variable box swap!) . etc) exp exp* ...)
+        (let ((stashed-box box))
+          (let-syntax ((variable (identifier-syntax
+                                  (atomic-box-ref box))))
+            (let ((swap! (lambda (expected desired)
+                           (atomic-box-compare-and-swap! box expected
+                                                         desired))))
+              (bind-atomic-boxen etc exp exp* ...)))))))))
diff --git a/guix.scm b/guix.scm
index c9291cf..6db8c36 100644
--- a/guix.scm
+++ b/guix.scm
@@ -66,8 +66,10 @@ random inputs and seeing if it holds.")
    (propagated-inputs `(("guile-zlib" ,guile-zlib)
                        ("guile-bytestructures" ,guile-bytestructures)
                        ("guile-fibers" ,guile-fibers)
-                       ("guile-json" ,guile-json-4)))
+                       ("guile-json" ,guile-json-4)
+                       ("guile-pfds" ,guile-pfds)))
    (native-inputs `(("guile" ,guile-3.0)
+                   ("guile-pfds" ,guile-pfds)
                    ("automake" ,automake)
                    ;; Only used for testing.
                    ("guile-quickcheck" ,guile-quickcheck)
diff --git a/tests/envelope.scm b/tests/envelope.scm
index eb6f39f..3444df0 100644
--- a/tests/envelope.scm
+++ b/tests/envelope.scm
@@ -16,116 +16,358 @@
 ;;
 ;; SPDX-License-Identifier: AGPL3.0-or-later
 
-(use-modules (gnu gnunet message envelope)
-            (gnu gnunet utils bv-slice)
-            (ice-9 control)
-            (ice-9 receive)
-            (fibers operations)
-            (rnrs bytevectors)
-            (srfi srfi-26))
-
-(test-begin "envelope")
-
-(define %arbitrary-slice (make-slice/read-write 50))
-(define %arbitrary-bv (make-bytevector 50))
-(define %arbitrary-priority 7)
-(define (%bogus-notify-sent!) (throw 'what))
-
-;; Priorities (represented by raw integers)
-(let ((mk-prio (cute make-envelope %arbitrary-slice
-                    #:priority <>))
-      (acceptable-priorities
-       '(0 1 511)))
-  (test-equal "priorities are preserved"
-    acceptable-priorities
-    (map (compose envelope-priority mk-prio)
-        acceptable-priorities))
-  (test-error "priorities ≥ 512 are rejected" #t
-             (mk-prio 512))
-  (test-error "priorities < 0 are rejected" #t
-             (mk-prio -1))
-  (test-error "inexact priorities are rejected" #t
-             (mk-prio 0.))
-  (test-error "fractional priorities are rejected" #t
-             (mk-prio 1/2)))
-
-;; Notify sent events
-(let ((mk (cute make-envelope %arbitrary-slice)))
-  (test-equal "notify-sent! is usable"
-    '()
-    (receive result (notify-sent! (mk))
-      result))
-
-  (test-equal "wait-sent-operation returns after notify-sent!"
-    '()
-    (let ((a (mk)))
-      (notify-sent! a)
-      (receive result (perform-operation (wait-sent-operation a))
-       result)))
-
-  (test-equal "wait-sent-operation can be used twice"
-    '(() . ())
-    (let ((a (mk)))
-      (notify-sent! a)
-      (cons
-       (receive result (perform-operation (wait-sent-operation a))
-          result)
-       (receive result (perform-operation (wait-sent-operation a))
-          result))))
-
-  (test-error "don't call notify-sent! twice"
-    &double-notify-sent
-    (let ((a (mk)))
-      (notify-sent! a)
-      (notify-sent! a))))
-
-;; Whether wait-sent blocking cannot really be tested
-;; without resorting to time-outs.
-
-;; Message slice
-(let ((mk-slice (cute make-envelope <>)))
-  (test-error "message must be a slice (bv)"
-    #t
-    (mk-slice %arbitrary-bv))
-  (test-error "message must be a slice (#f)"
-    #t
-    (mk-slice #f))
-  (test-error "slice must be readable"
-    #t
-    (mk-slice (slice/write-only (make-slice/read-write 50))))
-  (test-expect-fail 1)
-  (test-error "slice may be writable"
-    #t
-    (mk-slice (make-slice/read-write 50)))
-  ;; It isn't required that they be eq?, per se,
-  ;; but rather, it should point to the same
-  ;; memory region.
-  (test-eq "slice is preserved"
-    %arbitrary-slice
-    (envelope-message-slice (mk-slice %arbitrary-slice))))
-
-;; Envelope DLL
-(let ((mk-dll (cute make-envelope/dll <> %arbitrary-slice)))
-  (mk-dll 'stuff)
-  (test-equal "make-envelope/dll allows #:priority"
-    444
-    (envelope-priority
-     (make-envelope/dll 'cap %arbitrary-slice
-                       #:priority 444)))
-  (test-assert "envelope/dll? implies envelope?"
-    (envelope? (mk-dll 'check)))
-  (test-assert "envelope? does not imply envelope/dll?"
-    (not (envelope/dll? (make-envelope %arbitrary-slice))))
-
-  (test-assert "capability check success"
-    (envelope-dll-check (mk-dll 'cap) 'cap))
-  (test-error "capability check failure" #t
-             (envelope-dll-check (mk-dll 'cap) 'imposter))
-
-  (test-error "envelope-dll checks capability (failure)" #t
-             (envelope-dll (mk-dll 'cap) 'imposter))
-  (test-assert "envelope-dll checks capability (success)"
-              (envelope-dll (mk-dll 'cap) 'cap)))
-;; XXX test DLL, this requires a DLL library
-
-(test-end "envelope")
+(use-modules (ice-9 control)
+            (srfi srfi-26)
+            ((rnrs base) #:select (assert))
+            ((rnrs conditions) #:select (&assertion))
+            (gnu gnunet mq envelope)
+            (gnu gnunet mq prio-prefs)
+            (gnu gnunet mq prio-prefs2))
+
+(define *msg* (cons #f #t))
+
+(define (no-cancel!)
+  (error "cancel?"))
+(define (no-notify-sent!)
+  (error "notify-sent?"))
+
+(test-begin "notify-sent!")
+
+;; First test things without any kind of concurrency,
+;; and without stack overflows and OOM.
+;; (No recursion, no asynchronics, no threads, no interrupts.)
+(test-assert "notify-sent!: called by attempt-irrevocable-sent! (before 'go')"
+  (let/ec ec
+    (attempt-irrevocable-sent!
+     (make-envelope no-cancel! *msg*
+                   #:notify-sent!
+                   (lambda () (ec #t)))
+     ((go message priority) (error "unreachable"))
+     ((cancelled) (error "cancelled?"))
+     ((already-sent) (error "already sent?")))
+    (ec #f)))
+
+(test-eq "notify-sent!: only called once (--> already-sent)"
+  'already-sent
+  (let* ((notify-sent!? #f)
+        (first-part-done? #f)
+        (notify-sent!
+         (lambda ()
+           (if notify-sent!?
+               (error "called twice")
+               (set! notify-sent!? #t)))))
+    (let ((envelope (make-envelope no-cancel! *msg*
+                                  #:notify-sent! notify-sent!)))
+      (attempt-irrevocable-sent!
+       envelope
+       ((go message priority)
+       (assert notify-sent!?)
+       (assert (eq? message *msg*))
+       (assert (= priority 0))
+       ;; the assignment should only be done once
+       (assert (not first-part-done?))
+       (set! first-part-done? #t))
+       ((cancelled) (error "cancelled?"))
+       ((already-sent) (error "done?")))
+      (assert first-part-done?)
+      (attempt-irrevocable-sent!
+       envelope
+       ((go message priority) (error "go?/2"))
+       ((cancelled) (error "cancelled?/2"))
+       ((already-sent) 'already-sent)))))
+
+(test-equal "notify-sent!: not called if cancelled (--> cancelled)"
+  '(seems-ok . seems-ok/2)
+  (let* ((cancelled? #f)
+        (cancel!
+         (lambda ()
+           (if cancelled?
+               (error "what")
+               (set! cancelled? #t))))
+        (envelope (make-envelope cancel! *msg* #:notify-sent!
+                                 no-notify-sent!))
+        (result/1
+         (attempt-cancel!
+          envelope
+          ((now-cancelled)
+           (assert cancelled?)
+           'seems-ok)
+          ((already-cancelled) (error "what/cancelled"))
+          ((already-sent) (error "what/sent"))))
+        (result/2
+         (attempt-irrevocable-sent!
+          envelope
+          ((go message priority) (error "go?"))
+          ((cancelled) 'seems-ok/2)
+          ((already-sent) (error "what/sent/2")))))
+    (cons result/1 result/2)))
+
+;; Concurrency by recursion.
+(test-eq "notify-sent!: not called if cancelled (inside post-cancellation)"
+  'seems-ok
+  (let* ((cancel-ok? (make-parameter #t))
+        (cancel!
+         (lambda ()
+           (unless (cancel-ok?)
+             (error "what"))))
+        (envelope
+         (make-envelope cancel! *msg* #:notify-sent! no-notify-sent!)))
+    (attempt-cancel!
+     envelope
+     ((now-cancelled)
+      (parameterize ((cancel-ok? #f))
+       (attempt-irrevocable-sent!
+        envelope
+        ((go message priority) (error "go?"))
+        ((cancelled) 'seems-ok)
+        ((already-sent) (error "what/sent/2")))))
+     ((already-cancelled) (error "what/cancelled"))
+     ((already-sent) (error "what/sent")))))
+
+(test-eq "notify-sent!: only called once (nested)"
+  'seems-ok
+  (let* ((sent? #f)
+        (notify-sent!
+         (lambda ()
+           (if sent?
+               (error "but I was already sent!")
+               (set! sent? #t))))
+        (envelope (make-envelope no-cancel! *msg* #:notify-sent! 
notify-sent!)))
+    (attempt-irrevocable-sent!
+     envelope
+     ((go message priority)
+      (assert sent?)
+      (attempt-irrevocable-sent!
+       envelope
+       ((go message priority) (error "but I was already sent!"))
+       ((cancelled) (error "cancelled/2?"))
+       ((already-sent) 'seems-ok)))
+     ((cancelled) (error "cancelled/1"))
+     ((already-sent) (error "aleady-sent?")))))
+
+;; TODO: asynchronics, multi-threading.
+;; How does one reliably test these things anyways?
+;; Maybe the VM trap interface can be used
+;; (to delay asynchronics to inopportune times).
+;; This seems a project of its own though.
+(test-end "notify-sent!")
+
+(test-begin "cancel!")
+
+(test-eq "cancel!: only called once (nested)"
+  'seems-ok
+  (let* ((cancelled? #f)
+        (cancel! (lambda ()
+                   (if cancelled?
+                       (error "cancelled at wrong time / too often")
+                       (set! cancelled? #t))))
+        (envelope
+         (make-envelope cancel! *msg* #:notify-sent! no-notify-sent!)))
+    (attempt-cancel!
+     envelope
+     ((now-cancelled)
+      (assert cancelled?)
+      (attempt-cancel!
+       envelope
+       ((now-cancelled) 'twice-now-cancelled)
+       ((already-cancelled) 'seems-ok)
+       ((already-sent) (error "what send/1"))))
+     ((already-cancelled) 'too-early-cancel)
+     ((already-sent) (error "what send/2")))))
+
+(test-eq "cancel!: not after sent (sequential)"
+  'ok-already-sent
+  (let* ((envelope (make-envelope no-cancel! *msg*))
+        (first-step-done? #f)
+        (second-step-done? #f))
+    (attempt-irrevocable-sent!
+     envelope
+     ((go message priority)
+      (assert (not first-step-done?))
+      (set! first-step-done? #t))
+     ((cancelled) (error "what / cancelled"))
+     ((already-sent) (error "what / sent")))
+    (assert first-step-done?)
+    (attempt-cancel!
+     envelope
+     ((now-cancelled) (error "but I was sent"))
+     ((already-cancelled) (error "cancelled?"))
+     ((already-sent)
+      (assert (not second-step-done?))
+      (set! second-step-done? #t)
+      'ok-already-sent))))
+
+(test-eq "cancel!: not after sent (nested)"
+  'ok-already-sent
+  (let* ((envelope (make-envelope no-cancel! *msg*)))
+    (attempt-irrevocable-sent!
+     envelope
+     ((go message priority)
+      (attempt-cancel!
+       envelope
+       ((now-cancelled) (error "but I was sent"))
+       ((already-cancelled) (error "cancelled?"))
+       ((already-sent) 'ok-already-sent)))
+     ((cancelled) (error "what / cancelled"))
+     ((already-sent) (error "what / sent")))))
+
+(test-eq "cancel!: only called once (sequential)"
+  'ok
+  (let* ((cancelled? #f)
+        (cancel! (lambda ()
+                   (if cancelled?
+                       (error "cancelled at wrong time / too often")
+                       (set! cancelled? #t))))
+        (first-step-done? #f)
+        (second-step-done? #f)
+        (envelope
+         (make-envelope cancel! *msg* #:notify-sent! no-notify-sent!)))
+    (attempt-cancel!
+     envelope
+     ((now-cancelled)
+      (assert cancelled?)
+      (assert (not first-step-done?))
+      (set! first-step-done? #t))
+     ((already-cancelled) (error "too early already cancelled"))
+     ((already-sent) (error "too early send")))
+    (assert cancelled?)
+    (assert first-step-done?)
+    (attempt-cancel!
+     envelope
+     ((now-cancelled) 'double-cancel)
+     ((already-cancelled)
+      (assert (not second-step-done?))
+      (set! second-step-done? #t)
+      'ok)
+     ((already-sent) (error "should not have been sent")))))
+
+(test-end "cancel!")
+
+;; We will now test whether references
+;; to the notify-sent, cancel and message are dropped
+;; when the message is marked as sent.
+
+;; Current versions of guile (at least 3.0.5) use a conservative
+;; garbage collector, so these tests might sometimes fail without
+;; indicating a bug. For reprodicible builds, allow skipping these
+;; tests.
+
+(define conservative-gc?
+  (if (equal? "yes" (getenv "TOLERATE_CONSERVATIVE_COLLECTORS"))
+      #t
+      #f))
+
+(test-begin "gc")
+
+;; Compilation of the source code of this test file
+;; prevents procedures made by writing (lambda () STUFF)
+;; from being garbage-collected.
+(define (fresh-gc-thunk)
+  (eval '(lambda () 'fresh) (current-module)))
+
+(define (do-nothing) 'nothing)
+
+(test-skip (if conservative-gc? 4 0))
+
+(test-equal "references dropped after cancel"
+  '(#t #t #t)
+  (let* ((fresh-message (vector 0 1 2 3))
+        (fresh-cancel (fresh-gc-thunk))
+        (fresh-notify-sent (fresh-gc-thunk))
+        (message-guard (make-guardian))
+        (cancel-guard (make-guardian))
+        (notify-sent-guard (make-guardian))
+        (envelope (make-envelope fresh-cancel fresh-message
+                                 #:notify-sent! fresh-notify-sent)))
+    (message-guard fresh-message)
+    (cancel-guard fresh-cancel)
+    (notify-sent-guard fresh-notify-sent)
+    (attempt-cancel!
+     envelope
+     ((now-cancelled)
+      (gc)
+      (list (->bool (message-guard))
+           (->bool (cancel-guard))
+           (->bool (notify-sent-guard))))
+     ((already-cancelled) (error "what/cancelled"))
+     ((already-sent) (error "what/sent")))))
+
+(test-equal "references dropped after sent"
+  '(#t #t #t)
+  (let* ((fresh-message (vector 0 1 2 3))
+        (fresh-cancel (fresh-gc-thunk))
+        (fresh-notify-sent (fresh-gc-thunk))
+        (message-guard (make-guardian))
+        (cancel-guard (make-guardian))
+        (notify-sent-guard (make-guardian))
+        (envelope (make-envelope fresh-cancel fresh-message
+                                 #:notify-sent! fresh-notify-sent)))
+    (message-guard fresh-message)
+    (cancel-guard fresh-cancel)
+    (notify-sent-guard fresh-notify-sent)
+    (attempt-irrevocable-sent!
+     envelope
+     ((go message priority)
+      (gc)
+      (list (->bool (message-guard))
+           (->bool (cancel-guard))
+           (->bool (notify-sent-guard))))
+     ((cancelled) (error "cancelled"))
+     ((already-sent) (error "what/cancelled")))))
+
+(test-assert "reference to envelope dropped after cancel"
+  (let ((envelope (make-envelope (lambda () 'ok) *msg*))
+       (envelope-guard (make-guardian)))
+    (envelope-guard envelope)
+    (attempt-cancel!
+     envelope
+     ((now-cancelled)
+      (gc)
+      (list (->bool (envelope-guard))))
+     ((already-cancelled) (error "what/cancelled"))
+     ((already-sent) (error "what/sent")))))
+
+(test-assert "reference to envelope dropped after send"
+  (let ((envelope (make-envelope no-cancel! *msg*))
+       (envelope-guard (make-guardian)))
+    (envelope-guard envelope)
+    (attempt-irrevocable-sent!
+     envelope
+     ((go message priority)
+      (gc)
+      (list (->bool (envelope-guard))))
+     ((cancelled) (error "what/cancelled"))
+     ((already-sent) (error "what/sent")))))
+
+(test-end "gc")
+
+(test-begin "arguments")
+
+(define %max-prio (- (expt 2 9) 1))
+
+(test-equal "non-standard priority"
+  %max-prio
+  (attempt-irrevocable-sent!
+   (make-envelope no-cancel! *msg* #:priority %max-prio)
+   ((go message priority) *msg* %max-prio)
+   ((cancelled) (error "what/cancelled"))
+   ((already-sent) (error "what/sent"))))
+(test-error "no negative priority"
+  &assertion
+  (make-envelope no-cancel! *msg* #:priority -1))
+(test-error "no inexact priority"
+  &assertion
+  (make-envelope no-cancel! *msg* #:priority 0.0))
+(test-error "no fractional priority"
+  &assertion
+  (make-envelope no-cancel! *msg* #:priority 5/7))
+(test-error "no overly large priority"
+  &assertion
+  (make-envelope no-cancel! *msg* #:priority 512))
+
+(test-end "arguments")
+
+;; TODO for completeness: test recursion from
+;; the notify-sent! callback and from cancel!
+;; callback and that references are dropped
+;; there as well.

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