(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)