scheme-gnunet/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 (srfi srfi-8)
  #: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:}#)
  #:autoload (fibers conditions) (make-condition signal-condition! wait)
  #:autoload (fibers timers) (sleep)
  #:autoload (gnu gnunet config db)
  (hash->configuration hash-key key=? set-value!)
  #: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-fallbacks
			     garbage-collectable))

(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)
  (fibers:run-fibers (lambda () (call-with-services service-alist proc))))

(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-fallbacks 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."
  (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)))
		#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)))))