Pulling out servlet creation routines

svn: r12394

collects/tests/web-server/dispatchers/dispatch-lang-test.ss

@@ -6,7 +6,7 @@
          web-server/dispatchers/dispatch
          web-server/private/request-structs
          web-server/configuration/namespace
-         #;(prefix-in lang: web-server/dispatchers/dispatch-lang)
+         web-server/servlet/setup
          (prefix-in servlets: web-server/dispatchers/dispatch-servlets)
          "servlet-test-util.ss"
          "../util.ss")
@@ -29,7 +29,7 @@
   (define-values (! u->s)
     (servlets:make-cached-url->servlet
      (lambda _ (values p url0s))
-     (servlets:make-default-path->servlet)))
+     (make-default-path->servlet)))
   (define d
     (servlets:make u->s
                    #:responders-servlet-loading

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

@@ -7,6 +7,7 @@
          web-server/private/cache-table
          web-server/private/web-server-structs
          web-server/configuration/namespace
+         web-server/servlet/setup
          (prefix-in servlets: web-server/dispatchers/dispatch-servlets)
          "servlet-test-util.ss"
          "../util.ss")
@@ -18,7 +19,7 @@
   (define-values (! u->s)
     (servlets:make-cached-url->servlet
      (lambda _ (values p url0s))
-     (servlets:make-default-path->servlet)))
+     (make-default-path->servlet)))
   (define d
     (servlets:make u->s
                    #:responders-servlet-loading

collects/web-server/dispatchers/dispatch-servlets.ss

@@ -1,151 +1,22 @@
 #lang scheme/base
-(require mzlib/plt-match
-         scheme/contract)
-(require "dispatch.ss"
-         "../private/web-server-structs.ss"
-         "../private/connection-manager.ss"
-         web-server/managers/none
-         (only-in "../lang/web.ss"
-                  initialize-servlet)
-         "../private/response.ss"
-         "../private/request-structs.ss"
-         "../private/response-structs.ss"
-         "../servlet/web-cells.ss"
-         "../servlet/web.ss"
+(require scheme/contract)
+(require web-server/servlet/setup
+         web-server/managers/manager
+         web-server/private/response
+         web-server/private/response-structs
+         web-server/private/request-structs
          net/url
-         "../dispatchers/filesystem-map.ss"
-         "../configuration/responders.ss"
-         "../configuration/namespace.ss"
-         "../managers/manager.ss"
-         "../managers/timeouts.ss"
-         (except-in "../private/servlet.ss"
-                    servlet-prompt)
-         "../private/cache-table.ss"
-         "../private/util.ss")
+         web-server/dispatchers/dispatch
+         web-server/dispatchers/filesystem-map
+         web-server/configuration/responders
+         web-server/private/connection-manager
+         web-server/private/web-server-structs
+         web-server/private/servlet
+         web-server/private/cache-table)
 (provide/contract
  [interface-version dispatcher-interface-version/c])
 (define interface-version 'v1)
 
-; -----
-(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 (make-v1.servlet directory timeout start)
-  (make-v2.servlet 
-   directory                   
-   (create-timeout-manager
-    default-servlet-instance-expiration-handler
-    timeout
-    timeout)
-   (lambda (initial-request)
-     (adjust-timeout! timeout)
-     (start initial-request))))
-
-(define (make-v2.servlet directory manager start)
-  (make-servlet 
-   (current-custodian)
-   (current-namespace)
-   manager
-   directory                
-   (lambda (req)
-     (define uri (request-uri req))
-     
-     (define-values (instance-id handler)
-       (cond
-         [(continuation-url? uri)
-          => (match-lambda
-               [(list instance-id k-id salt)
-                (values instance-id
-                        (custodian-box-value ((manager-continuation-lookup manager) instance-id k-id salt)))])]
-         [else
-          (values ((manager-create-instance manager) (exit-handler))
-                  start)]))
-     
-     (parameterize ([current-servlet-instance-id instance-id])
-       (handler req)))))
-
-(define (make-stateless.servlet directory start)
-  (define ses 
-    (make-servlet
-     (current-custodian) (current-namespace)
-     (create-none-manager (lambda (req) (error "No continuations!")))
-     directory
-     (lambda (req) (error "Session not initialized"))))
-  (parameterize ([current-directory directory]
-                 [current-servlet ses])    
-    (set-servlet-handler! ses (initialize-servlet start)))
-  ses)
-
-(define common-module-specs
-  '(web-server/private/servlet
-    web-server/private/request-structs
-    web-server/private/response-structs))
-
-(define servlet-module-specs
-  '(web-server/servlet/web
-    web-server/servlet/web-cells))
-(define lang-module-specs
-  '(web-server/lang/web-cells
-    web-server/lang/abort-resume))
-(define default-module-specs
-  (append common-module-specs
-          servlet-module-specs
-          lang-module-specs))
-(provide/contract
- [make-v1.servlet (path? integer? (request? . -> . response?) . -> . servlet?)]
- [make-v2.servlet (path? manager? (request? . -> . response?) . -> . servlet?)]
- [make-stateless.servlet (path? (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
-                                       default-module-specs)]
-                   [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))]
-             [(stateless)
-              (let ([start (dynamic-require module-name 'start)])
-                (make-stateless.servlet (directory-part a-path) start))]
-             [else
-              (error 'path->servlet "unknown servlet version ~e, must be 'v1, 'v2, or 'stateless" 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?]

collects/web-server/run.ss

@@ -1,72 +0,0 @@
-#lang scheme/base
-; This file is intended to be copied and/or modified and used as a template.
-(require mzlib/cmdline
-         (only-in mzlib/file
-                  normalize-path)
-         web-server/web-server
-         web-server/configuration/responders
-         web-server/private/mime-types
-         (prefix-in path-procedure: "dispatchers/dispatch-pathprocedure.ss")
-         (prefix-in fsmap: web-server/dispatchers/filesystem-map)
-         (prefix-in timeout: web-server/dispatchers/dispatch-timeout)
-         (prefix-in files: web-server/dispatchers/dispatch-files)
-         (prefix-in filter: web-server/dispatchers/dispatch-filter)
-         (prefix-in lift: web-server/dispatchers/dispatch-lift)
-         (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
-         (prefix-in servlets: web-server/dispatchers/dispatch-servlets)
-         (prefix-in stat: web-server/dispatchers/dispatch-stat))
-
-(define server-root-path (make-parameter (collection-path "web-server" "default-web-root")))
-(define port (make-parameter 8080))
-
-(parse-command-line 
- "run" (current-command-line-arguments)
- `((once-each
-    [("-p" "--port") 
-     ,(lambda (flag the-port) (port (string->number the-port)))
-     (,(format "Specify a different port (default: ~a)" (number->string (port)))
-      "number")]
-    [("-r" "--root") 
-     ,(lambda (flag path) (server-root-path (normalize-path (string->path path))))
-     (,(format "Specify a different server root path (default: ~a)" (path->string (server-root-path)))
-      "path")]))
- (lambda (flag-accum) (void))
- null)
-
-(define default-host-path (build-path (server-root-path) "conf"))  
-(define file-not-found-file (build-path default-host-path "not-found.html"))
-(define servlet-error-file (build-path default-host-path "servlet-error.html"))
-(define servlet-refresh-file (build-path default-host-path "servlet-refresh.html"))
-
-(define url->path
-  (fsmap:make-url->path 
-   (build-path (server-root-path) "htdocs")))
-
-(define gc-thread (stat:make-gc-thread 30))
-
-(serve #:port (port)
-       #:dispatch
-       (sequencer:make          
-        (timeout:make (* 5 60))
-        (stat:make)
-        (let-values ([(clear-cache! url->servlet)
-                      (servlets:make-cached-url->servlet
-                       (fsmap:filter-url->path
-                        #rx"\\.(ss|scm)$"
-                        (fsmap:make-url->valid-path
-                         url->path))
-                       (servlets:make-default-path->servlet))])
-          (sequencer:make
-           (path-procedure:make "/conf/refresh-servlets"
-                                (lambda _
-                                  (clear-cache!)
-                                  ((gen-servlets-refreshed servlet-refresh-file))))
-           (servlets:make url->servlet
-                          #:responders-servlet-loading (gen-servlet-responder servlet-error-file)
-                          #:responders-servlet (gen-servlet-responder servlet-error-file))))
-        (files:make #:url->path url->path
-                    #:path->mime-type (make-path->mime-type (build-path (server-root-path) "mime.types"))
-                    #:indices (list "index.html" "index.htm"))
-        (lift:make (gen-file-not-found-responder file-not-found-file))))
-
-(do-not-return)

collects/web-server/scribblings/dispatchers.scrbl

@@ -332,48 +332,6 @@ 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.}]{
-
-@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.
-}
- 
-@defproc[(make-stateless.servlet [directory path?]
-                                 [start (request? . -> . response?)])
-         servlet?]{
- Creates a stateless @schememodname[web-server] servlet that uses @scheme[directory] as its current directory 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?)].
-}
-
-@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?)]}
 

collects/web-server/scribblings/running.scrbl

@@ -82,7 +82,7 @@ To run the web server with MrEd, use
 
 @filepath{web-server.ss} provides a number of functions for easing embedding
 of the @web-server in other applications, or loading a custom
-dispatcher. See @filepath{run.ss} for an example of such a script.
+dispatcher. 
 
 @defproc[(serve [#:dispatch dispatch dispatcher?]
                 [#:tcp@ tcp@ tcp-unit^ raw:tcp@]

collects/web-server/scribblings/servlet.scrbl

@@ -673,3 +673,53 @@ transformations of the program into continuation or store passing style.
                         (loop)))])
                   "+")))))))
 ]
+
+@; ------------------------------------------------------------
+@section[#:tag "setup.ss"]{Setup}
+@(require (for-label web-server/servlet/setup))
+
+@defmodule[web-server/servlet/setup]
+
+This module is used internally to build and load servlets. It may be useful to those who are trying to extend the server.
+
+@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.
+}
+ 
+@defproc[(make-stateless.servlet [directory path?]
+                                 [start (request? . -> . response?)])
+         servlet?]{
+ Creates a stateless @schememodname[web-server] servlet that uses @scheme[directory] as its current directory 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?)].
+}
+
+@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.)
+} 

collects/web-server/servlet-env.ss

@@ -17,6 +17,7 @@
          web-server/dispatchers/dispatch
          web-server/private/mime-types
          web-server/configuration/configuration-table
+         web-server/servlet/setup
          (prefix-in lift: web-server/dispatchers/dispatch-lift)
          (prefix-in fsmap: web-server/dispatchers/filesystem-map)         
          (prefix-in sequencer: web-server/dispatchers/dispatch-sequencer)
@@ -121,10 +122,10 @@
                                    [current-namespace
                                     (make-servlet-namespace
                                      #:additional-specs
-                                     servlets:default-module-specs)])
+                                     default-module-specs)])
                       (if stateless?
-                          (servlets:make-stateless.servlet servlet-current-directory start)
-                          (servlets:make-v2.servlet servlet-current-directory manager start)))])
+                          (make-stateless.servlet servlet-current-directory start)
+                          (make-v2.servlet servlet-current-directory manager start)))])
                (set-box! servlet-box servlet)
                servlet)))))
      (let-values ([(clear-cache! url->servlet)
@@ -133,7 +134,7 @@
                      #rx"\\.(ss|scm)$"
                      (fsmap:make-url->valid-path
                       (fsmap:make-url->path servlets-root)))
-                    (servlets:make-default-path->servlet
+                    (make-default-path->servlet
                      #:make-servlet-namespace make-servlet-namespace))])
        (servlets:make url->servlet))
      (apply sequencer:make

collects/web-server/servlet/setup.ss

@@ -0,0 +1,131 @@
+#lang scheme/base
+(require mzlib/plt-match
+         scheme/contract)
+(require web-server/managers/manager
+         web-server/managers/timeouts
+         web-server/managers/none
+         (only-in web-server/lang/web
+                  initialize-servlet)
+         web-server/private/response-structs
+         web-server/private/request-structs
+         web-server/servlet/web
+         web-server/configuration/namespace
+         web-server/private/web-server-structs
+         web-server/private/servlet
+         web-server/private/util)
+
+(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 (make-v1.servlet directory timeout start)
+  (make-v2.servlet 
+   directory                   
+   (create-timeout-manager
+    #f timeout timeout)
+   (lambda (initial-request)
+     (adjust-timeout! timeout)
+     (start initial-request))))
+
+(define (make-v2.servlet directory manager start)
+  (make-servlet 
+   (current-custodian)
+   (current-namespace)
+   manager
+   directory                
+   (lambda (req)
+     (define uri (request-uri req))
+     
+     (define-values (instance-id handler)
+       (cond
+         [(continuation-url? uri)
+          => (match-lambda
+               [(list instance-id k-id salt)
+                (values instance-id
+                        (custodian-box-value ((manager-continuation-lookup manager) instance-id k-id salt)))])]
+         [else
+          (values ((manager-create-instance manager) (exit-handler))
+                  start)]))
+     
+     (parameterize ([current-servlet-instance-id instance-id])
+       (handler req)))))
+
+(define (make-stateless.servlet directory start)
+  (define ses 
+    (make-servlet
+     (current-custodian) (current-namespace)
+     (create-none-manager (lambda (req) (error "No continuations!")))
+     directory
+     (lambda (req) (error "Session not initialized"))))
+  (parameterize ([current-directory directory]
+                 [current-servlet ses])    
+    (set-servlet-handler! ses (initialize-servlet start)))
+  ses)
+
+(define common-module-specs
+  '(web-server/private/servlet
+    web-server/private/request-structs
+    web-server/private/response-structs))
+
+(define servlet-module-specs
+  '(web-server/servlet/web
+    web-server/servlet/web-cells))
+(define lang-module-specs
+  '(web-server/lang/web-cells
+    web-server/lang/abort-resume))
+(define default-module-specs
+  (append common-module-specs
+          servlet-module-specs
+          lang-module-specs))
+(provide/contract
+ [make-v1.servlet (path? integer? (request? . -> . response?) . -> . servlet?)]
+ [make-v2.servlet (path? manager? (request? . -> . response?) . -> . servlet?)]
+ [make-stateless.servlet (path? (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
+                                       default-module-specs)]
+                   [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))]
+             [(stateless)
+              (let ([start (dynamic-require module-name 'start)])
+                (make-stateless.servlet (directory-part a-path) start))]
+             [else
+              (error 'path->servlet "unknown servlet version ~e, must be 'v1, 'v2, or 'stateless" 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)]))))

collects/web-server/web-server-unit.ss

@@ -11,6 +11,7 @@
          "private/cache-table.ss"
          (prefix-in http: "private/request.ss"))
 (require "dispatchers/dispatch.ss"
+         web-server/servlet/setup
          (prefix-in fsmap: "dispatchers/filesystem-map.ss")
          (prefix-in sequencer: "dispatchers/dispatch-sequencer.ss")
          (prefix-in timeout: web-server/dispatchers/dispatch-timeout)
@@ -81,7 +82,7 @@
                      #rx"\\.(ss|scm)$"
                      (fsmap:make-url->valid-path
                       (fsmap:make-url->path (paths-servlet (host-paths host-info)))))
-                    (servlets:make-default-path->servlet
+                    (make-default-path->servlet
                      #:make-servlet-namespace config:make-servlet-namespace
                      #:timeouts-default-servlet (timeouts-default-servlet (host-timeouts host-info))))])
        (sequencer:make