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