From 34c5db31efb537cca7b16a62c7a3ed78947751e4 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 11 Nov 2008 22:24:44 +0000 Subject: [PATCH] Adding a barrier, making a better name, and support stateless in serve/servlet svn: r12392 --- collects/tests/web-server/lang-test.ss | 4 +-- .../web-server/lang/abort-resume-test.ss | 24 ++++++++--------- .../dispatchers/dispatch-servlets.ss | 8 +++--- collects/web-server/lang/abort-resume.ss | 8 +++--- .../web-server/scribblings/servlet-env.scrbl | 14 ++++++++++ collects/web-server/servlet-env.ss | 26 +++++++++++++------ 6 files changed, 55 insertions(+), 29 deletions(-) diff --git a/collects/tests/web-server/lang-test.ss b/collects/tests/web-server/lang-test.ss index 709f20baea..f907c0ab87 100644 --- a/collects/tests/web-server/lang-test.ss +++ b/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)))) diff --git a/collects/tests/web-server/lang/abort-resume-test.ss b/collects/tests/web-server/lang/abort-resume-test.ss index 4fc8d58b07..6086f5573b 100644 --- a/collects/tests/web-server/lang/abort-resume-test.ss +++ b/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) diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index cf5d13f268..43fc442604 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/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)))) \ No newline at end of file diff --git a/collects/web-server/lang/abort-resume.ss b/collects/web-server/lang/abort-resume.ss index ecaf54e824..11c70b540a 100644 --- a/collects/web-server/lang/abort-resume.ss +++ b/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?] diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index e6427f26aa..ae4e3cb0b5 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/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]. diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 6553a85a28..3d9305aacc 100644 --- a/collects/web-server/servlet-env.ss +++ b/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