From 7479f59e13d0ccb94c20f79b0c0996ceae4ddfcf Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 7 Nov 2008 18:54:23 +0000 Subject: [PATCH] Expanding functionality of serve/servlet svn: r12346 --- collects/tests/web-server/servlet-env/env.ss | 28 +++++++++ .../dispatchers/dispatch-servlets.ss | 15 +++-- .../web-server/scribblings/dispatchers.scrbl | 20 +++++- .../web-server/scribblings/servlet-env.scrbl | 45 ++++++++----- collects/web-server/servlet-env.ss | 63 ++++++++++--------- 5 files changed, 123 insertions(+), 48 deletions(-) create mode 100644 collects/tests/web-server/servlet-env/env.ss diff --git a/collects/tests/web-server/servlet-env/env.ss b/collects/tests/web-server/servlet-env/env.ss new file mode 100644 index 0000000000..6826d5c4d7 --- /dev/null +++ b/collects/tests/web-server/servlet-env/env.ss @@ -0,0 +1,28 @@ +#lang scheme +(require web-server/servlet + web-server/servlet-env) + +; request-number : str -> num +(define (request-number which-number) + (string->number + (extract-binding/single + 'number + (request-bindings (send/suspend (build-request-page which-number)))))) + +; build-request-page : str -> str -> response +(define (build-request-page which-number) + (lambda (k-url) + `(html (head (title "Enter a Number to Add")) + (body ([bgcolor "white"]) + (form ([action ,k-url] [method "post"]) + "Enter the " ,which-number " number to add: " + (input ([type "text"] [name "number"] [value ""])) + (input ([type "submit"] [name "enter"] [value "Enter"]))))))) +(define (start request) + `(html (head (title "Sum")) + (body ([bgcolor "white"]) + (p "The sum is " + ,(number->string (+ (request-number "first") (request-number "second"))))))) + +(serve/servlet start + #:servlet-path "/") \ No newline at end of file diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index 40f48a2c1e..4b137b7256 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -62,15 +62,22 @@ directory start)) +(define default-module-specs + '(web-server/servlet + web-server/private/servlet + web-server/servlet/web + web-server/servlet/web-cells)) +(provide/contract + [make-v1.servlet (path? integer? (request? . -> . response?) . -> . servlet?)] + [make-v2.servlet (path? manager? (request? . -> . response?) . -> . servlet?)] + [default-module-specs (listof module-path?)]) + (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))] + default-module-specs)] [current-custodian (make-servlet-custodian)]) (define s (load/use-compiled a-path)) (cond diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl index 39e65b4aa7..410b2c9ee1 100644 --- a/collects/web-server/scribblings/dispatchers.scrbl +++ b/collects/web-server/scribblings/dispatchers.scrbl @@ -332,7 +332,25 @@ 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.}]{ - + +@defproc[(make-v1.servlet [directory path?] + [timeout integer?] + [start (request? . -> . response?)]) + servlet?]{ + Creates a version 1 servlet that uses @scheme[directory] as its current directory, a timeout manager with a @scheme[timeout] timeout, and @scheme[start] as the request handler. +} + +@defproc[(make-v2.servlet [directory path?] + [manager manager?] + [start (request? . -> . response?)]) + servlet?]{ + Creates a version 2 servlet that uses @scheme[directory] as its current directory, a @scheme[manager] as the continuation manager, and @scheme[start] as the request handler. +} + +@defthing[default-module-specs (listof module-path?)]{ + The modules that the Web Server needs to share with all servlets. +} + @defthing[path->servlet/c contract?]{ Equivalent to @scheme[(path? . -> . servlet?)]. } diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index 2d1b30787b..e6427f26aa 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -32,9 +32,19 @@ By default the URL for your servlet is @filepath{http://localhost:8000/servlets/ suppose you wanted it to be @filepath{http://localhost:8000/hello.ss}: @schemeblock[ (serve/servlet my-app - #:servlet-path (build-path "hello.ss")) + #:servlet-path "/hello.ss") +] + +Suppose you wanted it to capture top-level requests: +@schemeblock[ +(serve/servlet my-app + #:servlet-path "/") +] +Or, perhaps just some nice top-level name: +@schemeblock[ +(serve/servlet my-app + #:servlet-path "/main") ] -For the time being, this path must end in @filepath{.ss} or @filepath{.scm}. Suppose you wanted to use a style-sheet (@filepath{style.css}) found on your Desktop (@filepath{/Users/jay/Desktop/}): @schemeblock[ @@ -46,43 +56,50 @@ Suppose you wanted to use a style-sheet (@filepath{style.css}) found on your Des These files are served @emph{in addition} to those from the @scheme[#:server-root-path] @filepath{htdocs} directory. Notice that you may pass any number of extra paths. -@defproc[(serve/servlet [servlet (request? . -> . response?)] +@defproc[(serve/servlet [start (request? . -> . response?)] [#:launch-browser? launch-browser? boolean? #t] [#:quit? quit? boolean? #t] [#:listen-ip listen-ip string? "127.0.0.1"] [#:port port number? 8000] + [#:servlet-path servlet-path string? + "/servlets/standalone.ss"] + [#:servlet-regexp servlet-regexp regexp? + (regexp (format "^~a$" (regexp-quote servlet-path)))] [#:manager manager manager? default-threshold-LRU-manager] [#:servlet-namespace servlet-namespace (listof module-path?) empty] [#:server-root-path server-root-path path? default-server-root-path] [#:extra-files-paths extra-files-paths (listof path?) (list (build-path server-root-path "htdocs"))] - [#:servlets-root servlets-root path? (build-path server-root-path ".")] + [#:servlets-root servlets-root path? (build-path server-root-path "htdocs")] + [#:servlet-current-directory servlet-current-directory path? servlets-root] [#:file-not-found-path file-not-found-path path? (build-path server-root-path "conf" "not-found.html")] [#:mime-types-path mime-types-path path? - (build-path server-root-path "mime.types")] - [#:servlet-path servlet-path path? - "servlets/standalone.ss"]) + (build-path server-root-path "mime.types")]) void]{ This sets up and starts a fairly default server instance. - @scheme[servlet] is installed as a server at @scheme[servlet-path] 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.) - - If @scheme[launch-browser?] is true, then a web browser is opened to the servlet's start page. + @scheme[start] is loaded as a servlet and responds to requests that match @scheme[servlet-regexp]. The current directory + of servlet execution is @scheme[servlet-current-directory]. + + If @scheme[launch-browser?] is true, then a web browser is opened to @filepath{http://localhost:}. If @scheme[quit?] is true, then the URL @filepath["/quit"] ends the server. - + Advanced users may need the following options: The server listens on @scheme[listen-ip] and port @scheme[port]. + 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. The server files are rooted at @scheme[server-root-path] (which is defaultly the distribution root.) File paths, in addition to the @filepath["htdocs"] directory under @scheme[server-root-path] may be provided with @scheme[extra-files-paths]. These paths are checked first, in the order they appear in the list. - The @filepath["servlets"] directory is expected at @scheme[servlets-root]. + + Other servlets are served from @scheme[servlets-root]. If a file cannot be found, @scheme[file-not-found-path] is used as an error response. diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 5158ada8cc..5e2b1fedae 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -52,10 +52,11 @@ #:servlets-root path? #:file-not-found-path path? #:mime-types-path path? - #:servlet-path path?) + #:servlet-path string? + #:servlet-regexp regexp?) . ->* . void)]) -(define (serve/servlet new-servlet +(define (serve/servlet start #:launch-browser? [launch-browser? #t] #:quit? @@ -72,7 +73,12 @@ (lambda (request) `(html (head (title "Page Has Expired.")) (body (p "Sorry, this page has expired. Please go back.")))) - (* 64 1024 1024))] + (* 64 1024 1024))] + + #:servlet-path + [servlet-path "/servlets/standalone.ss"] + #:servlet-regexp + [servlet-regexp (regexp (format "^~a$" (regexp-quote servlet-path)))] #:servlet-namespace [servlet-namespace empty] @@ -81,20 +87,27 @@ #:extra-files-paths [extra-files-paths (list (build-path server-root-path "htdocs"))] #:servlets-root - [servlets-root (build-path server-root-path ".")] + [servlets-root (build-path server-root-path "htdocs")] + #:servlet-current-directory + [servlet-current-directory servlets-root] #:file-not-found-path [file-not-found-path (build-path server-root-path "conf" "not-found.html")] #:mime-types-path - [mime-types-path (build-path server-root-path "mime.types")] - #:servlet-path - [servlet-path "servlets/standalone.ss"]) + [mime-types-path (build-path server-root-path "mime.types")]) (let*-values ([(standalone-url) - (format "http://localhost:~a/~a" the-port servlet-path)] + (format "http://localhost:~a~a" the-port servlet-path)] [(make-servlet-namespace) (make-make-servlet-namespace #:to-be-copied-module-specs servlet-namespace)] [(the-scripts) (make-cache-table)] [(sema) (make-semaphore 0)] + [(servlet) + (parameterize ([current-custodian (make-custodian)] + [current-namespace + (make-servlet-namespace + #:additional-specs + servlets:default-module-specs)]) + (servlets:make-v2.servlet servlet-current-directory manager start))] [(dispatcher) (sequencer:make (if quit? @@ -103,16 +116,18 @@ (quit-server sema)) (lambda _ (next-dispatcher))) (filter:make - #rx"\\.ss" - (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))) + servlet-regexp + (servlets:make (lambda (url) servlet))) + (let-values ([(clear-cache! url->servlet) + (servlets:make-cached-url->servlet + (box the-scripts) + (fsmap:filter-url->path + #rx"\\.(ss|scm)$" + (fsmap:make-url->valid-path + (fsmap:make-url->path servlets-root))) + (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 @@ -130,17 +145,7 @@ [(shutdown-server) (serve #:dispatch dispatcher #:listen-ip listen-ip - #:port the-port)]) - (cache-table-lookup! the-scripts - (string->symbol - (path->string - (build-path servlets-root servlet-path))) - (lambda () - (make-servlet (make-custodian) - (make-servlet-namespace) - manager - servlets-root - new-servlet))) + #:port the-port)]) (when launch-browser? ((send-url) standalone-url #t)) (printf "Your Web application is running at ~a.~n" standalone-url)