Using delimited continuations to remove some effects
svn: r6617
This commit is contained in:
Jay McCarthy
parent
20220e60b6
commit
72ec6342ea
|
|
@ -41,6 +41,7 @@
|
|||
(adjust-connection-timeout!
|
||||
conn
|
||||
timeouts-servlet-connection)
|
||||
; XXX Allow servlet to respond
|
||||
(case meth
|
||||
[(head)
|
||||
(output-response/method
|
||||
|
|
@ -62,17 +63,17 @@
|
|||
;; This is not a continuation url so the loading behavior is determined
|
||||
;; by the url path. Build the servlet path and then load the servlet
|
||||
(define (servlet-content-producer/path conn req uri)
|
||||
(with-handlers (;; couldn't find the servlet
|
||||
[exn:fail:filesystem:exists:servlet?
|
||||
(lambda (the-exn)
|
||||
(next-dispatcher))]
|
||||
;; servlet won't load (e.g. syntax error)
|
||||
[(lambda (x) #t)
|
||||
(lambda (the-exn)
|
||||
(output-response/method conn (responders-servlet-loading uri the-exn) (request-method req)))])
|
||||
(define servlet-mutex (make-semaphore 0))
|
||||
(define servlet-mutex (make-semaphore 1))
|
||||
(define response
|
||||
(let/cc suspend
|
||||
(with-handlers ([exn:fail:filesystem:exists:servlet?
|
||||
(lambda (the-exn) (next-dispatcher))]
|
||||
[(lambda (x) #t)
|
||||
(lambda (the-exn) (responders-servlet-loading uri the-exn))])
|
||||
(call-with-semaphore
|
||||
servlet-mutex
|
||||
(lambda ()
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
; Create the session frame
|
||||
(with-frame
|
||||
(define instance-custodian (make-servlet-custodian))
|
||||
|
|
@ -86,73 +87,40 @@
|
|||
(parameterize ([current-directory (get-servlet-base-dir servlet-path)]
|
||||
[current-custodian instance-custodian]
|
||||
[exit-handler
|
||||
(lambda _
|
||||
(lambda (v)
|
||||
(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))
|
||||
(thread-cell-set! current-servlet the-servlet)
|
||||
(parameterize ([current-namespace (servlet-namespace the-servlet)])
|
||||
(parameterize ([current-servlet the-servlet]
|
||||
[current-namespace (servlet-namespace the-servlet)])
|
||||
(define manager (servlet-manager the-servlet))
|
||||
(define ctxt
|
||||
(make-execution-context
|
||||
conn req suspend))
|
||||
(define data
|
||||
(make-servlet-instance-data
|
||||
servlet-mutex))
|
||||
(define the-exit-handler
|
||||
(lambda _
|
||||
(define ectxt
|
||||
(thread-cell-ref current-execution-context))
|
||||
(when ectxt
|
||||
(kill-connection!
|
||||
(execution-context-connection ectxt)))
|
||||
(custodian-shutdown-all instance-custodian)))
|
||||
(thread-cell-set! current-execution-context ctxt)
|
||||
(parameterize ([exit-handler the-exit-handler])
|
||||
(define instance-id ((manager-create-instance manager) data the-exit-handler))
|
||||
(thread-cell-set! current-servlet-instance-id instance-id)
|
||||
(parameterize ([current-execution-context (make-execution-context req)])
|
||||
(define instance-id ((manager-create-instance manager) (make-servlet-instance-data servlet-mutex) (exit-handler)))
|
||||
; XXX Locking is broken
|
||||
((manager-instance-lock! manager) instance-id)
|
||||
(parameterize ([exit-handler (lambda x
|
||||
(parameterize ([current-servlet-instance-id instance-id]
|
||||
[exit-handler (lambda (v)
|
||||
((manager-instance-unlock! manager) instance-id)
|
||||
(the-exit-handler x))])
|
||||
(with-handlers ([(lambda (x) #t)
|
||||
(exit v))])
|
||||
(begin0 (with-handlers ([(lambda (x) #t)
|
||||
(make-servlet-exception-handler)])
|
||||
(send/back ((servlet-handler the-servlet) req)))
|
||||
((servlet-handler the-servlet) req))
|
||||
((manager-instance-unlock! manager) instance-id))))))))
|
||||
(output-response conn response)
|
||||
(semaphore-post servlet-mutex)
|
||||
(thread-cell-set! current-execution-context #f)
|
||||
(thread-cell-set! current-servlet #f)
|
||||
(thread-cell-set! current-servlet-instance-id #f)))
|
||||
servlet-prompt)))))
|
||||
(output-response conn response))
|
||||
|
||||
;; default-server-instance-expiration-handler : (request -> response)
|
||||
(define (default-servlet-instance-expiration-handler req)
|
||||
(next-dispatcher))
|
||||
|
||||
;; make-servlet-exception-handler: servlet-instance -> exn -> void
|
||||
;; This exception handler traps all unhandled servlet exceptions
|
||||
;; * Must occur within the dynamic extent of the servlet
|
||||
;; custodian since several connection custodians will typically
|
||||
;; be shutdown during the dynamic extent of a continuation
|
||||
;; * Use the connection from the current-servlet-context in case
|
||||
;; the exception is raised while invoking a continuation.
|
||||
;; * Use the suspend from the servlet-instanct-context which is
|
||||
;; closed over the current tcp ports which may need to be
|
||||
;; closed for an http 1.0 request.
|
||||
;; * Also, suspend will post to the semaphore so that future
|
||||
;; requests won't be blocked.
|
||||
;; * This fixes PR# 7066
|
||||
(define ((make-servlet-exception-handler) the-exn)
|
||||
(define context (thread-cell-ref current-execution-context))
|
||||
(define request (execution-context-request context))
|
||||
(define resp
|
||||
(responders-servlet
|
||||
(request-uri request)
|
||||
(request-uri (execution-context-request (current-execution-context)))
|
||||
the-exn))
|
||||
((execution-context-suspend context) resp))
|
||||
|
||||
;; path -> path
|
||||
;; The actual servlet's parent directory.
|
||||
|
|
@ -164,59 +132,37 @@
|
|||
(and (directory-exists? base) base))
|
||||
(loop base))))
|
||||
|
||||
;; invoke-servlet-continuation: connection request continuation-reference -> void
|
||||
;; pull the continuation out of the table and apply it
|
||||
(define (invoke-servlet-continuation conn req instance-id k-id salt)
|
||||
(define uri (request-uri req))
|
||||
(define-values (servlet-path _) (url->path uri))
|
||||
(define the-servlet (cached-load servlet-path))
|
||||
(define manager (servlet-manager the-servlet))
|
||||
(thread-cell-set! current-servlet the-servlet)
|
||||
(thread-cell-set! current-servlet-instance-id instance-id)
|
||||
(parameterize ([current-custodian (servlet-custodian the-servlet)])
|
||||
(define data ((manager-instance-lookup-data manager) instance-id))
|
||||
(define _v ((manager-instance-lock! manager) instance-id))
|
||||
(define response
|
||||
(parameterize ([current-servlet the-servlet]
|
||||
[current-servlet-instance-id instance-id]
|
||||
[current-custodian (servlet-custodian the-servlet)])
|
||||
(with-handlers ([exn:fail:servlet-manager:no-instance?
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((exn:fail:servlet-manager:no-instance-expiration-handler the-exn)
|
||||
req)
|
||||
(request-method req)))]
|
||||
((exn:fail:servlet-manager:no-instance-expiration-handler the-exn) req))]
|
||||
[exn:fail:servlet-manager:no-continuation?
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((exn:fail:servlet-manager:no-continuation-expiration-handler the-exn)
|
||||
req)
|
||||
(request-method req)))]
|
||||
((exn:fail:servlet-manager:no-continuation-expiration-handler the-exn) req))]
|
||||
[exn:fail:servlet:instance?
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
(default-servlet-instance-expiration-handler
|
||||
req)
|
||||
(request-method req)))])
|
||||
(define data ((manager-instance-lookup-data manager) instance-id))
|
||||
((manager-instance-lock! manager) instance-id)
|
||||
; We don't use call-with-semaphore or dynamic-wind because we
|
||||
; always call a continuation. The exit-handler above ensures that
|
||||
; the post is done.
|
||||
(semaphore-wait (servlet-instance-data-mutex data))
|
||||
(with-handlers ([exn? (lambda (exn)
|
||||
(semaphore-post (servlet-instance-data-mutex data))
|
||||
(raise exn))])
|
||||
(let ([response
|
||||
(let/cc suspend
|
||||
(thread-cell-set! current-execution-context
|
||||
(make-execution-context
|
||||
conn req suspend))
|
||||
(let ([kcb ((manager-continuation-lookup manager) instance-id k-id salt)])
|
||||
((custodian-box-value kcb) req)))])
|
||||
(output-response conn response))
|
||||
(semaphore-post (servlet-instance-data-mutex data)))))
|
||||
((manager-instance-unlock! manager) instance-id)
|
||||
(thread-cell-set! current-execution-context #f)
|
||||
(thread-cell-set! current-servlet-instance-id #f)
|
||||
(thread-cell-set! current-servlet #f))
|
||||
(default-servlet-instance-expiration-handler req))])
|
||||
(call-with-semaphore
|
||||
(servlet-instance-data-mutex data)
|
||||
(lambda ()
|
||||
(parameterize ([current-execution-context (make-execution-context req)])
|
||||
(call-with-continuation-prompt
|
||||
(lambda ()
|
||||
(define kcb ((manager-continuation-lookup manager) instance-id k-id salt))
|
||||
((custodian-box-value kcb) req))
|
||||
servlet-prompt)))))))
|
||||
(output-response conn response)
|
||||
((manager-instance-unlock! manager) instance-id))
|
||||
|
||||
;; cached-load : path -> script, namespace
|
||||
;; timestamps are no longer checked for performance. The cache must be explicitly
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@
|
|||
(define-struct (exn:fail:servlet-manager:no-continuation exn:fail) (expiration-handler))
|
||||
|
||||
(provide/contract
|
||||
[struct manager ([create-instance (any/c (-> void) . -> . number?)]
|
||||
[struct manager ([create-instance (any/c (any/c . -> . void) . -> . number?)]
|
||||
[adjust-timeout! (number? number? . -> . void)]
|
||||
[instance-lookup-data (number? . -> . any/c)]
|
||||
[instance-lock! (number? . -> . void)]
|
||||
|
|
|
|||
|
|
@ -5,31 +5,20 @@
|
|||
"connection-manager.ss"
|
||||
"../private/request-structs.ss")
|
||||
|
||||
(define servlet-prompt (make-continuation-prompt-tag 'servlet))
|
||||
(provide servlet-prompt)
|
||||
|
||||
(define-struct (exn:fail:servlet:instance exn:fail) ())
|
||||
(define-struct servlet (custodian namespace manager handler))
|
||||
(define-struct servlet-instance-data (mutex))
|
||||
(define-struct execution-context (connection request suspend))
|
||||
(define-struct execution-context (request))
|
||||
|
||||
(define current-servlet (make-thread-cell #f))
|
||||
(define current-servlet-instance-id (make-thread-cell #f))
|
||||
(define current-execution-context (make-thread-cell #f))
|
||||
|
||||
(define (get-current-servlet-instance-id)
|
||||
(define instance-id (thread-cell-ref current-servlet-instance-id))
|
||||
(unless instance-id
|
||||
(raise (make-exn:fail:servlet:instance "No current servlet instance" (current-continuation-marks))))
|
||||
instance-id)
|
||||
(define current-servlet (make-parameter #f))
|
||||
(define current-servlet-instance-id (make-parameter #f))
|
||||
(define current-execution-context (make-parameter #f))
|
||||
|
||||
(define (current-servlet-manager)
|
||||
(define servlet (thread-cell-ref current-servlet))
|
||||
(unless servlet
|
||||
(raise (make-exn:fail:servlet:instance "No current servlet" (current-continuation-marks))))
|
||||
(servlet-manager servlet))
|
||||
|
||||
(define (current-servlet-instance-data)
|
||||
(define manager (current-servlet-manager))
|
||||
(define instance-id (thread-cell-ref current-servlet-instance-id))
|
||||
((manager-instance-lookup-data manager) instance-id))
|
||||
(servlet-manager (current-servlet)))
|
||||
|
||||
(provide/contract
|
||||
[struct (exn:fail:servlet:instance exn:fail)
|
||||
|
|
@ -43,12 +32,8 @@
|
|||
[struct servlet-instance-data
|
||||
([mutex semaphore?])]
|
||||
[struct execution-context
|
||||
([connection connection?]
|
||||
[request request?]
|
||||
[suspend procedure?])]
|
||||
[current-servlet thread-cell?]
|
||||
[current-servlet-instance-id thread-cell?]
|
||||
[current-execution-context thread-cell?]
|
||||
[get-current-servlet-instance-id (-> number?)]
|
||||
[current-servlet-manager (-> manager?)]
|
||||
[current-servlet-instance-data (-> servlet-instance-data?)]))
|
||||
([request request?])]
|
||||
[current-servlet parameter?]
|
||||
[current-servlet-instance-id parameter?]
|
||||
[current-execution-context parameter?]
|
||||
[current-servlet-manager (-> manager?)]))
|
||||
|
|
@ -108,17 +108,16 @@
|
|||
;; adjust-timeout! : sec -> void
|
||||
;; adjust the timeout on the servlet
|
||||
(define (adjust-timeout! secs)
|
||||
((manager-adjust-timeout! (current-servlet-manager)) (get-current-servlet-instance-id) secs))
|
||||
((manager-adjust-timeout! (current-servlet-manager)) (current-servlet-instance-id) secs))
|
||||
|
||||
;; ext:clear-continuations! -> void
|
||||
(define (clear-continuation-table!)
|
||||
((manager-clear-continuations! (current-servlet-manager)) (get-current-servlet-instance-id)))
|
||||
((manager-clear-continuations! (current-servlet-manager)) (current-servlet-instance-id)))
|
||||
|
||||
;; send/back: response -> void
|
||||
;; send a response and don't clear the continuation table
|
||||
(define (send/back resp)
|
||||
(define ctxt (thread-cell-ref current-execution-context))
|
||||
((execution-context-suspend ctxt) resp))
|
||||
(abort-current-continuation servlet-prompt (lambda () resp)))
|
||||
|
||||
;; send/finish: response -> void
|
||||
;; send a response and clear the continuation table
|
||||
|
|
@ -128,6 +127,7 @@
|
|||
; we cannot wait for send/back to return, because it doesn't
|
||||
; Also, we cannot get the initial-connection-timeout variable from here
|
||||
; In the future, we should use the servlet's specific default-timeout
|
||||
; XXX
|
||||
(adjust-timeout! 10)
|
||||
(send/back resp))
|
||||
|
||||
|
|
@ -136,9 +136,10 @@
|
|||
(define send/suspend
|
||||
(opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)])
|
||||
(with-frame-after
|
||||
(let/cc k
|
||||
(define instance-id (get-current-servlet-instance-id))
|
||||
(define ctxt (thread-cell-ref current-execution-context))
|
||||
(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)
|
||||
|
|
@ -147,7 +148,8 @@
|
|||
(embed-ids
|
||||
(list* instance-id k-embedding)
|
||||
(request-uri (execution-context-request ctxt)))))
|
||||
(send/back (response-generator k-url))))))
|
||||
(send/back (response-generator k-url)))
|
||||
servlet-prompt))))
|
||||
|
||||
;; send/forward: (url -> response) [(request -> response)] -> request
|
||||
;; clear the continuation table, then behave like send/suspend
|
||||
|
|
@ -164,13 +166,15 @@
|
|||
; 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
|
||||
(let/cc k0
|
||||
(call-with-current-continuation
|
||||
(lambda (k0)
|
||||
(send/back
|
||||
(response-generator
|
||||
(opt-lambda (proc [expiration-handler (current-servlet-continuation-expiration-handler)])
|
||||
(let/ec k1
|
||||
(let ([new-request (send/suspend k1 expiration-handler)])
|
||||
(k0 (lambda () (proc new-request)))))))))])
|
||||
(k0 (lambda () (proc new-request)))))))))
|
||||
servlet-prompt)])
|
||||
(thunk)))
|
||||
|
||||
;; send/suspend/callback : xexpr/callback? -> void
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user