From bd5819639ed3cfce1898ae0f22f699462a41c4a7 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 13 Jun 2007 17:25:21 +0000 Subject: [PATCH] Making dispatch-files more modular svn: r6635 --- collects/web-server/bench/bench.ss | 3 +-- .../web-server/dispatchers/dispatch-files.ss | 12 ++++----- .../docs/reference/dispatchers.scrbl | 8 +++--- .../web-server/docs/reference/private.scrbl | 2 +- collects/web-server/private/mime-types.ss | 25 +++++++++---------- collects/web-server/run.ss | 3 ++- .../tests/dispatchers/dispatch-files-test.ss | 1 - .../tests/private/mime-types-test.ss | 10 ++++---- collects/web-server/web-server-unit.ss | 3 ++- 9 files changed, 32 insertions(+), 35 deletions(-) diff --git a/collects/web-server/bench/bench.ss b/collects/web-server/bench/bench.ss index f21fcc1b2d..d0ae32d9fb 100644 --- a/collects/web-server/bench/bench.ss +++ b/collects/web-server/bench/bench.ss @@ -22,8 +22,7 @@ (parameterize ([current-custodian server-cust]) (serve #:port (port) #:dispatch - (files:make #:url->path (lambda _ (values *test-file* empty)) - #:mime-types-path (build-path "/etc/httpd/mime.types"))))) + (files:make #:url->path (lambda _ (values *test-file* empty)))))) (define before/s (current-memory-use server-cust)) (define before (current-memory-use)) diff --git a/collects/web-server/dispatchers/dispatch-files.ss b/collects/web-server/dispatchers/dispatch-files.ss index 8cf553add1..1ff64aa7f2 100644 --- a/collects/web-server/dispatchers/dispatch-files.ss +++ b/collects/web-server/dispatchers/dispatch-files.ss @@ -20,9 +20,9 @@ (define interface-version 'v1) (define/kw (make #:key url->path - [mime-types-path "mime.types"] + ; XXX Make the default a define from response.ss + [path->mime-type (lambda (path) #"text/plain; charset=utf-8")] [indices (list "index.html" "index.htm")]) - (define get-mime-type (make-get-mime-type mime-types-path)) (lambda (conn req) (define uri (request-uri req)) (define method (request-method req)) @@ -31,7 +31,7 @@ [(file-exists? path) (match (headers-assq* #"Range" (request-headers/raw req)) [#f - (output-file conn path method (get-mime-type path) + (output-file conn path method (path->mime-type path) 0 +inf.0)] [range (match (bytes->string/utf-8 (header-value range)) @@ -44,11 +44,11 @@ (if (string=? "" end) +inf.0 (string->number end))) - (output-file conn path method (get-mime-type path) + (output-file conn path method (path->mime-type path) startn endn)] [r ; XXX: Unhandled range: r - (output-file conn path method (get-mime-type path) + (output-file conn path method (path->mime-type path) 0 +inf.0)])])] [(and (directory-exists? path) (looks-like-directory? (url-path->string (url-path uri)))) @@ -56,7 +56,7 @@ (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 (get-mime-type full-name) + (esc (output-file conn full-name method (path->mime-type full-name) 0 +inf.0)))) indices) (next-dispatcher))] diff --git a/collects/web-server/docs/reference/dispatchers.scrbl b/collects/web-server/docs/reference/dispatchers.scrbl index 5e3cba6796..fdf4c12c6a 100644 --- a/collects/web-server/docs/reference/dispatchers.scrbl +++ b/collects/web-server/docs/reference/dispatchers.scrbl @@ -223,18 +223,16 @@ that calls a different dispatcher based upon the host requested. @file{dispatchers/dispatch-files.ss} allows files to be served. It defines a dispatcher construction procedure: -@; XXX Change mime-types-path to path->mime-type -@; XXX Include make-get-mime-type @defproc[(make [#:url->path url->path url->path?] - [#:mime-types-path mime-types-path path-string? "mime.types"] + [#:path->mime-type path->mime-type (path? . -> . bytes?) (lambda (path) #"text/plain; charset=utf-8")] [#:indices indices (listof string?) (list "index.html" "index.htm")]) dispatcher?]{ Uses @scheme[url->path] to extract a path from the URL in the request object. If this path does not exist, then the dispatcher does not apply. If the path is a directory, then the @scheme[indices] are checked in order for an index file to serve. In that case, or in the case of a path that is - a file already, the @scheme[mime-types-path] file is consulted for the MIME - Type of the path, via @scheme[make-get-mime-type]. The file is then + a file already, @scheme[path->mime-type] is consulted for the MIME + Type of the path. The file is then streamed out the connection object. This dispatcher supports HTTP Range GET requests and HEAD requests.} diff --git a/collects/web-server/docs/reference/private.scrbl b/collects/web-server/docs/reference/private.scrbl index 714a0699a4..991b4cb9e1 100644 --- a/collects/web-server/docs/reference/private.scrbl +++ b/collects/web-server/docs/reference/private.scrbl @@ -225,7 +225,7 @@ files. hash table mapping extensions to MIME types. } -@defproc[(make-get-mime-type [p path?]) +@defproc[(make-path->mime-type [p path?]) (path? . -> . bytes?)]{ Uses a @scheme[read-mime-types] with @scheme[p] and constructs a function from paths to their MIME type. diff --git a/collects/web-server/private/mime-types.ss b/collects/web-server/private/mime-types.ss index c0de5b24a9..b9c627c4da 100644 --- a/collects/web-server/private/mime-types.ss +++ b/collects/web-server/private/mime-types.ss @@ -5,7 +5,7 @@ (require "util.ss") (provide/contract [read-mime-types (path? . -> . hash-table?)] - [make-get-mime-type (path? . -> . (path? . -> . bytes?))]) + [make-path->mime-type (path? . -> . (path? . -> . bytes?))]) ; read-mime-types : path? -> hash-table? (define (read-mime-types a-path) @@ -34,15 +34,14 @@ ;; Notes (GregP): ;; 1. Can we determine the mime type based on file contents? ;; 2. Assuming that 7-bit ASCII is correct for mime-type - (define (make-get-mime-type a-path) - (let ([MIME-TYPE-TABLE (read-mime-types a-path)] - [DEFAULT-MIME-TYPE #"text/plain; charset=utf-8"] - [file-suffix-regexp (byte-regexp #".*\\.([^\\.]*$)")]) - - (lambda (path) - (match (regexp-match file-suffix-regexp (path->bytes path)) - [(list path-bytes sffx) - (hash-table-get MIME-TYPE-TABLE - (lowercase-symbol! sffx) - (lambda () DEFAULT-MIME-TYPE))] - [_ DEFAULT-MIME-TYPE]))))) \ No newline at end of file + (define (make-path->mime-type a-path) + (define MIME-TYPE-TABLE (read-mime-types a-path)) + (define DEFAULT-MIME-TYPE #"text/plain; charset=utf-8") + (define file-suffix-regexp (byte-regexp #".*\\.([^\\.]*$)")) + (lambda (path) + (match (regexp-match file-suffix-regexp (path->bytes path)) + [(list path-bytes sffx) + (hash-table-get MIME-TYPE-TABLE + (lowercase-symbol! sffx) + (lambda () DEFAULT-MIME-TYPE))] + [_ DEFAULT-MIME-TYPE])))) \ No newline at end of file diff --git a/collects/web-server/run.ss b/collects/web-server/run.ss index 796951d82f..8e996d9059 100644 --- a/collects/web-server/run.ss +++ b/collects/web-server/run.ss @@ -4,6 +4,7 @@ (lib "file.ss") (lib "web-server.ss" "web-server") (lib "responders.ss" "web-server" "configuration") + (lib "mime-types.ss" "web-server" "private") (prefix fsmap: (lib "filesystem-map.ss" "web-server" "dispatchers")) (prefix files: (lib "dispatch-files.ss" "web-server" "dispatchers")) (prefix filter: (lib "dispatch-filter.ss" "web-server" "dispatchers")) @@ -46,7 +47,7 @@ #:responders-servlet-loading (gen-servlet-responder servlet-error-file) #:responders-servlet (gen-servlet-responder servlet-error-file))) (files:make #:url->path url->path - #:mime-types-path (build-path (server-root-path) "mime.types") + #:path->mime-type (make-path->mime-type (build-path (server-root-path) "mime.types")) #:indices (list "index.html" "index.htm")) (lift:make (gen-file-not-found-responder file-not-found-file)))) diff --git a/collects/web-server/tests/dispatchers/dispatch-files-test.ss b/collects/web-server/tests/dispatchers/dispatch-files-test.ss index da9e9289ac..777704fae3 100644 --- a/collects/web-server/tests/dispatchers/dispatch-files-test.ss +++ b/collects/web-server/tests/dispatchers/dispatch-files-test.ss @@ -29,7 +29,6 @@ (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 file-url (string->url "http://test.com/foo")) diff --git a/collects/web-server/tests/private/mime-types-test.ss b/collects/web-server/tests/private/mime-types-test.ss index fc6ce904d2..d69615865b 100644 --- a/collects/web-server/tests/private/mime-types-test.ss +++ b/collects/web-server/tests/private/mime-types-test.ss @@ -27,16 +27,16 @@ END (check-not-false (read-mime-types test-file))) (test-case "Default mime-type given" - (check-equal? ((make-get-mime-type test-file) (build-path "test.html")) #"text/plain; charset=utf-8")) + (check-equal? ((make-path->mime-type test-file) (build-path "test.html")) #"text/plain; charset=utf-8")) (test-case "MIME type resolves (single in file)" - (check-equal? ((make-get-mime-type test-file) (build-path "test.mp4")) #"video/mp4")) + (check-equal? ((make-path->mime-type test-file) (build-path "test.mp4")) #"video/mp4")) (test-case "MIME type resolves (multiple in file)" - (check-equal? ((make-get-mime-type test-file) (build-path "test.mpeg")) #"video/mpeg")) + (check-equal? ((make-path->mime-type test-file) (build-path "test.mpeg")) #"video/mpeg")) (test-case "MIME type resolves (multiple in file)" - (check-equal? ((make-get-mime-type test-file) (build-path "test.mpg")) #"video/mpeg")) + (check-equal? ((make-path->mime-type test-file) (build-path "test.mpg")) #"video/mpeg")) (test-case "MIME type resolves (multiple in file)" - (check-equal? ((make-get-mime-type test-file) (build-path "test.mpe")) #"video/mpeg"))))) \ No newline at end of file + (check-equal? ((make-path->mime-type test-file) (build-path "test.mpe")) #"video/mpeg"))))) \ No newline at end of file diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index 184ac5a416..5215edade7 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -6,6 +6,7 @@ "private/dispatch-server-unit.ss" "private/dispatch-server-sig.ss" "private/web-server-structs.ss" + "private/mime-types.ss" "configuration/configuration-table-structs.ss" "private/cache-table.ss" (prefix http: "private/request.ss")) @@ -83,7 +84,7 @@ #rx"^/servlets" servlet-dispatch))) (files:make #:url->path (fsmap:make-url->path (paths-htdocs (host-paths host-info))) - #:mime-types-path (paths-mime-types (host-paths host-info)) + #:path->mime-type (make-path->mime-type (paths-mime-types (host-paths host-info))) #:indices (host-indices host-info)) (lift:make (responders-file-not-found (host-responders host-info))))))