scheme-gnunet/tests/repeated-condition.scm

;; This file is part of scheme-GNUnet.
;; 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

(import (gnu gnunet concurrency repeated-condition)
        (gnu gnunet utils hat-let)
        (fibers operations)
        (fibers conditions)
        (fibers timers)
	(fibers)
	(srfi srfi-43))

;; Copied from 'tests/update.scm'.
;; TODO abstract this?
(define expected-blocking-operation
  (wrap-operation (sleep-operation 1e-4)
		  (lambda () 'blocking)))

;; First some basic sequential tests, ignoring memory ordering
;; issues and other concurrency.

(test-begin "repeated condition")

(test-assert "repeated conditions are condition?"
  (repeated-condition? (make-repeated-condition)))

(test-equal "initially, await-trigger! blocks"
  '(blocking)
  (let^ ((<-- (rcvar) (make-repeated-condition))
	 (<-- (operation) (prepare-await-trigger! rcvar)))
	(call-with-values
	    (lambda ()
	      (perform-operation
	       (choice-operation operation expected-blocking-operation)))
	  list)))

(test-assert "trigger-condition! & await-trigger! completes, sequential"
  (let^ ((<-- (rcvar) (make-repeated-condition))
	 (<-- () (trigger-condition! rcvar))
	 (<-- () (await-trigger! rcvar)))
	#t))

(test-assert "likewise, but multiple times"
  (let^ ((<-- (rcvar) (make-repeated-condition))
	 (/o/ loop (todo 10))
	 (<-- () (trigger-condition! rcvar))
	 (<-- () (await-trigger! rcvar))
	 (? (> todo 1)
	    (loop (- todo 1))))
	#t))

(test-assert "likewise, but prepare awaiting the trigger before triggering"
  (let^ ((<-- (rcvar) (make-repeated-condition))
	 (<-- (operation) (prepare-await-trigger! rcvar))
	 (<-- () (trigger-condition! rcvar))
	 (<-- () (perform-operation operation)))
	#t))

;; This is a departure from fiber's conditions:
;; ‘repeated conditions’ are re-usable.

(test-equal "await-trigger! hangs the second time (without trigger-condition!)"
  '(blocking)
  (let^ ((<-- (rcvar) (make-repeated-condition))
	 (<-- () (trigger-condition! rcvar))
	 (<-- () (await-trigger! rcvar))
	 (<-- (operation) (prepare-await-trigger! rcvar)))
	(call-with-values
	    (lambda ()
	      (perform-operation
	       (choice-operation operation expected-blocking-operation)))
	  list)))

;; Now some concurrency tests.
;;
;; This test was meant to detect the absence of
;;   (? (not next-old) (spin next-old)))
;;
;; but I didn't ever notice 'spin' being run.
;; (Try adding a 'pk' before 'spin').
(test-assert "concurrent ping pong completes"
  (let^ ((! n/games 400)
	 (! n/rounds 500)
	 (! game/done?
	    (vector-unfold (lambda (_) (make-condition)) n/games))
	 (! start? (make-condition))
	 (! (run-game done?)
	    ;; In each round, concurrently ‘await’
	    ;; and ‘trigger’ the condition.  The result
	    ;; should be that the round eventually
	    ;; is completed.
	    (let^ ((! rcvar (make-repeated-condition))
		   (/o/ loop (round 0))
		   (! (next-round) (loop (+ round 1)))
		   (? (= round n/rounds)
		      (signal-condition! done?))
		   (! start-round? (make-condition))
		   (! awaiter-done? (make-condition))
		   (! trigger-done? (make-condition))
		   (<-- ()
			(spawn-fiber
			 (lambda ()
			   (wait start-round?)
			   (await-trigger! rcvar)
			   (signal-condition! awaiter-done?))))
		   (<-- ()
			(spawn-fiber
			 (lambda ()
			   (wait start-round?)
			   (trigger-condition! rcvar)
			   (signal-condition! trigger-done?))))
		   (<-- (_) (signal-condition! start-round?))
		   (<-- () (wait awaiter-done?))
		   (<-- () (wait trigger-done?)))
		  (next-round)))
	 (! (spawn-game _ done?)
	    (spawn-fiber
	     (lambda ()
	       (wait start?)
	       (run-game done?)))))
	(run-fibers
	 (lambda ()
	   (vector-for-each spawn-game game/done?)
	   (signal-condition! start?)
	   (vector-for-each (lambda (_ c) (wait c)) game/done?)
	   #t)
	 #:hz 6000)))

(test-end "repeated condition")