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.

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.