path: root/tests/utils.scm

;; This file is part of scheme-GNUnet.
;; Copyright © 2021, 2022 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
(define-module (tests utils)
  #:use-module (quickcheck)
  #:use-module (quickcheck property)
  #:use-module (quickcheck generator)
  #:use-module (quickcheck arbitrary)
  #:use-module (srfi srfi-8)
  #:use-module (srfi srfi-64)
  #:use-module (ice-9 match)
  #:use-module (ice-9 weak-vector)
  #:use-module ((rnrs hashtables) #:prefix |rnrs:|)
  #:use-module ((rnrs arithmetic bitwise)
		#:select (bitwise-ior))
  #:use-module ((rnrs base) #:select (assert))
  #:use-module ((fibers) #:prefix |fibers:|)
  #:use-module (gnu gnunet utils hat-let)
  #:autoload (fibers conditions) (make-condition signal-condition! wait)
  #:autoload (fibers timers) (sleep)
  #:autoload (gnu gnunet config db)
  (hash->configuration hash-key key=? set-value!)
  #:autoload (gnu gnunet mq error-reporting) (error-reporter)
  #:autoload (gnu gnunet utils bv-slice)
  (slice-readable? slice-writable?)
  #:export (conservative-gc? calls-in-tail-position?
			     call-with-services
			     call-with-services/fibers
			     call-with-spawner
			     call-with-spawner/wait
			     call-with-spawner/wait*
			     call-with-temporary-directory
			     make-nonblocking!
			     call-with-absent-service
			     trivial-service-config
			     |don't-call-me|
			     close-not-connected-no-callbacks
			     garbage-collectable
			     disconnect-after-eof-after-connected
			     reconnects
			     determine-reported-errors
			     test-roundtrip))

(define (make-nonblocking! sock)
  (fcntl sock F_SETFL
	 (bitwise-ior (fcntl sock F_GETFL) O_NONBLOCK)))

;; Current versions of guile (at least 3.0.5) use a conservative
;; garbage collector, so some tests concerning garbage collection
;; 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))

