;; 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: AGPL3.0-or-later
(define-module (tests utils)
  #:use-module (srfi srfi-8)
  #:use-module (ice-9 match)
  #: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 (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-temporary-directory
			     make-nonblocking!))

(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 . args)
  (apply fibers:run-fibers
	 (lambda ()
	   (call-with-services
	    '()
	    (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 . args)
  (define h (make-weak-key-hash-table)) ; condition -> nothing in particular
  (apply call-with-spawner
	 (lambda (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 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))
	 args))