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

Generalizing dispatch-servlets

Browse Source 
svn: r12338
This commit is contained in:
Jay McCarthy 2008-11-06 22:23:45 +00:00
parent 714031c1d6
commit a8bc141a77
9 changed files with 212 additions and 169 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/tests/web-server/dispatchers/dispatch-servlets-test.ss
View File

@ -15,9 +15,13 @@
(current-server-custodian (current-custodian))
(define (mkd p)
(define-values (! d)
(servlets:make (box (make-cache-table))
#:url->path (lambda _ (values p url0s))
(define-values (! u->s)
(servlets:make-cached-url->servlet
(box (make-cache-table))
(lambda _ (values p url0s))
(servlets:make-default-path->servlet)))
(define d
(servlets:make u->s
#:responders-servlet-loading
(lambda (u exn)
(raise exn))

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

@ -16,7 +16,7 @@
[interface-version dispatcher-interface-version/c]
[read-range-header (-> (listof header?) (or/c (listof pair?) false/c))]
[make
(->* (#:url->path url-path/c)
(->* (#:url->path url->path/c)
(#:path->mime-type (path? . -> . bytes?)
#:indices (listof path-string?))
dispatcher/c)])

2
collects/web-server/dispatchers/dispatch-lang.ss
View File

@ -19,7 +19,7 @@
(provide/contract
[interface-version dispatcher-interface-version/c]
[make
(->* (#:url->path url-path/c)
(->* (#:url->path url->path/c)
(#:make-servlet-namespace make-servlet-namespace/c
#:responders-servlet-loading (url? any/c . -> . response?)
#:responders-servlet (url? any/c . -> . response?))

232
collects/web-server/dispatchers/dispatch-servlets.ss
View File

@ -15,27 +15,130 @@
"../configuration/namespace.ss"
"../managers/manager.ss"
"../managers/timeouts.ss"
"../private/servlet.ss"
(except-in "../private/servlet.ss"
servlet-prompt)
"../private/cache-table.ss"
"../private/util.ss")
"../private/util.ss")
(provide/contract
[interface-version dispatcher-interface-version/c]
[make (->* ((box/c cache-table?)
#:url->path url-path/c)
(#:make-servlet-namespace make-servlet-namespace/c
#:responders-servlet-loading (url? any/c . -> . response?)
#:responders-servlet (url? any/c . -> . response?)
#:timeouts-default-servlet number?)
(values (-> void)
dispatcher/c))])
[interface-version dispatcher-interface-version/c])
(define interface-version 'v1)
(define (make config:scripts
#:url->path url->path
#:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)]
; -----
(define path->servlet/c (path? . -> . servlet?))
(provide/contract
[path->servlet/c contract?]
[make-default-path->servlet
(->* ()
(#:make-servlet-namespace make-servlet-namespace/c
#:timeouts-default-servlet number?)
path->servlet/c)])
(define (v0.response->v1.lambda response response-path)
(define go
(box
(lambda ()
(set-box! go (lambda () (load/use-compiled response-path)))
response)))
(lambda (initial-request)
((unbox go))))
(define (v1.module->v1.lambda timeout start)
(lambda (initial-request)
(adjust-timeout! timeout)
(start initial-request)))
(define (make-v1.servlet directory timeout start)
(make-v2.servlet directory
(create-timeout-manager
default-servlet-instance-expiration-handler
timeout
timeout)
(v1.module->v1.lambda timeout start)))
(define (make-v2.servlet directory manager start)
(make-servlet (current-custodian)
(current-namespace)
manager
directory
start))
(define (make-default-path->servlet #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)]
#:timeouts-default-servlet [timeouts-default-servlet 30])
(lambda (a-path)
(parameterize ([current-namespace (make-servlet-namespace
#:additional-specs
'(web-server/servlet
web-server/private/servlet
web-server/servlet/web
web-server/servlet/web-cells))]
[current-custodian (make-servlet-custodian)])
(define s (load/use-compiled a-path))
(cond
[(void? s)
(let* ([module-name `(file ,(path->string a-path))]
[version (dynamic-require module-name 'interface-version)])
(case version
[(v1)
(let ([timeout (dynamic-require module-name 'timeout)]
[start (dynamic-require module-name 'start)])
(make-v1.servlet (directory-part a-path) timeout start))]
[(v2)
(let ([start (dynamic-require module-name 'start)]
[manager (dynamic-require module-name 'manager)])
(make-v2.servlet (directory-part a-path) manager start))]
[else
(error 'path->servlet "unknown servlet version ~e, must be 'v1 or 'v2" version)]))]
[(response? s)
(make-v1.servlet (directory-part a-path) timeouts-default-servlet
(v0.response->v1.lambda s a-path))]
[else
(error 'path->servlet
"Loading ~e produced ~n~e~n instead of either (1) a response or (2) nothing and exports 'interface-version" a-path s)]))))
; -----
(define url->servlet/c (url? . -> . servlet?))
(provide/contract
[url->servlet/c contract?]
[make-cached-url->servlet
(-> (box/c cache-table?)
url->path/c
path->servlet/c
(values (-> void)
url->servlet/c))])
(define (make-cached-url->servlet
config:scripts
url->path
path->servlet)
(values (lambda ()
;; This is broken - only out of date or specifically mentioned scripts should be flushed. This destroys persistent state!
(cache-table-clear! (unbox config:scripts)))
(lambda (uri)
(define-values (servlet-path _)
(with-handlers
([void (lambda (e)
(raise (make-exn:fail:filesystem:exists
(exn-message e)
(exn-continuation-marks e))))])
(url->path uri)))
(cache-table-lookup! (unbox config:scripts)
(string->symbol (path->string servlet-path))
(lambda () (path->servlet servlet-path))))))
; -----
(provide/contract
[make (->* (url->servlet/c)
(#:responders-servlet-loading (url? any/c . -> . response?)
#:responders-servlet (url? any/c . -> . response?))
dispatcher/c)])
;; default-server-instance-expiration-handler : (request -> response)
(define (default-servlet-instance-expiration-handler req)
(next-dispatcher))
(define (make url->servlet
#:responders-servlet-loading [responders-servlet-loading servlet-loading-responder]
#:responders-servlet [responders-servlet servlet-error-responder]
#:timeouts-default-servlet [timeouts-default-servlet 30])
#:responders-servlet [responders-servlet servlet-error-responder])
;; servlet-content-producer: connection request -> void
(define (servlet-content-producer conn req)
@ -58,16 +161,8 @@
(lambda (the-exn) (responders-servlet-loading uri the-exn))])
(call-with-continuation-prompt
(lambda ()
(define instance-custodian (make-servlet-custodian))
(define-values (servlet-path _)
(with-handlers
([void (lambda (e)
(raise (make-exn:fail:filesystem:exists
(exn-message e)
(exn-continuation-marks e))))])
(url->path uri)))
(parameterize ([current-directory (directory-part servlet-path)]
[current-custodian instance-custodian]
(define instance-custodian (make-servlet-custodian))
(parameterize ([current-custodian instance-custodian]
[exit-handler
(lambda _
(kill-connection! conn)
@ -75,8 +170,9 @@
;; any resources (e.g. threads) created when the
;; servlet is loaded should be within the dynamic
;; extent of the servlet custodian
(define the-servlet (cached-load servlet-path))
(define the-servlet (url->servlet uri))
(parameterize ([current-servlet the-servlet]
[current-directory (servlet-directory the-servlet)]
[current-namespace (servlet-namespace the-servlet)])
(define manager (servlet-manager the-servlet))
(parameterize ([current-execution-context (make-execution-context req)])
@ -91,18 +187,13 @@
servlet-prompt)))
(output-response conn response))
;; default-server-instance-expiration-handler : (request -> response)
(define (default-servlet-instance-expiration-handler req)
(next-dispatcher))
(define (invoke-servlet-continuation conn req instance-id k-id salt)
(define uri (request-uri req))
(define-values (servlet-path _) (url->path uri))
(define the-servlet (cached-load servlet-path))
(define the-servlet (url->servlet uri))
(define manager (servlet-manager the-servlet))
(define response
(parameterize ([current-servlet the-servlet]
[current-directory (directory-part servlet-path)]
[current-directory (servlet-directory the-servlet)]
[current-servlet-instance-id instance-id]
[current-custodian (servlet-custodian the-servlet)]
[current-namespace (servlet-namespace the-servlet)]
@ -127,73 +218,4 @@
servlet-prompt)))))
(output-response conn response))
;; cached-load : path -> script, namespace
(define (cached-load servlet-path)
(cache-table-lookup! (unbox config:scripts)
(string->symbol (path->string servlet-path))
(lambda () (load-servlet/path servlet-path))))
(define (v0.response->v1.lambda response response-path)
(define go
(box
(lambda ()
(set-box! go (lambda () (load/use-compiled response-path)))
response)))
(lambda (initial-request)
((unbox go))))
(define (v1.module->v1.lambda timeout start)
(lambda (initial-request)
(adjust-timeout! timeout)
(start initial-request)))
;; load-servlet/path path -> servlet
(define (load-servlet/path a-path)
(parameterize ([current-namespace (make-servlet-namespace
#:additional-specs
'(web-server/servlet
web-server/private/servlet
web-server/servlet/web
web-server/servlet/web-cells))]
[current-custodian (make-servlet-custodian)])
(define s (load/use-compiled a-path))
(cond
[(void? s)
(let* ([module-name `(file ,(path->string a-path))]
[version (dynamic-require module-name 'interface-version)])
(case version
[(v1)
(let ([timeout (dynamic-require module-name 'timeout)]
[start (dynamic-require module-name 'start)])
(make-servlet (current-custodian)
(current-namespace)
(create-timeout-manager
default-servlet-instance-expiration-handler
timeout
timeout)
(v1.module->v1.lambda timeout start)))]
[(v2)
(let ([start (dynamic-require module-name 'start)]
[manager (dynamic-require module-name 'manager)])
(make-servlet (current-custodian)
(current-namespace)
manager
start))]
[else
(error 'load-servlet/path "unknown servlet version ~e, must be 'v1 or 'v2" version)]))]
[(response? s)
(make-servlet (current-custodian)
(current-namespace)
(create-timeout-manager
default-servlet-instance-expiration-handler
timeouts-default-servlet
timeouts-default-servlet)
(v0.response->v1.lambda s a-path))]
[else
(error 'load-servlet/path
"Loading ~e produced ~n~e~n instead of either (1) a response or (2) nothing and exports 'interface-version" a-path s)])))
(values (lambda ()
;; This is broken - only out of date or specifically mentioned scripts should be flushed. This destroys persistent state!
(cache-table-clear! (unbox config:scripts)))
servlet-content-producer))
servlet-content-producer)

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

@ -3,14 +3,14 @@
mzlib/list
mzlib/contract)
(require "../private/util.ss")
(define url-path/c
(define url->path/c
((url?) . ->* . (path? (listof path-element?))))
(provide/contract
[url-path/c contract?]
[make-url->path (path? . -> . url-path/c)]
[make-url->valid-path (url-path/c . -> . url-path/c)]
[filter-url->path (regexp? url-path/c . -> . url-path/c)])
[url->path/c contract?]
[make-url->path (path? . -> . url->path/c)]
[make-url->valid-path (url->path/c . -> . url->path/c)]
[filter-url->path (regexp? url->path/c . -> . url->path/c)])
(define (build-path* . l)
(if (empty? l)

3
collects/web-server/private/servlet.ss
View File

@ -7,7 +7,7 @@
(define servlet-prompt (make-continuation-prompt-tag 'servlet))
(define-struct (exn:fail:servlet:instance exn:fail) ()
#:mutable)
(define-struct servlet (custodian namespace manager handler)
(define-struct servlet (custodian namespace manager directory handler)
#:mutable)
(define-struct execution-context (request)
#:mutable)
@ -28,6 +28,7 @@
([custodian custodian?]
[namespace namespace?]
[manager manager?]
[directory path?]
[handler (request? . -> . response?)])]
[struct execution-context
([request request?])]

77
collects/web-server/scribblings/dispatchers.scrbl
View File

@ -84,18 +84,18 @@ Consider the following example dispatcher, that captures the essence of URL rewr
@filepath{dispatchers/filesystem-map.ss} provides a means of mapping
URLs to paths on the filesystem.
@defthing[url-path/c contract?]{
@defthing[url->path/c contract?]{
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.}
@defproc[(make-url->path (base path?))
url-path/c]{
url->path/c]{
The @scheme[url-path/c] returned by this procedure considers the root
URL to be @scheme[base]. It ensures that @scheme[".."]s in the URL
do not escape the @scheme[base] and removes them silently otherwise.}
@defproc[(make-url->valid-path (url->path url->pathc))
@defproc[(make-url->valid-path (url->path url->path/c))
url->path/c]{
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
@ -312,7 +312,7 @@ a URL that refreshes the password file, servlet cache, etc.}
@elem{allows files to be served.
It defines a dispatcher construction procedure.}]{
@defproc[(make [#:url->path url->path url->path?]
@defproc[(make [#:url->path url->path url->path/c]
[#:path->mime-type path->mime-type (path? . -> . bytes?) (lambda (path) TEXT/HTML-MIME-TYPE)]
[#:indices indices (listof string?) (list "index.html" "index.htm")])
dispatcher/c]{
@ -332,13 +332,39 @@ a URL that refreshes the password file, servlet cache, etc.}
@a-dispatcher[web-server/dispatchers/dispatch-servlets
@elem{defines a dispatcher constructor
that runs servlets written in Scheme.}]{
@defthing[path->servlet/c contract?]{
Equivalent to @scheme[(path? . -> . servlet?)].
}
@defproc[(make [config:scripts (box/c cache-table?)]
[#:url->path url->path url->path?]
[#:make-servlet-namespace
make-servlet-namespace
make-servlet-namespace?
(make-make-servlet-namespace)]
@defproc[(make-default-path->servlet
[#:make-servlet-namespace
make-servlet-namespace
make-servlet-namespace?
(make-make-servlet-namespace)]
[#:timeouts-default-servlet
timeouts-default-servlet
integer?
30])
path->servlet/c]{
Constructs a procedure that loads a servlet from the path in a namespace created with @scheme[make-servlet-namespace],
using a timeout manager with @scheme[timeouts-default-servlet] as the default timeout (if no manager is given.)
}
@defthing[url->servlet/c contract?]{Equivalent to @scheme[(url? . -> . servlet?)]}
@defproc[(make-cached-url->servlet
[config:scripts (box/c cache-table?)]
[url->path url->path/c]
[path->serlvet path->servlet/c])
(values (-> void)
url->servlet/c)]{
The first return value flushes the cache.
The second is a procedure that uses @scheme[url->path] to resolve the URL to a path, then uses @scheme[path->servlet] to resolve
that path to a servlet, caching the results in @scheme[config:scripts].
}
@defproc[(make [url->servlet url->servlet/c]
[#:responders-servlet-loading
responders-servlet-loading
((url url?) (exn exn?) . -> . response?)
@ -346,27 +372,14 @@ a URL that refreshes the password file, servlet cache, etc.}
[#:responders-servlet
responders-servlet
((url url?) (exn exn?) . -> . response?)
servlet-error-responder]
[#:timeouts-default-servlet
timeouts-default-servlet
integer?
30])
(values (-> void)
dispatcher/c)]{
The first returned value is a procedure that refreshes the servlet
code cache.
The dispatcher does the following:
If the request URL contains a continuation reference, then it is invoked with the
request. Otherwise, @scheme[url->path] is used to resolve the URL to a path.
The path is evaluated as a module, in a namespace constructed by @scheme[make-servlet-namespace].
If this fails then @scheme[responders-servlet-loading] is used to format a response
with the exception. If it succeeds, then @scheme[start] export of the module is invoked.
If there is an error when a servlet is invoked, then @scheme[responders-servlet] is
used to format a response with the exception.
Servlets that do not specify timeouts are given timeouts according to @scheme[timeouts-default-servlet].
}}
servlet-error-responder])
dispatcher/c]{
This dispatcher runs Scheme servlets, using @scheme[url->servlet] to resolve URLs to the underlying servlets.
If servlets have errors loading, then @scheme[responders-servlet-loading] is used. Other errors are handled with
@scheme[responders-servlet].
}
}
@; ------------------------------------------------------------
@section[#:tag "dispatch-lang.ss"]{Serving Web Language Servlets}
@ -374,7 +387,7 @@ a URL that refreshes the password file, servlet cache, etc.}
@elem{defines a dispatcher constructor
that runs servlets written in the Web Language.}]{
@defproc[(make [#:url->path url->path url->path?]
@defproc[(make [#:url->path url->path url->path/c]
[#:make-servlet-namespace make-servlet-namespace
make-servlet-namespace?
(make-make-servlet-namespace)]

18
collects/web-server/servlet-env.ss
View File

@ -104,14 +104,15 @@
(lambda _ (next-dispatcher)))
(filter:make
#rx"\\.ss"
(let-values ([(clear-cache! servlet-dispatch)
(servlets:make (box the-scripts)
#:make-servlet-namespace make-servlet-namespace
#:url->path
(lambda _
(values (build-path servlets-root servlet-path)
empty)))])
servlet-dispatch))
(let-values ([(clear-cache! url->servlet)
(servlets:make-cached-url->servlet
(box the-scripts)
(lambda _
(values (build-path servlets-root servlet-path)
empty))
(servlets:make-default-path->servlet
#:make-servlet-namespace make-servlet-namespace))])
(servlets:make url->servlet)))
(apply sequencer:make
(map (lambda (extra-files-path)
(files:make
@ -138,6 +139,7 @@
(make-servlet (make-custodian)
(make-servlet-namespace)
manager
servlets-root
new-servlet)))
(when launch-browser?
((send-url) standalone-url #t))

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

@ -72,18 +72,17 @@
(path-procedure:make "/conf/collect-garbage"
(lambda _
(collect-garbage)
((responders-collect-garbage (host-responders host-info)))))
(let-values ([(clear-cache! servlet-dispatch)
(servlets:make config:scripts
#:make-servlet-namespace config:make-servlet-namespace
#:url->path
(fsmap:filter-url->path
#rx"\\.(ss|scm)$"
(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))
#:timeouts-default-servlet (timeouts-default-servlet (host-timeouts host-info)))])
((responders-collect-garbage (host-responders host-info)))))
(let-values ([(clear-cache! url->servlet)
(servlets:make-cached-url->servlet
config:scripts
(fsmap:filter-url->path
#rx"\\.(ss|scm)$"
(fsmap:make-url->valid-path
(fsmap:make-url->path (paths-servlet (host-paths host-info)))))
(servlets:make-default-path->servlet
#:make-servlet-namespace config:make-servlet-namespace
#:timeouts-default-servlet (timeouts-default-servlet (host-timeouts host-info))))])
(sequencer:make
(path-procedure:make "/conf/refresh-servlets"
(lambda _
@ -91,7 +90,9 @@
((responders-servlets-refreshed (host-responders host-info)))))
(sequencer:make
(timeout:make (timeouts-servlet-connection (host-timeouts host-info)))
servlet-dispatch)))
(servlets:make url->servlet
#:responders-servlet-loading (responders-servlet-loading (host-responders host-info))
#:responders-servlet (responders-servlet (host-responders host-info))))))
(files:make #:url->path (fsmap:make-url->path (paths-htdocs (host-paths host-info)))
#:path->mime-type (make-path->mime-type (paths-mime-types (host-paths host-info)))
#:indices (host-indices host-info))