(define (calls-in-tail-position? proc)
  "Does @var{proc} calls its argument in tail position?
Additionally, return the values returned to the argument
of @var{proc} in-order. @var{proc} should not return multiple
times."
  (receive (continuation . arguments)
      (let ((t (make-prompt-tag 'tail-position?)))
	(call-with-prompt t
	  (lambda ()
	    (proc (lambda args (apply abort-to-prompt t args))))
	  (lambda _ (apply values _))))
    (apply values
	   (= 1 (stack-length (make-stack continuation)))
	   arguments)))

;; Some basic checks
(assert (calls-in-tail-position? (lambda (thunk) (thunk))))
;; TODO figure out why these fail ...
#;
(assert (not (calls-in-tail-position? (lambda (thunk) (thunk) 1))))
#;
(assert (not (calls-in-tail-position? (lambda (thunk) (+ 1 (thunk))))))
#;
(assert (not (calls-in-tail-position? (lambda (thunk) (for-each thunk '("bla" "bla"))))))

(define (call-with-temporary-directory proc)
  (let ((file (mkdtemp (in-vicinity (or (getenv "TMPDIR") "/tmp")
				    "test-XXXXXX"))))
    (with-exception-handler
	(lambda (e)
	  (system* "rm" "-r" file)
	  (raise-exception e))
      (lambda ()
	(call-with-values
	    (lambda () (proc file))
	  (lambda the-values
	    (system* "rm" "-r" file)
	    (apply values the-values)))))))

(define (call-with-services service-alist proc)
  "Call the procedure @var{proc} with a configuration database
and a procedure behaving like @code{spawn-fiber}, in an environment
where the services listed in @var{service-alist} can
be connected to.  The heads in @var{service-alist} are the names of
the services and each tails is a list of a procedure accepting ports
(connected to the client) and the procedure behaving like @code{spawn-fiber}."
  (define %thread-table (make-hash-table))
  (define (wrapped-spawn-fiber thunk)
    (define o (list))
    (hashq-set! %thread-table o 'running)
    (fibers:spawn-fiber
     (lambda ()
       (with-exception-handler
	   (lambda (e)
	     (hashq-set! %thread-table o (cons 'exception e))
	     (raise-exception e))
	 thunk)))
    (values))
  (define config (hash->configuration
		  (rnrs:make-hashtable hash-key key=?)))
  (call-with-temporary-directory
   (lambda (dir)
     (define (start-service key+value)
       (define where (in-vicinity dir (string-append (car key+value) ".sock")))
       (set-value! identity config (car key+value) "UNIXPATH" where)
       (wrapped-spawn-fiber
	(lambda ()
	  (define sock (socket AF_UNIX SOCK_STREAM 0))
	  (bind sock AF_UNIX where)
	  (listen sock 40)
	  (make-nonblocking! sock)
	  (let loop ()
	    (define client-sock
	      (car (accept sock (logior SOCK_NONBLOCK
					SOCK_CLOEXEC))))
	    (wrapped-spawn-fiber
	     (lambda ()
	       ((cdr key+value) client-sock wrapped-spawn-fiber)))
	    (loop)))))
     (for-each start-service service-alist)
     (call-with-values
	 (lambda () (proc config wrapped-spawn-fiber))
       (lambda results
	 ;; Make sure exceptions are visible
	 (hash-for-each (lambda (key value)
			  (match value
			    (('exception . e)
			     (raise-exception e))
			    ('running (values))))
			%thread-table)
	 (apply values results))))))

(define (call-with-services/fibers service-alist proc . rest)
  (apply fibers:run-fibers
	 (lambda () (call-with-services service-alist proc)) rest))

(define* (call-with-spawner* proc service-alist . args)
  (apply fibers:run-fibers
	 (lambda ()
	   (call-with-services
	    service-alist
	    proc))
	 args))

(define (call-with-spawner proc . args)
  (apply call-with-spawner* (lambda (config spawn) (proc spawn)) '() args))

;; When done, wait for every fiber to complete.
;; Somewhat racy, don't use outside tests.
(define* (call-with-spawner/wait* proc service-alist . args)
  (define h (make-weak-key-hash-table)) ; condition -> nothing in particular
  (apply call-with-spawner*
	 (lambda (config spawn/not-waiting)
	   (define (spawn thunk)
	     (define done-condition (make-condition))
	     (hashq-set! h done-condition #f)
	     (spawn/not-waiting
	      (lambda ()
		(thunk)
		(signal-condition! done-condition))))
	   (define-values return-values
	     (proc config spawn))
	   ;; Make sure every fiber completes before returning.
	   ;; XXX hash-for-each imposes a continuation barrier
	   (for-each wait (hash-map->list (lambda (x y) x) h))
	   (apply values return-values))
	 service-alist
	 args))

(define (call-with-spawner/wait proc . args)
  (apply call-with-spawner/wait* (lambda (config spawn) (proc spawn)) '() args))

(define (trivial-service-config what where)
  "Make a configuration where the socket location of the @var{what} service
is @var{where}."
  (define config (hash->configuration
		  (rnrs:make-hashtable hash-key key=?)))
  (set-value! identity config what "UNIXPATH" where)
  config)

(define (call-with-absent-service what proc)
  "Call @var{proc} with a configuration in which the @var{what} service
cannot be connected to."
  (call-with-temporary-directory
   (lambda (somewhere)
     ;; Something like "/dev/this-file-does-not-exist" would do as well.
     (define where (in-vicinity somewhere "sock.et"))
     (define config (trivial-service-config what where))
     (proc config))))

(define (|don't-call-me| . rest)
  (error "oops ~a" rest))

(define* (close-not-connected-no-callbacks service connect disconnect!
					   #:key (rest '()))
  "Try to connect to the @var{service} service in an environment where
the service daemon is down.  Verify that the 'connected' and 'disconnected'
callbacks were not called.  Also verify that all spawned fibers exit."
  (call-with-spawner/wait
   (lambda (spawn)
     (call-with-absent-service
      service
      (lambda (config)
	(define server (apply connect config #:spawn spawn
			      #:connected |don't-call-me|
			      #:disconnected |don't-call-me|
			      rest))
	;; Sleep to give the client fibers a chance to mistakenly
	;; call a callback.
	(sleep 0.001)
	(disconnect! server)
	(sleep 0.001)
	#t)))))

(define* (garbage-collectable service connect)
  "Try to connect to the @var{service} service in an an environment where
the service daemon is down.  Verify that the @var{connected} and
@var{disconnected} callbacks were not called.  Also verify that all spawned
fiber exit and the fibers do not keep a reference to the service object."
  (when (eq? connect (@ (guile) connect))
    ;; This has happened in the past.  Let's make the test failure more
    ;; more informative, to avoid having to spend time on investigating
    ;; this in the future.
    (error "you passed Guile's connect procedure, not connect procedure for connecting to the GNUnet service!"))
  (define (test)
    (call-with-spawner/wait
     (lambda (spawn)
       (call-with-absent-service
	service
	(lambda (config)
	  (define reference
	    (weak-vector
	     (connect config #:spawn spawn #:connected |don't-call-me|
		      #:disconnected |don't-call-me|)))
	  ;; Sleep to give the client fibers a chance to mistakenly
	  ;; call a callback and to allow the fibers to actually stop.
	  (let loop ((delay 0.0005))
	    (pk 'loop delay)
	    (gc)
	    (pk 'gced)
	    (sleep delay)
	    (if (weak-vector-ref reference 0)
		;; not yet collected, try again later.
		(and (< delay 2.) (loop (* 2 delay)))
		;; A single (gc) is not sufficient -- the entry in the weak vector
		;; could become #false without it being added to the guardian,
		;; causing the fibers started by the service to not stop yet,
		;; causing hanging tests -- a second (gc) fixes that.
		;;
		;; Seem like an implementation detail, not worth reporting
		;; upstream.
		(begin (gc)
		       #true)))))))) ; it was collected!
  (define n-trials 32)
  (let loop ((successes 0)
	     (trials 0))
    (pk successes trials)
    (if (>= trials n-trials)
	(>= (/ successes trials) (if (conservative-gc?) 8/10 1))
	(loop (if (test) (+ 1 successes) successes) (+ 1 trials)))))

(define (disconnect-after-eof-after-connected service connect)
  "Test that when connected to a sevice and an end-of-file is encountered,
the disconnection callback is called and that the disconnection callback
is called after the connection callback."
  (call-with-services/fibers
   `((,service . ,(lambda (port spawn-fiber)
		    (close-port port))))
   (lambda (config spawn-fiber)
     (define disconnected? #f)
     (define connected? #f)
     (define c (make-condition))
     (define (connected)
       (set! connected? #t))
     (define (disconnected)
       (assert connected?)
       ;; Because (gnu gnunet SERVICE client) automatically reconnects,
       ;; the following commented-out assertion can be false.
       #;(assert (not disconnected?))
       (set! disconnected? #t)
       (signal-condition! c))
     (define server
       (connect config #:spawn spawn-fiber #:connected connected
		#:disconnected disconnected))
     (wait c)
     ;; Give (gnu gnunet SERVICE client) a chance to (incorrectly) call
     ;; disconnected again.
     (sleep 0.001)
     #t)))

(define forever (make-condition))

(define (reconnects service connect)
  "This tests the reconnection logic, by repeatedly closing the
connection from the server side and verifying that the connection
and disconnection callbacks are called in the right order and
sufficiently often."
  (let ((n 9)
	(too-many? #f)
	(done (make-condition)))
    (call-with-services/fibers
     `((,service . ,(lambda (port spawn-fiber)
		      (if (> n 0)
			  (begin
			    (set! n (- n 1))
			    (close-port port))
			  (wait forever)))))
     (lambda (config spawn-fiber)
       (define disconnected? #f)
       (define connected? #f)
       (define connected-again (make-condition))
       (define disconnect-count 0)
       (define (connected)
	 (match (cons disconnected? connected?)
	   ((#t . #f)
	    (set! disconnected? #f)
	    (set! connected? #t)
	    (when (= disconnect-count 9)
	      (signal-condition! connected-again))
	    (values))
	   ((#t . #t) (error "impossible"))
	   ((#f . #f)
	    (set! connected? #t)
	    (values)) ; first connect
	   ((#f . #t) (error "doubly connected"))))
       (define (disconnected)
	 (match (cons connected? disconnected?)
	   ((#t . #f)
	    (set! connected? #f)
	    (set! disconnected? #t)
	    (set! disconnect-count (+ 1 disconnect-count))
	    (cond
	     ((= disconnect-count 9)
	      (signal-condition! done))
	     ((> disconnect-count 9)
	      (set! too-many? #t)
	      (error "too many disconnects")))
	    (values))
	   ((#t . #t) (error "impossible"))
	   ((#f . #f)
	    (error "disconnected before connecting"))
	   ((#f . #t)
	    (error "doubly disconnected"))))
       (define server
	 (connect config #:spawn spawn-fiber #:connected connected
		  #:disconnected disconnected))
       (wait done)
       (assert (not too-many?))
       ;; We used to do (sleep 0.01) here but this was
       ;; (rarely) insufficient.
       (wait connected-again)
       (assert connected?)
       #t))))

(define* (determine-reported-errors service connect proc #:key (n-connections 1) (n-errors 1))
  "This procedure can be used as a basic for the error reporting logic --
it connects to a simulated service, builds a list of errors passed to
@code{error-reporter} and return it.  After a disconnect, it will automatically
reconnect until @var{n-connections} have been made.  It also waits for @var{n-errors}
to be gathered and verifies that all fibers complete.

The simulation is done by the procedure @var{proc}.  It is a procedure accepting the
connection port as seen by the server and can e.g. write to the port or close it."
  (call-with-spawner/wait*
   (lambda (config spawn)
     (define errors '())
     (define currently-connected? #false)
     (define times-connected 0)
     (define times-errored 0)
     (define finally-disconnected-c (make-condition))
     (define all-errors-c (make-condition))
     (parameterize ((error-reporter (lambda foo
				      (assert (> times-connected 0))
				      (set! times-errored (+ 1 times-errored))
				      (set! errors (cons foo errors))
				      (when (>= times-errored n-errors)
					(signal-condition! all-errors-c)))))
       (define (connected)
	 (assert (not currently-connected?))
	 (set! currently-connected? #true)
	 (set! times-connected (+ 1 times-connected))
	 (assert (<= times-connected n-connections)))
       (define (disconnected)
	 (assert currently-connected?)
	 (set! currently-connected? #false)
	 (when (= times-connected n-connections)
	   (signal-condition! finally-disconnected-c)))
       (define server
	 (connect config #:connected connected #:disconnected disconnected
		  #:spawn spawn))
       ;; Give 'error-reporter' a chance to be called too often
       (sleep 0.001)
       ;; The error handler and 'disconnected' are called in no particular
       ;; order, so we have to wait for both.
       (wait finally-disconnected-c)
       (wait all-errors-c)
       ;; keep 'server' reachable long enough.
       (pk server)
       (and (not currently-connected?)
	    (= times-connected n-connections) errors)))
   `((,service . ,proc))))

;; TODO export
(define make-property (@@ (quickcheck property) make-property))

(define (round-trip-property analyse construct normalise names gen/arbs)
  (make-property
   names gen/arbs
   (lambda expected
     (let^ ((! constructed (apply construct expected))
	    (<-- analysed (analyse constructed))
	    (! analysed (normalise analysed)))
	   (and (slice-readable? constructed)
		(slice-writable? constructed)
		(equal? expected analysed))))))

;; This test construct network messages by generating @var{name} ...
;; with the quickcheck arbitraries @var{$arbitrary} ...
;; and passing them to the construction procedure
;; @var{construct}.  @var{testcase} is the name of this test.
;;
;; TODO: don't assume @code{equal?} / normalisation
;; and explain why.  TODO document construct/analyse
;; pattern.
(define-syntax-rule
  (test-roundtrip testcase analyse construct normalise
		  (name $arbitrary) ...)
  (test-assert testcase
    (quickcheck (round-trip-property analyse construct normalise
				     '(name ...)
				     (list $arbitrary ...)))))