Expanding functionality of serve/servlet

svn: r12346

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

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
+                                       default-module-specs)]
-                                         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

collects/web-server/scribblings/dispatchers.scrbl

@@ -333,6 +333,24 @@ a URL that refreshes the password file, servlet cache, etc.}
               @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?)].
 }

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,30 +56,32 @@ 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")]
+                                          (build-path server-root-path "mime.types")])
-                       [#:servlet-path servlet-path path?
-                                       "servlets/standalone.ss"])
                        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]
+ @scheme[start] is loaded as a servlet and responds to requests that match @scheme[servlet-regexp]. The current directory
- as its continuation manager. (The default manager limits the amount of memory to 64 MB and
+ of servlet execution is @scheme[servlet-current-directory].
- 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.
+ If @scheme[launch-browser?] is true, then a web browser is opened to @filepath{http://localhost:<port><servlet-path>}.
  
  If @scheme[quit?] is true, then the URL @filepath["/quit"] ends the server.
  
@@ -77,12 +89,17 @@ Notice that you may pass any number of extra paths.
  
  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.
  

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?
@@ -74,6 +75,11 @@
                                   (body (p "Sorry, this page has expired. Please go back."))))
                          (* 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]
                        #:server-root-path 
@@ -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")]
+                       [mime-types-path (build-path server-root-path "mime.types")])
-                       #:servlet-path
-                       [servlet-path "servlets/standalone.ss"])
   (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"
+          servlet-regexp
-          (let-values ([(clear-cache! url->servlet)
+          (servlets:make (lambda (url) servlet)))
-                        (servlets:make-cached-url->servlet
+         (let-values ([(clear-cache! url->servlet)
-                         (box the-scripts)
+                       (servlets:make-cached-url->servlet
-                         (lambda _
+                        (box the-scripts)
-                           (values (build-path servlets-root servlet-path)
+                        (fsmap:filter-url->path
-                                   empty))
+                         #rx"\\.(ss|scm)$"
-                         (servlets:make-default-path->servlet
+                         (fsmap:make-url->valid-path
-                          #:make-servlet-namespace make-servlet-namespace))])
+                          (fsmap:make-url->path servlets-root)))
-            (servlets:make url->servlet)))
+                        (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 
@@ -131,16 +146,6 @@
         (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)))
     (when launch-browser?
       ((send-url) standalone-url #t))
     (printf "Your Web application is running at ~a.~n" standalone-url)