From 72ec6342ea127883fd63cf2827de0ca8ecaeff99 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 13 Jun 2007 01:01:55 +0000 Subject: [PATCH] Using delimited continuations to remove some effects svn: r6617 --- .../dispatchers/dispatch-servlets.ss | 212 +++++++----------- collects/web-server/managers/manager.ss | 2 +- collects/web-server/private/servlet.ss | 47 ++-- collects/web-server/servlet/web.ss | 50 +++-- 4 files changed, 123 insertions(+), 188 deletions(-) diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index a6ff69a138..f2fb6dfce9 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -31,7 +31,7 @@ (gen-servlet-responder "servlet-error.html")] [timeouts-servlet-connection (* 60 60 24)] [timeouts-default-servlet 30]) - + ;; servlet-content-producer: connection request -> void (define (servlet-content-producer conn req) (define meth (request-method req)) @@ -41,6 +41,7 @@ (adjust-connection-timeout! conn timeouts-servlet-connection) + ; XXX Allow servlet to respond (case meth [(head) (output-response/method @@ -62,97 +63,64 @@ ;; 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 response - (let/cc suspend - ; 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 (get-servlet-base-dir 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)) - (thread-cell-set! current-servlet the-servlet) - (parameterize ([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) - ((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))) + (define servlet-mutex (make-semaphore 1)) + (define response + (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)) + (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 (get-servlet-base-dir servlet-path)] + [current-custodian instance-custodian] + [exit-handler + (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)) + (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) (make-servlet-instance-data servlet-mutex) (exit-handler))) + ; XXX Locking is broken + ((manager-instance-lock! manager) instance-id) + (parameterize ([current-servlet-instance-id instance-id] + [exit-handler (lambda (v) + ((manager-instance-unlock! manager) instance-id) + (exit v))]) + (begin0 (with-handlers ([(lambda (x) #t) + (make-servlet-exception-handler)]) + ((servlet-handler the-servlet) req)) + ((manager-instance-unlock! manager) instance-id)))))))) + 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) - the-exn)) - ((execution-context-suspend context) resp)) + (responders-servlet + (request-uri (execution-context-request (current-execution-context))) + the-exn)) ;; 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)]) - (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-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: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)) + (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) + ((exn:fail:servlet-manager:no-instance-expiration-handler the-exn) req))] + [exn:fail:servlet-manager:no-continuation? + (lambda (the-exn) + ((exn:fail:servlet-manager:no-continuation-expiration-handler the-exn) req))] + [exn:fail:servlet:instance? + (lambda (the-exn) + (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 diff --git a/collects/web-server/managers/manager.ss b/collects/web-server/managers/manager.ss index 57f4a0c7f3..ca60addead 100644 --- a/collects/web-server/managers/manager.ss +++ b/collects/web-server/managers/manager.ss @@ -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)] diff --git a/collects/web-server/private/servlet.ss b/collects/web-server/private/servlet.ss index c7b823c485..7b09b10cc3 100644 --- a/collects/web-server/private/servlet.ss +++ b/collects/web-server/private/servlet.ss @@ -5,32 +5,21 @@ "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 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-struct servlet-instance-data (mutex)) + (define-struct execution-context (request)) + (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) ([message string?] @@ -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?)])) \ No newline at end of file + ([request request?])] + [current-servlet parameter?] + [current-servlet-instance-id parameter?] + [current-execution-context parameter?] + [current-servlet-manager (-> manager?)])) \ No newline at end of file diff --git a/collects/web-server/servlet/web.ss b/collects/web-server/servlet/web.ss index 8a18e76af6..0c5b187421 100644 --- a/collects/web-server/servlet/web.ss +++ b/collects/web-server/servlet/web.ss @@ -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,18 +136,20 @@ (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)) - (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)))))) + (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)))) ;; 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 - (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)))))))))]) + (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))))))))) + servlet-prompt)]) (thunk))) ;; send/suspend/callback : xexpr/callback? -> void