blob: d124554f2d1272bda8bd86326a2735d908a2beb8 (
plain)
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
|
(import (chicken condition) (chicken format) (chicken io)
(chicken process-context) (chicken process-context posix)
(chicken tcp) (chicken process) (chicken file posix)
uri-common intarweb srfi-18)
(cond-expand
(chicken-6)
(else (define read-bytevector read-string)))
(server-port (string->number
(or (get-environment-variable "SPIFFY_TEST_PORT") "8080")))
(define (check-port)
(let ((listener #f)
(msg (sprintf "Checking port ~A is available" (server-port))))
(handle-exceptions exn (void)
(set! listener (tcp-listen (server-port))))
(test-assert msg (tcp-listener? listener))
(tcp-close listener)))
(define spiffy-pid #f)
(define (can-connect?)
(handle-exceptions exn #f
(receive (in out)
(tcp-connect "127.0.0.1" (server-port))
(close-input-port in)
(close-output-port out)
#t)))
(define (wait-for-spiffy times)
(if (zero? times)
#f
(begin (thread-sleep! 1) (or (can-connect?) (wait-for-spiffy (sub1 times))))))
(define NOT-FOUND "file not found")
(define (send-string/code code reason string)
(current-response
(update-response (current-response)
code: code reason: reason))
(write-logged-response)
(display string (response-port (current-response))))
(define response-error? #f)
(define (start-spiffy)
(check-port)
(set! spiffy-pid
(process-fork
(lambda ()
(parameterize ((root-path "./testweb")
(error-log (get-environment-variable "SPIFFY_ERROR_LOG"))
(handle-not-found
(lambda (p)
(send-string/code 404 "Not found" NOT-FOUND)))
(handle-exception
(lambda (exn chain)
(let ((m ((condition-property-accessor 'exn 'message) exn))
(a ((condition-property-accessor 'exn 'arguments) exn)))
(log-to (error-log) (build-error-message exn chain #t))
(set! response-error? #t)
(send-string/code 500 "Internal server error"
(if (and a (not (null? a)))
(sprintf "~A ~A" m a)
m))))))
(start-server)))))
(on-exit (lambda _ (process-signal spiffy-pid)))
(test-assert "Spiffy responds in 3 seconds" (wait-for-spiffy 3))
(void))
;;;; test tools
(define (fetch-file file host #!key (send-headers `((host (,host . ,(server-port))))) (get-headers #f) (version '(1 0)) (method 'GET) (absolute-uri #t) (binary #f))
(set! response-error? #f)
(let ((uri (uri-reference (if absolute-uri
(sprintf "http://~A:~A~A" host (server-port) file)
file))))
(receive (in out)
(tcp-connect "127.0.0.1" (server-port))
(let* ((req-headers (headers send-headers))
(req (make-request method: method uri: uri
major: (car version) minor: (cadr version)
headers: req-headers port: out)))
(write-request req)
(let* ((resp (read-response in))
(str ((if binary read-bytevector read-string)
(header-value 'content-length (response-headers resp)) in)))
(close-output-port out)
(close-input-port in)
(if get-headers
(response-headers resp)
(list (response-code resp) str)))))))
(define-syntax test-response
(syntax-rules ()
((_ ?text (?code-expected ?contents-expected) ?args ...)
(test ?text (list ?code-expected ?contents-expected) (fetch-file ?args ...)))
((_ ?text ?code-expected ?args ...)
(test ?text ?code-expected (car (fetch-file ?args ...))))))
(define-syntax test-binary-response
(syntax-rules ()
((_ ?text (?code-expected ?contents-expected) ?args ...)
(test ?text (list ?code-expected ?contents-expected) (fetch-file ?args ... binary: #t)))
((_ ?text ?code-expected ?args ...)
(test ?text ?code-expected (car (fetch-file ?args ... binary: #t))))))
(define-syntax test-header
(syntax-rules ()
((_ ?text ?header-name (?header-values ...) ?args ...)
(test ?text `(?header-values ...)
(header-values `?header-name
(fetch-file ?args ... get-headers: #t))))))
;; Create an uri for this test server, which is needed because its
;; port may be overridden.
(define (testserver-uri str)
(let ((ref (uri-reference str)))
(update-uri ref port: (server-port))))
|
