Fixing web-cell bug
svn: r11485
This commit is contained in:
Jay McCarthy
parent
5d4338ff24
commit
08e2704d8d
|
|
@ -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)
|
||||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user