blob: 220fb967305ef089116b4789e215d5d96e1ca1f5 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
|
;; 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
(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))
|
