scheme-gnunet/tests/envelope.scm

;; This file is part of scheme-GNUnet.
;; Copyright (C) 2021 GNUnet e.V.
;;
;; 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: AGPL-3.0-or-later

(use-modules (ice-9 control)
	     (srfi srfi-26)
	     ((rnrs base) #:select (assert))
	     ((rnrs conditions) #:select (&assertion))
	     (tests utils) ; for conservative-gc?
	     (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.

(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.