From d42ec59149ae307d0eb5886f3978cacb77ec5bef Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 9 Jun 2007 04:45:23 +0000 Subject: [PATCH] Testing tools and dispatch-files tests svn: r6554 --- .../web-server/dispatchers/dispatch-files.ss | 6 +- .../web-server/private/request-structs.ss | 13 ++-- collects/web-server/private/response.ss | 1 + .../tests/dispatchers/dispatch-files-test.ss | 78 ++++++++++++++++++- .../web-server/tests/private/response-test.ss | 21 +---- collects/web-server/tests/util.ss | 25 +++++- 6 files changed, 112 insertions(+), 32 deletions(-) diff --git a/collects/web-server/dispatchers/dispatch-files.ss b/collects/web-server/dispatchers/dispatch-files.ss index bd7a6cb682..8cf553add1 100644 --- a/collects/web-server/dispatchers/dispatch-files.ss +++ b/collects/web-server/dispatchers/dispatch-files.ss @@ -50,12 +50,12 @@ ; XXX: Unhandled range: r (output-file conn path method (get-mime-type path) 0 +inf.0)])])] - [(directory-exists? path) + [(and (directory-exists? path) + (looks-like-directory? (url-path->string (url-path uri)))) (let/ec esc (for-each (lambda (dir-default) (define full-name (build-path path dir-default)) - (when (and (file-exists? full-name) - (looks-like-directory? (url-path->string (url-path uri)))) + (when (file-exists? full-name) (esc (output-file conn full-name method (get-mime-type full-name) 0 +inf.0)))) indices) diff --git a/collects/web-server/private/request-structs.ss b/collects/web-server/private/request-structs.ss index af2c128a8a..71cc94def1 100644 --- a/collects/web-server/private/request-structs.ss +++ b/collects/web-server/private/request-structs.ss @@ -54,9 +54,10 @@ (define-serializable-struct request (method uri headers/raw bindings/raw post-data/raw host-ip host-port client-ip)) (provide/contract - [struct request ([method symbol?] [uri url?] - [headers/raw (listof header?)] - [bindings/raw (listof binding?)] - [post-data/raw (or/c false/c bytes?)] - [host-ip string?] [host-port number?] - [client-ip string?])])) \ No newline at end of file + [struct request ([method symbol?] + [uri url?] + [headers/raw (listof header?)] + [bindings/raw (listof binding?)] + [post-data/raw (or/c false/c bytes?)] + [host-ip string?] [host-port number?] + [client-ip string?])])) \ No newline at end of file diff --git a/collects/web-server/private/response.ss b/collects/web-server/private/response.ss index 0483c84d66..bf9bede2e6 100644 --- a/collects/web-server/private/response.ss +++ b/collects/web-server/private/response.ss @@ -201,6 +201,7 @@ (define bresp (make-response/basic 206 "Okay" (file-or-directory-modify-seconds file-path) mime-type (list (cons 'Content-Length (number->string len)) + ; XXX Remove on non-gets? (cons 'Content-Range (format "bytes ~a-~a/~a" start end total-len))))) (output-headers+response/basic conn bresp) (when (eq? method 'get) diff --git a/collects/web-server/tests/dispatchers/dispatch-files-test.ss b/collects/web-server/tests/dispatchers/dispatch-files-test.ss index 6200926487..57c60a6bc7 100644 --- a/collects/web-server/tests/dispatchers/dispatch-files-test.ss +++ b/collects/web-server/tests/dispatchers/dispatch-files-test.ss @@ -1,8 +1,80 @@ (module dispatch-files-test mzscheme - (require (planet "test.ss" ("schematics" "schemeunit.plt" 2))) + (require (planet "test.ss" ("schematics" "schemeunit.plt" 2)) + (lib "file.ss") + (lib "url.ss" "net") + (lib "list.ss") + (lib "xml.ss" "xml") + (lib "request-structs.ss" "web-server" "private") + (lib "util.ss" "web-server" "private") + (lib "dispatch.ss" "web-server" "dispatchers") + (prefix files: (lib "dispatch-files.ss" "web-server" "dispatchers")) + "../util.ss") (provide dispatch-files-tests) - ; XXX + (define tmp-file (make-temporary-file)) + (with-output-to-file tmp-file + (lambda () + (display + (xexpr->string + `(html (head (title "A title")) + (body "Here's some content!"))))) + 'truncate/replace) + + (define a-dir (directory-part tmp-file)) + (define not-there (build-path "I/probably/do/not/exist")) + + (define (dispatch i? . paths) + (define b (box 0)) + (files:make #:url->path + (lambda (url) + (begin0 (values (list-ref paths (min (unbox b) (sub1 (length paths)))) empty) + (set-box! b (add1 (unbox b))))) + #:mime-types-path (build-path "/etc/httpd/mime.types") + #:indices (list (if i? (file-name-from-path tmp-file) not-there)))) + + (define (collect d req) + (define-values (c i o) (make-mock-connection #"")) + (d c req) + (redact (get-output-bytes o))) + + (define file-url (string->url "http://test.com/foo")) + (define dir-url (string->url "http://test.com/foo/")) + (define (req d? meth heads) + (make-request meth (if d? dir-url file-url) heads empty #"" "host" 80 "client")) + (define dispatch-files-tests (test-suite - "Files"))) \ No newline at end of file + "Files" + + (test-equal? "file, exists, whole, get" + (collect (dispatch #t tmp-file) (req #f 'get empty)) + #"HTTP/1.1 206 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 81\r\nContent-Range: bytes 0-81/81\r\n\r\nA titleHere's some content!") + (test-equal? "file, exists, whole, head" + (collect (dispatch #t tmp-file) (req #f 'head empty)) + #"HTTP/1.1 206 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 81\r\nContent-Range: bytes 0-81/81\r\n\r\n") + (test-equal? "file, exists, part, get" + (collect (dispatch #t tmp-file) (req #f 'get (list (make-header #"Range" #"bytes=5-10")))) + #"HTTP/1.1 206 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 5\r\nContent-Range: bytes 5-10/81\r\n\r\n>A titleHere's some content!") + (test-equal? "dir, exists, head" + (collect (dispatch #t a-dir) (req #t 'head empty)) + #"HTTP/1.1 206 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/plain; charset=utf-8\r\nContent-Length: 81\r\nContent-Range: bytes 0-81/81\r\n\r\n") + (test-exn "dir, not dir-url, get" + exn:dispatcher? + (lambda () (collect (dispatch #t a-dir) (req #f 'get empty)))) + (test-exn "dir, not exists, get" + exn:dispatcher? + (lambda () (collect (dispatch #f a-dir) (req #t 'get empty)))) + (test-exn "dir, not exists, head" + exn:dispatcher? + (lambda () (collect (dispatch #f a-dir) (req #t 'head empty))))))) \ No newline at end of file diff --git a/collects/web-server/tests/private/response-test.ss b/collects/web-server/tests/private/response-test.ss index dfd8d08a87..e05d7082c6 100644 --- a/collects/web-server/tests/private/response-test.ss +++ b/collects/web-server/tests/private/response-test.ss @@ -4,28 +4,13 @@ (lib "file.ss") (lib "response.ss" "web-server" "private") (lib "response-structs.ss" "web-server" "private") - (lib "connection-manager.ss" "web-server" "private") - (lib "timer.ss" "web-server" "private")) + "../util.ss") (provide response-tests) - - (define (make-mock-connection ib) - (define ip (open-input-bytes ib)) - (define op (open-output-bytes)) - (values (make-connection (make-timer never-evt +inf.0 (lambda () (void))) - ip op (make-custodian) #f (make-semaphore 1)) - ip - op)) - + (define (output f . any) (define-values (c i o) (make-mock-connection #"")) (apply f c any) - (regexp-replace - #"Date: [a-zA-Z0-9:, ]+ GMT\r\n" - (regexp-replace - #"Last-Modified: [a-zA-Z0-9:, ]+ GMT\r\n" - (get-output-bytes o) - #"Last-Modified: REDACTED GMT\r\n") - #"Date: REDACTED GMT\r\n")) + (redact (get-output-bytes o))) (define response-tests (test-suite diff --git a/collects/web-server/tests/util.ss b/collects/web-server/tests/util.ss index 927b6eec1b..022ea7908c 100644 --- a/collects/web-server/tests/util.ss +++ b/collects/web-server/tests/util.ss @@ -1,6 +1,27 @@ (module util mzscheme + (require (lib "connection-manager.ss" "web-server" "private") + (lib "timer.ss" "web-server" "private")) (provide make-module-eval - make-eval/mod-path) + make-eval/mod-path + make-mock-connection + redact) + + (define (make-mock-connection ib) + (define ip (open-input-bytes ib)) + (define op (open-output-bytes)) + (values (make-connection (make-timer never-evt +inf.0 (lambda () (void))) + ip op (make-custodian) #f (make-semaphore 1)) + ip + op)) + + (define (redact b) + (regexp-replace + #"Date: [a-zA-Z0-9:, ]+ GMT\r\n" + (regexp-replace + #"Last-Modified: [a-zA-Z0-9:, ]+ GMT\r\n" + b + #"Last-Modified: REDACTED GMT\r\n") + #"Date: REDACTED GMT\r\n")) (define-syntax (make-module-eval m-expr) (syntax-case m-expr (module) @@ -14,7 +35,7 @@ (lambda (s-expr) (parameterize ([current-namespace ns]) - (eval s-expr))))] + (eval s-expr))))] [else (raise-syntax-error #f "make-module-evel: dropped through" m-expr)]))