diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index 76609ddf4d..9b2dea26ae 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -15,6 +15,7 @@ "../managers/manager.ss" "../managers/timeouts.ss" "../managers/lru.ss" + "../managers/none.ss" "../private/url.ss" "../private/servlet.ss" "../private/cache-table.ss") @@ -76,69 +77,71 @@ (lambda (the-exn) (output-response/method conn (responders-servlet-loading uri the-exn) (request-method req)))]) (define servlet-mutex (make-semaphore 0)) - (define last-servlet (thread-cell-ref current-servlet)) - (define last-servlet-instance-id (thread-cell-ref current-servlet-instance-id)) - (let/cc suspend - ; Create the session frame - (with-frame - (define instance-custodian (make-servlet-custodian)) - (define servlet-path - (with-handlers - ([void (lambda (e) - (raise (make-exn:fail:filesystem:exists:servlet - (exn-message e) - (exn-continuation-marks e))))]) - (url-path->path - servlet-root - (url-path->string (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 data - (make-servlet-instance-data - servlet-mutex - (make-execution-context - conn req (lambda () (suspend #t))))) - (define the-exit-handler - (lambda _ - (kill-connection! - (execution-context-connection - (servlet-instance-data-context - data))) - (custodian-shutdown-all instance-custodian))) - (parameterize ([exit-handler the-exit-handler]) - (define instance-id ((manager-create-instance manager) data the-exit-handler)) - (parameterize ([exit-handler (lambda x - ((manager-instance-unlock! manager) instance-id) - (the-exit-handler x))]) - (thread-cell-set! current-servlet-instance-id instance-id) - ((manager-instance-lock! manager) instance-id) - (with-handlers ([(lambda (x) #t) - (make-servlet-exception-handler data)]) - ;; Two possibilities: - ;; - module servlet. start : Request -> Void handles - ;; output-response via send/finish, etc. - ;; - unit/sig or simple xexpr servlet. These must produce a - ;; response, which is then output by the server. - ;; Here, we do not know if the servlet was a module, - ;; unit/sig, or Xexpr; we do know whether it produces a - ;; response. - (define r ((servlet-handler the-servlet) req)) - (when (response? r) - (send/back r))) - ((manager-instance-unlock! manager) instance-id))))))) - (thread-cell-set! current-servlet last-servlet) - (thread-cell-set! current-servlet-instance-id last-servlet-instance-id) + (define response + (let/cc suspend + ; Create the session frame + (with-frame + (define instance-custodian (make-servlet-custodian)) + (define servlet-path + (with-handlers + ([void (lambda (e) + (raise (make-exn:fail:filesystem:exists:servlet + (exn-message e) + (exn-continuation-marks e))))]) + (url-path->path + servlet-root + (url-path->string (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 _ + (kill-connection! + (execution-context-connection + (thread-cell-ref current-execution-context))) + (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)) + (parameterize ([exit-handler (lambda x + ((manager-instance-unlock! manager) instance-id) + (the-exit-handler x))]) + (thread-cell-set! current-servlet-instance-id instance-id) + ((manager-instance-lock! manager) instance-id) + (with-handlers ([(lambda (x) #t) + (make-servlet-exception-handler data)]) + ;; Two possibilities: + ;; - module servlet. start : Request -> Void handles + ;; output-response via send/finish, etc. + ;; - unit/sig or simple xexpr servlet. These must produce a + ;; response, which is then output by the server. + ;; Here, we do not know if the servlet was a module, + ;; unit/sig, or Xexpr; we do know whether it produces a + ;; response. + (define r ((servlet-handler the-servlet) req)) + (when (response? r) + (send/back r))) + ((manager-instance-unlock! manager) instance-id)))))))) + (output-response conn response) + (thread-cell-set! current-execution-context #f) + (thread-cell-set! current-servlet #f) + (thread-cell-set! current-servlet-instance-id #f) (semaphore-post servlet-mutex))) ;; default-server-instance-expiration-handler : (request -> response) @@ -160,18 +163,13 @@ ;; requests won't be blocked. ;; * This fixes PR# 7066 (define ((make-servlet-exception-handler inst-data) the-exn) - (define context (servlet-instance-data-context inst-data)) + (define context (thread-cell-ref current-execution-context)) (define request (execution-context-request context)) (define resp (responders-servlet (request-uri request) the-exn)) - ;; Don't handle twice - (with-handlers ([exn:fail? (lambda (exn) (void))]) - (output-response/method - (execution-context-connection context) - resp (request-method request))) - ((execution-context-suspend context))) + ((execution-context-suspend context) resp)) ;; path -> path ;; The actual servlet's parent directory. @@ -191,8 +189,6 @@ (url-path->path servlet-root (url-path->string (url-path uri)))) - (define last-servlet (thread-cell-ref current-servlet)) - (define last-servlet-instance-id (thread-cell-ref current-servlet-instance-id)) (define the-servlet (cached-load servlet-path)) (define manager (servlet-manager the-servlet)) (thread-cell-set! current-servlet the-servlet) @@ -225,17 +221,18 @@ ; always call a continuation. The exit-handler above ensures that ; the post is done. (semaphore-wait (servlet-instance-data-mutex data)) - (let/cc suspend - (define k ((manager-continuation-lookup manager) instance-id k-id salt)) - (set-servlet-instance-data-context! - data - (make-execution-context - conn req (lambda () (suspend #t)))) - (k req)) + (let ([response + (let/cc suspend + (define k ((manager-continuation-lookup manager) instance-id k-id salt)) + (thread-cell-set! current-execution-context + (make-execution-context + conn req suspend)) + (k req))]) + (output-response conn response)) (semaphore-post (servlet-instance-data-mutex data)))) ((manager-instance-unlock! manager) instance-id) - (thread-cell-set! current-servlet-instance-id last-servlet-instance-id) - (thread-cell-set! current-servlet last-servlet)) + (thread-cell-set! current-servlet-instance-id #f) + (thread-cell-set! current-servlet #f)) ;; ************************************************************ ;; ************************************************************ @@ -281,11 +278,13 @@ (lambda (initial-request) (invoke-unit/sig servlet servlet^))) (define (v0.response->v1.lambda response-path response) - (letrec ([go (lambda () - (begin - (set! go (lambda () (load/use-compiled a-path))) - response))]) - (lambda (initial-request) (go)))) + (define go + (box + (lambda () + (set-box! go (lambda () (load/use-compiled a-path))) + response))) + (lambda (initial-request) + ((unbox go)))) (define (v1.module->v1.lambda timeout start) (lambda (initial-request) (adjust-timeout! timeout) diff --git a/collects/web-server/private/servlet.ss b/collects/web-server/private/servlet.ss index 5fe2842acc..42091b8a9f 100644 --- a/collects/web-server/private/servlet.ss +++ b/collects/web-server/private/servlet.ss @@ -7,11 +7,12 @@ (define-struct (exn:fail:servlet:instance exn:fail) ()) (define-struct servlet (custodian namespace manager handler)) - (define-struct servlet-instance-data (mutex context)) + (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)) @@ -40,8 +41,7 @@ [manager manager?] [handler (request? . -> . servlet-response?)])] [struct servlet-instance-data - ([mutex semaphore?] - [context execution-context?])] + ([mutex semaphore?])] [struct execution-context ([connection connection?] [request request?] @@ -50,6 +50,8 @@ [current-servlet thread-cell?] ; XXX contract maybe [current-servlet-instance-id thread-cell?] + ; XXX contract maybe + [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 diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 4e4ee37cad..cc63dea01b 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -35,7 +35,6 @@ (lambda (initial-request) (let ([v (servlet-expr initial-request)]) (set! final-value v) - ;(set! final-conn (execution-context-connection (servlet-instance-context (current-servlet-instance)))) (semaphore-post sema) (if (response? v) v diff --git a/collects/web-server/servlet.ss b/collects/web-server/servlet.ss index ea72b2a768..7704644edc 100644 --- a/collects/web-server/servlet.ss +++ b/collects/web-server/servlet.ss @@ -2,8 +2,7 @@ (require (lib "contract.ss") (lib "etc.ss") (lib "xml.ss" "xml")) - (require "response.ss" - "managers/manager.ss" + (require "managers/manager.ss" "private/servlet.ss" "private/url.ss" "servlet-helpers.ss" @@ -71,9 +70,8 @@ ;; send/back: response -> void ;; send a response and don't clear the continuation table (define (send/back resp) - (define ctxt (servlet-instance-data-context (current-servlet-instance-data))) - (output-response (execution-context-connection ctxt) resp) - ((execution-context-suspend ctxt))) + (define ctxt (thread-cell-ref current-execution-context)) + ((execution-context-suspend ctxt) resp)) ;; send/finish: response -> void ;; send a response and clear the continuation table @@ -93,15 +91,13 @@ (with-frame-after (let/cc k (define instance-id (get-current-servlet-instance-id)) - (define ctxt (servlet-instance-data-context (current-servlet-instance-data))) + (define ctxt (thread-cell-ref current-execution-context)) (define k-embedding ((manager-continuation-store! (current-servlet-manager)) instance-id k expiration-handler)) (define k-url ((current-url-transform) (embed-ids (list* instance-id k-embedding) (request-uri (execution-context-request ctxt))))) - (define response (response-generator k-url)) - (output-response (execution-context-connection ctxt) response) - ((execution-context-suspend ctxt)))))) + (send/back (response-generator k-url)))))) ;; send/forward: (url -> response) [(request -> response)] -> request ;; clear the continuation table, then behave like send/suspend diff --git a/collects/web-server/tools/backend.ss b/collects/web-server/tools/backend.ss index 1eeadb2848..953be7aa99 100644 --- a/collects/web-server/tools/backend.ss +++ b/collects/web-server/tools/backend.ss @@ -3,24 +3,25 @@ (lib "timer.ss" "web-server") (lib "response.ss" "web-server") (lib "connection-manager.ss" "web-server")) - + (provide start-servlet resume-servlet) - + ;; make-servlet-custodian: -> custodian (define make-servlet-custodian (let ([cust (current-custodian)]) (lambda () (make-custodian cust)))) - + ;; start-servlet: connection request hash-table number (number->void request -> response) -> void ;; start a new instance of a servlet (define (start-servlet conn req instance-table instance-timeout svt) - (let ([sema (make-semaphore 0)]) + (define sema (make-semaphore 0)) + (define response (let/cc suspend (let* ([servlet-custodian (make-servlet-custodian)] [inst (create-new-instance! instance-table servlet-custodian (make-execution-context - conn req (lambda () (suspend #t))) + conn req suspend) sema)] [servlet-exit-handler (make-servlet-exit-handler inst instance-table)] [time-bomb (start-timer instance-timeout @@ -34,9 +35,10 @@ (reset-timer! time-bomb secs)) req)]) (when (response? r) - (send/back r))))))) - (semaphore-post sema))) - + (send/back r)))))))) + (output-respose conn response) + (semaphore-post sema)) + ;; make-servlet-exit-handler: servlet-instance -> alpha -> void ;; exit handler for a servlet (define (make-servlet-exit-handler inst instance-table) @@ -46,7 +48,7 @@ (execution-context-connection (servlet-instance-context inst))) (custodian-shutdown-all (servlet-instance-custodian inst)))) - + ;; make-servlet-exception-handler: host -> exn -> void ;; This exception handler traps all unhandled servlet exceptions (define (make-servlet-exception-handler inst) @@ -61,27 +63,29 @@ (p ,(exn-message the-exn)))) (request-method req)) ((execution-context-suspend ctxt))))) - + ;; resume-servlet: connection request continuation-reference hash-table -> void ;; pull the continuation out of the table and apply it (define (resume-servlet conn req k-ref instance-table) - (let* ([inst (hash-table-get instance-table (car k-ref) + (define inst (hash-table-get instance-table (car k-ref) (lambda () (raise (make-exn:servlet:instance - "" (current-continuation-marks)))))] - [k-table - (servlet-instance-k-table inst)]) + "" (current-continuation-marks)))))) + (define k-table + (servlet-instance-k-table inst)) + (define response (let/cc suspend (set-servlet-instance-context! inst (make-execution-context - conn req (lambda () (suspend #t)))) + conn req suspend)) (semaphore-wait (servlet-instance-mutex inst)) ((hash-table-get k-table (cadr k-ref) (lambda () (raise (make-exn:servlet:continuation "" (current-continuation-marks))))) - req)) - (semaphore-post (servlet-instance-mutex inst))))) \ No newline at end of file + req))) + (output-response conn response) + (semaphore-post (servlet-instance-mutex inst)))) \ No newline at end of file