Adding a barrier, making a better name, and support stateless in serve/servlet

svn: r12392

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

@@ -268,7 +268,7 @@
        (let* ([first-key (test-m06.1 '(dispatch-start start 'foo))]
               [second-key (test-m06.1 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) 1)))]
               [third-key (test-m06.1 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) -7)))])
-         (check = 3 (test-m06.1 `(abort/cc (lambda () (dispatch ,the-dispatch (list ,second-key 2))))))
+         (check = 3 (test-m06.1 `(call-with-web-prompt (lambda () (dispatch ,the-dispatch (list ,second-key 2))))))
          (check = 4 (test-m06.1 `(dispatch ,the-dispatch (list ,second-key 3))))
          (check-true (zero? (test-m06.1 `(dispatch ,the-dispatch (list ,second-key -1)))))
          (check = -7 (test-m06.1 `(dispatch ,the-dispatch (list ,third-key 0))))
@@ -295,7 +295,7 @@
        (let* ([first-key (test-m06.2 '(dispatch-start start 'foo))]
               [second-key (test-m06.2 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) 1)))]
               [third-key (test-m06.2 `(dispatch ,the-dispatch (list (deserialize (serialize ,first-key)) -7)))])
-         (check = 3 (test-m06.2 `(abort/cc (lambda () (dispatch ,the-dispatch (list ,second-key 2))))))
+         (check = 3 (test-m06.2 `(call-with-web-prompt (lambda () (dispatch ,the-dispatch (list ,second-key 2))))))
          (check = 4 (test-m06.2 `(dispatch ,the-dispatch (list ,second-key 3))))
          (check-true (zero? (test-m06.2 `(dispatch ,the-dispatch (list ,second-key -1)))))
          (check = -7 (test-m06.2 `(dispatch ,the-dispatch (list ,third-key 0))))

collects/tests/web-server/lang/abort-resume-test.ss

@@ -17,13 +17,13 @@
     
     (test-case
      "Easy"
-     (check-equal? (abort/cc
+     (check-equal? (call-with-web-prompt
                     (lambda () (current-saved-continuation-marks-and 'k1 'v1)))
                    (make-immutable-hash (list (cons 'k1 'v1)))))
     
     (test-case
      "Preserve"
-     (check-equal? (abort/cc
+     (check-equal? (call-with-web-prompt
                     (lambda () 
                       (with-continuation-mark the-save-cm-key (make-immutable-hash (list (cons 'k2 'v2)))
                         (current-saved-continuation-marks-and 'k1 'v1))))
@@ -33,7 +33,7 @@
     
     (test-case
      "Update"
-     (check-equal? (abort/cc
+     (check-equal? (call-with-web-prompt
                     (lambda () 
                       (with-continuation-mark the-save-cm-key 
                         (make-immutable-hash (list (cons 'k2 'v2) (cons 'k1 'v3)))
@@ -44,7 +44,7 @@
     
     (test-case
      "Double"
-     (check-equal? (abort/cc
+     (check-equal? (call-with-web-prompt
                     (lambda () 
                       (with-continuation-mark the-save-cm-key 
                         (make-immutable-hash (list (cons 'k3 'v1) (cons 'k4 'v0)))
@@ -65,13 +65,13 @@
     
     (test-case
      "Easy"
-     (check-equal? (abort/cc
+     (check-equal? (call-with-web-prompt
                     (lambda () (activation-record-list)))
                    empty))
     
     (test-case
      "Single"
-     (check-equal? (abort/cc
+     (check-equal? (call-with-web-prompt
                     (lambda () 
                       (let/ec esc
                         ('f1 (with-continuation-mark the-cont-key +
@@ -80,7 +80,7 @@
     
     (test-case
      "Double"
-     (check-equal? (abort/cc
+     (check-equal? (call-with-web-prompt
                     (lambda () 
                       (let/ec esc
                         ('f1 (with-continuation-mark the-cont-key +
@@ -95,7 +95,7 @@
      (check-exn
       exn?
       (lambda ()
-        (abort/cc
+        (call-with-web-prompt
          (lambda () 
            (with-continuation-mark safe-call? #f
              (activation-record-list))))))))
@@ -109,7 +109,7 @@
     
     (test-case
      "Simple"
-     (check-equal? (abort/cc
+     (check-equal? (call-with-web-prompt
                     (lambda () 
                       (abort (lambda () 42))))
                    42)))
@@ -145,7 +145,7 @@
            [g (lambda (x) (+ x x))]
            [esc-b (box #f)]
            [capture (lambda _ (activation-record-list))])
-       (check-equal? (abort/cc
+       (check-equal? (call-with-web-prompt
                       (lambda ()
                         (let/ec esc 
                           (set-box! esc-b esc)
@@ -159,7 +159,7 @@
      "marks"
      (let ([f (lambda (x) (* x x))]
            [g (lambda (x) (+ x x))])
-       (check-equal? (abort/cc
+       (check-equal? (call-with-web-prompt
                       (lambda ()
                         (let/ec esc 
                           (resume (list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2)))) 
@@ -181,7 +181,7 @@
            [g (lambda (x) (+ x x))]
            [esc-b (box #f)]
            [capture (lambda _ (activation-record-list))])
-       (check-equal? (abort/cc
+       (check-equal? (call-with-web-prompt
                       (lambda ()
                         (let/ec esc 
                           (set-box! esc-b esc)

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

@@ -221,9 +221,11 @@
                                (responders-servlet
                                 (request-uri req)
                                 exn))])
-              (call-with-continuation-prompt
+              (call-with-continuation-barrier 
                (lambda ()
-                 ((servlet-handler the-servlet) req))
-               servlet-prompt)))))
+                 (call-with-continuation-prompt
+                  (lambda ()
+                    ((servlet-handler the-servlet) req))
+                  servlet-prompt)))))))
       
       (output-response conn response))))

collects/web-server/lang/abort-resume.ss

@@ -87,7 +87,7 @@
        [(vector f cms)
         (with-continuation-marks/hash cms (lambda () (rebuild-cms fs thunk)))])]))
 
-(define (abort/cc thunk)
+(define (call-with-web-prompt thunk)
   (call-with-continuation-prompt
    thunk
    web-prompt))
@@ -132,7 +132,7 @@
 ;; dispatch-start: (request -> response) request -> reponse
 ;; pass the initial request to the starting interaction point
 (define (dispatch-start start req0)
-  (abort/cc 
+  (call-with-web-prompt 
    (lambda ()
      (with-continuation-mark safe-call? '(#t start)
        (start
@@ -142,7 +142,7 @@
 ;; dispatch: (request -> (request -> response)) request -> response
 ;; lookup the continuation for this request and invoke it
 (define (dispatch decode-continuation req)   
-  (abort/cc
+  (call-with-web-prompt
    (lambda ()
      (cond
        [(decode-continuation req)
@@ -166,7 +166,7 @@
 (provide/contract
  ;; AUXILLIARIES
  [abort ((-> any) . -> . any)]
- [abort/cc ((-> any) . -> . any)]
+ [call-with-web-prompt ((-> any) . -> . any)]
  [resume (saved-context? any/c . -> . any)]
  [the-cont-key mark-key?]
  [the-save-cm-key mark-key?]

collects/web-server/scribblings/servlet-env.scrbl

@@ -56,6 +56,17 @@ 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.
 
+Suppose you would like to start a server for a stateless Web servlet @filepath{servlet.ss} that provides @schemeid[start]:
+@schememod[
+ scheme
+ (require "servlet.ss"
+          web-server/servlet-env)
+
+ (serve/servlet start #:stateless? #t)
+]
+Note: If you put the call to @scheme[serve/servlet] in the module like normal, strange things will happen because of the way
+the top-level interacts with continuations. (Read: Don't do it.)
+
 @defproc[(serve/servlet [start (request? . -> . response?)]
                        [#:launch-browser? launch-browser? boolean? #t]
                        [#:quit? quit? boolean? #t]
@@ -65,6 +76,7 @@ Notice that you may pass any number of extra paths.
                                        "/servlets/standalone.ss"]
                        [#:servlet-regexp servlet-regexp regexp?
                                          (regexp (format "^~a$" (regexp-quote servlet-path)))]
+                       [#:stateless? stateless? boolean? #f]
                        [#: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]
@@ -85,6 +97,8 @@ Notice that you may pass any number of extra paths.
  
  If @scheme[quit?] is true, then the URL @filepath["/quit"] ends the server.
  
+ If @scheme[stateless?] is true, then the servlet is run as a stateless @schememodname[web-server] module.
+ 
  Advanced users may need the following options:
  
  The server listens on @scheme[listen-ip] and port @scheme[port].

collects/web-server/servlet-env.ss

@@ -48,6 +48,7 @@
                                     #:manager manager?
                                     #:servlet-namespace (listof module-path?)
                                     #:server-root-path path?
+                                    #:stateless? boolean?
                                     #:extra-files-paths (listof path?)
                                     #:servlets-root path?
                                     #:file-not-found-path path?
@@ -79,6 +80,8 @@
                        [servlet-path "/servlets/standalone.ss"]
                        #:servlet-regexp
                        [servlet-regexp (regexp (format "^~a$" (regexp-quote servlet-path)))]
+                       #:stateless? 
+                       [stateless? #f]
                        
                        #:servlet-namespace
                        [servlet-namespace empty]
@@ -100,13 +103,7 @@
     (make-make-servlet-namespace
      #:to-be-copied-module-specs servlet-namespace))
   (define sema (make-semaphore 0))
-  (define 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)))
+  (define servlet-box (box #f))
   (define dispatcher
     (sequencer:make
      (if quit?
@@ -116,7 +113,20 @@
          (lambda _ (next-dispatcher)))
      (filter:make
       servlet-regexp
-      (servlets:make (lambda (url) servlet)))
+      (servlets:make
+       (lambda (url)
+         (or (unbox servlet-box)
+             (let ([servlet
+                    (parameterize ([current-custodian (make-custodian)]
+                                   [current-namespace
+                                    (make-servlet-namespace
+                                     #:additional-specs
+                                     servlets:default-module-specs)])
+                      (if stateless?
+                          (servlets:make-stateless.servlet servlet-current-directory start)
+                          (servlets:make-v2.servlet servlet-current-directory manager start)))])
+               (set-box! servlet-box servlet)
+               servlet)))))
      (let-values ([(clear-cache! url->servlet)
                    (servlets:make-cached-url->servlet
                     (fsmap:filter-url->path