From 776d00c6cd7cabc16f13a18eee54fa2f3f36bf21 Mon Sep 17 00:00:00 2001 From: Peter Bex Date: Sun, 29 Jul 2018 19:39:39 +0200 Subject: Port to CHICKEN 5 --- tests/run.scm | 287 +++++++++++++++++++++++++++++ tests/testlib.scm | 108 +++++++++++ tests/testweb/data | 1 + tests/testweb/denied.txt | 1 + tests/testweb/hello.txt | 1 + tests/testweb/index.html | 15 ++ tests/testweb/once.scm | 2 + tests/testweb/pics/chicken-logo.png | Bin 0 -> 24679 bytes tests/testweb/pics/lambda-chicken.gif | Bin 0 -> 1050 bytes tests/testweb/secrets/bank/pin-code.txt | 1 + tests/testweb/secrets/password.txt | 1 + tests/testweb/secrets/spiffy-access | 5 + tests/testweb/spiffy-access | 4 + tests/testweb/subdir with space/index.html | 14 ++ tests/testweb/subdir/index.html | 15 ++ tests/testweb/subdir/spiffy-access | 4 + tests/testweb/subdir/subsubdir/index.html | 15 ++ tests/testweb/test.myscript | 1 + 18 files changed, 475 insertions(+) create mode 100644 tests/run.scm create mode 100644 tests/testlib.scm create mode 100644 tests/testweb/data create mode 100644 tests/testweb/denied.txt create mode 100644 tests/testweb/hello.txt create mode 100644 tests/testweb/index.html create mode 100644 tests/testweb/once.scm create mode 100644 tests/testweb/pics/chicken-logo.png create mode 100644 tests/testweb/pics/lambda-chicken.gif create mode 100644 tests/testweb/secrets/bank/pin-code.txt create mode 100644 tests/testweb/secrets/password.txt create mode 100644 tests/testweb/secrets/spiffy-access create mode 100644 tests/testweb/spiffy-access create mode 100644 tests/testweb/subdir with space/index.html create mode 100644 tests/testweb/subdir/index.html create mode 100644 tests/testweb/subdir/spiffy-access create mode 100644 tests/testweb/subdir/subsubdir/index.html create mode 100644 tests/testweb/test.myscript (limited to 'tests') 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) diff --git a/tests/testlib.scm b/tests/testlib.scm new file mode 100644 index 0000000..f706753 --- /dev/null +++ b/tests/testlib.scm @@ -0,0 +1,108 @@ +(import (chicken condition) (chicken format) (chicken io) + (chicken process-context) (chicken process-context posix) + (chicken tcp) (chicken process) (chicken file posix) + uri-common intarweb srfi-18) + +(server-port (string->number + (or (get-environment-variable "SPIFFY_TEST_PORT") "8080"))) + +(define (check-port) + (let ((listener #f) + (msg (sprintf "Checking port ~A is available" (server-port)))) + (handle-exceptions exn (void) + (set! listener (tcp-listen (server-port)))) + (test-assert msg (tcp-listener? listener)) + (tcp-close listener))) + +(define spiffy-pid #f) + +(define (can-connect?) + (handle-exceptions exn #f + (receive (in out) + (tcp-connect "127.0.0.1" (server-port)) + (close-input-port in) + (close-output-port out) + #t))) + +(define (wait-for-spiffy times) + (if (zero? times) + #f + (begin (thread-sleep! 1) (or (can-connect?) (wait-for-spiffy (sub1 times)))))) + +(define NOT-FOUND "file not found") + +(define (send-string/code code reason string) + (current-response + (update-response (current-response) + code: code reason: reason)) + (write-logged-response) + (display string (response-port (current-response)))) + +(define response-error? #f) + +(define (start-spiffy) + (check-port) + (set! spiffy-pid + (process-fork + (lambda () + (parameterize ((root-path "./testweb") + (error-log (get-environment-variable "SPIFFY_ERROR_LOG")) + (handle-not-found + (lambda (p) + (send-string/code 404 "Not found" NOT-FOUND))) + (handle-exception + (lambda (exn chain) + (let ((m ((condition-property-accessor 'exn 'message) exn)) + (a ((condition-property-accessor 'exn 'arguments) exn))) + (log-to (error-log) (build-error-message exn chain #t)) + (set! response-error? #t) + (send-string/code 500 "Internal server error" + (if (and a (not (null? a))) + (sprintf "~A ~A" m a) + m)))))) + (start-server))))) + (on-exit (lambda _ (process-signal spiffy-pid))) + (test-assert "Spiffy responds in 3 seconds" (wait-for-spiffy 3)) + (void)) + +;;;; test tools + +(define (fetch-file file host #!key (send-headers `((host (,host . ,(server-port))))) (get-headers #f) (version '(1 0)) (method 'GET) (absolute-uri #t)) + (set! response-error? #f) + (let ((uri (uri-reference (if absolute-uri + (sprintf "http://~A:~A~A" host (server-port) file) + file)))) + (receive (in out) + (tcp-connect "127.0.0.1" (server-port)) + (let* ((req-headers (headers send-headers)) + (req (make-request method: method uri: uri + major: (car version) minor: (cadr version) + headers: req-headers port: out))) + (write-request req) + (let* ((resp (read-response in)) + (str (read-string (header-value 'content-length (response-headers resp)) in))) + (close-output-port out) + (close-input-port in) + (if get-headers + (response-headers resp) + (list (response-code resp) str))))))) + +(define-syntax test-response + (syntax-rules () + ((_ ?text (?code-expected ?contents-expected) ?args ...) + (test ?text (list ?code-expected ?contents-expected) (fetch-file ?args ...))) + ((_ ?text ?code-expected ?args ...) + (test ?text ?code-expected (car (fetch-file ?args ...)))))) + +(define-syntax test-header + (syntax-rules () + ((_ ?text ?header-name (?header-values ...) ?args ...) + (test ?text `(?header-values ...) + (header-values `?header-name + (fetch-file ?args ... get-headers: #t)))))) + +;; Create an uri for this test server, which is needed because its +;; port may be overridden. +(define (testserver-uri str) + (let ((ref (uri-reference str))) + (update-uri ref port: (server-port)))) diff --git a/tests/testweb/data b/tests/testweb/data new file mode 100644 index 0000000..1331fda --- /dev/null +++ b/tests/testweb/data @@ -0,0 +1 @@ +This is some data. Who knows what content type it could be? \ No newline at end of file diff --git a/tests/testweb/denied.txt b/tests/testweb/denied.txt new file mode 100644 index 0000000..94e2755 --- /dev/null +++ b/tests/testweb/denied.txt @@ -0,0 +1 @@ +This file should not be accessible (tests ensure that) diff --git a/tests/testweb/hello.txt b/tests/testweb/hello.txt new file mode 100644 index 0000000..270c611 --- /dev/null +++ b/tests/testweb/hello.txt @@ -0,0 +1 @@ +hello, world! diff --git a/tests/testweb/index.html b/tests/testweb/index.html new file mode 100644 index 0000000..4ec1376 --- /dev/null +++ b/tests/testweb/index.html @@ -0,0 +1,15 @@ + + + + This is an index page + + +

An index page

+ +

Hard to believe, but yes, this is an index page. It does not really +provide you with an index of any kind, but it's here to let spiffy's +test know that we loaded the index page even when we simply provided a +directory name with no filename.

+ + \ No newline at end of file diff --git a/tests/testweb/once.scm b/tests/testweb/once.scm new file mode 100644 index 0000000..f725903 --- /dev/null +++ b/tests/testweb/once.scm @@ -0,0 +1,2 @@ +(let ((counter (with-input-from-file "counter" read))) + (with-output-to-file "counter" (lambda () (write (add1 counter))))) diff --git a/tests/testweb/pics/chicken-logo.png b/tests/testweb/pics/chicken-logo.png new file mode 100644 index 0000000..072b068 Binary files /dev/null and b/tests/testweb/pics/chicken-logo.png differ diff --git a/tests/testweb/pics/lambda-chicken.gif b/tests/testweb/pics/lambda-chicken.gif new file mode 100644 index 0000000..5c3ccc7 Binary files /dev/null and b/tests/testweb/pics/lambda-chicken.gif differ diff --git a/tests/testweb/secrets/bank/pin-code.txt b/tests/testweb/secrets/bank/pin-code.txt new file mode 100644 index 0000000..81c545e --- /dev/null +++ b/tests/testweb/secrets/bank/pin-code.txt @@ -0,0 +1 @@ +1234 diff --git a/tests/testweb/secrets/password.txt b/tests/testweb/secrets/password.txt new file mode 100644 index 0000000..a1ddf5c --- /dev/null +++ b/tests/testweb/secrets/password.txt @@ -0,0 +1 @@ +Follow the yellow brick road \ No newline at end of file diff --git a/tests/testweb/secrets/spiffy-access b/tests/testweb/secrets/spiffy-access new file mode 100644 index 0000000..bd6e4e8 --- /dev/null +++ b/tests/testweb/secrets/spiffy-access @@ -0,0 +1,5 @@ +(lambda (continue) + (with-headers `((content-length ,(string-length noway))) + (lambda () + (write-logged-response) + (display noway (response-port (current-response)))))) \ No newline at end of file diff --git a/tests/testweb/spiffy-access b/tests/testweb/spiffy-access new file mode 100644 index 0000000..a4ffff5 --- /dev/null +++ b/tests/testweb/spiffy-access @@ -0,0 +1,4 @@ +(lambda (continue) + (let ((counter (with-input-from-file "root-counter" read))) + (with-output-to-file "root-counter" (lambda () (write (add1 counter))))) + (continue)) diff --git a/tests/testweb/subdir with space/index.html b/tests/testweb/subdir with space/index.html new file mode 100644 index 0000000..0d97655 --- /dev/null +++ b/tests/testweb/subdir with space/index.html @@ -0,0 +1,14 @@ + + + + This is an index page in a subdir with a space + + +

An index page

+ +

This is here to test whether Spiffy can handle redirects to URLs +with spaces (and more generally, encoding of special URI chars) +correctly.

+ + diff --git a/tests/testweb/subdir/index.html b/tests/testweb/subdir/index.html new file mode 100644 index 0000000..8fecc46 --- /dev/null +++ b/tests/testweb/subdir/index.html @@ -0,0 +1,15 @@ + + + + This is an index page in a subdir + + +

An index page

+ +

Hard to believe, but yes, this is an index page in a subdir. +It does not really provide you with an index of any kind, but it's +here to let spiffy's test know that we loaded the index page even +when we simply provided a directory name with no filename.

+ + diff --git a/tests/testweb/subdir/spiffy-access b/tests/testweb/subdir/spiffy-access new file mode 100644 index 0000000..265eb7b --- /dev/null +++ b/tests/testweb/subdir/spiffy-access @@ -0,0 +1,4 @@ +(lambda (continue) + (let ((counter (with-input-from-file "counter" read))) + (with-output-to-file "counter" (lambda () (write (add1 counter))))) + (continue)) diff --git a/tests/testweb/subdir/subsubdir/index.html b/tests/testweb/subdir/subsubdir/index.html new file mode 100644 index 0000000..de9d3c3 --- /dev/null +++ b/tests/testweb/subdir/subsubdir/index.html @@ -0,0 +1,15 @@ + + + + This is an index page in a subdir under a subdir + + +

An index page

+ +

Hard to believe, but yes, this is an index page in a subsubdir. +It does not really provide you with an index of any kind, but it's +here to let spiffy's test know that we loaded the index page even +when we simply provided a directory name with no filename.

+ + diff --git a/tests/testweb/test.myscript b/tests/testweb/test.myscript new file mode 100644 index 0000000..4b3bed3 --- /dev/null +++ b/tests/testweb/test.myscript @@ -0,0 +1 @@ +Contents of this file are irrelevant \ No newline at end of file -- cgit v1.2.3