From 1f0c06c0e8821fdb2ac153395656279456c6b629 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 13 Jun 2007 01:46:25 +0000 Subject: [PATCH] Cleaning up some code svn: r6620 --- .../web-server/configuration/responders.ss | 22 +++++++++---------- .../{dispatch-const.ss => dispatch-lift.ss} | 2 +- .../web-server/dispatchers/filesystem-map.ss | 7 +++--- .../docs/reference/configuration.scrbl | 10 +-------- .../docs/reference/dispatchers.scrbl | 13 ++++------- collects/web-server/run.ss | 6 ++--- .../tests/dispatchers/filesystem-map-test.ss | 14 ++++++------ collects/web-server/web-server-unit.ss | 6 ++--- 8 files changed, 34 insertions(+), 46 deletions(-) rename collects/web-server/dispatchers/{dispatch-const.ss => dispatch-lift.ss} (88%) diff --git a/collects/web-server/configuration/responders.ss b/collects/web-server/configuration/responders.ss index 4f4b0cd814..92caa2eef1 100644 --- a/collects/web-server/configuration/responders.ss +++ b/collects/web-server/configuration/responders.ss @@ -4,11 +4,11 @@ (require "../private/response-structs.ss" "../private/request-structs.ss") - ; error-response : nat str str [(cons sym str) ...] -> response + ; file-response : nat str str [(cons sym str) ...] -> response ; XXX - cache files with a refresh option. ; The server should still start without the files there, so the ; configuration tool still runs. (Alternatively, find an work around.) - (define (error-response code short text-file . extra-headers) + (define (file-response code short text-file . extra-headers) (make-response/full code short (current-seconds) TEXT/HTML-MIME-TYPE extra-headers @@ -29,7 +29,7 @@ ; gen-servlet-not-found : str -> url -> response (define (gen-servlet-not-found file-not-found-file) (lambda (url) - (error-response 404 "Servlet not found" file-not-found-file))) + (file-response 404 "Servlet not found" file-not-found-file))) ; gen-servlet-responder : str -> url tst -> response (define (gen-servlet-responder servlet-error-file) @@ -38,38 +38,38 @@ ((error-display-handler) (format "Servlet exception:\n~a\n" (exn-message exn)) exn) - (error-response 500 "Servlet error" servlet-error-file))) + (file-response 500 "Servlet error" servlet-error-file))) ; gen-servlets-refreshed : str -> -> response (define (gen-servlets-refreshed servlet-refresh-file) (lambda () - (error-response 200 "Servlet cache refreshed" servlet-refresh-file))) + (file-response 200 "Servlet cache refreshed" servlet-refresh-file))) ; gen-passwords-refreshed : str -> -> response (define (gen-passwords-refreshed password-refresh-file) (lambda () - (error-response 200 "Passwords refreshed" password-refresh-file))) + (file-response 200 "Passwords refreshed" password-refresh-file))) ; gen-authentication-responder : str -> url (cons sym str) -> response (define (gen-authentication-responder access-denied-file) (lambda (uri recommended-header) - (error-response 401 "Authorization Required" access-denied-file + (file-response 401 "Authorization Required" access-denied-file recommended-header))) ; gen-protocol-responder : str -> str -> response (define (gen-protocol-responder protocol-file) (lambda (error-message) - (error-response 400 "Malformed Request" protocol-file))) + (file-response 400 "Malformed Request" protocol-file))) ; gen-file-not-found-responder : str -> req -> response (define (gen-file-not-found-responder file-not-found-file) (lambda (req) - (error-response 404 "File not found" file-not-found-file))) + (file-response 404 "File not found" file-not-found-file))) ; gen-collect-garbage-responder : str -> -> response (define (gen-collect-garbage-responder file) (lambda () - (error-response 200 "Garbage collected" file))) + (file-response 200 "Garbage collected" file))) ; read-file : str -> str (define (read-file path) @@ -77,7 +77,7 @@ (lambda (in) (read-string (file-size path) in)))) (provide/contract - [error-response ((natural-number/c string? path-string?) (listof (cons/c symbol? string?)) . ->* . (response?))] + [file-response ((natural-number/c string? path-string?) (listof (cons/c symbol? string?)) . ->* . (response?))] [servlet-loading-responder (url? any/c . -> . response?)] [gen-servlet-not-found (path-string? . -> . (url? . -> . response?))] [gen-servlet-responder (path-string? . -> . (url? any/c . -> . response?))] diff --git a/collects/web-server/dispatchers/dispatch-const.ss b/collects/web-server/dispatchers/dispatch-lift.ss similarity index 88% rename from collects/web-server/dispatchers/dispatch-const.ss rename to collects/web-server/dispatchers/dispatch-lift.ss index 4d40cd4447..67bd2b2005 100644 --- a/collects/web-server/dispatchers/dispatch-const.ss +++ b/collects/web-server/dispatchers/dispatch-lift.ss @@ -1,4 +1,4 @@ -(module dispatch-const mzscheme +(module dispatch-lift mzscheme (require (lib "contract.ss")) (require "dispatch.ss" "../private/response.ss" diff --git a/collects/web-server/dispatchers/filesystem-map.ss b/collects/web-server/dispatchers/filesystem-map.ss index 254750c492..f99b5a4483 100644 --- a/collects/web-server/dispatchers/filesystem-map.ss +++ b/collects/web-server/dispatchers/filesystem-map.ss @@ -4,12 +4,13 @@ (lib "contract.ss")) (require "../private/util.ss") (define url-path? + ; XXX should be (listof path-element?) ((url?) . ->* . (path? list?))) (provide/contract [url-path? contract?] [make-url->path (path? . -> . url-path?)] - [make-url->path/optimism (url-path? . -> . url-path?)]) + [make-url->valid-path (url-path? . -> . url-path?)]) (define (build-path* . l) (if (empty? l) @@ -38,9 +39,9 @@ #;(printf "~S~n" `(url->path ,base ,nbase ,(url->string u) ,the-path ,w/o-base)) (values the-path w/o-base)) - (define ((make-url->path/optimism url->path) u) + (define ((make-url->valid-path url->path) u) (let loop ([up (url-path u)]) - #;(printf "~S~n" `(url->path/optimism ,(url->string u) ,up)) + #;(printf "~S~n" `(url->valid-path ,(url->string u) ,up)) (with-handlers ([exn? (lambda (exn) #;((error-display-handler) (exn-message exn) exn) (if (empty? up) diff --git a/collects/web-server/docs/reference/configuration.scrbl b/collects/web-server/docs/reference/configuration.scrbl index 8472a8b42a..f70179da31 100644 --- a/collects/web-server/docs/reference/configuration.scrbl +++ b/collects/web-server/docs/reference/configuration.scrbl @@ -1,6 +1,5 @@ #reader(lib "docreader.ss" "scribble") @require["../web-server.ss"] -@; XXX require mzscheme, url.ss, and contract.ss @title[#:tag "configuration" #:style 'toc]{Configuration} @@ -148,15 +147,11 @@ This function writes a @scheme[configuration-table] to @scheme[path]. @; ------------------------------------------------------------ @section[#:tag "namespace.ss"]{Servlet Namespaces} -@; XXX Require dispatch-servlets and dispatch-lang - @file{configuration/namespace.ss} provides a function to help create the @scheme[make-servlet-namespace] procedure needed by the @scheme[make] functions of @file{dispatchers/dispatch-servlets.ss} and @file{dispatchers/dispatch-lang.ss}. @; XXX Use actual keyword argument syntax -@; XXX Require for current-namespace -@; XXX Link to module-spec? @defproc[(make-make-servlet-namespace (#:to-be-copied-module-specs to-be-copied-module-specs (listof module-spec?))) (key-> ([additional-specs (listof module-spec?)]) @@ -195,10 +190,7 @@ of servlets can share different sets of modules. These functions are used by the default dispatcher constructor (see @secref["web-server-unit.ss"]) to turn the paths given in the @scheme[configuration-table] into responders for the associated circumstance. -@; XXX Include response/full -@; XXX Rename error-response - -@defproc[(error-response (http-code natural-number/c) (short-version string?) (text-file string?) (extra-header (cons/c symbol? string?)) ...) +@defproc[(file-response (http-code natural-number/c) (short-version string?) (text-file string?) (extra-header (cons/c symbol? string?)) ...) response?]{ Generates a @scheme[response/full] with the given @scheme[http-code] and @scheme[short-version] as the corresponding fields; with the content of the @scheme[text-file] as the body; and, with diff --git a/collects/web-server/docs/reference/dispatchers.scrbl b/collects/web-server/docs/reference/dispatchers.scrbl index c5a0b330f2..3bc28d3d57 100644 --- a/collects/web-server/docs/reference/dispatchers.scrbl +++ b/collects/web-server/docs/reference/dispatchers.scrbl @@ -13,8 +13,6 @@ documentation will be useful. @local-table-of-contents[] -@; XXX Include connection? and request? - @; ------------------------------------------------------------ @section[#:tag "dispatch.ss"]{General} @@ -63,9 +61,8 @@ Consider the following example dispatcher, that captures the essence of URL rewr @file{dispatchers/filesystem-map.ss} provides a means of mapping URLs to paths on the filesystem. -@; XXX Change to listof path? @defthing[url-path? contract?]{ - This contract is equivalent to @scheme[((url?) . ->* . (path? list?))]. + This contract is equivalent to @scheme[((url?) . ->* . (path? (listof path-element?)))]. The returned @scheme[path?] is the path on disk. The list is the list of path elements that correspond to the path of the URL.} @@ -75,8 +72,7 @@ URLs to paths on the filesystem. URL to be @scheme[base]. It ensures that @scheme[".."]s in the URL do not escape the @scheme[base].} -@; XXX Rename to /valid -@defproc[(make-url-path/optimism (url->path url->path?)) +@defproc[(make-url->valid-path (url->path url->path?)) url->path?]{ Runs the underlying @scheme[url->path], but only returns if the path refers to a file that actually exists. If it is does not, then the suffix @@ -100,11 +96,10 @@ that invokes a sequence of dispatchers until one applies. then it calls @scheme[next-dispatcher] itself. } -@; XXX Rename const to lift @; ------------------------------------------------------------ -@section[#:tag "dispatch-const.ss"]{Lifting Procedures} +@section[#:tag "dispatch-lift.ss"]{Lifting Procedures} -@file{dispatchers/dispatch-const.ss} defines: +@file{dispatchers/dispatch-lift.ss} defines: @defproc[(make (proc (request? . -> . response?))) dispatcher?]{ diff --git a/collects/web-server/run.ss b/collects/web-server/run.ss index 253b902733..302376590f 100644 --- a/collects/web-server/run.ss +++ b/collects/web-server/run.ss @@ -7,7 +7,7 @@ (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")) - (prefix const: (lib "dispatch-const.ss" "web-server" "dispatchers")) + (prefix lift: (lib "dispatch-const.ss" "web-server" "dispatchers")) (prefix sequencer: (lib "dispatch-sequencer.ss" "web-server" "dispatchers")) (prefix lang: (lib "dispatch-lang.ss" "web-server" "dispatchers"))) @@ -41,13 +41,13 @@ (sequencer:make (filter:make #rx"\\.ss" - (lang:make #:url->path (fsmap:make-url->path/optimism url->path) + (lang:make #:url->path (fsmap:make-url->valid-path url->path) #:timeouts-servlet-connection 86400 #: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") #:indices (list "index.html" "index.htm")) - (const:make (gen-file-not-found-responder file-not-found-file)))) + (lift:make (gen-file-not-found-responder file-not-found-file)))) (do-not-return)) \ No newline at end of file diff --git a/collects/web-server/tests/dispatchers/filesystem-map-test.ss b/collects/web-server/tests/dispatchers/filesystem-map-test.ss index 8dcdc4afb4..307116c6ee 100644 --- a/collects/web-server/tests/dispatchers/filesystem-map-test.ss +++ b/collects/web-server/tests/dispatchers/filesystem-map-test.ss @@ -8,7 +8,7 @@ (define base-dir (collection-path "web-server")) (define test-map (make-url->path base-dir)) - (define test-map/optimism (make-url->path/optimism test-map)) + (define test-valid-map (make-url->valid-path test-map)) (define/kw (test-url->path url->path file #:key @@ -39,19 +39,19 @@ (test-url->path test-map (build-path "dispatchers/../dispatchers/filesystem-map.ss")))) (test-suite - "url->path/optimism" + "url->valid-path" (test-suite "Preserves url->path" (test-case "Simple case" - (test-url->path test-map/optimism (build-path "dispatchers/filesystem-map.ss"))) + (test-url->path test-valid-map (build-path "dispatchers/filesystem-map.ss"))) (test-case "Strips parameters" - (test-url->path test-map/optimism (build-path "dispatchers/filesystem-map.ss") + (test-url->path test-valid-map (build-path "dispatchers/filesystem-map.ss") #:url-string "http://test.com/dispatchers/filesystem-map.ss;foo")) (test-case "Strips outs bad '..'s" - (test-url->path test-map/optimism (build-path "dispatchers/filesystem-map.ss") + (test-url->path test-valid-map (build-path "dispatchers/filesystem-map.ss") #:url-string "http://test.com/../../dispatchers/filesystem-map.ss")) (test-case "Leaves in good '..'s" - (test-url->path test-map/optimism (build-path "dispatchers/../dispatchers/filesystem-map.ss")))) + (test-url->path test-valid-map (build-path "dispatchers/../dispatchers/filesystem-map.ss")))) (test-case "Finds valid path underneath" - (test-url->path test-map/optimism (build-path "dispatchers/filesystem-map.ss/not-a-file") + (test-url->path test-valid-map (build-path "dispatchers/filesystem-map.ss/not-a-file") #:expected (build-path "dispatchers/filesystem-map.ss"))))))) \ 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 d7cc47f1bc..83159e7c61 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -18,7 +18,7 @@ (prefix log: "dispatchers/dispatch-log.ss") (prefix host: "dispatchers/dispatch-host.ss") (prefix filter: "dispatchers/dispatch-filter.ss") - (prefix const: "dispatchers/dispatch-const.ss")) + (prefix lift: "dispatchers/dispatch-lift.ss")) (provide web-server@) @@ -67,7 +67,7 @@ (let-values ([(clear-cache! servlet-dispatch) (servlets:make config:instances config:scripts config:make-servlet-namespace #:url->path - (fsmap:make-url->path/optimism + (fsmap:make-url->valid-path (fsmap:make-url->path (paths-servlet (host-paths host-info)))) #:responders-servlet-loading (responders-servlet-loading (host-responders host-info)) #:responders-servlet (responders-servlet (host-responders host-info)) @@ -84,7 +84,7 @@ (files:make #:url->path (fsmap:make-url->path (paths-htdocs (host-paths host-info))) #:mime-types-path (paths-mime-types (host-paths host-info)) #:indices (host-indices host-info)) - (const:make (responders-file-not-found (host-responders host-info)))))) + (lift:make (responders-file-not-found (host-responders host-info)))))) (define-compound-unit/infer web-server@ (import tcp^ web-config^)