diff --git a/collects/tests/web-server/dispatchers/dispatch-lang-test.ss b/collects/tests/web-server/dispatchers/dispatch-lang-test.ss index 0796cea256..6227336694 100644 --- a/collects/tests/web-server/dispatchers/dispatch-lang-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-lang-test.ss @@ -106,6 +106,16 @@ "add06.ss - send/suspend/dispatch" (build-path example-servlets "add06.ss")) + (test-add-two-numbers + mkd + "add-native.ss - native continuation parts" + (build-path example-servlets "add-native.ss")) + + (test-add-two-numbers + mkd + "add-soft.ss - soft state" + (build-path example-servlets "add-soft.ss")) + ; XXX test something is not d-c (test-double-counters mkd @@ -153,3 +163,8 @@ ; XXX test web-extras.ss - redirect/get )) + +#| +(require schemeunit/text-ui) +(run-tests dispatch-lang-tests) +|# \ No newline at end of file diff --git a/collects/tests/web-server/lang/abort-resume-test.ss b/collects/tests/web-server/lang/abort-resume-test.ss index f73366ee4f..d946d67b5c 100644 --- a/collects/tests/web-server/lang/abort-resume-test.ss +++ b/collects/tests/web-server/lang/abort-resume-test.ss @@ -169,8 +169,8 @@ (lambda () (let/ec esc ('f1 (with-continuation-mark the-cont-key + - (esc (activation-record-list))))))) - (list (vector + #f)))) + (esc (reverse (activation-record-list)))))))) + (list (vector + #f #f)))) (test-case "Double" @@ -179,10 +179,10 @@ (let/ec esc ('f1 (with-continuation-mark the-cont-key + ('f2 (with-continuation-mark the-cont-key - - (esc (activation-record-list))))))))) + (esc (reverse (activation-record-list)))))))))) ; Opposite the order of c-c-m - (list (vector + #f) - (vector - #f)))) + (list (vector + #f #f) + (vector - #f #f)))) (test-case "Unsafe" @@ -216,21 +216,21 @@ (check-equal? (resume empty (list 42)) 42)) - (test-case + #;(test-case "Empty frame" - (check-exn exn? (lambda () (resume (list (vector #f #f)) (list 42))))) + (check-exn exn? (lambda () (resume (reverse (list (vector #f #f #f))) (list 42))))) (test-case "Kont" (let ([f (lambda (x) (* x x))]) - (check-equal? (resume (list (vector f #f)) (list 42)) + (check-equal? (resume (reverse (list (vector f #f #f))) (list 42)) (f 42)))) (test-case "Kont 2" (let ([f (lambda (x) (* x x))] [g (lambda (x) (+ x x))]) - (check-equal? (resume (list (vector f #f) (vector g #f)) (list 42)) + (check-equal? (resume (reverse (list (vector f #f #f) (vector g #f #f))) (list 42)) (f (g 42))))) (test-case @@ -238,16 +238,17 @@ (let ([f (lambda (x) (* x x))] [g (lambda (x) (+ x x))] [esc-b (box #f)] - [capture (lambda _ (activation-record-list))]) + [capture (lambda _ (reverse (activation-record-list)))]) (check-equal? (call-with-web-prompt (lambda () (let/ec esc (set-box! esc-b esc) - (resume (list (vector f #f) (vector g #f) - (vector esc #f) (vector capture #f)) + (resume (reverse + (list (vector f #f #f) (vector g #f #f) + (vector esc #f #f) (vector capture #f #f))) (list 42))))) - (list (vector f #f) (vector g #f) - (vector (unbox esc-b) #f))))) + (list (vector f #f #f) (vector g #f #f) + (vector (unbox esc-b) #f #f))))) (test-case "marks" @@ -256,14 +257,16 @@ (check-equal? (call-with-web-prompt (lambda () (let/ec esc - (resume (list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2)))) - (vector g (make-immutable-hash (list (cons 5 6)))) - (vector esc (make-immutable-hash (list (cons 7 8)))) - (vector (lambda _ - (continuation-mark-set->list* - (current-continuation-marks) - (list 1 3 5 7))) - #f)) + (resume (reverse + (list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))) #f) + (vector g (make-immutable-hash (list (cons 5 6))) #f) + (vector esc (make-immutable-hash (list (cons 7 8))) #f) + (vector (lambda _ + (continuation-mark-set->list* + (current-continuation-marks) + (list 1 3 5 7))) + #f + #f))) (list 42))))) (list (vector #f #f #f 8) (vector #f #f 6 #f) @@ -279,14 +282,16 @@ (lambda () (let/ec esc (set-box! esc-b esc) - (resume (list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2)))) - (vector g (make-immutable-hash (list (cons 5 6)))) - (vector esc (make-immutable-hash (list (cons 7 8)))) - (vector capture #f)) + (resume (reverse + (list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))) #f) + (vector g (make-immutable-hash (list (cons 5 6))) #f) + (vector esc (make-immutable-hash (list (cons 7 8))) #f) + (vector capture #f #f))) (list 42))))) - (list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2)))) - (vector g (make-immutable-hash (list (cons 5 6)))) - (vector (unbox esc-b) (make-immutable-hash (list (cons 7 8))))))))) + (reverse + (list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))) #f) + (vector g (make-immutable-hash (list (cons 5 6))) #f) + (vector (unbox esc-b) (make-immutable-hash (list (cons 7 8))) #f))))))) ; XXX test kont @@ -299,3 +304,8 @@ ; XXX test dispatch )) + +#| +(require schemeunit/text-ui) +(run-tests abort-resume-tests) +|# \ No newline at end of file diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add-native.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add-native.ss new file mode 100644 index 0000000000..85e120629a --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add-native.ss @@ -0,0 +1,34 @@ +#lang web-server +(require web-server/managers/lru) + +(define interface-version 'stateless) +(define manager + (make-threshold-LRU-manager #f (* 1024 1024 128))) +(provide start manager interface-version) + +;; get-number-from-user: string -> number +;; ask the user for a number +(define (gn msg) + (let ([req + (send/suspend/url + (lambda (k-url) + `(html (head (title ,(format "Get ~a number" msg))) + (body + (form ([action ,(url->string k-url)] + [method "get"] + [enctype "application/x-www-form-urlencoded"]) + ,(format "Enter the ~a number to add: " msg) + (input ([type "text"] [name "number"] [value ""])) + (input ([type "submit"])))))))]) + (string->number + (cdr (assoc 'number (url-query (request-uri req))))))) + +(define (gn* m) + (first (serial->native (map (lambda (m) (native->serial (gn m))) (list m))))) + +(define (start initial-request) + `(html (head (title "Final Page")) + (body + (h1 "Final Page") + (p ,(format "The answer is ~a" + (+ (gn* "first") (gn* "second"))))))) diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss index 632e16f282..35166dd1da 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss @@ -11,7 +11,7 @@ (send/suspend/url (lambda (k-url) (printf "ssu ~S~n" (msg)) - `(hmtl (head (title ,(format "Get ~a number" (msg)))) + `(html (head (title ,(format "Get ~a number" (msg)))) (body (form ([action ,(url->string k-url)] [method "post"] diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss index f416ee5866..e0b4b2f154 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss @@ -11,7 +11,7 @@ (send/suspend/url (lambda (k-url) (printf "ssu ~S~n" (msg)) - `(hmtl (head (title ,(format "Get ~a number" (msg)))) + `(html (head (title ,(format "Get ~a number" (msg)))) (body (form ([action ,(url->string k-url)] [method "post"] diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add-soft.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add-soft.ss new file mode 100644 index 0000000000..f1ac2af414 --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add-soft.ss @@ -0,0 +1,31 @@ +#lang web-server +(define interface-version 'stateless) +(provide start interface-version) + +(define softie + (soft-state + "submit")) + +;; get-number-from-user: string -> number +;; ask the user for a number +(define (gn msg) + (let ([req + (send/suspend/url + (lambda (k-url) + `(html (head (title ,(format "Get ~a number" msg))) + (body + (form ([action ,(url->string k-url)] + [method "get"] + [enctype "application/x-www-form-urlencoded"]) + ,(format "Enter the ~a number to add: " msg) + (input ([type "text"] [name "number"] [value ""])) + (input ([type ,(soft-state-ref softie)])))))))]) + (string->number + (cdr (assoc 'number (url-query (request-uri req))))))) + +(define (start initial-request) + `(html (head (title "Final Page")) + (body + (h1 "Final Page") + (p ,(format "The answer is ~a" + (+ (gn "first") (gn "second"))))))) diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add.ss index b6b1352909..7460aa3d5d 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add.ss @@ -12,7 +12,7 @@ (send/suspend/url (lambda (k-url) (printf "ssu~n") - `(hmtl (head (title ,(format "Get ~a number" msg))) + `(html (head (title ,(format "Get ~a number" msg))) (body (form ([action ,(url->string k-url)] [method "post"] diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add02.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add02.ss index 46eacc3c06..6fa97a7e27 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add02.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add02.ss @@ -8,7 +8,7 @@ (let ([req (send/suspend/url (lambda (k-url) - `(hmtl (head (title ,(format "Get ~a number" msg))) + `(html (head (title ,(format "Get ~a number" msg))) (body (form ([action ,(url->string k-url)] [method "get"] diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add03.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add03.ss index 7f87454f70..63a59b82d5 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add03.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add03.ss @@ -8,7 +8,7 @@ (let ([req (send/suspend/hidden (lambda (ses-url k-hidden) - `(hmtl (head (title ,(format "Get ~a number" msg))) + `(html (head (title ,(format "Get ~a number" msg))) (body (form ([action ,(url->string ses-url)] [method "post"] diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add04-stuffer.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add04-stuffer.ss index 6c6629baaf..6384b64b5e 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add04-stuffer.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add04-stuffer.ss @@ -12,7 +12,7 @@ (let ([req (send/suspend/url (lambda (k-url) - `(hmtl (head (title ,(format "Get ~a number" msg))) + `(html (head (title ,(format "Get ~a number" msg))) (body (form ([action ,(url->string k-url)] [method "post"] diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add04.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add04.ss index cab7b4978a..3035c480e1 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add04.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add04.ss @@ -8,7 +8,7 @@ (let ([req (send/suspend/url (lambda (k-url) - `(hmtl (head (title ,(format "Get ~a number" msg))) + `(html (head (title ,(format "Get ~a number" msg))) (body (form ([action ,(url->string k-url)] [method "post"] diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss index 4573a4d94c..3eeeb81834 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss @@ -7,7 +7,7 @@ (define (gn msg) (send/suspend/url/dispatch (lambda (embed/url) - `(hmtl (head (title ,(format "Get ~a number" msg))) + `(html (head (title ,(format "Get ~a number" msg))) (body (form ([action ,(url->string (embed/url diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/map.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/map.ss new file mode 100644 index 0000000000..b6dfc059bb --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/map.ss @@ -0,0 +1,43 @@ +#lang web-server +(require web-server/managers/lru) + +(define-native (build-list/native _ ho) build-list) + +(define interface-version 'stateless) +(define manager + (make-threshold-LRU-manager #f (* 1024 1024 128))) + +(provide start interface-version manager) + +;; get-number-from-user: number -> number +;; ask the user for a number +(define (get-number-from-user message) + (let ([req + (send/suspend/url + (lambda (k-url) + `(html (head (title ,message)) + (body + (form ([action ,(url->string k-url)] + [method "post"] + [enctype "application/x-www-form-urlencoded"]) + ,message + (input ([type "text"] [name "number"] [value ""])) + (input ([type "submit"])))))))]) + (string->number + (bytes->string/utf-8 + (binding:form-value + (bindings-assq #"number" + (request-bindings/raw req))))))) + +(define (start initial-request) + (define how-many-numbers + (get-number-from-user "How many numbers do you want to add?")) + `(html (head (title "Final Page")) + (body + (h1 "Final Page") + (p ,(format "The answer is ~a" + (apply + + (build-list/native how-many-numbers + (lambda (i) + (get-number-from-user + (format "Enter number ~a" (add1 i))))))))))) \ No newline at end of file diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/quiz-lib.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/quiz-lib.ss index 0a94370f00..8c5a362292 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/quiz-lib.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/quiz-lib.ss @@ -24,7 +24,7 @@ ;; generate the page for the question (define (make-cue-page mc-q) (lambda (ses-url k-hidden) - `(hmtl (head (title "Question")) + `(html (head (title "Question")) (body (form ([action ,(url->string ses-url)] [method "post"] [enctype "application/x-www-form-urlencoded"]) diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/soft.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/soft.ss new file mode 100644 index 0000000000..48070412ef --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/soft.ss @@ -0,0 +1,17 @@ +#lang web-server +(provide interface-version start) +(define interface-version 'stateless) + +(define softie + (soft-state + (printf "Doing a long computation...~n") + (sleep 1) + 5)) + +(define (start req) + (soft-state-ref softie) + (printf "Done~n") + (start + (send/suspend + (lambda (k-url) + `(html (body (a ([href ,k-url]) "Done"))))))) diff --git a/collects/web-server/lang/abort-resume.ss b/collects/web-server/lang/abort-resume.ss index b805349e92..5862e2315a 100644 --- a/collects/web-server/lang/abort-resume.ss +++ b/collects/web-server/lang/abort-resume.ss @@ -1,7 +1,9 @@ #lang scheme (require scheme/serialize - "../private/define-closure.ss" - "../lang/web-cells.ss") + web-server/private/servlet + web-server/managers/manager + web-server/private/define-closure + web-server/lang/web-cells) ;; ********************************************************************** ;; ********************************************************************** @@ -12,6 +14,8 @@ (define safe-call? (make-mark-key)) (define web-prompt (make-continuation-prompt-tag 'web)) +(define empty-hash + (make-immutable-hash empty)) (define (with-current-saved-continuation-marks-and key val thnk) (call-with-immediate-continuation-mark the-save-cm-key @@ -19,27 +23,34 @@ (with-continuation-mark the-save-cm-key (hash-set old-cms key val) (thnk))) - (make-immutable-hash empty))) + empty-hash)) ;; current-continuation-as-list: -> (listof value) ;; check the safety marks and return the list of marks representing the continuation (define (activation-record-list) (let* ([cm (current-continuation-marks web-prompt)] - [sl (continuation-mark-set->list cm safe-call?)]) - (if (andmap (lambda (x) - (if (pair? x) - (car x) - x)) - sl) - (begin #;(printf "Safe continuation capture from ~S with cm ~S~n" sl cm) - #;(printf "CMs: ~S~n" (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key))) - (reverse (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key)))) + ; XXX call this once with a non-#f default + [sl (continuation-mark-set->list* cm (list safe-call? continuation-of-unsafe-part-mark))]) + (if (calling-context-okay? sl #f) + (store-unsafe-parts-on-server! (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key continuation-of-unsafe-part-mark))) (error "Attempt to capture a continuation from within an unsafe context:" sl)))) +;; calling-context-okay? : (listof (vector safe-call? unsafe-continuation-mark)) -> boolean +(define (calling-context-okay? ctxt native-above?) + (match ctxt + [(list) #t] + [(list-rest (vector (or (list-rest safe-call? _) + safe-call?) + unsafe-part) + more-ctxt) + (and (or native-above? safe-call?) + (calling-context-okay? + more-ctxt + (or unsafe-part native-above?)))])) + ;; abort: ( -> alpha) -> alpha ;; erase the stack and apply a thunk -(define (abort thunk) - #;(printf "abort ~S~n" thunk) +(define (abort thunk) (abort-current-continuation web-prompt thunk)) ;; with-continuation-marks : (listof (cons any1 any2)) (-> any3) -> any3 @@ -55,25 +66,43 @@ (hash-map cms cons) thnk)) -;; resume: (listof (value -> value)) value -> value +;; resume*: (listof (value -> value)) value -> value ;; resume a computation given a value and list of frame procedures -(define (resume frames val) +(define (resume* frames val) #;(printf "~S~n" `(resume ,frames ,val)) (match frames [(list) + #;(printf "Returning value ~S~n" val) (apply values val)] - [(list-rest f fs) - (match f - [(vector #f #f) - (error 'resume "Empty frame")] - [(vector f #f) - (call-with-values (lambda () (with-continuation-mark the-cont-key f (resume fs val))) + [(list-rest frame fs) + #;(printf "Frame ~S~n" frame) + (match frame + [(vector #f #f #f) + ; XXX Perhaps I should err? + #;(error 'resume "Empty frame") + (resume* fs val)] + [(vector f #f #f) + (call-with-values (lambda () (with-continuation-mark the-cont-key f (resume* fs val))) f)] - [(vector #f cms) + [(vector #f cms #f) (with-continuation-mark the-save-cm-key cms - (with-continuation-marks/hash cms (lambda () (resume fs val))))] - [(vector f cms) - (resume (list* (vector f #f) (vector #f cms) fs) val)])])) + (with-continuation-marks/hash cms (lambda () (resume* fs val))))] + [(vector #f #f nkpt-label) + (serial->native + ((get-unsafe-part-from-server nkpt-label) + (with-continuation-mark continuation-of-unsafe-part-mark nkpt-label + (resume* fs val))))] + [(vector f cms nkpt-label) + (resume* (list* (vector f #f #f) + (vector #f cms #f) + (if nkpt-label + (list* (vector #f #f nkpt-label) + fs) + fs)) + val)])])) + +(define (resume frames val) + (resume* (reverse frames) val)) ;; rebuild-cms : frames (-> value) -> value (define (rebuild-cms frames thunk) @@ -81,11 +110,11 @@ (match frames [(list) (thunk)] - [(list-rest f fs) - (match f - [(vector f #f) + [(list-rest frame fs) + (match (vector-ref frame 1) + [#f (rebuild-cms fs thunk)] - [(vector f cms) + [cms (with-continuation-marks/hash cms (lambda () (rebuild-cms fs thunk)))])])) (define (call-with-web-prompt thunk) @@ -111,20 +140,54 @@ (define-values (wcs current-marks) ((kont-env k))) (make-kont (lambda () - (values wcs - (append current-marks (list (vector f #f))))))) + (values wcs (list* (vector f #f #f) current-marks))))) ;; send/suspend: (continuation -> response) -> request ;; produce the current response and wait for the next request (define (call-with-serializable-current-continuation response-maker) (with-continuation-mark safe-call? '(#t send/suspend) - (let ([current-marks (activation-record-list)] - [wcs (capture-web-cell-set)]) - ((lambda (k) - (abort (lambda () - ; Since we escaped from the previous context, we need to re-install the user's continuation-marks - (rebuild-cms current-marks (lambda () (response-maker k)))))) - (make-kont (lambda () (values wcs current-marks))))))) + (let* ([current-marks (activation-record-list)] + [wcs (capture-web-cell-set)] + [k (make-kont (lambda () (values wcs current-marks)))]) + (abort (lambda () + ; Since we escaped from the previous context, we need to re-install the user's continuation-marks + (rebuild-cms (reverse current-marks) (lambda () (response-maker k)))))))) + +;; combining native and transformed continuations +(define unsafe-barrier-prompt-tag (make-continuation-prompt-tag 'unsafe)) +(define continuation-of-unsafe-part-mark (make-mark-key)) + +(define (store-unsafe-part-on-server! k) + ((manager-continuation-store! (current-servlet-manager)) + (current-servlet-instance-id) k #f)) +(define (get-unsafe-part-from-server k-label) + (apply (manager-continuation-lookup (current-servlet-manager)) + (current-servlet-instance-id) k-label)) + +(define store-unsafe-parts-on-server! + (match-lambda + [(list) empty] + [(list-rest (vector f cms unsafe-part) ctxt) + (list* (vector f cms + (if unsafe-part + (store-unsafe-part-on-server! unsafe-part) + #f)) + (store-unsafe-parts-on-server! ctxt))])) + +(define-syntax-rule (serial->native f) + (serial->native* (lambda () f))) +(define-syntax-rule (native->serial f) + (native->serial* (lambda () f))) + +(define (serial->native* thnk) + (call-with-continuation-prompt thnk unsafe-barrier-prompt-tag)) +(define (native->serial* thnk) + (call-with-current-continuation + (lambda (unsafe-continuation-portion) + (with-continuation-mark + continuation-of-unsafe-part-mark unsafe-continuation-portion + (thnk))) + unsafe-barrier-prompt-tag)) ;; ********************************************************************** ;; ********************************************************************** @@ -162,7 +225,8 @@ (define saved-context? (listof (vector/c (or/c false/c procedure?) - (or/c false/c cms?)))) + (or/c false/c cms?) + (or/c false/c symbol?)))) (provide/contract ;; AUXILLIARIES @@ -176,7 +240,7 @@ [activation-record-list (-> saved-context?)] [with-current-saved-continuation-marks-and (any/c any/c (-> any/c) . -> . any/c)] [kont-append-fun (kont? procedure? . -> . kont?)] - + ;; "CLIENT" INTERFACE [dispatch ((request? . -> . (request? . -> . response?)) request? @@ -189,4 +253,6 @@ (provide ;; "SERVLET" INTERFACE ; A contract would interfere with the safe-call? key + native->serial + serial->native call-with-serializable-current-continuation) diff --git a/collects/web-server/lang/elim-callcc.ss b/collects/web-server/lang/elim-callcc.ss index c0de68006c..cb4cb45a26 100644 --- a/collects/web-server/lang/elim-callcc.ss +++ b/collects/web-server/lang/elim-callcc.ss @@ -88,6 +88,7 @@ (#,cm) (#%plain-lambda #,x (#%plain-app abort + ; XXX Do I need to rebuild the CMs? (#%plain-lambda () (#%plain-app resume #,ref-to-cm #,ref-to-x))))) (#%plain-app activation-record-list))))))] [(#%plain-app call-with-values (#%plain-lambda () prod) cons) diff --git a/collects/web-server/lang/lang-api.ss b/collects/web-server/lang/lang-api.ss index b94ac3a048..8c97b1a93f 100644 --- a/collects/web-server/lang/lang-api.ss +++ b/collects/web-server/lang/lang-api.ss @@ -6,9 +6,11 @@ web-server/stuffers web-server/lang/abort-resume web-server/lang/web + web-server/lang/native web-server/lang/web-cells web-server/lang/web-param - web-server/lang/file-box) + web-server/lang/file-box + web-server/lang/soft) (provide (except-out (all-from-out scheme) #%module-begin) (all-from-out net/url web-server/http @@ -17,6 +19,8 @@ web-server/stuffers web-server/lang/abort-resume web-server/lang/web + web-server/lang/native web-server/lang/web-cells web-server/lang/web-param - web-server/lang/file-box)) + web-server/lang/file-box + web-server/lang/soft)) diff --git a/collects/web-server/lang/native.ss b/collects/web-server/lang/native.ss new file mode 100644 index 0000000000..8819c0f90b --- /dev/null +++ b/collects/web-server/lang/native.ss @@ -0,0 +1,25 @@ +#lang scheme +(require web-server/lang/abort-resume + (for-syntax scheme)) + +(define-syntax (define-native stx) + (syntax-case stx () + [(_ (id . argspec) original) + (quasisyntax/loc stx + (define id + (lambda id-args + (serial->native + (apply original + (map (lambda (higher-order? arg) + (if higher-order? + (lambda arg-args + (native->serial (apply arg arg-args))) + arg)) + (list #,@(map (lambda (arg) + (syntax-case arg (ho) + [ho #t] + [_ #f])) + (syntax->list #'argspec))) + id-args))))))])) + +(provide define-native) \ No newline at end of file diff --git a/collects/web-server/lang/soft.ss b/collects/web-server/lang/soft.ss new file mode 100644 index 0000000000..affd8bbf9b --- /dev/null +++ b/collects/web-server/lang/soft.ss @@ -0,0 +1,33 @@ +#lang scheme +(require scheme/serialize) + +(define-serializable-struct soft-state-record (id thnk)) + +(define *soft-state-cache* + (make-weak-hasheq)) + +(define next-record-id! + (local [(define record-id 0)] + (lambda () + (begin0 record-id + (set! record-id (add1 record-id)))))) + +(define (make-soft-state thnk) + (make-soft-state-record (next-record-id!) thnk)) + +(define soft-state-ref + (match-lambda + [(struct soft-state-record (id thnk)) + (hash-ref! *soft-state-cache* id thnk)])) + +(define soft-state? soft-state-record?) + +(define-syntax-rule (soft-state expr ...) + (make-soft-state (lambda () expr ...))) + +(provide + soft-state) +(provide/contract + [soft-state? (any/c . -> . boolean?)] + [make-soft-state ((-> any/c) . -> . soft-state?)] + [soft-state-ref (soft-state? . -> . any/c)]) \ No newline at end of file diff --git a/collects/web-server/lang/web.ss b/collects/web-server/lang/web.ss index 1e63658bde..e3ef0b1ffc 100644 --- a/collects/web-server/lang/web.ss +++ b/collects/web-server/lang/web.ss @@ -81,25 +81,23 @@ (lambda (k-url) (page-maker (url->string k-url))))) -(define-closure embed/url (proc) (k) - (stuff-url (stateless-servlet-stuffer (current-servlet)) - (request-uri (execution-context-request (current-execution-context))) - (kont-append-fun k proc))) +(define-closure embed/url (proc) (k string?) + (let ([url + (stuff-url (stateless-servlet-stuffer (current-servlet)) + (request-uri (execution-context-request (current-execution-context))) + (kont-append-fun k proc))]) + (if string? + (url->string url) + url))) + (define (send/suspend/url/dispatch response-generator) (call-with-serializable-current-continuation (lambda (k) - (response-generator (make-embed/url (lambda () k)))))) - -; XXX Uncopy&paste -(define-closure embed (proc) (k) - (url->string - (stuff-url (stateless-servlet-stuffer (current-servlet)) - (request-uri (execution-context-request (current-execution-context))) - (kont-append-fun k proc)))) + (response-generator (make-embed/url (lambda () (values k #f))))))) (define (send/suspend/dispatch response-generator) (call-with-serializable-current-continuation (lambda (k) - (response-generator (make-embed (lambda () k)))))) + (response-generator (make-embed/url (lambda () (values k #t))))))) ;; request->continuation: req -> continuation ;; decode the continuation from the hidden field of a request diff --git a/collects/web-server/scribblings/dummy-stateless-servlet.ss b/collects/web-server/scribblings/dummy-stateless-servlet.ss index 68f97d1288..920111bcdf 100644 --- a/collects/web-server/scribblings/dummy-stateless-servlet.ss +++ b/collects/web-server/scribblings/dummy-stateless-servlet.ss @@ -2,6 +2,7 @@ (define interface-version #f) (define stuffer #f) +(define manager #f) (define start #f) (provide (all-defined-out)) diff --git a/collects/web-server/scribblings/lang-api.scrbl b/collects/web-server/scribblings/lang-api.scrbl index 16757de287..b1e634a655 100644 --- a/collects/web-server/scribblings/lang-api.scrbl +++ b/collects/web-server/scribblings/lang-api.scrbl @@ -11,8 +11,10 @@ A stateless servlet should @scheme[provide] the following exports: @(require (for-label web-server/http scheme/serialize - web-server/stuffers - (except-in "dummy-stateless-servlet.ss" stuffer))) @; to give a binding context + (except-in web-server/stuffers stuffer) + web-server/managers/none + (except-in web-server/managers/manager manager) + "dummy-stateless-servlet.ss")) @; to give a binding context @declare-exporting[#:use-sources (web-server/scribblings/dummy-stateless-servlet)] @defthing[interface-version (one-of/c 'stateless)]{ @@ -20,11 +22,17 @@ A stateless servlet should @scheme[provide] the following exports: } @defthing[stuffer (stuffer/c serializable? bytes?)]{ - This is the @scheme[stuffer] that will be used for the servlet. + This is the stuffer that will be used for the servlet. If it is not provided, it defaults to @scheme[default-stuffer]. } +@defthing[manager manager?]{ + This is the manager that will be used for the servlet. + + If it is not provided, it defaults to @scheme[(create-none-manager #f)]. +} + @defproc[(start [initial-request request?]) response/c]{ This function is called when an instance of this servlet is started. @@ -34,6 +42,7 @@ A stateless servlet should @scheme[provide] the following exports: An example @scheme['stateless] servlet module: @schememod[ web-server + (provide interface-version stuffer start) (define interface-version 'stateless) (define stuffer (stuffer-chain @@ -46,14 +55,18 @@ An example @scheme['stateless] servlet module: These servlets have an extensive API available to them: @schememodname[net/url], @schememodname[web-server/http], @schememodname[web-server/http/bindings], -@schememodname[web-server/lang/abort-resume], @schememodname[web-server/lang/web], @schememodname[web-server/lang/web-param], -@schememodname[web-server/lang/web-cells], @schememodname[web-server/lang/file-box], @schememodname[web-server/dispatch], and +@schememodname[web-server/lang/abort-resume], @schememodname[web-server/lang/web], @schememodname[web-server/lang/native], +@schememodname[web-server/lang/web-param], +@schememodname[web-server/lang/web-cells], @schememodname[web-server/lang/file-box], @schememodname[web-server/lang/soft], @schememodname[web-server/dispatch], and @schememodname[web-server/stuffers]. Some of these are documented in the subsections that follow. +@include-section["serial.scrbl"] +@include-section["native.scrbl"] @include-section["lang.scrbl"] @include-section["lang-web-cells.scrbl"] @include-section["file-box.scrbl"] @include-section["web-param.scrbl"] +@include-section["soft.scrbl"] @include-section["stuffers.scrbl"] @include-section["stateless-usage.scrbl"] \ No newline at end of file diff --git a/collects/web-server/scribblings/lang.scrbl b/collects/web-server/scribblings/lang.scrbl index d6a67ec56a..36dde2a7a6 100644 --- a/collects/web-server/scribblings/lang.scrbl +++ b/collects/web-server/scribblings/lang.scrbl @@ -5,25 +5,10 @@ @(require (for-label net/url xml - scheme/serialize - web-server/servlet/servlet-structs + web-server/lang/web + scheme web-server/http)) -@section{Low Level} - -@(require (for-label web-server/lang/abort-resume)) -@defmodule[web-server/lang/abort-resume]{ - -@defproc[(call-with-serializable-current-continuation [response-generator (continuation? . -> . any)]) - any]{ - Captures the current continuation in a serializable way and calls @scheme[response-generator] with it, returning the result. -} - -} - -@section{High Level} - -@(require (for-label web-server/lang/web)) @defmodule[web-server/lang/web]{ @defproc[(send/suspend/url [response-generator (url? . -> . response/c)]) diff --git a/collects/web-server/scribblings/native.scrbl b/collects/web-server/scribblings/native.scrbl new file mode 100644 index 0000000000..3d8b148502 --- /dev/null +++ b/collects/web-server/scribblings/native.scrbl @@ -0,0 +1,36 @@ +#lang scribble/doc +@(require "web-server.ss") + +@title[]{Native Interfaces} + +@(require (for-label scheme + web-server/lang/native + web-server/lang/abort-resume)) + +@defmodule[web-server/lang/native]{ + +It is sometimes inconvenient to use @scheme[serial->native] and @scheme[native->serial] throughout your program. +This module provides a macro for creating wrappers. + +@defform[#:literals (ho) (define-native (native arg-spec ...) original) #:contracts ([arg-spec ho] [arg-spec _])]{ + Builds an interface around @scheme[original] named @scheme[native] such that calls to @scheme[native] are wrapped in @scheme[serial->native] + and all arguments marked with @scheme[ho] in @scheme[arg-spec] are assumed to procedures and are wrapped in @scheme[native->serial]. + + For example, + @schemeblock[ + (define-native (build-list/native _ ho) build-list) + ] + + is equivalent to + @schemeblock[ + (define (build-list/native fst snd) + (serial->native + (build-list + fst + (lambda args + (native->serial + (apply snd args)))))) + ] + } + +} diff --git a/collects/web-server/scribblings/serial.scrbl b/collects/web-server/scribblings/serial.scrbl new file mode 100644 index 0000000000..12a315b7ff --- /dev/null +++ b/collects/web-server/scribblings/serial.scrbl @@ -0,0 +1,57 @@ +#lang scribble/doc +@(require "web-server.ss") + +@title[]{Serializable Continuations} + +@(require (for-label web-server/lang/abort-resume + "dummy-stateless-servlet.ss" + scheme/serialize)) + +@defmodule[web-server/lang/abort-resume]{ + +The main purpose of the stateless language is to provide serializable continuations to your servlet. + +@defproc[(call-with-serializable-current-continuation [response-generator (continuation? . -> . any)]) + any]{ + Captures the current continuation in a serializable way and calls @scheme[response-generator] with it, returning the result. + + This potentially uses resources of the current servlet's @scheme[manager] if @scheme[serial->native] and @scheme[native->serial] were used + to capture an untransformable context. +} + +@defform[(serial->native expr)]{ + @scheme[serial->native] informs the serializing runtime that @scheme[expr] is potentially a call to an untransformed context. + This sets up the necessary information for + @scheme[native->serial] to signal to @scheme[call-with-serializable-current-continuation] to capture the native (and thus unserializable) section + of the context and store it on the server. +} + +@defform[(native->serial expr)]{ + @scheme[native->serial] informs the serializing runtime that @scheme[expr] marks first expression after returning from an untransformed context. + This captures the + untransformed context such that @scheme[call-with-serializable-current-continuation] can store it on the server and reference it from serializable + continuations. + + For example, + @schemeblock[ + (build-list + 3 + (lambda (i) + (call-with-serializable-current-continuation + (lambda (k) (serialize k))))) + ] + will fail at runtime because @scheme[build-list] is not transformed. However, + @schemeblock[ + (serial->native + (build-list + 3 + (lambda (i) + (native->serial + (call-with-serializable-current-continuation + (lambda (k) (serialize k))))))) + ] + will succeed and @scheme[k] will reference a cell in the current servlet's @scheme[manager] that stores the part of the continuation in + @scheme[build-list]. +} + +} \ No newline at end of file diff --git a/collects/web-server/scribblings/servlet-setup.scrbl b/collects/web-server/scribblings/servlet-setup.scrbl index 633b67ae98..281ca53cf1 100644 --- a/collects/web-server/scribblings/servlet-setup.scrbl +++ b/collects/web-server/scribblings/servlet-setup.scrbl @@ -27,9 +27,11 @@ This module is used internally to build and load servlets. It may be useful to t } @defproc[(make-stateless.servlet [directory path-string?] + [stuffer (stuffer/c serializable? bytes?)] + [manager manager?] [start (request? . -> . response/c)]) servlet?]{ - Creates a stateless @schememodname[web-server] servlet that uses @scheme[directory] as its current directory and @scheme[start] as the request handler. + Creates a stateless @schememodname[web-server] servlet that uses @scheme[directory] as its current directory, @scheme[stuffer] as its stuffer, and @scheme[manager] as the continuation manager, and @scheme[start] as the request handler. } @defthing[default-module-specs (listof module-path?)]{ diff --git a/collects/web-server/scribblings/servlet.scrbl b/collects/web-server/scribblings/servlet.scrbl index 45d488130a..5dbb1c3bda 100644 --- a/collects/web-server/scribblings/servlet.scrbl +++ b/collects/web-server/scribblings/servlet.scrbl @@ -33,6 +33,7 @@ An example version 2 module: @schememod[ scheme (require web-server/managers/none) + (provide interface-version manager start) (define interface-version 'v2) (define manager diff --git a/collects/web-server/scribblings/soft.scrbl b/collects/web-server/scribblings/soft.scrbl new file mode 100644 index 0000000000..bbc8cc9a54 --- /dev/null +++ b/collects/web-server/scribblings/soft.scrbl @@ -0,0 +1,71 @@ +#lang scribble/doc +@(require "web-server.ss" + (for-label web-server/lang/soft + web-server/lang/web)) + +@title[]{Soft State} + +@defmodule[web-server/lang/soft]{ + +Sometimes you want to reference a large data-structure from a stateless program without the data-structure being serialized +and increasing the size of the serialization. This module provides support for this scenario. + +@defproc[(soft-state? [v any/c]) + boolean?]{ + Determines if @scheme[v] is a soft state record. +} + +@defproc[(make-soft-state [thnk (-> any/c)]) + soft-state?]{ + Creates a piece of soft state that is computed by @scheme[thnk]. This value is serializable. +} + +@defproc[(soft-state-ref [ss soft-state?]) + any/c]{ + Extracts the value associated with @scheme[ss]. If the value is not available (perhaps because of garbage collection, deserialization in an uninitialized process, etc), then the thunk associated with @scheme[ss] is invoked and the value is cached. +} + +@defform[(soft-state expr ...)]{ + Equivalent to @scheme[(make-soft-state (lambda () expr ...))]. +} + +Here's an example servlet that uses soft state: +@schememod[ + web-server + + (provide interface-version start) + (define interface-version 'stateless) + + (define softie + (soft-state + (printf "Doing a long computation...~n") + (sleep 1))) + + (define (start req) + (soft-state-ref softie) + (printf "Done~n") + (start + (send/suspend + (lambda (k-url) + `(html (body (a ([href ,k-url]) "Done"))))))) +] + +When this is run and the link is clicked a few times, the output is: +@verbatim{ +$ plt-web-server -p 8080 +Doing a long computation... +Done +Done +Done +Done +} + +If the server is restarted or the hostname in the URL is changed to a different host with the same code, and the URL is clicked: +@verbatim{ +^Cuser break +$ plt-web-server -p 8080 +Doing a long computation... +Done +} + +} \ No newline at end of file diff --git a/collects/web-server/scribblings/stateless-usage.scrbl b/collects/web-server/scribblings/stateless-usage.scrbl index 3ae1a7ea6b..85df06777f 100644 --- a/collects/web-server/scribblings/stateless-usage.scrbl +++ b/collects/web-server/scribblings/stateless-usage.scrbl @@ -1,22 +1,25 @@ #lang scribble/doc -@(require "web-server.ss") +@(require "web-server.ss" + (for-label scheme/serialize + web-server/lang/abort-resume + web-server/lang/web)) @title[#:tag "considerations"]{Usage Considerations} -A servlet has the following process performed on it automatically: +A stateless servlet has the following process performed on it automatically: @itemize[ @item{All uses of @scheme[letrec] are removed and replaced with equivalent uses of @scheme[let] and imperative features.} - @item{The program is converted into ANF (Administrative Normal Form), + @item{The program is converted into @link["http://en.wikipedia.org/wiki/Administrative_normal_form"]{ANF} (Administrative Normal Form), making all continuations explicit.} - @item{All continuations (and other continuations marks) are recorded in the + @item{All continuations and continuations marks are recorded in the continuation marks of the expression they are the continuation of.} @item{All calls to external modules are identified and marked.} @item{All uses of @scheme[call/cc] are removed and replaced with - equivalent gathering of the continuations through the continuation-marks.} + equivalent gathering of the continuations through the continuation marks installed earlier.} @item{The program is defunctionalized with a serializable data-structure for each - anonymous lambda.} + @scheme[lambda].} ] This process allows the continuations captured by your servlet to be serialized. @@ -24,21 +27,21 @@ This means they may be stored on the client's browser or the server's disk. Thus, your servlet has no cost to the server other than execution. This is very attractive if you've used Scheme servlets and had memory problems. -This process IS defined on all of PLT Scheme and occurs AFTER macro-expansion, +This process is defined on all of PLT Scheme and occurs after macro-expansion, so you are free to use all interesting features of PLT Scheme. However, there are some considerations you must make. First, this process drastically changes the structure of your program. It will create an immense number of lambdas and structures your program did not normally contain. The performance implication of this has not been -studied with PLT Scheme. However, it is theoretically a benefit. The main -implications would be due to optimizations MzScheme attempts to perform -that will no longer apply. Ideally, your program should be optimized first. +studied with PLT Scheme. Second, the defunctionalization process is sensitive to the syntactic structure of your program. Therefore, if you change your program in a trivial way, for example, changing a constant, then all serialized continuations will be obsolete and will -error when deserialization is attempted. This is a feature, not a bug! +error when deserialization is attempted. This is a feature, not a bug! It is a small +price to pay for protection from the sorts of errors that would occur if your program +were changed in a meaningful way. Third, the values in the lexical scope of your continuations must be serializable for the continuations itself to be serializable. This means that you must use @@ -47,7 +50,7 @@ care to use modules that do the same. Similarly, you may not use @scheme[paramet because parameterizations are not serializable. Fourth, and related, this process only runs on your code, not on the code you -@scheme[require]. Thus, your continuations---to be capturable---must not +@scheme[require]. Thus, your continuations---to be serializable---must not be in the context of another module. For example, the following will not work: @schemeblock[ (define requests @@ -55,12 +58,22 @@ be in the context of another module. For example, the following will not work: response-generators)) ] because @scheme[map] is not transformed by the process. However, if you defined -your own @scheme[map] function, there would be no problem. +your own @scheme[map] function, there would be no problem. Another solution is to +store the @scheme[map] part of the continuation on the server with @scheme[serial->native] +and @scheme[native->serial]: +@schemeblock[ + (define requests + (serial->native + (map (lambda (rg) (native->serial (send/suspend/url rg))) + response-generators))) +] -Fifth, the store is NOT serialized. If you rely on the store you will +Fifth, the store is @bold{not} serialized. If you rely on the store you will be taking huge risks. You will be assuming that the serialized continuation -is invoked before the server is restarted or the memory is garbage collected. +is invoked on the same server before the server is restarted or +the memory is garbage collected. -This process is derived from the paper -@href-link["http://www.cs.brown.edu/~sk/Publications/Papers/Published/pcmkf-cont-from-gen-stack-insp/" "Continuations from Generalized Stack Inspection"]. +This process is derived from the ICFP papers +@emph{@link["http://www.cs.brown.edu/~sk/Publications/Papers/Published/pcmkf-cont-from-gen-stack-insp/"]{Continuations from Generalized Stack Inspection}} by Pettyjohn et al. in 2005 and +@emph{Automatically RESTful Web Applications, Or Marking Modular Serializable Continuations} by Jay McCarthy in 2009. We thank Greg Pettyjohn for his initial implementation of this algorithm. diff --git a/collects/web-server/scribblings/stuffers.scrbl b/collects/web-server/scribblings/stuffers.scrbl index 1b3c7322e6..660b63e950 100644 --- a/collects/web-server/scribblings/stuffers.scrbl +++ b/collects/web-server/scribblings/stuffers.scrbl @@ -49,22 +49,22 @@ You can supply your own (built with these functions) when you write a stateless The identitiy @tech{stuffer}. } -@defproc[(stuffer-compose [g (stuffer any/c any/c)] - [f (stuffer any/c any/c)]) - (stuffer any/c any/c)]{ +@defproc[(stuffer-compose [g (stuffer/c any/c any/c)] + [f (stuffer/c any/c any/c)]) + (stuffer/c any/c any/c)]{ Composes @scheme[f] and @scheme[g], i.e., applies @scheme[f] then @scheme[g] for @scheme[in] and @scheme[g] then @scheme[f] for @scheme[out]. } -@defproc[(stuffer-sequence [f (stuffer any/c any/c)] - [g (stuffer any/c any/c)]) - (stuffer any/c any/c)]{ +@defproc[(stuffer-sequence [f (stuffer/c any/c any/c)] + [g (stuffer/c any/c any/c)]) + (stuffer/c any/c any/c)]{ @scheme[stuffer-compose] with arguments swapped. } @defproc[(stuffer-if [c (bytes? . -> . boolean?)] - [f (stuffer bytes? bytes?)]) - (stuffer bytes? bytes?)]{ + [f (stuffer/c bytes? bytes?)]) + (stuffer/c bytes? bytes?)]{ Creates a @tech{stuffer} that stuffs with @scheme[f] if @scheme[c] is true on the input to @scheme[in]. Similarly, applies @scheme[f] during @scheme[out] if it was applied during @scheme[in] (which is recorded by prepending a byte.) @@ -140,7 +140,7 @@ The @schememodname[web-server/stuffers/hash] @tech{stuffers} rely on a key/value ] } - It should be easy to use this interface to create store for databases, like SQLite, CouchDB, or BerkeleyDB. + It should be easy to use this interface to create store for databases like SQLite, CouchDB, or BerkeleyDB. } @section{Hash-addressed Storage} @@ -201,7 +201,7 @@ The @schememodname[web-server/stuffers/hash] @tech{stuffers} rely on a key/value @defproc[(is-url-too-big? [v bytes?]) boolean?]{ Determines if stuffing @scheme[v] into the current servlet's URL would result in a URL that is too big for Internet Explorer. - (@link["http://www.boutell.com/newfaq/misc/urllength.html"]{IE only supports URLs up to 2048 characters.}). + (@link["http://www.boutell.com/newfaq/misc/urllength.html"]{IE only supports URLs up to 2048 characters.}) } @defproc[(make-default-stuffer [root path-string?]) diff --git a/collects/web-server/scribblings/web-cells.scrbl b/collects/web-server/scribblings/web-cells.scrbl index e0902514e5..7c203f6229 100644 --- a/collects/web-server/scribblings/web-cells.scrbl +++ b/collects/web-server/scribblings/web-cells.scrbl @@ -2,7 +2,8 @@ @(require "web-server.ss") @title[#:tag "web-cells.ss"]{Web Cells} -@(require (for-label web-server/servlet/web-cells)) +@(require (for-label web-server/servlet/web-cells + web-server/servlet/web)) @defmodule[web-server/servlet/web-cells]{The @schememodname[web-server/servlet/web-cells] library provides the diff --git a/collects/web-server/servlet/setup.ss b/collects/web-server/servlet/setup.ss index 85a99a78c6..414831f5f2 100644 --- a/collects/web-server/servlet/setup.ss +++ b/collects/web-server/servlet/setup.ss @@ -67,15 +67,18 @@ (parameterize ([current-servlet-instance-id instance-id]) (handler req)))))) -(define (make-stateless.servlet directory stuffer start) +(define (make-stateless.servlet directory stuffer manager start) + (define instance-id + ((manager-create-instance manager) (exit-handler))) (define ses (make-stateless-servlet (current-custodian) (current-namespace) - (create-none-manager (lambda (req) (error "No continuations!"))) + manager directory (lambda (req) (error "Session not initialized")) stuffer)) (parameterize ([current-directory directory] + [current-servlet-instance-id instance-id] [current-servlet ses]) (set-servlet-handler! ses (initialize-servlet start))) ses) @@ -110,7 +113,7 @@ (provide/contract [make-v1.servlet (path-string? integer? (request? . -> . response/c) . -> . servlet?)] [make-v2.servlet (path-string? manager? (request? . -> . response/c) . -> . servlet?)] - [make-stateless.servlet (path-string? (stuffer/c serializable? bytes?) (request? . -> . response/c) . -> . servlet?)] + [make-stateless.servlet (path-string? (stuffer/c serializable? bytes?) manager? (request? . -> . response/c) . -> . servlet?)] [default-module-specs (listof (or/c resolved-module-path? module-path?))]) (define (make-default-path->servlet #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)] @@ -163,11 +166,16 @@ (dynamic-require module-name 'start) pos-blame neg-blame (mk-loc "start"))] + [manager (contract manager? + (dynamic-require module-name 'manager + (lambda () (create-none-manager (lambda (req) (error "No continuations!"))))) + pos-blame neg-blame + (mk-loc "manager"))] [stuffer (contract (stuffer/c serializable? bytes?) (dynamic-require module-name 'stuffer (lambda () default-stuffer)) pos-blame neg-blame (mk-loc "stuffer"))]) - (make-stateless.servlet (directory-part a-path) stuffer start))]))] + (make-stateless.servlet (directory-part a-path) stuffer manager start))]))] [else (make-v1.servlet (directory-part a-path) timeouts-default-servlet (v0.response->v1.lambda