From a8bc141a772863efc81305386afca33d5ef4b6fa Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 6 Nov 2008 22:23:45 +0000 Subject: [PATCH] Generalizing dispatch-servlets svn: r12338 --- .../dispatchers/dispatch-servlets-test.ss | 10 +- .../web-server/dispatchers/dispatch-files.ss | 2 +- .../web-server/dispatchers/dispatch-lang.ss | 2 +- .../dispatchers/dispatch-servlets.ss | 232 ++++++++++-------- .../web-server/dispatchers/filesystem-map.ss | 10 +- collects/web-server/private/servlet.ss | 3 +- .../web-server/scribblings/dispatchers.scrbl | 77 +++--- collects/web-server/servlet-env.ss | 18 +- collects/web-server/web-server-unit.ss | 27 +- 9 files changed, 212 insertions(+), 169 deletions(-) diff --git a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss index 15ff62287c..bfeb4bf7f8 100644 --- a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss @@ -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)) diff --git a/collects/web-server/dispatchers/dispatch-files.ss b/collects/web-server/dispatchers/dispatch-files.ss index 406f55cf5c..dc5b4cd77e 100644 --- a/collects/web-server/dispatchers/dispatch-files.ss +++ b/collects/web-server/dispatchers/dispatch-files.ss @@ -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)]) diff --git a/collects/web-server/dispatchers/dispatch-lang.ss b/collects/web-server/dispatchers/dispatch-lang.ss index f50f48727d..c806429af7 100644 --- a/collects/web-server/dispatchers/dispatch-lang.ss +++ b/collects/web-server/dispatchers/dispatch-lang.ss @@ -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?)) diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index 72f2b0e1b8..40f48a2c1e 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -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) diff --git a/collects/web-server/dispatchers/filesystem-map.ss b/collects/web-server/dispatchers/filesystem-map.ss index bed3e607e5..346733be88 100644 --- a/collects/web-server/dispatchers/filesystem-map.ss +++ b/collects/web-server/dispatchers/filesystem-map.ss @@ -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) diff --git a/collects/web-server/private/servlet.ss b/collects/web-server/private/servlet.ss index 838dc8e351..daac93335b 100644 --- a/collects/web-server/private/servlet.ss +++ b/collects/web-server/private/servlet.ss @@ -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?])] diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl index e4fc46403a..39e65b4aa7 100644 --- a/collects/web-server/scribblings/dispatchers.scrbl +++ b/collects/web-server/scribblings/dispatchers.scrbl @@ -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)] diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index dc21ae91b4..5158ada8cc 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -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)) diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index 714031dc23..a9fc06229c 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -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))