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

Cleaning up some code

Browse Source 
svn: r6620
This commit is contained in:
Jay McCarthy 2007-06-13 01:46:25 +00:00
parent 7bd7135fb3
commit 1f0c06c0e8
8 changed files with 34 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/web-server/configuration/responders.ss
View File

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

2
collects/web-server/dispatchers/dispatch-const.ss → collects/web-server/dispatchers/dispatch-lift.ss
View File

@ -1,4 +1,4 @@
(module dispatch-const mzscheme
(module dispatch-lift mzscheme
(require (lib "contract.ss"))
(require "dispatch.ss"
"../private/response.ss"

7
collects/web-server/dispatchers/filesystem-map.ss
View File

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

10
collects/web-server/docs/reference/configuration.scrbl
View File

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

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

@ -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?]{

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

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

14
collects/web-server/tests/dispatchers/filesystem-map-test.ss
View File

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

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

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