From e155deea8ee22a0c9533ef985713989e9b239abd Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 13 Aug 2007 21:13:45 +0000 Subject: [PATCH] up svn: r7088 --- .../web-server/dispatchers/dispatch-files.ss | 28 +++++++++++++------ .../tests/dispatchers/dispatch-files-test.ss | 2 +- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/collects/web-server/dispatchers/dispatch-files.ss b/collects/web-server/dispatchers/dispatch-files.ss index 6823806b1c..aabbd2e5ba 100644 --- a/collects/web-server/dispatchers/dispatch-files.ss +++ b/collects/web-server/dispatchers/dispatch-files.ss @@ -7,11 +7,17 @@ "../private/util.ss" "../private/request-structs.ss" "../private/response-structs.ss" + "../servlet/helpers.ss" "../private/response.ss") (provide/contract [interface-version dispatcher-interface-version?]) (provide make) + ;; looks-like-directory : str -> bool + ;; to determine if is url style path looks like it refers to a directory + (define (looks-like-directory? path) + (eq? #\/ (string-ref path (sub1 (string-length path))))) + (define interface-version 'v1) (define/kw (make #:key url->path @@ -46,14 +52,18 @@ r) (output-file conn path method (path->mime-type path) 0 +inf.0)])])] - [(and (directory-exists? path)) - (let/ec esc - (for-each (lambda (dir-default) - (define full-name (build-path path dir-default)) - (when (file-exists? full-name) - (esc (output-file conn full-name method (path->mime-type full-name) - 0 +inf.0)))) - indices) - (next-dispatcher))] + [(directory-exists? path) + (if (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 (file-exists? full-name) + (esc (output-file conn full-name method (path->mime-type full-name) + 0 +inf.0)))) + indices) + (next-dispatcher)) + (output-response + conn + (redirect-to (string-append (url-path->string (url-path uri)) "/"))))] [else (next-dispatcher)])))) \ No newline at end of file diff --git a/collects/web-server/tests/dispatchers/dispatch-files-test.ss b/collects/web-server/tests/dispatchers/dispatch-files-test.ss index 304eca3898..689baf3ecb 100644 --- a/collects/web-server/tests/dispatchers/dispatch-files-test.ss +++ b/collects/web-server/tests/dispatchers/dispatch-files-test.ss @@ -65,7 +65,7 @@ #"HTTP/1.1 206 Okay\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html; charset=utf-8\r\nContent-Length: 81\r\nContent-Range: bytes 0-81/81\r\n\r\n") (test-equal? "dir, not dir-url, get" (collect (dispatch #t a-dir) (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/html; charset=utf-8\r\nContent-Length: 81\r\nContent-Range: bytes 0-81/81\r\n\r\nA titleHere's some content!") + #"HTTP/1.1 302 Moved Temporarily\r\nDate: REDACTED GMT\r\nLast-Modified: REDACTED GMT\r\nServer: PLT Scheme\r\nContent-Type: text/html\r\nContent-Length: 0\r\nLocation: /foo/\r\n\r\n") (test-exn "dir, not exists, get" exn:dispatcher? (lambda () (collect (dispatch #f a-dir) (req #t 'get empty))))