suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Using delimited continuations to remove some effects

Browse Source 
svn: r6617
This commit is contained in:
Jay McCarthy 2007-06-13 01:01:55 +00:00
parent 20220e60b6
commit 72ec6342ea
4 changed files with 123 additions and 188 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

212
collects/web-server/dispatchers/dispatch-servlets.ss
View File

@ -31,7 +31,7 @@
(gen-servlet-responder "servlet-error.html")] (gen-servlet-responder "servlet-error.html")]
[timeouts-servlet-connection (* 60 60 24)] [timeouts-servlet-connection (* 60 60 24)]
[timeouts-default-servlet 30]) [timeouts-default-servlet 30])
;; servlet-content-producer: connection request -> void ;; servlet-content-producer: connection request -> void
(define (servlet-content-producer conn req) (define (servlet-content-producer conn req)
(define meth (request-method req)) (define meth (request-method req))
@ -41,6 +41,7 @@
(adjust-connection-timeout! (adjust-connection-timeout!
conn conn
timeouts-servlet-connection) timeouts-servlet-connection)
; XXX Allow servlet to respond
(case meth (case meth
[(head) [(head)
(output-response/method (output-response/method
@ -62,97 +63,64 @@
;; This is not a continuation url so the loading behavior is determined ;; 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 ;; by the url path. Build the servlet path and then load the servlet
(define (servlet-content-producer/path conn req uri) (define (servlet-content-producer/path conn req uri)
(with-handlers (;; couldn't find the servlet (define servlet-mutex (make-semaphore 1))
[exn:fail:filesystem:exists:servlet? (define response
(lambda (the-exn) (with-handlers ([exn:fail:filesystem:exists:servlet?
(next-dispatcher))] (lambda (the-exn) (next-dispatcher))]
;; servlet won't load (e.g. syntax error) [(lambda (x) #t)
[(lambda (x) #t) (lambda (the-exn) (responders-servlet-loading uri the-exn))])
(lambda (the-exn) (call-with-semaphore
(output-response/method conn (responders-servlet-loading uri the-exn) (request-method req)))]) servlet-mutex
(define servlet-mutex (make-semaphore 0)) (lambda ()
(define response (call-with-continuation-prompt
(let/cc suspend (lambda ()
; Create the session frame ; Create the session frame
(with-frame (with-frame
(define instance-custodian (make-servlet-custodian)) (define instance-custodian (make-servlet-custodian))
(define-values (servlet-path _) (define-values (servlet-path _)
(with-handlers (with-handlers
([void (lambda (e) ([void (lambda (e)
(raise (make-exn:fail:filesystem:exists:servlet (raise (make-exn:fail:filesystem:exists:servlet
(exn-message e) (exn-message e)
(exn-continuation-marks e))))]) (exn-continuation-marks e))))])
(url->path uri))) (url->path uri)))
(parameterize ([current-directory (get-servlet-base-dir servlet-path)] (parameterize ([current-directory (get-servlet-base-dir servlet-path)]
[current-custodian instance-custodian] [current-custodian instance-custodian]
[exit-handler [exit-handler
(lambda _ (lambda (v)
(kill-connection! conn) (kill-connection! conn)
(custodian-shutdown-all instance-custodian))]) (custodian-shutdown-all instance-custodian))])
;; any resources (e.g. threads) created when the ;; any resources (e.g. threads) created when the
;; servlet is loaded should be within the dynamic ;; servlet is loaded should be within the dynamic
;; extent of the servlet custodian ;; extent of the servlet custodian
(define the-servlet (cached-load servlet-path)) (define the-servlet (cached-load servlet-path))
(thread-cell-set! current-servlet the-servlet) (parameterize ([current-servlet the-servlet]
(parameterize ([current-namespace (servlet-namespace the-servlet)]) [current-namespace (servlet-namespace the-servlet)])
(define manager (servlet-manager the-servlet)) (define manager (servlet-manager the-servlet))
(define ctxt (parameterize ([current-execution-context (make-execution-context req)])
(make-execution-context (define instance-id ((manager-create-instance manager) (make-servlet-instance-data servlet-mutex) (exit-handler)))
conn req suspend)) ; XXX Locking is broken
(define data ((manager-instance-lock! manager) instance-id)
(make-servlet-instance-data (parameterize ([current-servlet-instance-id instance-id]
servlet-mutex)) [exit-handler (lambda (v)
(define the-exit-handler ((manager-instance-unlock! manager) instance-id)
(lambda _ (exit v))])
(define ectxt (begin0 (with-handlers ([(lambda (x) #t)
(thread-cell-ref current-execution-context)) (make-servlet-exception-handler)])
(when ectxt ((servlet-handler the-servlet) req))
(kill-connection! ((manager-instance-unlock! manager) instance-id))))))))
(execution-context-connection ectxt))) servlet-prompt)))))
(custodian-shutdown-all instance-custodian))) (output-response conn response))
(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)
((manager-instance-lock! manager) instance-id)
(parameterize ([exit-handler (lambda x
((manager-instance-unlock! manager) instance-id)
(the-exit-handler x))])
(with-handlers ([(lambda (x) #t)
(make-servlet-exception-handler)])
(send/back ((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)))
;; default-server-instance-expiration-handler : (request -> response) ;; default-server-instance-expiration-handler : (request -> response)
(define (default-servlet-instance-expiration-handler req) (define (default-servlet-instance-expiration-handler req)
(next-dispatcher)) (next-dispatcher))
;; make-servlet-exception-handler: servlet-instance -> exn -> void ;; 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 ((make-servlet-exception-handler) the-exn)
(define context (thread-cell-ref current-execution-context)) (responders-servlet
(define request (execution-context-request context)) (request-uri (execution-context-request (current-execution-context)))
(define resp the-exn))
(responders-servlet
(request-uri request)
the-exn))
((execution-context-suspend context) resp))
;; path -> path ;; path -> path
;; The actual servlet's parent directory. ;; The actual servlet's parent directory.
@ -164,59 +132,37 @@
(and (directory-exists? base) base)) (and (directory-exists? base) base))
(loop 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 (invoke-servlet-continuation conn req instance-id k-id salt)
(define uri (request-uri req)) (define uri (request-uri req))
(define-values (servlet-path _) (url->path uri)) (define-values (servlet-path _) (url->path uri))
(define the-servlet (cached-load servlet-path)) (define the-servlet (cached-load servlet-path))
(define manager (servlet-manager the-servlet)) (define manager (servlet-manager the-servlet))
(thread-cell-set! current-servlet the-servlet) (define data ((manager-instance-lookup-data manager) instance-id))
(thread-cell-set! current-servlet-instance-id instance-id) (define _v ((manager-instance-lock! manager) instance-id))
(parameterize ([current-custodian (servlet-custodian the-servlet)]) (define response
(with-handlers ([exn:fail:servlet-manager:no-instance? (parameterize ([current-servlet the-servlet]
(lambda (the-exn) [current-servlet-instance-id instance-id]
(output-response/method [current-custodian (servlet-custodian the-servlet)])
conn (with-handlers ([exn:fail:servlet-manager:no-instance?
((exn:fail:servlet-manager:no-instance-expiration-handler the-exn) (lambda (the-exn)
req) ((exn:fail:servlet-manager:no-instance-expiration-handler the-exn) req))]
(request-method req)))] [exn:fail:servlet-manager:no-continuation?
[exn:fail:servlet-manager:no-continuation? (lambda (the-exn)
(lambda (the-exn) ((exn:fail:servlet-manager:no-continuation-expiration-handler the-exn) req))]
(output-response/method [exn:fail:servlet:instance?
conn (lambda (the-exn)
((exn:fail:servlet-manager:no-continuation-expiration-handler the-exn) (default-servlet-instance-expiration-handler req))])
req) (call-with-semaphore
(request-method req)))] (servlet-instance-data-mutex data)
[exn:fail:servlet:instance? (lambda ()
(lambda (the-exn) (parameterize ([current-execution-context (make-execution-context req)])
(output-response/method (call-with-continuation-prompt
conn (lambda ()
(default-servlet-instance-expiration-handler (define kcb ((manager-continuation-lookup manager) instance-id k-id salt))
req) ((custodian-box-value kcb) req))
(request-method req)))]) servlet-prompt)))))))
(define data ((manager-instance-lookup-data manager) instance-id)) (output-response conn response)
((manager-instance-lock! manager) instance-id) ((manager-instance-unlock! 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))
;; cached-load : path -> script, namespace ;; cached-load : path -> script, namespace
;; timestamps are no longer checked for performance. The cache must be explicitly ;; timestamps are no longer checked for performance. The cache must be explicitly

2
collects/web-server/managers/manager.ss
View File

@ -15,7 +15,7 @@
(define-struct (exn:fail:servlet-manager:no-continuation exn:fail) (expiration-handler)) (define-struct (exn:fail:servlet-manager:no-continuation exn:fail) (expiration-handler))
(provide/contract (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)] [adjust-timeout! (number? number? . -> . void)]
[instance-lookup-data (number? . -> . any/c)] [instance-lookup-data (number? . -> . any/c)]
[instance-lock! (number? . -> . void)] [instance-lock! (number? . -> . void)]

47
collects/web-server/private/servlet.ss
View File

@ -5,32 +5,21 @@
"connection-manager.ss" "connection-manager.ss"
"../private/request-structs.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 (exn:fail:servlet:instance exn:fail) ())
(define-struct servlet (custodian namespace manager handler)) (define-struct servlet (custodian namespace manager handler))
(define-struct servlet-instance-data (mutex)) (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 (current-servlet-manager)
(define servlet (thread-cell-ref current-servlet)) (servlet-manager (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))
(provide/contract (provide/contract
[struct (exn:fail:servlet:instance exn:fail) [struct (exn:fail:servlet:instance exn:fail)
([message string?] ([message string?]
@ -43,12 +32,8 @@
[struct servlet-instance-data [struct servlet-instance-data
([mutex semaphore?])] ([mutex semaphore?])]
[struct execution-context [struct execution-context
([connection connection?] ([request request?])]
[request request?] [current-servlet parameter?]
[suspend procedure?])] [current-servlet-instance-id parameter?]
[current-servlet thread-cell?] [current-execution-context parameter?]
[current-servlet-instance-id thread-cell?] [current-servlet-manager (-> manager?)]))
[current-execution-context thread-cell?]
[get-current-servlet-instance-id (-> number?)]
[current-servlet-manager (-> manager?)]
[current-servlet-instance-data (-> servlet-instance-data?)]))

50
collects/web-server/servlet/web.ss
View File

@ -108,17 +108,16 @@
;; adjust-timeout! : sec -> void ;; adjust-timeout! : sec -> void
;; adjust the timeout on the servlet ;; adjust the timeout on the servlet
(define (adjust-timeout! secs) (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 ;; ext:clear-continuations! -> void
(define (clear-continuation-table!) (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/back: response -> void
;; send a response and don't clear the continuation table ;; send a response and don't clear the continuation table
(define (send/back resp) (define (send/back resp)
(define ctxt (thread-cell-ref current-execution-context)) (abort-current-continuation servlet-prompt (lambda () resp)))
((execution-context-suspend ctxt) resp))
;; send/finish: response -> void ;; send/finish: response -> void
;; send a response and clear the continuation table ;; send a response and clear the continuation table
@ -128,6 +127,7 @@
; we cannot wait for send/back to return, because it doesn't ; we cannot wait for send/back to return, because it doesn't
; Also, we cannot get the initial-connection-timeout variable from here ; Also, we cannot get the initial-connection-timeout variable from here
; In the future, we should use the servlet's specific default-timeout ; In the future, we should use the servlet's specific default-timeout
; XXX
(adjust-timeout! 10) (adjust-timeout! 10)
(send/back resp)) (send/back resp))
@ -136,18 +136,20 @@
(define send/suspend (define send/suspend
(opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)]) (opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)])
(with-frame-after (with-frame-after
(let/cc k (call-with-composable-continuation
(define instance-id (get-current-servlet-instance-id)) (lambda (k)
(define ctxt (thread-cell-ref current-execution-context)) (define instance-id (current-servlet-instance-id))
(define k-embedding ((manager-continuation-store! (current-servlet-manager)) (define ctxt (current-execution-context))
instance-id (define k-embedding ((manager-continuation-store! (current-servlet-manager))
(make-custodian-box (current-custodian) k) instance-id
expiration-handler)) (make-custodian-box (current-custodian) k)
(define k-url ((current-url-transform) expiration-handler))
(embed-ids (define k-url ((current-url-transform)
(list* instance-id k-embedding) (embed-ids
(request-uri (execution-context-request ctxt))))) (list* instance-id k-embedding)
(send/back (response-generator k-url)))))) (request-uri (execution-context-request ctxt)))))
(send/back (response-generator k-url)))
servlet-prompt))))
;; send/forward: (url -> response) [(request -> response)] -> request ;; send/forward: (url -> response) [(request -> response)] -> request
;; clear the continuation table, then behave like send/suspend ;; 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. ; 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.) ; (Moving this to the tail-position is not possible anyway, by the way.)
(let ([thunk (let ([thunk
(let/cc k0 (call-with-current-continuation
(send/back (lambda (k0)
(response-generator (send/back
(opt-lambda (proc [expiration-handler (current-servlet-continuation-expiration-handler)]) (response-generator
(let/ec k1 (opt-lambda (proc [expiration-handler (current-servlet-continuation-expiration-handler)])
(let ([new-request (send/suspend k1 expiration-handler)]) (let/ec k1
(k0 (lambda () (proc new-request)))))))))]) (let ([new-request (send/suspend k1 expiration-handler)])
(k0 (lambda () (proc new-request)))))))))
servlet-prompt)])
(thunk))) (thunk)))
;; send/suspend/callback : xexpr/callback? -> void ;; send/suspend/callback : xexpr/callback? -> void