diff options
Diffstat (limited to 'tests/run.scm')
| -rw-r--r-- | tests/run.scm | 287 |
1 files changed, 287 insertions, 0 deletions
diff --git a/tests/run.scm b/tests/run.scm new file mode 100644 index 0000000..722d6e3 --- /dev/null +++ b/tests/run.scm @@ -0,0 +1,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) |