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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
|
(import test (chicken irregex) (chicken time) (chicken time posix)
(chicken file) intarweb)
;; Change this to (use spiffy) when compiling tests
(load "../spiffy.scm")
(import spiffy)
(test-begin "spiffy")
(include "testlib.scm")
(define noway "No way, Jose!")
(with-output-to-file "root-counter" (lambda () (write 0)))
(with-output-to-file "counter" (lambda () (write 0)))
(define (myscript-handler path)
(write-logged-response)
(display "script!" (response-port (current-response))))
(parameterize
((default-mime-type 'application/unknown)
(handle-directory (lambda (p) (send-string/code 403 "Forbidden" "forbidden")))
(file-extension-handlers `(("myscript" . ,myscript-handler)))
(access-file "spiffy-access")
(trusted-proxies '("127.0.0.1" "10.0.0.1"))
(vhost-map
`(("foohost" . , (lambda (continue)
(parameterize ((current-request
(update-request
(current-request)
uri: (update-uri
(request-uri (current-request))
path: '(/ "hello.txt")))))
(continue))))
(,(irregex "testhost.*") . ,(lambda (continue)
(continue)))
("redirect-host" . ,(lambda (continue)
(with-headers
`((location ,(update-uri
(request-uri (current-request))
path: '(/ "move-along"))))
(lambda ()
(send-status 303 "Moved")))))
("error-host" . ,(lambda (continue)
(error "This should give a 500 error")))
("unknown-length-host" . ,(lambda (continue)
(write-logged-response)
(let ((p (response-port (current-response))))
(display "foo" p)
(close-output-port p))))
("subdir-host" . ,(lambda (continue)
(parameterize ((root-path "./testweb/subdir"))
(continue))))
("ip-host" . ,(lambda (continue)
(send-string/code 200 "OK" (remote-address)))))))
(start-spiffy))
(define hello.txt (with-input-from-file "testweb/hello.txt" read-string))
(test-begin "vhost support")
(test-response "String match" (200 hello.txt) "/hello.txt" "foohost")
(test-response "String case insensitivity" (200 hello.txt)
"/hello.txt" "FOOHOST")
(test-response "URI override works" (200 hello.txt) "/index.html" "foohost")
(test-response "Regexp match" (200 hello.txt) "/hello.txt" "testhost")
(test-response "Regexp case sensitivity" (404 NOT-FOUND) "/hello.txt" "TESTHOST")
(test-response "Nonexistent host name" (404 NOT-FOUND)
"/hello.txt" "call-with-previous-continuation.org")
(test-response "No host on HTTP/1.0 works" (200 hello.txt)
"/hello.txt" "foohost" send-headers: '())
(test-response "No host on HTTP/1.1 gives error" 400
"/hello.txt" "foohost" send-headers: '() version: '(1 1)
absolute-uri: #f)
(test-end "vhost support")
(define chicken-logo.png (with-input-from-file "testweb/pics/chicken-logo.png" read-string))
(define lambda-chicken.gif (with-input-from-file "testweb/pics/lambda-chicken.gif" read-string))
(define index.html (with-input-from-file "testweb/index.html" read-string))
(define index-subdir (with-input-from-file "testweb/subdir/index.html" read-string))
(define index-subsubdir (with-input-from-file "testweb/subdir/subsubdir/index.html" read-string))
(define index-subdir-with-space (with-input-from-file "testweb/subdir with space/index.html" read-string))
(test-begin "static file serving")
(test-response "Nonexistant file" (404 NOT-FOUND)
"/bogus" "testhost")
(unless (zero? (current-user-id)) ; Root can read even unreadable files :)
(let ((old-perm (file-permissions "testweb/denied.txt")))
(set-file-permissions! "testweb/denied.txt" 0)
(test-response "Forbidden file" 403 "/denied.txt" "testhost")
(set-file-permissions! "testweb/denied.txt" old-perm)))
(test-header "Nonexistant file mimetype" content-type (text/html)
"/bogus" "testhost")
(test-response "Nonexistant file with extension" (404 NOT-FOUND)
"/bogus.gif" "testhost")
(test-header "Nonexistant file with extension mimetype" content-type (text/html)
"/bogus.gif" "testhost")
(test-header "text/plain mimetype" content-type (text/plain)
"/hello.txt" "testhost")
(test-header "image/gif mimetype" content-type (image/gif)
"/pics/lambda-chicken.gif" "testhost")
(test-response "image/gif contents" (200 lambda-chicken.gif)
"/pics/lambda-chicken.gif" "testhost")
(test-header "image/png mimetype" content-type (image/png)
"/pics/chicken-logo.png" "testhost")
(test-response "image/png contents" (200 chicken-logo.png)
"/pics/chicken-logo.png" "testhost")
(test-header "unknown mimetype" content-type (application/unknown)
"/data" "testhost")
(test-response "'Moved Permanently' on directory" 301 "/pics" "testhost")
(test-header "location URI is absolute" location
(,(testserver-uri "http://testhost/pics/"))
"/pics" "testhost" absolute-uri: #f)
(test-response "directory listing denied" (403 "forbidden")
"/pics/" "testhost")
(test-response "non-GET/HEAD method disallowed" 405
"/hello.txt" "testhost" method: 'PUT)
(test-header "non-GET/HEAD method Allow header present" allow (HEAD GET)
"/hello.txt" "testhost" method: 'PUT)
(test-end "static file serving")
(test-begin "path normalization")
(test-header "index page redir" location
(,(testserver-uri "http://testhost/subdir%20with%20space/"))
"/subdir%20with%20space" "testhost")
(test-header "index page redir preserves GET args" location
(,(testserver-uri "http://testhost/subdir%20with%20space/?foo=bar"))
"/subdir%20with%20space?foo=bar" "testhost")
(test-response "index page redir status" 301
"/subdir%20with%20space" "testhost")
(test-response "index page" (200 index-subdir-with-space)
"/subdir%20with%20space/" "testhost")
(test-response "break out of webroot fails" (200 index-subdir)
"/subdir/../../subdir/" "testhost")
;; This doesn't work because it's not accepted by uri-common. One
;; could send it raw on the HTTP line, but it wouldn't be accepted
;; either. Still, it would be good to actually test for this!
#;(test-response "break out of webroot fails w/ backslash"
(400 index-subdir) "/subdir\\..\\../subdir/" "testhost")
(test-response "index page in subdir vhost" (200 index-subdir)
"/" "subdir-host")
(test-header "index page redir for subdir vhost" location
(,(testserver-uri "http://subdir-host/subsubdir/"))
"/subsubdir" "subdir-host")
(test-response "index page redir status for subdir vhost" 301
"/subsubdir" "subdir-host")
(test-response "index page in subdir for subdir vhost" (200 index-subsubdir)
"/subsubdir/" "subdir-host")
(test-response "break out of vhost webroot gives index of root"
(200 index-subsubdir)
"/subsubdir/../../subsubdir/" "subdir-host")
;; Same as above
#;(test-response "break out of vhost webroot fails w/ backslash"
(200 index-subsubdir)
"/subsubdir\\..\\../subsubdir/" "subdir-host")
(test-response "break out of vhost webroot fails w/ backslash" 404
"/subsubdir%5C..%5C../subsubdir/" "subdir-host")
(test-response "break out of vhost webroot fails" (404 NOT-FOUND)
"/../hello.txt" "subdir-host")
;; Once again
#;(test-response "break out of vhost webroot w/ backslash fails"
(404 NOT-FOUND)
"\\..\\hello.txt" "subdir-host")
;; But we *can* test it with an encoded backslash
(test-response "break out of vhost webroot w/ backslash fails"
(404 NOT-FOUND)
"/%5C../hello.txt" "subdir-host")
(test-response "Null-terminated filename fails" (404 NOT-FOUND)
"/hello.txt%00xyz" "testhost")
(test-response "encoded break out of vhost webroot fails" (404 NOT-FOUND)
"/%2e%2e%2fhello.txt" "subdir-host")
(test-response "encoded break out of vhost webroot fails w/ backslash"
(404 NOT-FOUND)
"/%5c%2e%2e/hello.txt" "subdir-host")
(test-end "path normalization")
(test-begin "access files")
(with-output-to-file "root-counter" (lambda () (write 0)))
(test-response "Webroot" (200 index.html) "/" "testhost")
(test "After webroot, root-counter is 1"
1 (with-input-from-file "root-counter" read))
(with-output-to-file "counter" (lambda () (write 0)))
(test-response "Two slashes" (200 index-subdir) "/subdir//" "testhost")
(test "After two slashes, counter is 1"
1 (with-input-from-file "counter" read))
(test "After webroot and two slashes, root-counter is 2"
2 (with-input-from-file "root-counter" read))
(test-response "Dir request" (200 noway)
"/secrets" "testhost") ;; Access file applies on dir and all below
(test-response "File request in dir" (200 noway)
"/secrets/password.txt" "testhost")
(test-response "Subdir request" (200 noway)
"/secrets/bank" "testhost")
(test-response "File request in subdir" (200 noway)
"/secrets/bank/pin-code.txt" "testhost")
(test-end "access files")
(test-begin "miscellaneous")
(test-response "custom extension handlers" (200 "script!")
"/test.myscript" "testhost")
(test-response "redirect" 303 "/blah" "redirect-host")
(test-header "redirect location" location
(,(testserver-uri "http://redirect-host/move-along"))
"/blah" "redirect-host")
(test-header "redirect for simulated proxy (other port)" location
;; This uri is an absolute reference elsewhere, NOT on
;; the test server!
(,(uri-reference "http://redirect-host:8081/move-along"))
"/blah" "redirect-host"
send-headers: `((host ("redirect-host" . 8081))) absolute-uri: #f)
;; The exception handler in testlib just dumps the message in response
(test-response "internal error" (500 "This should give a 500 error")
"/cause-error" "error-host")
(test-response "Variable length (no content-length header)" (200 "foo")
"/whatever" "unknown-length-host")
(test-assert "Variable length didn't cause error after response was sent" (not response-error?))
;; We're spoofing forwarded headers on a trusted host. How's that for irony? :)
(test-response "Trusted proxies are stripped when determining IP address"
(200 "10.0.0.2")
"/whats-my-ip" "ip-host"
send-headers: `((x-forwarded-for "10.0.0.2" "10.0.0.1")))
(test-response "Last proxy is used if all nodes are trusted"
(200 "10.0.0.1")
"/whats-my-ip" "ip-host"
send-headers: `((x-forwarded-for "10.0.0.1")))
(test-end "miscellaneous")
(test-begin "Caching and other efficiency support")
(test-begin "If-Modified-Since/If-None-Match support")
(with-output-to-file "testweb/testfile.txt" (lambda () (display "Testing\n")))
(define timestamp (seconds->utc-time (current-seconds)))
(test-response "If-Modified-Since when not modified"
(304 "") ; Should return 304 status, but also empty body
"/testfile.txt" "testhost"
send-headers: `((host ("testhost" . ,(server-port)))
(if-modified-since #(,timestamp ()))))
(define original-etag
(header-value
'etag
(fetch-file "/testfile.txt" "testhost"
get-headers: #t
send-headers: `((host ("testhost" . ,(server-port)))))))
(test-response "If-None-Match when not modified"
(304 "") ; Should return 304 status, but also empty body
"/testfile.txt" "testhost"
send-headers: `((host ("testhost" . ,(server-port)))
(if-none-match ,original-etag)))
(sleep 1)
(with-output-to-file "testweb/testfile.txt" (lambda () (display "Testing2\n")))
(test-response "If-Modified-Since when modified" (200 "Testing2\n")
"/testfile.txt" "testhost"
send-headers: `((host ("testhost" . ,(server-port)))
(if-modified-since #(,timestamp ()))))
(test-response "If-None-Match when modified" (200 "Testing2\n")
"/testfile.txt" "testhost"
send-headers: `((host ("testhost" . ,(server-port)))
(if-none-match ,original-etag)))
(let ((h (fetch-file "/testfile.txt" "testhost"
get-headers: #t
send-headers: `((host ("testhost" . ,(server-port)))
(if-modified-since #(,timestamp ()))))))
;; RFC 2616, 10.3.5: Not modified must have date, unless clockless origin
;; We don't explicitly check against a date because the second might
;; roll over while we're doing the request or other nonsense.
(test "Headers contain Date"
#t
(not (not (header-value 'date h))))
;; RFC 2616, 14.29:
;; "HTTP/1.1 servers SHOULD send Last-Modified whenever feasible"
(test "Headers contain Last-Modified"
(file-modification-time "testweb/testfile.txt")
(utc-time->seconds (header-value 'last-modified h))))
(delete-file "testweb/testfile.txt") ;; Clean up after the tests
(test-end)
(test-begin "HEAD support")
(test-response "Regular response has no body" (200 #!eof)
"/hello.txt" "testhost" method: 'HEAD)
(test-response "Status code responses have no body" (303 #!eof)
"/blah" "redirect-host" method: 'HEAD)
(test-end)
(test-end)
(test-end)
(test-exit)
|
