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

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

Fix #266

File size: 10.1 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(define index-subdir-with-space (with-input-from-file "testweb/subdir with space/index.html" read-string))
66
67
68(test-begin "static file serving")
69(test "Nonexistant file" `(404 ,NOT-FOUND) (fetch-file "bogus" "testhost"))
70(test "Nonexistant file mimetype" 'text/html (header-value 'content-type (fetch-file "bogus" "testhost" get-headers: #t)))
71(test "Nonexistant file with extension" `(404 ,NOT-FOUND) (fetch-file "bogus.gif" "testhost"))
72(test "Nonexistant file with extension mimetype" 'text/html (header-value 'content-type (fetch-file "bogus.gif" "testhost" get-headers: #t)))
73(test "text/plain mimetype" 'text/plain (header-value 'content-type (fetch-file "hello.txt" "testhost" get-headers: #t)))
74(test "image/gif mimetype" 'image/gif (header-value 'content-type (fetch-file "pics/lambda-chicken.gif" "testhost" get-headers: #t)))
75(test "image/gif contents" `(200 ,lambda-chicken.gif) (fetch-file "pics/lambda-chicken.gif" "testhost"))
76(test "image/png mimetype" 'image/png (header-value 'content-type (fetch-file "pics/chicken-logo.png" "testhost" get-headers: #t)))
77(test "image/png contents" `(200 ,chicken-logo.png)  (fetch-file "pics/chicken-logo.png" "testhost"))
78(test "unknown mimetype" 'application/unknown (header-value 'content-type (fetch-file "data" "testhost" get-headers: #t)))
79(test "'Moved Permanently' on directory" 301 (car (fetch-file "pics" "testhost")))
80(test "location URI is absolute" "http://testhost:8080/pics/"
81      (uri->string (header-value 'location (fetch-file "pics" "testhost" get-headers: #t absolute-uri: #f))))
82(test "directory listing denied" `(403 ,"forbidden") (fetch-file "pics/" "testhost"))
83(test-end "static file serving")
84
85(test-begin "path normalization")
86(test "index page redir" '(/ "subdir with space" "") (uri-path (header-value 'location (fetch-file "/subdir%20with%20space" "testhost" get-headers: #t))))
87(test "index page redir preserves GET args" '((foo . "bar")) (uri-query (header-value 'location (fetch-file "/subdir%20with%20space?foo=bar" "testhost" get-headers: #t))))
88(test "index page redir status" 301 (car (fetch-file "/subdir%20with%20space" "testhost")))
89(test "index page" `(200 ,index-subdir-with-space) (fetch-file "/subdir%20with%20space/" "testhost"))
90(test "break out of webroot fails" `(200 ,index-subdir) (fetch-file "/subdir/../../subdir/" "testhost"))
91(test "index page in subdir vhost" `(200 ,index-subdir) (fetch-file "/" "subdir-host"))
92(test "index page redir for subdir vhost" '(/ "subsubdir" "") (uri-path (header-value 'location (fetch-file "/subsubdir" "subdir-host" get-headers: #t))))
93(test "index page redir status for subdir vhost" `301 (car (fetch-file "/subsubdir" "subdir-host")))
94(test "index page in subdir for subdir vhost" `(200 ,index-subsubdir) (fetch-file "/subsubdir/" "subdir-host"))
95(test "break out of vhost webroot gives index of root" `(200 ,index-subsubdir) (fetch-file "/subsubdir/../../subsubdir/" "subdir-host"))
96(test "break out of vhost webroot fails" `(404 ,NOT-FOUND) (fetch-file "../hello.txt" "subdir-host"))
97(test "Null-terminated filename fails" `(404 ,NOT-FOUND) (fetch-file "hello.txt%00xyz" "testhost"))
98(test "encoded break out of vhost webroot fails" `(404 ,NOT-FOUND) (fetch-file "%2e%2e%2fhello.txt" "subdir-host"))
99(test-end "path normalization")
100
101(test-begin "access files")
102(set! counter 0)
103(test "Two slashes" `(200 ,index-subdir) (fetch-file "subdir//" "testhost"))
104(test "After two slashes, counter is 1" 1 counter)
105(test "Dir request" `(200 ,noway) (fetch-file "secrets" "testhost")) ;; Access file applies on dir and all below
106(test "File request in dir" `(200 ,noway) (fetch-file "secrets/password.txt" "testhost"))
107(test "Subdir request" `(200 ,noway) (fetch-file "secrets/bank" "testhost"))
108(test "File request in subdir" `(200 ,noway) (fetch-file "secrets/bank/pin-code.txt" "testhost"))
109(test-end "access files")
110
111(test-begin "miscellaneous")
112(test "custom extension handlers" `(200 "script!") (fetch-file "test.myscript" "testhost"))
113(test "redirect" 303 (car (fetch-file "blah" "redirect-host")))
114(test "redirect location" (uri-reference "http://redirect-host:8080/move-along") (header-value 'location (fetch-file "blah" "redirect-host" get-headers: #t)))
115(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)))
116(test "internal error" `(500 ,EXN) (fetch-file "cause-error" "error-host"))
117(test "Variable length (no content-length header)" `(200 "foo") (fetch-file "whatever" "unknown-length-host"))
118(test-assert "Variable length didn't cause error after response was sent" (not response-error?))
119(test-end "miscellaneous")
120
121(test-begin "Caching and other efficiency support")
122(test-begin "If-Modified-Since/If-None-Match support")
123(with-output-to-file "testweb/testfile.txt" (lambda () (display "Testing\n")))
124(define timestamp (seconds->utc-time (current-seconds)))
125(test "If-Modified-Since when not modified"
126      `(304 "") ;; Should return 304 status, but also empty body
127      (fetch-file "testfile.txt" "testhost"
128                  send-headers: `((host ("testhost" . ,(server-port)))
129                                  (if-modified-since #(,timestamp ())))))
130(define original-etag
131  (header-value
132   'etag
133   (fetch-file "testfile.txt" "testhost"
134               get-headers: #t
135               send-headers: `((host ("testhost" . ,(server-port)))))))
136(test "If-None-Match when not modified"
137      `(304 "") ;; Should return 304 status, but also empty body
138      (fetch-file "testfile.txt" "testhost"
139                  send-headers: `((host ("testhost" . ,(server-port)))
140                                  (if-none-match ,original-etag))))
141(sleep 1)
142(with-output-to-file "testweb/testfile.txt" (lambda () (display "Testing2\n")))
143(test "If-Modified-Since when modified"
144      `(200 "Testing2\n")
145      (fetch-file "testfile.txt" "testhost"
146                  send-headers: `((host ("testhost" . ,(server-port)))
147                                  (if-modified-since #(,timestamp ())))))
148(test "If-None-Match when modified"
149      `(200 "Testing2\n")
150      (fetch-file "testfile.txt" "testhost"
151                  send-headers: `((host ("testhost" . ,(server-port)))
152                                  (if-none-match ,original-etag))))
153(let ((h (fetch-file "testfile.txt" "testhost"
154                     get-headers: #t
155                     send-headers: `((host ("testhost" . ,(server-port)))
156                                     (if-modified-since #(,timestamp ()))))))
157  ;; RFC 2616, 10.3.5: Not modified must have date, unless clockless origin
158  (test "Headers contain Date"
159        #t
160        (not (not (header-value 'date h))))
161  ;; RFC 2616, 14.29:
162  ;; "HTTP/1.1 servers SHOULD send Last-Modified whenever feasible"
163  (test "Headers contain Last-Modified"
164        (file-modification-time "testweb/testfile.txt")
165        (utc-time->seconds (header-value 'last-modified h))))
166(delete-file "testweb/testfile.txt") ;; Clean up after the tests
167(test-end)
168(test-begin "HEAD support")
169(test "Regular response has no body"
170      `(200 "")
171      (fetch-file "hello.txt" "testhost" method: 'HEAD))
172(test "Status code responses have no body"
173      `(303 "")
174      (fetch-file "blah" "redirect-host" method: 'HEAD))
175(test-end)
176(test-end)
177
178(test-end)
Note: See TracBrowser for help on using the repository browser.