suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Making dispatch-files more modular

Browse Source 
svn: r6635
This commit is contained in:
Jay McCarthy 2007-06-13 17:25:21 +00:00
parent 50eeb657fd
commit bd5819639e
9 changed files with 32 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/web-server/bench/bench.ss
View File

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

12
collects/web-server/dispatchers/dispatch-files.ss
View File

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

8
collects/web-server/docs/reference/dispatchers.scrbl
View File

@ -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.}

2
collects/web-server/docs/reference/private.scrbl
View File

@ -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.

25
collects/web-server/private/mime-types.ss
View File

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

3
collects/web-server/run.ss
View File

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

1
collects/web-server/tests/dispatchers/dispatch-files-test.ss
View File

@ -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"))

10
collects/web-server/tests/private/mime-types-test.ss
View File

@ -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")))))
(check-equal? ((make-path->mime-type test-file) (build-path "test.mpe")) #"video/mpeg")))))

3
collects/web-server/web-server-unit.ss
View File

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