Merging the web language dispatcher into the standard one

svn: r12378

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

@@ -6,12 +6,13 @@
          web-server/dispatchers/dispatch
          web-server/private/request-structs
          web-server/configuration/namespace
-         (prefix-in lang: web-server/dispatchers/dispatch-lang)
+         #;(prefix-in lang: web-server/dispatchers/dispatch-lang)
+         (prefix-in servlets: web-server/dispatchers/dispatch-servlets)
          "servlet-test-util.ss"
          "../util.ss")
 (provide dispatch-lang-tests)
 
-(define (mkd p)
+#;(define (mkd p)
   (lang:make #:url->path (lambda _ (values p (list p)))
              #:make-servlet-namespace
              (make-make-servlet-namespace)
@@ -24,6 +25,21 @@
                ((error-display-handler) (exn-message exn) exn)
                (raise exn))))
 
+(define (mkd p)
+  (define-values (! u->s)
+    (servlets:make-cached-url->servlet
+     (lambda _ (values p url0s))
+     (servlets:make-default-path->servlet)))
+  (define d
+    (servlets:make u->s
+                   #:responders-servlet-loading
+                   (lambda (u exn)
+                     (raise exn))
+                   #:responders-servlet
+                   (lambda (u exn)
+                     (raise exn))))
+  d)
+
 (define example-servlets (build-path (collection-path "web-server") "default-web-root" "htdocs" "lang-servlets/"))
 
 (define dispatch-lang-tests
@@ -32,7 +48,7 @@
    
    (test-exn
     "add-param.ss - Parameters, s/s/u (should fail)"
-    exn:dispatcher?
+    exn:fail:contract?
     (lambda ()
       (let* ([xs #"10"]
              [ys #"17"]

collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss

@@ -1,5 +1,6 @@
 #lang web-server
-(provide start)
+(define interface-version 'stateless)
+(provide start interface-version)
 
 (define msg (make-parameter "unknown"))
 

collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss

@@ -1,5 +1,6 @@
 #lang web-server
-(provide start)
+(define interface-version 'stateless)
+(provide start interface-version)
 
 (define msg (make-web-parameter "unknown"))
 

collects/web-server/default-web-root/htdocs/lang-servlets/add.ss

@@ -1,5 +1,6 @@
 #lang web-server
-(provide start)
+(define interface-version 'stateless)
+(provide start interface-version)
 
 ;; get-number-from-user: string -> number
 ;; ask the user for a number

collects/web-server/default-web-root/htdocs/lang-servlets/add01.ss

@@ -1,7 +1,8 @@
 #lang scheme/base
 (require web-server/private/request-structs
          net/url)
-(provide start)
+(define interface-version 'stateless)
+(provide start interface-version)
 
 (define (start req)
   (let* ([uri (request-uri req)]

collects/web-server/default-web-root/htdocs/lang-servlets/add02.ss

@@ -1,5 +1,6 @@
 #lang web-server
-(provide start)
+(define interface-version 'stateless)
+(provide start interface-version)
 
 ;; get-number-from-user: string -> number
 ;; ask the user for a number

collects/web-server/default-web-root/htdocs/lang-servlets/add03.ss

@@ -1,5 +1,6 @@
 #lang web-server
-(provide start)
+(define interface-version 'stateless)
+(provide start interface-version)
 
 ;; get-number-from-user: string -> number
 ;; ask the user for a number

collects/web-server/default-web-root/htdocs/lang-servlets/add04.ss

@@ -1,5 +1,6 @@
 #lang web-server
-(provide start)
+(define interface-version 'stateless)
+(provide start interface-version)
 
 ;; get-number-from-user: string -> number
 ;; ask the user for a number

collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss

@@ -1,5 +1,6 @@
 #lang web-server
-(provide start)
+(define interface-version 'stateless)
+(provide start interface-version)
 
 ;; get-number-from-user: string -> number
 ;; ask the user for a number

collects/web-server/default-web-root/htdocs/lang-servlets/check-dir.ss

@@ -1,5 +1,6 @@
 #lang web-server
-(provide start)
+(define interface-version 'stateless)
+(provide start interface-version)
 
 (define (directory-page n)
   (send/suspend/url

collects/web-server/default-web-root/htdocs/lang-servlets/mm00.ss

@@ -1,5 +1,6 @@
 #lang web-server
-(provide start)
+(define interface-version 'stateless)
+(provide start interface-version)
 
 (define (gn which)
   (cadr

collects/web-server/default-web-root/htdocs/lang-servlets/mm01.ss

@@ -1,5 +1,7 @@
 #lang web-server
-(provide start)
+(define interface-version 'stateless)
+(provide start interface-version)
+
 (define (gn which)
   (cadr
    (send/suspend

collects/web-server/default-web-root/htdocs/lang-servlets/quiz01.ss

@@ -1,6 +1,7 @@
 #lang web-server
 (require "quiz-lib.ss")
-(provide start)
+(define interface-version 'stateless)
+(provide start interface-version)
 
 ;; get-answer: mc-question -> number
 ;; get an answer for a multiple choice question

collects/web-server/default-web-root/htdocs/lang-servlets/quiz02.ss

@@ -1,6 +1,7 @@
 #lang web-server
 (require "quiz-lib.ss")
-(provide start)
+(define interface-version 'stateless)
+(provide start interface-version)
 
 ;; get-answer: mc-question -> number
 ;; get an answer for a multiple choice question

collects/web-server/default-web-root/htdocs/lang-servlets/wc-comp.ss

@@ -1,6 +1,7 @@
 #lang web-server
 (require web-server/lang/web-cell-component)
-(provide start)
+(define interface-version 'stateless)
+(provide start interface-version)
 
 (define (start initial-request)
   ; A top-level frame must exist

collects/web-server/default-web-root/htdocs/lang-servlets/wc-fake.ss

@@ -1,5 +1,6 @@
 #lang web-server
-(provide start)
+(define interface-version 'stateless)
+(provide start interface-version)
 
 (define (start initial-request)
   (define counter1 0)

collects/web-server/default-web-root/htdocs/lang-servlets/wc.ss

@@ -1,5 +1,6 @@
 #lang web-server
-(provide start)
+(define interface-version 'stateless)
+(provide start interface-version)
 
 (define (start initial-request)
   ; A top-level frame must exist

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

@@ -1,101 +0,0 @@
-#lang scheme/base
-(require mzlib/list
-         scheme/contract
-         (only-in "../lang/web.ss"
-                  initialize-servlet)           
-         web-server/lang/web-cells
-         web-server/managers/none
-         web-server/private/servlet
-         "../private/request-structs.ss"
-         "../private/response-structs.ss"
-         "dispatch.ss"
-         net/url
-         "../private/web-server-structs.ss"
-         "../private/util.ss"
-         "../private/response.ss"
-         "../dispatchers/filesystem-map.ss"
-         "../configuration/namespace.ss"
-         "../configuration/responders.ss")
-
-(provide/contract
- [interface-version dispatcher-interface-version/c]
- [make
-  (->* (#: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?))
-       dispatcher/c)])
-
-;; HACK
-(define the-session-table (make-weak-hash))
-
-(define (install-session ses paths)
-  (hash-set! the-session-table paths ses))
-
-;; lookup-session : (listof string) -> (union session #f)
-(define (lookup-session paths)
-  (hash-ref the-session-table paths 
-            (lambda () #f)))
-;; /HACK
-
-
-(define interface-version 'v1)
-(define (make #:url->path url->path
-              #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)]
-              #:responders-servlet-loading [responders-servlet-loading servlet-loading-responder]
-              #:responders-servlet [responders-servlet servlet-error-responder])
-  (lambda (conn req)
-    (define uri (request-uri req))
-    (with-handlers ([void (lambda (exn) (next-dispatcher))])
-      (define-values (a-path url-servlet-path) (url->path uri))
-      (define url-servlet-paths (map path->string url-servlet-path))
-      (with-handlers ([exn?
-                       (lambda (the-exn)
-                         (output-response/method
-                          conn
-                          (responders-servlet-loading uri the-exn)
-                          (request-method req)))])
-        
-        (define ses 
-          (cond
-            [(lookup-session url-servlet-paths)
-             => (lambda (ses) ses)]
-            [else
-             (let ()
-               (define cust (make-servlet-custodian))
-               (define ns (make-servlet-namespace
-                           #:additional-specs
-                           '(web-server/lang/web-cells
-                             web-server/lang/abort-resume                             
-                             web-server/private/servlet
-                             web-server/private/request-structs)))
-               (define dir (directory-part a-path))
-               (define ses 
-                 (make-servlet
-                  cust ns
-                  (create-none-manager (lambda (req) (error "No continuations!")))
-                  dir
-                  (lambda (req) (error "session not initialized"))))
-               (parameterize ([current-custodian cust]
-                              [current-directory dir]
-                              [current-namespace ns]
-                              [current-execution-context (make-execution-context req)]
-                              [current-servlet ses])
-                 (define start
-                   (dynamic-require `(file ,(path->string a-path))
-                                    'start))
-                 (set-servlet-handler! ses (initialize-servlet start)))
-               (install-session ses url-servlet-paths)
-               ses)]))
-        (parameterize ([current-custodian (servlet-custodian ses)]
-                       [current-directory (servlet-directory ses)]
-                       [current-namespace (servlet-namespace ses)]
-                       [current-execution-context (make-execution-context req)]
-                       [current-servlet ses])
-          (with-handlers ([exn?
-                           (lambda (the-exn)
-                             (output-response/method
-                              conn
-                              (responders-servlet uri the-exn)
-                              (request-method req)))])
-            (output-response conn ((servlet-handler ses) req))))))))

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

@@ -4,6 +4,9 @@
 (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"
@@ -42,34 +45,71 @@
   (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                   
+  (make-v2.servlet 
+   directory                   
    (create-timeout-manager
     default-servlet-instance-expiration-handler
     timeout
     timeout)
-                   (v1.module->v1.lambda timeout start)))
+   (lambda (initial-request)
+     (adjust-timeout! timeout)
+     (start initial-request))))
 
 (define (make-v2.servlet directory manager start)
-  (make-servlet (current-custodian)
+  (make-servlet 
+   (current-custodian)
    (current-namespace)
    manager
    directory                
-                start))
+   (lambda (req)
+     (define uri (request-uri req))
      
-(define default-module-specs
+     (define-values (instance-id handler)
-  '(web-server/servlet
+       (cond
-    web-server/private/servlet
+         [(continuation-url? uri)
-    web-server/servlet/web
+          => (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)]
@@ -93,8 +133,11 @@
               (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 or 'v2" version)]))]
+              (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))]
@@ -173,20 +216,6 @@
                          [current-custodian (servlet-custodian the-servlet)]
                          [current-directory (servlet-directory the-servlet)]
                          [current-namespace (servlet-namespace the-servlet)])
-            (define manager (servlet-manager the-servlet))
-            
-            (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))
-                         (servlet-handler the-servlet))]))
-            
-            (parameterize ([current-servlet-instance-id instance-id])
             (with-handlers ([(lambda (x) #t)
                              (lambda (exn)
                                (responders-servlet
@@ -194,7 +223,7 @@
                                 exn))])
               (call-with-continuation-prompt
                (lambda ()
-                   (handler req))
+                 ((servlet-handler the-servlet) req))
-                 servlet-prompt))))))
+               servlet-prompt)))))
       
       (output-response conn response))))

collects/web-server/run.ss

@@ -6,13 +6,14 @@
          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 lang: web-server/dispatchers/dispatch-lang)
+         (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")))
@@ -35,6 +36,7 @@
 (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 
@@ -47,11 +49,21 @@
        (sequencer:make          
         (timeout:make (* 5 60))
         (stat:make)
-        (filter:make
+        (let-values ([(clear-cache! url->servlet)
-         #rx"\\.ss"
+                      (servlets:make-cached-url->servlet
-         (lang:make #:url->path (fsmap:make-url->valid-path url->path)
+                       (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)))
+                          #: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"))

collects/web-server/scribblings/dispatchers.scrbl

@@ -328,10 +328,10 @@ a URL that refreshes the password file, servlet cache, etc.}
  This dispatcher supports HTTP Range GET requests and HEAD requests.}}
 
 @; ------------------------------------------------------------
-@section[#:tag "dispatch-servlets.ss"]{Serving Scheme Servlets}
+@section[#:tag "dispatch-servlets.ss"]{Serving Servlets}
 @a-dispatcher[web-server/dispatchers/dispatch-servlets
               @elem{defines a dispatcher constructor
-                    that runs servlets written in Scheme.}]{
+                    that runs servlets.}]{
 
 @defproc[(make-v1.servlet [directory path?]
                           [timeout integer?]
@@ -347,6 +347,12 @@ a URL that refreshes the password file, servlet cache, etc.}
  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 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.
 }
@@ -398,32 +404,6 @@ Equivalent to @scheme[(path? . -> . servlet?)].
                       
 }
 
-@; ------------------------------------------------------------
-@section[#:tag "dispatch-lang.ss"]{Serving Web Language Servlets}
-@a-dispatcher[web-server/dispatchers/dispatch-lang
-             @elem{defines a dispatcher constructor
-                   that runs servlets written in the Web Language.}]{
-
-@defproc[(make [#:url->path url->path url->path/c]
-               [#:make-servlet-namespace make-servlet-namespace
-                                         make-servlet-namespace?
-                                         (make-make-servlet-namespace)]
-               [#:responders-servlet-loading responders-servlet-loading 
-                                             ((url url?) (exn exn?) . -> . response?)
-                                             servlet-loading-responder]
-               [#:responders-servlet responders-servlet
-                                     ((url url?) (exn exn?) . -> . response?)
-                                     servlet-error-responder])
-         dispatcher/c]{
- If the request URL contains a serialized continuation, 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.
-}}
-
 @; ------------------------------------------------------------
 @section[#:tag "dispatch-stat.ss"]{Statistics}
 @a-dispatcher[web-server/dispatchers/dispatch-stat

collects/web-server/scribblings/lang.scrbl

@@ -2,7 +2,9 @@
 @(require "web-server.ss")
 
 @title[#:tag "lang"
-       #:style 'toc]{Web Language Servlets}
+       #:style 'toc]{Web Language}
+
+@defmodulelang[web-server]
                     
 The @web-server allows servlets to be written in a special Web
 language that is nearly identical to Scheme. Herein we discuss how it
@@ -10,28 +12,6 @@ is different and what API is provided.
 
 @local-table-of-contents[]
 
-@; ------------------------------------------------------------
-@section[#:tag "lang-servlets"]{Definition}
-@(require (for-label "dummy-language-servlet.ss")) @; to give a binding context
-
-@defmodule*/no-declare[(web-server/lang)]
-
-@declare-exporting[#:use-sources (web-server/scribblings/dummy-language-servlet)]
-
-A @defterm{Web language servlet} is a module written in the
-@schememodname[web-server/lang] language. The servlet module should
-provide the following function:
-
-@defproc[(start [initial-request request?])
-         response?]{
- Called when this servlet is invoked.
- The argument is the HTTP request that initiated the servlet.
-}
-                   
-The only way to run Web language servlets currently is to use the
-functional interface to starting the server and create a dispatcher
-that includes a @scheme[make-lang-dispatcher] dispatcher.
-
 @; ------------------------------------------------------------
 @section[#:tag "considerations"]{Usage Considerations}
 
@@ -156,10 +136,15 @@ the future.
 @defproc[(stuff-url [v serializable?]
                     [u url?])
          url?]{
- Serializes @scheme[v] and computes the MD5 of the serialized
+ Returns a URL based on @scheme[u] with @scheme[v] serialized and "stuffed" into it.
- representation. The serialization of @scheme[v] is written to
+ The following steps are applied until the URL is short enough to be accepted by IE.
+ @itemize[
+  @item{Put the plain-text serialization in the URL.}
+  @item{Compress the serialization with @schememodname[file/gzip] into the URL.}
+  @item{Compute the MD5 of the compressed seralization and write it to
    @filepath{$HOME/.urls/M} where `M' is the MD5. `M' is then
- placed in @scheme[u] as a URL param.
+   placed in the URL}
+ ]
 }
 
 @defproc[(stuffed-url? [u url?])

collects/web-server/scribblings/servlet.scrbl

@@ -20,7 +20,7 @@ of these servlets.
 
 A @defterm{servlet} is a module that provides the following:
 
-@defthing[interface-version (one-of/c 'v1 'v2)]{
+@defthing[interface-version (one-of/c 'v1 'v2 'stateless)]{
  A symbol indicating the servlet interface the servlet conforms
  to. This influences the other provided identifiers.
 }
@@ -74,6 +74,13 @@ An example version 2 module:
           (body (h1 "Hi Mom!"))))
  ]
 
+An example @scheme['stateless] servlet module:
+@schememod[
+ web-server
+ (define interface-version 'stateless)
+ (define (start req)
+   `(html (body (h2 "Look ma, no state!"))))
+]
 
 @; ------------------------------------------------------------
 @section[#:tag "servlet-structs.ss"]{Contracts}

collects/web-server/scribblings/web-server-unit.scrbl

@@ -43,7 +43,7 @@ operations:
  @item{Allows the @scheme["/conf/refresh-passwords"] URL to refresh the password file.}
  @item{Allows the @scheme["/conf/collect-garbage"] URL to call the garbage collector.}
  @item{Allows the @scheme["/conf/refresh-servlets"] URL to refresh the servlets cache.}
- @item{Execute servlets in the mapping URLs to the given servlet root directory.}
+ @item{Execute servlets in the mapping URLs to the given servlet root directory under htdocs.}
  @item{Serves files under the @scheme["/"] URL in the given htdocs directory.}
 ]