diff options
| -rw-r--r-- | simple-directory-handler.scm | 4 | ||||
| -rw-r--r-- | spiffy.scm | 6 | ||||
| -rw-r--r-- | tests/run.scm | 8 | ||||
| -rw-r--r-- | tests/testlib.scm | 16 |
4 files changed, 27 insertions, 7 deletions
diff --git a/simple-directory-handler.scm b/simple-directory-handler.scm index 4d722c6..47dbea9 100644 --- a/simple-directory-handler.scm +++ b/simple-directory-handler.scm @@ -40,6 +40,10 @@ intarweb spiffy (only uri-common uri-encode-string char-set:uri-unreserved) (only srfi-14 char-set-complement char-set-delete)) +(cond-expand + (chicken-6 (import (scheme base))) ; For make-parameter, which moved from (chicken base) + (else)) + (define (encode-path p) (let ((cs (char-set-delete (char-set-complement char-set:uri-unreserved) #\/))) (uri-encode-string p cs))) @@ -58,8 +58,12 @@ srfi-1 srfi-13 srfi-14 srfi-18 uri-common sendfile (rename intarweb (headers intarweb:headers))) +(cond-expand + (chicken-6 (import (scheme base))) ; For make-parameter, which moved from (chicken base) + (else)) + (define version 6) -(define release 3) +(define release 4) ;;; Request processing information (define current-request (make-parameter #f)) diff --git a/tests/run.scm b/tests/run.scm index 722d6e3..d7e3d27 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -74,8 +74,8 @@ 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 chicken-logo.png (with-input-from-file "testweb/pics/chicken-logo.png" read-bytevector)) +(define lambda-chicken.gif (with-input-from-file "testweb/pics/lambda-chicken.gif" read-bytevector)) (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)) @@ -100,11 +100,11 @@ "/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) +(test-binary-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) +(test-binary-response "image/png contents" (200 chicken-logo.png) "/pics/chicken-logo.png" "testhost") (test-header "unknown mimetype" content-type (application/unknown) "/data" "testhost") diff --git a/tests/testlib.scm b/tests/testlib.scm index f706753..d124554 100644 --- a/tests/testlib.scm +++ b/tests/testlib.scm @@ -3,6 +3,10 @@ (chicken tcp) (chicken process) (chicken file posix) uri-common intarweb srfi-18) +(cond-expand + (chicken-6) + (else (define read-bytevector read-string))) + (server-port (string->number (or (get-environment-variable "SPIFFY_TEST_PORT") "8080"))) @@ -67,7 +71,7 @@ ;;;; 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)) +(define (fetch-file file host #!key (send-headers `((host (,host . ,(server-port))))) (get-headers #f) (version '(1 0)) (method 'GET) (absolute-uri #t) (binary #f)) (set! response-error? #f) (let ((uri (uri-reference (if absolute-uri (sprintf "http://~A:~A~A" host (server-port) file) @@ -80,7 +84,8 @@ headers: req-headers port: out))) (write-request req) (let* ((resp (read-response in)) - (str (read-string (header-value 'content-length (response-headers resp)) in))) + (str ((if binary read-bytevector read-string) + (header-value 'content-length (response-headers resp)) in))) (close-output-port out) (close-input-port in) (if get-headers @@ -94,6 +99,13 @@ ((_ ?text ?code-expected ?args ...) (test ?text ?code-expected (car (fetch-file ?args ...)))))) +(define-syntax test-binary-response + (syntax-rules () + ((_ ?text (?code-expected ?contents-expected) ?args ...) + (test ?text (list ?code-expected ?contents-expected) (fetch-file ?args ... binary: #t))) + ((_ ?text ?code-expected ?args ...) + (test ?text ?code-expected (car (fetch-file ?args ... binary: #t)))))) + (define-syntax test-header (syntax-rules () ((_ ?text ?header-name (?header-values ...) ?args ...) |