From 5d3a76489f7c74cfe21895edb1636c2e6b8bbfa0 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 6 Feb 2009 17:01:31 +0000 Subject: [PATCH] up svn: r13466 --- .../web-server/scribblings/servlet-env.scrbl | 24 +++++++ collects/web-server/servlet-env.ss | 70 ++++++++++++++----- 2 files changed, 77 insertions(+), 17 deletions(-) diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index 016765d201..612d3405de 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -7,6 +7,7 @@ web-server/http web-server/managers/lru web-server/private/util + web-server/dispatchers/dispatch web-server/configuration/configuration-table web-server/configuration/responders web-server/dispatchers/dispatch-log @@ -157,4 +158,27 @@ If you want to use @scheme[serve/servlet] in a start up script for a Web server, are those allowed by @scheme[log-format->format]. } +@defproc[(dispatch/servlet + [start (request? . -> . response/c)] + [#:regexp regexp regexp? #rx""] + [#:stateless? stateless? boolean? #f] + [#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))] + [#:namespace namespace (listof module-path?) empty] + [#:current-directory servlet-current-directory path-string? (current-directory)]) + dispatcher/c]{ + @scheme[serve/servlet] starts a server and uses a particular dispatching sequence. For some applications, this + nails down too much, but users are conflicted, because the interface is so convenient. For those users, @scheme[dispatch/servlet] + does the hardest part of @scheme[serve/servlet] and constructs a dispatcher just for the @scheme[start] servlet. + + The dispatcher responds to requests that match @scheme[regexp]. The current directory + of servlet execution is @scheme[servlet-current-directory]. + + If @scheme[stateless?] is true, then the servlet is run as a stateless @schememodname[web-server] module. + + The servlet is loaded with @scheme[manager] as its continuation manager. (The default manager limits the amount of memory to 64 MB and + deals with memory pressure as discussed in the @scheme[make-threshold-LRU-manager] documentation.) + + The modules specified by @scheme[servlet-namespace] are shared with other servlets. +} + } diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 2aff0f14f3..728c2f3a27 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -17,6 +17,7 @@ web-server/configuration/responders web-server/private/mime-types web-server/servlet/setup + web-server/dispatchers/dispatch (prefix-in lift: web-server/dispatchers/dispatch-lift) (prefix-in fsmap: web-server/dispatchers/filesystem-map) (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer) @@ -42,6 +43,14 @@ "web-server/default-web-root")) (provide/contract + [dispatch/servlet (((request? . -> . response/c)) + (#:regexp regexp? + #:current-directory path-string? + #:namespace (listof module-path?) + #:stateless? boolean? + #:manager manager?) + . ->* . + dispatcher/c)] [serve/servlet (((request? . -> . response/c)) (#:command-line? boolean? #:launch-browser? boolean? @@ -74,6 +83,43 @@ [(list? (car ds)) (loop (append (car ds) (cdr ds)) r)] [else (loop (cdr ds) (cons (car ds) r))]))) +(define (dispatch/servlet + start + #:regexp + [servlet-regexp #rx""] + #:current-directory + [servlet-current-directory (current-directory)] + #:namespace + [servlet-namespace empty] + #:stateless? + [stateless? #f] + #:manager + [manager + (make-threshold-LRU-manager + (lambda (request) + `(html (head (title "Page Has Expired.")) + (body (p "Sorry, this page has expired. Please go back.")))) + (* 64 1024 1024))]) + (define servlet-box (box #f)) + (define make-servlet-namespace + (make-make-servlet-namespace #:to-be-copied-module-specs servlet-namespace)) + (filter:make + servlet-regexp + (servlets:make + (lambda (url) + (or (unbox servlet-box) + (let ([servlet + (parameterize ([current-custodian (make-custodian)] + [current-namespace + (make-servlet-namespace + #:additional-specs + default-module-specs)]) + (if stateless? + (make-stateless.servlet servlet-current-directory start) + (make-v2.servlet servlet-current-directory manager start)))]) + (set-box! servlet-box servlet) + servlet)))))) + (define (serve/servlet start #:command-line? @@ -140,28 +186,18 @@ (define make-servlet-namespace (make-make-servlet-namespace #:to-be-copied-module-specs servlet-namespace)) (define sema (make-semaphore 0)) - (define servlet-box (box #f)) (define dispatcher (dispatcher-sequence (and log-file (log:make #:format (log:log-format->format log-format) #:log-path log-file)) (and quit? (filter:make #rx"^/quit$" (quit-server sema))) - (filter:make - servlet-regexp - (servlets:make - (lambda (url) - (or (unbox servlet-box) - (let ([servlet - (parameterize ([current-custodian (make-custodian)] - [current-namespace - (make-servlet-namespace - #:additional-specs - default-module-specs)]) - (if stateless? - (make-stateless.servlet servlet-current-directory start) - (make-v2.servlet servlet-current-directory manager start)))]) - (set-box! servlet-box servlet) - servlet))))) + (dispatch/servlet + start + #:regexp servlet-regexp + #:namespace servlet-namespace + #:stateless? stateless? + #:current-directory servlet-current-directory + #:manager manager) (let-values ([(clear-cache! url->servlet) (servlets:make-cached-url->servlet (fsmap:filter-url->path