From 08e2704d8d5f0856cef91b09bf3f63230d048d72 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 29 Aug 2008 18:22:28 +0000 Subject: [PATCH] Fixing web-cell bug svn: r11485 --- .../dispatchers/dispatch-servlets-test.ss | 18 +- .../dispatchers/dispatch-servlets.ss | 62 +++--- collects/web-server/scribblings/servlet.scrbl | 2 - collects/web-server/servlet/web-cells.ss | 190 ++++-------------- collects/web-server/servlet/web.ss | 68 ++++--- 5 files changed, 115 insertions(+), 225 deletions(-) diff --git a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss index 7e6e2d7485..3476c5daea 100644 --- a/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-servlets-test.ss @@ -97,14 +97,14 @@ "Expired")) (test-double-counters - mkd - "wc-fake.ss - no cells" - (build-path example-servlets "wc-fake.ss")) - - (test-double-counters - mkd - "wc.ss - make-web-cell web-cell-ref web-cell-shadow" - (build-path example-servlets "wc.ss")) + mkd + "wc-fake.ss - no cells" + (build-path example-servlets "wc-fake.ss")) + + (test-double-counters + mkd + "wc.ss - make-web-cell web-cell-ref web-cell-shadow" + (build-path example-servlets "wc.ss")) ; XXX Broken #;(test-equal? "adjust.ss - adjust-timeout!" @@ -117,5 +117,5 @@ ; Comment in to run tests #;(require #;(planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2)) - (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2))) + (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2))) #;(test/text-ui dispatch-servlets-tests) \ No newline at end of file diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index 8b505bcd6f..1a1a9ed548 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -58,38 +58,36 @@ (lambda (the-exn) (responders-servlet-loading uri the-exn))]) (call-with-continuation-prompt (lambda () - ; Create the session frame - (with-frame - (define instance-custodian (make-servlet-custodian)) - (define-values (servlet-path _) - (with-handlers - ([void (lambda (e) - (raise (make-exn:fail:filesystem:exists:servlet - (exn-message e) - (exn-continuation-marks e))))]) - (url->path uri))) - (parameterize ([current-directory (directory-part servlet-path)] - [current-custodian instance-custodian] - [exit-handler - (lambda _ - (kill-connection! conn) - (custodian-shutdown-all instance-custodian))]) - ;; any resources (e.g. threads) created when the - ;; servlet is loaded should be within the dynamic - ;; extent of the servlet custodian - (define the-servlet (cached-load servlet-path)) - (parameterize ([current-servlet the-servlet] - [current-namespace (servlet-namespace the-servlet)]) - (define manager (servlet-manager the-servlet)) - (parameterize ([current-execution-context (make-execution-context req)]) - (define instance-id ((manager-create-instance manager) (exit-handler))) - (parameterize ([current-servlet-instance-id instance-id]) - (with-handlers ([(lambda (x) #t) - (lambda (exn) - (responders-servlet - (request-uri req) - exn))]) - ((servlet-handler the-servlet) req)))))))) + (define instance-custodian (make-servlet-custodian)) + (define-values (servlet-path _) + (with-handlers + ([void (lambda (e) + (raise (make-exn:fail:filesystem:exists:servlet + (exn-message e) + (exn-continuation-marks e))))]) + (url->path uri))) + (parameterize ([current-directory (directory-part servlet-path)] + [current-custodian instance-custodian] + [exit-handler + (lambda _ + (kill-connection! conn) + (custodian-shutdown-all instance-custodian))]) + ;; any resources (e.g. threads) created when the + ;; servlet is loaded should be within the dynamic + ;; extent of the servlet custodian + (define the-servlet (cached-load servlet-path)) + (parameterize ([current-servlet the-servlet] + [current-namespace (servlet-namespace the-servlet)]) + (define manager (servlet-manager the-servlet)) + (parameterize ([current-execution-context (make-execution-context req)]) + (define instance-id ((manager-create-instance manager) (exit-handler))) + (parameterize ([current-servlet-instance-id instance-id]) + (with-handlers ([(lambda (x) #t) + (lambda (exn) + (responders-servlet + (request-uri req) + exn))]) + ((servlet-handler the-servlet) req))))))) servlet-prompt))) (output-response conn response)) diff --git a/collects/web-server/scribblings/servlet.scrbl b/collects/web-server/scribblings/servlet.scrbl index a3e27e1240..03011f319f 100644 --- a/collects/web-server/scribblings/servlet.scrbl +++ b/collects/web-server/scribblings/servlet.scrbl @@ -418,8 +418,6 @@ generated. For more information on their semantics, consult the paper @href-link["http://www.cs.brown.edu/~sk/Publications/Papers/Published/mk-int-safe-state-web/" "\"Interaction-Safe State for the Web\""]. -@; XXX Document with-frame and with-frame-after? - @defproc[(web-cell? [v any/c]) boolean?]{ Determines if @scheme[v] is a web-cell. diff --git a/collects/web-server/servlet/web-cells.ss b/collects/web-server/servlet/web-cells.ss index 702fe116a2..87eb6f6ab7 100644 --- a/collects/web-server/servlet/web-cells.ss +++ b/collects/web-server/servlet/web-cells.ss @@ -1,157 +1,49 @@ -#lang scheme/base -(require mzlib/struct - mzlib/contract) +#lang scheme +;; Implementation: Have a distinguished frame variable that is read and captured by send/suspend, +;; installed on invocations of continuations by the server (and NOT from other continuation invocations) -(define-struct (exn:fail:frame:top exn) ()) -(define (exn:fail:frame:top-raise) - (raise (make-exn:fail:frame:top - "Reached top of stack" - (current-continuation-marks)))) +;; Data types +(define-struct primitive-wc (id)) +(define-struct frame (env)) -;; frames -(define-struct frame ()) -(define-struct (frame:empty frame) ()) -; frame:ns : (alist * (box frame) * namespace) -(define-struct (frame:ns frame) (annotations boxed-parent namespace)) +;; Frames +(define *wc-frame* (make-thread-cell (make-frame (make-immutable-hasheq empty)) #t)) +(define (current-frame) (thread-cell-ref *wc-frame*)) +(define (update-frame! nf) (thread-cell-set! *wc-frame* nf)) -; frame:ns?/raise : frame -> frame -(define (frame:ns?/raise f) - (if (frame:ns? f) - f - (exn:fail:frame:top-raise))) +;; Web Cell Sets +(define web-cell-set? frame?) +(define (capture-web-cell-set) (current-frame)) +(define (restore-web-cell-set! wcs) (update-frame! wcs)) -; make-frame/parent : (box frame) -> frame:ns -(define (make-frame/parent parent-frame-box) - (make-frame:ns (list) parent-frame-box (make-empty-namespace))) - -; search-frames : frame:ns (frame:ns -> boolean?) -> frame -; Returns the first frame in the stack that matches the predicate -(define (search-frames a-frame predicate?) - (if (predicate? a-frame) - a-frame - (search-frames (frame:ns?/raise - (unbox (frame:ns-boxed-parent a-frame))) - predicate?))) - -; frame-ref : frame:ns symbol -> any -; Lookups up the variable in the frame and its parent(s) -(define (frame-ref a-frame var) - #;(printf "~S~n" (list (namespace-mapped-symbols (frame:ns-namespace a-frame)) var)) - (namespace-variable-value - var #f - (lambda () - (frame-ref (frame:ns?/raise - (unbox (frame:ns-boxed-parent a-frame))) - var)) - (frame:ns-namespace a-frame))) - -; frame-set? : frame:ns symbol -> boolean -(define (frame-set? a-frame var) - (not - (not - (namespace-variable-value - var #f - (lambda () #f) - (frame:ns-namespace a-frame))))) - -; frame-set! : frame:ns symbol any -> void -; Sets the variable in the frame to a value -(define (frame-set! a-frame var val) - (namespace-set-variable-value! - var val - #t (frame:ns-namespace a-frame))) - -;; frame stacks -(define *global-root-id* (gensym)) - -; *frame-stack* : (box frame) -(define *frame-stack* - (make-parameter - (box (copy-struct frame:ns (make-frame/parent (box (make-frame:empty))) - [frame:ns-annotations (list (cons *global-root-id* #t))])))) - -; annotation-present? : symbol frame:ns -> boolean -(define (annotation-present? i a-frame) - (not (not (assq i (frame:ns-annotations a-frame))))) - -; global-root? : frame:ns -> boolean -(define (global-root? a-frame) - (annotation-present? *global-root-id* a-frame)) - -; make-frame/top : -> frame:ns -(define (make-frame/top) - (define cur-top-box (*frame-stack*)) - (define cur-top (unbox cur-top-box)) - (make-frame/parent cur-top-box)) - -; push-frame! : -> void -; Pushs a new frame onto the session stack -(define (push-frame!) - (*frame-stack* (box (make-frame/top)))) - -; pop-frame! : -> void -; Pops the frame from the stack -(define (pop-frame!) - (*frame-stack* (frame:ns-boxed-parent (unbox (*frame-stack*))))) - -; save-stack/push/return : (-> 'a) -> 'a -; Pushes a frame after the thunk's execution with the same parent as the call site -(define (save-stack/push/return thunk) - (define initial-stack (*frame-stack*)) - (begin0 (thunk) - (*frame-stack* initial-stack) - (push-frame!))) - -; syntax version of above -(define-syntax with-frame-after - (syntax-rules () - [(_ body ...) - (save-stack/push/return (lambda () body ...))])) - -; parameterized-push : (-> 'a) -> 'a -(define (parameterized-push thunk) - (parameterize ([*frame-stack* (box (make-frame/top))]) - (thunk))) - -; syntax version of above -(define-syntax with-frame - (syntax-rules () - [(_ body ...) - (parameterized-push (lambda () body ...))])) - -; search-stack : (frame -> boolean) -> frame -(define (search-stack predicate?) - (search-frames (frame:ns?/raise (unbox (*frame-stack*))) - predicate?)) - -; cells -(define-struct cell (id)) -(define-struct (cell:local cell) ()) - -(define web-cell? cell:local?) - -; ext:make-'a 'b -> 'a -(define (make-web-cell default) - (define new-name (gensym)) - (frame-set! (search-stack global-root?) - new-name default) - (make-cell:local new-name)) - -; cell:local-ref : cell:local -> any -; returns the value of the local cell -(define (web-cell-ref lc) - (frame-ref (search-stack frame?) - (cell-id lc))) -; cell:local-mask : cell:local any -> void -; masks the local cell to the given value -(define (web-cell-shadow lc nv) - (frame-set! (search-stack frame?) - (cell-id lc) - nv)) - -(provide with-frame ; syntax - with-frame-after) (provide/contract + [web-cell-set? (any/c . -> . boolean?)] + [capture-web-cell-set (-> web-cell-set?)] + [restore-web-cell-set! (web-cell-set? . -> . void)]) + +;; Web Cells +(define web-cell? primitive-wc?) + +(define (make-web-cell default) + (define key (gensym 'web-cell)) + (define wc (make-primitive-wc key)) + (web-cell-shadow wc default) + wc) + +(define (web-cell-ref pwc) + (define i (primitive-wc-id pwc)) + (hash-ref + (frame-env (current-frame)) i + (lambda () + (error 'web-cell "Undefined web-cell: ~e" i)))) + +(define (web-cell-shadow wc nv) + (update-frame! + (make-frame + (hash-set (frame-env (current-frame)) + (primitive-wc-id wc) nv)))) + +(provide/contract [web-cell? (any/c . -> . boolean?)] [make-web-cell (any/c . -> . web-cell?)] [web-cell-ref (web-cell? . -> . any/c)] diff --git a/collects/web-server/servlet/web.ss b/collects/web-server/servlet/web.ss index d52ee1adcd..e586235f63 100644 --- a/collects/web-server/servlet/web.ss +++ b/collects/web-server/servlet/web.ss @@ -116,21 +116,23 @@ ;; send a response and apply the continuation to the next request (define (send/suspend response-generator [expiration-handler (current-servlet-continuation-expiration-handler)]) - (with-frame-after - (call-with-composable-continuation - (lambda (k) - (define instance-id (current-servlet-instance-id)) - (define ctxt (current-execution-context)) - (define k-embedding ((manager-continuation-store! (current-servlet-manager)) - instance-id - (make-custodian-box (current-custodian) k) - expiration-handler)) - (define k-url ((current-url-transform) - (embed-ids - (list* instance-id k-embedding) - (request-uri (execution-context-request ctxt))))) - (send/back (response-generator k-url))) - servlet-prompt))) + (define wcs (capture-web-cell-set)) + (begin0 + (call-with-composable-continuation + (lambda (k) + (define instance-id (current-servlet-instance-id)) + (define ctxt (current-execution-context)) + (define k-embedding ((manager-continuation-store! (current-servlet-manager)) + instance-id + (make-custodian-box (current-custodian) k) + expiration-handler)) + (define k-url ((current-url-transform) + (embed-ids + (list* instance-id k-embedding) + (request-uri (execution-context-request ctxt))))) + (send/back (response-generator k-url))) + servlet-prompt) + (restore-web-cell-set! wcs))) ;; send/forward: (url -> response) [(request -> response)] -> request ;; clear the continuation table, then behave like send/suspend @@ -143,24 +145,24 @@ ;; send/back a response generated from a procedure that may convert ;; procedures to continuation urls (define (send/suspend/dispatch response-generator) - ; This restores the tail position. - ; Note: Herman's syntactic strategy would fail without the new-request capture. - ; (Moving this to the tail-position is not possible anyway, by the way.) - (let ([thunk - (call-with-current-continuation - (lambda (k0) - (send/back - (response-generator - (lambda (proc [expiration-handler (current-servlet-continuation-expiration-handler)]) - (let/ec k1 - ; This makes the second continuation captured by send/suspend smaller - (call-with-continuation-prompt - (lambda () - (let ([new-request (send/suspend k1 expiration-handler)]) - (k0 (lambda () (proc new-request))))) - servlet-prompt)))))) - servlet-prompt)]) - (thunk))) + ; This restores the tail position. + ; Note: Herman's syntactic strategy would fail without the new-request capture. + ; (Moving this to the tail-position is not possible anyway, by the way.) + (let ([thunk + (call-with-current-continuation + (lambda (k0) + (send/back + (response-generator + (lambda (proc [expiration-handler (current-servlet-continuation-expiration-handler)]) + (let/ec k1 + ; This makes the second continuation captured by send/suspend smaller + (call-with-continuation-prompt + (lambda () + (let ([new-request (send/suspend k1 expiration-handler)]) + (k0 (lambda () (proc new-request))))) + servlet-prompt)))))) + servlet-prompt)]) + (thunk))) ;; ************************************************************ ;; HIGHER-LEVEL EXPORTS