source: project/release/4/spiffy/trunk/tests/run.scm @ 18086

Last change on this file since 18086 was 18086, checked in by sjamaan, 11 years ago

Fix problem with host & port in URI when serving behind a proxy (it used the server's actual port instead of the port the request came in on). Thanks to zbigniew, again :)

File size: 9.9 KB
Line 
1(require-extension test)
2
3(load "../spiffy.scm")
4
5(import spiffy regex)
6
7(test-begin "spiffy")
8
9(load "testlib")
10
11(define noway "No way, Jose!")
12
13(define counter 0)
14
15(define (myscript-handler path)
16  (write-logged-response)
17  (display "script!" (response-port (current-response))))
18
19(parameterize
20    ((default-mime-type 'application/unknown)
21     (handle-directory (lambda (p) (send-string/code 403 "Forbidden" "forbidden")))
22     (file-extension-handlers `(("myscript" . ,myscript-handler)))
23     (access-file "spiffy-access")
24     (vhost-map
25      `(("foohost" . , (lambda (continue)
26                         (continue)))
27        (,(regexp "testhost.*") . ,(lambda (continue)
28                                     (continue)))
29        ("redirect-host" . ,(lambda (continue)
30                              (with-headers
31                                  `((location ,(update-uri
32                                                (server-root-uri)
33                                                path: '(/ "move-along"))))
34                                (lambda ()
35                                  (send-status 303 "Moved")))))
36        ("error-host" . ,(lambda (continue)
37                           (error "This should give a 500 error")))
38        ("unknown-length-host" . ,(lambda (continue)
39                                    (write-logged-response)
40                                    (let ((p (response-port (current-response))))
41                                      (display "foo" p)
42                                      (close-output-port p))))
43        ("subdir-host" . ,(lambda (continue)
44                            (parameterize ((root-path "./testweb/subdir"))
45                              (continue)))))))
46  (start-spiffy))
47
48(define hello.txt (with-input-from-file "testweb/hello.txt" read-string))
49
50(test-begin "vhost support")
51(test "String match" `(200 ,hello.txt) (fetch-file "hello.txt" "foohost"))
52(test "String case insensitivity" `(200 ,hello.txt) (fetch-file "hello.txt" "FOOHOST"))
53(test "Regexp match" `(200 ,hello.txt) (fetch-file "hello.txt" "testhost"))
54(test "Regexp case sensitivity" `(404 ,NOT-FOUND) (fetch-file "hello.txt" "TESTHOST"))
55(test "Nonexistent host name" `(404 ,NOT-FOUND) (fetch-file "hello.txt" "call-with-previous-continuation.org"))
56(test "No host on HTTP/1.0 works" `(200 ,hello.txt) (fetch-file "hello.txt" "foohost" send-headers: '()))
57(test "No host on HTTP/1.1 gives error" 400 (car (fetch-file "hello.txt" "foohost" send-headers: '() version: '(1 1))))
58(test-end "vhost support")
59
60(define chicken-logo.png (with-input-from-file "testweb/pics/chicken-logo.png" read-string))
61(define lambda-chicken.gif (with-input-from-file "testweb/pics/lambda-chicken.gif" read-string))
62(define index.html (with-input-from-file "testweb/index.html" read-string))
63(define index-subdir (with-input-from-file "testweb/subdir/index.html" read-string))
64(define index-subsubdir (with-input-from-file "testweb/subdir/subsubdir/index.html" read-string))
65
66(test-begin "static file serving")
67(test "Nonexistant file" `(404 ,NOT-FOUND) (fetch-file "bogus" "testhost"))
68(test "Nonexistant file mimetype" 'text/html (header-value 'content-type (fetch-file "bogus" "testhost" get-headers: #t)))
69(test "Nonexistant file with extension" `(404 ,NOT-FOUND) (fetch-file "bogus.gif" "testhost"))
70(test "Nonexistant file with extension mimetype" 'text/html (header-value 'content-type (fetch-file "bogus.gif" "testhost" get-headers: #t)))
71(test "text/plain mimetype" 'text/plain (header-value 'content-type (fetch-file "hello.txt" "testhost" get-headers: #t)))
72(test "image/gif mimetype" 'image/gif (header-value 'content-type (fetch-file "pics/lambda-chicken.gif" "testhost" get-headers: #t)))
73(test "image/gif contents" `(200 ,lambda-chicken.gif) (fetch-file "pics/lambda-chicken.gif" "testhost"))
74(test "image/png mimetype" 'image/png (header-value 'content-type (fetch-file "pics/chicken-logo.png" "testhost" get-headers: #t)))
75(test "image/png contents" `(200 ,chicken-logo.png)  (fetch-file "pics/chicken-logo.png" "testhost"))
76(test "unknown mimetype" 'application/unknown (header-value 'content-type (fetch-file "data" "testhost" get-headers: #t)))
77(test "'Moved Permanently' on directory" 301 (car (fetch-file "pics" "testhost")))
78(test "location URI is absolute" "http://testhost:8080/pics/"
79      (uri->string (header-value 'location (fetch-file "pics" "testhost" get-headers: #t absolute-uri: #f))))
80(test "directory listing denied" `(403 ,"forbidden") (fetch-file "pics/" "testhost"))
81(test-end "static file serving")
82
83(test-begin "path normalization")
84(test "index page redir" '(/ "subdir" "") (uri-path (header-value 'location (fetch-file "/subdir" "testhost" get-headers: #t))))
85(test "index page redir preserves GET args" '((foo . "bar")) (uri-query (header-value 'location (fetch-file "/subdir?foo=bar" "testhost" get-headers: #t))))
86(test "index page redir status" 301 (car (fetch-file "/subdir" "testhost")))
87(test "index page" `(200 ,index-subdir) (fetch-file "/subdir/" "testhost"))
88(test "break out of webroot fails" `(200 ,index-subdir) (fetch-file "/subdir/../../subdir/" "testhost"))
89(test "index page in subdir vhost" `(200 ,index-subdir) (fetch-file "/" "subdir-host"))
90(test "index page redir for subdir vhost" '(/ "subsubdir" "") (uri-path (header-value 'location (fetch-file "/subsubdir" "subdir-host" get-headers: #t))))
91(test "index page redir status for subdir vhost" `301 (car (fetch-file "/subsubdir" "subdir-host")))
92(test "index page in subdir for subdir vhost" `(200 ,index-subsubdir) (fetch-file "/subsubdir/" "subdir-host"))
93(test "break out of vhost webroot gives index of root" `(200 ,index-subsubdir) (fetch-file "/subsubdir/../../subsubdir/" "subdir-host"))
94(test "break out of vhost webroot fails" `(404 ,NOT-FOUND) (fetch-file "../hello.txt" "subdir-host"))
95(test "Null-terminated filename fails" `(404 ,NOT-FOUND) (fetch-file "hello.txt%00xyz" "testhost"))
96(test "encoded break out of vhost webroot fails" `(404 ,NOT-FOUND) (fetch-file "%2e%2e%2fhello.txt" "subdir-host"))
97(test-end "path normalization")
98
99(test-begin "access files")
100(set! counter 0)
101(test "Two slashes" `(200 ,index-subdir) (fetch-file "subdir//" "testhost"))
102(test "After two slashes, counter is 1" 1 counter)
103(test "Dir request" `(200 ,noway) (fetch-file "secrets" "testhost")) ;; Access file applies on dir and all below
104(test "File request in dir" `(200 ,noway) (fetch-file "secrets/password.txt" "testhost"))
105(test "Subdir request" `(200 ,noway) (fetch-file "secrets/bank" "testhost"))
106(test "File request in subdir" `(200 ,noway) (fetch-file "secrets/bank/pin-code.txt" "testhost"))
107(test-end "access files")
108
109(test-begin "miscellaneous")
110(test "custom extension handlers" `(200 "script!") (fetch-file "test.myscript" "testhost"))
111(test "redirect" 303 (car (fetch-file "blah" "redirect-host")))
112(test "redirect location" (uri-reference "http://redirect-host:8080/move-along") (header-value 'location (fetch-file "blah" "redirect-host" get-headers: #t)))
113(test "redirect for simulated proxy (other port)" (uri-reference "http://redirect-host:8081/move-along") (header-value 'location (fetch-file "blah" "redirect-host" get-headers: #t send-headers: `((host ("redirect-host" . 8081))) absolute-uri: #f)))
114(test "internal error" `(500 ,EXN) (fetch-file "cause-error" "error-host"))
115(test "Variable length (no content-length header)" `(200 "foo") (fetch-file "whatever" "unknown-length-host"))
116(test-assert "Variable length didn't cause error after response was sent" (not response-error?))
117(test-end "miscellaneous")
118
119(test-begin "Caching and other efficiency support")
120(test-begin "If-Modified-Since/If-None-Match support")
121(with-output-to-file "testweb/testfile.txt" (lambda () (display "Testing\n")))
122(define timestamp (seconds->utc-time (current-seconds)))
123(test "If-Modified-Since when not modified"
124      `(304 "") ;; Should return 304 status, but also empty body
125      (fetch-file "testfile.txt" "testhost"
126                  send-headers: `((host ("testhost" . ,(server-port)))
127                                  (if-modified-since #(,timestamp ())))))
128(define original-etag
129  (header-value
130   'etag
131   (fetch-file "testfile.txt" "testhost"
132               get-headers: #t
133               send-headers: `((host ("testhost" . ,(server-port)))))))
134(test "If-None-Match when not modified"
135      `(304 "") ;; Should return 304 status, but also empty body
136      (fetch-file "testfile.txt" "testhost"
137                  send-headers: `((host ("testhost" . ,(server-port)))
138                                  (if-none-match ,original-etag))))
139(sleep 1)
140(with-output-to-file "testweb/testfile.txt" (lambda () (display "Testing2\n")))
141(test "If-Modified-Since when modified"
142      `(200 "Testing2\n")
143      (fetch-file "testfile.txt" "testhost"
144                  send-headers: `((host ("testhost" . ,(server-port)))
145                                  (if-modified-since #(,timestamp ())))))
146(test "If-None-Match when modified"
147      `(200 "Testing2\n")
148      (fetch-file "testfile.txt" "testhost"
149                  send-headers: `((host ("testhost" . ,(server-port)))
150                                  (if-none-match ,original-etag))))
151(let ((h (fetch-file "testfile.txt" "testhost"
152                     get-headers: #t
153                     send-headers: `((host ("testhost" . ,(server-port)))
154                                     (if-modified-since #(,timestamp ()))))))
155  ;; RFC 2616, 10.3.5: Not modified must have date, unless clockless origin
156  (test "Headers contain Date"
157        #t
158        (not (not (header-value 'date h))))
159  ;; RFC 2616, 14.29:
160  ;; "HTTP/1.1 servers SHOULD send Last-Modified whenever feasible"
161  (test "Headers contain Last-Modified"
162        (file-modification-time "testweb/testfile.txt")
163        (utc-time->seconds (header-value 'last-modified h))))
164(delete-file "testweb/testfile.txt") ;; Clean up after the tests
165(test-end)
166(test-begin "HEAD support")
167(test "Regular response has no body"
168      `(200 "")
169      (fetch-file "hello.txt" "testhost" method: 'HEAD))
170(test "Status code responses have no body"
171      `(303 "")
172      (fetch-file "blah" "redirect-host" method: 'HEAD))
173(test-end)
174(test-end)
175
176(test-end)
Note: See TracBrowser for help on using the repository browser.