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

thread specific execution context

Browse Source 
svn: r3983
This commit is contained in:
Jay McCarthy 2006-08-08 01:05:35 +00:00
parent 8b60b3202c
commit 27e7ddad4f
5 changed files with 116 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -15,6 +15,7 @@
"../managers/manager.ss" "../managers/manager.ss"
"../managers/timeouts.ss" "../managers/timeouts.ss"
"../managers/lru.ss" "../managers/lru.ss"
"../managers/none.ss"
"../private/url.ss" "../private/url.ss"
"../private/servlet.ss" "../private/servlet.ss"
"../private/cache-table.ss") "../private/cache-table.ss")
@ -76,69 +77,71 @@
(lambda (the-exn) (lambda (the-exn)
(output-response/method conn (responders-servlet-loading uri the-exn) (request-method req)))]) (output-response/method conn (responders-servlet-loading uri the-exn) (request-method req)))])
(define servlet-mutex (make-semaphore 0)) (define servlet-mutex (make-semaphore 0))
(define last-servlet (thread-cell-ref current-servlet)) (define response
(define last-servlet-instance-id (thread-cell-ref current-servlet-instance-id)) (let/cc suspend
(let/cc suspend ; 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 servlet-path
(define 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->path
(url-path->path servlet-root
servlet-root (url-path->string (url-path uri)))))
(url-path->string (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 _ (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)
(thread-cell-set! current-servlet the-servlet) (parameterize ([current-namespace (servlet-namespace the-servlet)])
(parameterize ([current-namespace (servlet-namespace the-servlet)]) (define manager (servlet-manager the-servlet))
(define manager (servlet-manager the-servlet)) (define ctxt
(define data (make-execution-context
(make-servlet-instance-data conn req suspend))
servlet-mutex (define data
(make-execution-context (make-servlet-instance-data
conn req (lambda () (suspend #t))))) servlet-mutex))
(define the-exit-handler (define the-exit-handler
(lambda _ (lambda _
(kill-connection! (kill-connection!
(execution-context-connection (execution-context-connection
(servlet-instance-data-context (thread-cell-ref current-execution-context)))
data))) (custodian-shutdown-all instance-custodian)))
(custodian-shutdown-all instance-custodian))) (thread-cell-set! current-execution-context ctxt)
(parameterize ([exit-handler the-exit-handler]) (parameterize ([exit-handler the-exit-handler])
(define instance-id ((manager-create-instance manager) data the-exit-handler)) (define instance-id ((manager-create-instance manager) data the-exit-handler))
(parameterize ([exit-handler (lambda x (parameterize ([exit-handler (lambda x
((manager-instance-unlock! manager) instance-id) ((manager-instance-unlock! manager) instance-id)
(the-exit-handler x))]) (the-exit-handler x))])
(thread-cell-set! current-servlet-instance-id instance-id) (thread-cell-set! current-servlet-instance-id instance-id)
((manager-instance-lock! manager) instance-id) ((manager-instance-lock! manager) instance-id)
(with-handlers ([(lambda (x) #t) (with-handlers ([(lambda (x) #t)
(make-servlet-exception-handler data)]) (make-servlet-exception-handler data)])
;; Two possibilities: ;; Two possibilities:
;; - module servlet. start : Request -> Void handles ;; - module servlet. start : Request -> Void handles
;; output-response via send/finish, etc. ;; output-response via send/finish, etc.
;; - unit/sig or simple xexpr servlet. These must produce a ;; - unit/sig or simple xexpr servlet. These must produce a
;; response, which is then output by the server. ;; response, which is then output by the server.
;; Here, we do not know if the servlet was a module, ;; Here, we do not know if the servlet was a module,
;; unit/sig, or Xexpr; we do know whether it produces a ;; unit/sig, or Xexpr; we do know whether it produces a
;; response. ;; response.
(define r ((servlet-handler the-servlet) req)) (define r ((servlet-handler the-servlet) req))
(when (response? r) (when (response? r)
(send/back r))) (send/back r)))
((manager-instance-unlock! manager) instance-id))))))) ((manager-instance-unlock! manager) instance-id))))))))
(thread-cell-set! current-servlet last-servlet) (output-response conn response)
(thread-cell-set! current-servlet-instance-id last-servlet-instance-id) (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))) (semaphore-post servlet-mutex)))
;; default-server-instance-expiration-handler : (request -> response) ;; default-server-instance-expiration-handler : (request -> response)
@ -160,18 +163,13 @@
;; requests won't be blocked. ;; requests won't be blocked.
;; * This fixes PR# 7066 ;; * This fixes PR# 7066
(define ((make-servlet-exception-handler inst-data) the-exn) (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 request (execution-context-request context))
(define resp (define resp
(responders-servlet (responders-servlet
(request-uri request) (request-uri request)
the-exn)) the-exn))
;; Don't handle twice ((execution-context-suspend context) resp))
(with-handlers ([exn:fail? (lambda (exn) (void))])
(output-response/method
(execution-context-connection context)
resp (request-method request)))
((execution-context-suspend context)))
;; path -> path ;; path -> path
;; The actual servlet's parent directory. ;; The actual servlet's parent directory.
@ -191,8 +189,6 @@
(url-path->path (url-path->path
servlet-root servlet-root
(url-path->string (url-path uri)))) (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 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) (thread-cell-set! current-servlet the-servlet)
@ -225,17 +221,18 @@
; always call a continuation. The exit-handler above ensures that ; always call a continuation. The exit-handler above ensures that
; the post is done. ; the post is done.
(semaphore-wait (servlet-instance-data-mutex data)) (semaphore-wait (servlet-instance-data-mutex data))
(let/cc suspend (let ([response
(define k ((manager-continuation-lookup manager) instance-id k-id salt)) (let/cc suspend
(set-servlet-instance-data-context! (define k ((manager-continuation-lookup manager) instance-id k-id salt))
data (thread-cell-set! current-execution-context
(make-execution-context (make-execution-context
conn req (lambda () (suspend #t)))) conn req suspend))
(k req)) (k req))])
(output-response conn response))
(semaphore-post (servlet-instance-data-mutex data)))) (semaphore-post (servlet-instance-data-mutex data))))
((manager-instance-unlock! manager) instance-id) ((manager-instance-unlock! manager) instance-id)
(thread-cell-set! current-servlet-instance-id last-servlet-instance-id) (thread-cell-set! current-servlet-instance-id #f)
(thread-cell-set! current-servlet last-servlet)) (thread-cell-set! current-servlet #f))
;; ************************************************************ ;; ************************************************************
;; ************************************************************ ;; ************************************************************
@ -281,11 +278,13 @@
(lambda (initial-request) (lambda (initial-request)
(invoke-unit/sig servlet servlet^))) (invoke-unit/sig servlet servlet^)))
(define (v0.response->v1.lambda response-path response) (define (v0.response->v1.lambda response-path response)
(letrec ([go (lambda () (define go
(begin (box
(set! go (lambda () (load/use-compiled a-path))) (lambda ()
response))]) (set-box! go (lambda () (load/use-compiled a-path)))
(lambda (initial-request) (go)))) response)))
(lambda (initial-request)
((unbox go))))
(define (v1.module->v1.lambda timeout start) (define (v1.module->v1.lambda timeout start)
(lambda (initial-request) (lambda (initial-request)
(adjust-timeout! timeout) (adjust-timeout! timeout)

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

@ -7,11 +7,12 @@
(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 context)) (define-struct servlet-instance-data (mutex))
(define-struct execution-context (connection request suspend)) (define-struct execution-context (connection request suspend))
(define current-servlet (make-thread-cell #f)) (define current-servlet (make-thread-cell #f))
(define current-servlet-instance-id (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 (get-current-servlet-instance-id)
(define instance-id (thread-cell-ref current-servlet-instance-id)) (define instance-id (thread-cell-ref current-servlet-instance-id))
@ -40,8 +41,7 @@
[manager manager?] [manager manager?]
[handler (request? . -> . servlet-response?)])] [handler (request? . -> . servlet-response?)])]
[struct servlet-instance-data [struct servlet-instance-data
([mutex semaphore?] ([mutex semaphore?])]
[context execution-context?])]
[struct execution-context [struct execution-context
([connection connection?] ([connection connection?]
[request request?] [request request?]
@ -50,6 +50,8 @@
[current-servlet thread-cell?] [current-servlet thread-cell?]
; XXX contract maybe ; XXX contract maybe
[current-servlet-instance-id thread-cell?] [current-servlet-instance-id thread-cell?]
; XXX contract maybe
[current-execution-context thread-cell?]
[get-current-servlet-instance-id (-> number?)] [get-current-servlet-instance-id (-> number?)]
[current-servlet-manager (-> manager?)] [current-servlet-manager (-> manager?)]
[current-servlet-instance-data (-> servlet-instance-data?)])) [current-servlet-instance-data (-> servlet-instance-data?)]))

1
collects/web-server/servlet-env.ss
View File

@ -35,7 +35,6 @@
(lambda (initial-request) (lambda (initial-request)
(let ([v (servlet-expr initial-request)]) (let ([v (servlet-expr initial-request)])
(set! final-value v) (set! final-value v)
;(set! final-conn (execution-context-connection (servlet-instance-context (current-servlet-instance))))
(semaphore-post sema) (semaphore-post sema)
(if (response? v) (if (response? v)
v v

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

@ -2,8 +2,7 @@
(require (lib "contract.ss") (require (lib "contract.ss")
(lib "etc.ss") (lib "etc.ss")
(lib "xml.ss" "xml")) (lib "xml.ss" "xml"))
(require "response.ss" (require "managers/manager.ss"
"managers/manager.ss"
"private/servlet.ss" "private/servlet.ss"
"private/url.ss" "private/url.ss"
"servlet-helpers.ss" "servlet-helpers.ss"
@ -71,9 +70,8 @@
;; 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 (servlet-instance-data-context (current-servlet-instance-data))) (define ctxt (thread-cell-ref current-execution-context))
(output-response (execution-context-connection ctxt) resp) ((execution-context-suspend ctxt) resp))
((execution-context-suspend ctxt)))
;; send/finish: response -> void ;; send/finish: response -> void
;; send a response and clear the continuation table ;; send a response and clear the continuation table
@ -93,15 +91,13 @@
(with-frame-after (with-frame-after
(let/cc k (let/cc k
(define instance-id (get-current-servlet-instance-id)) (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-embedding ((manager-continuation-store! (current-servlet-manager)) instance-id k expiration-handler))
(define k-url ((current-url-transform) (define k-url ((current-url-transform)
(embed-ids (embed-ids
(list* instance-id k-embedding) (list* instance-id k-embedding)
(request-uri (execution-context-request ctxt))))) (request-uri (execution-context-request ctxt)))))
(define response (response-generator k-url)) (send/back (response-generator k-url))))))
(output-response (execution-context-connection ctxt) response)
((execution-context-suspend ctxt))))))
;; 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

38
collects/web-server/tools/backend.ss
View File

@ -3,24 +3,25 @@
(lib "timer.ss" "web-server") (lib "timer.ss" "web-server")
(lib "response.ss" "web-server") (lib "response.ss" "web-server")
(lib "connection-manager.ss" "web-server")) (lib "connection-manager.ss" "web-server"))
(provide start-servlet resume-servlet) (provide start-servlet resume-servlet)
;; make-servlet-custodian: -> custodian ;; make-servlet-custodian: -> custodian
(define make-servlet-custodian (define make-servlet-custodian
(let ([cust (current-custodian)]) (let ([cust (current-custodian)])
(lambda () (make-custodian cust)))) (lambda () (make-custodian cust))))
;; start-servlet: connection request hash-table number (number->void request -> response) -> void ;; start-servlet: connection request hash-table number (number->void request -> response) -> void
;; start a new instance of a servlet ;; start a new instance of a servlet
(define (start-servlet conn req instance-table instance-timeout svt) (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/cc suspend
(let* ([servlet-custodian (make-servlet-custodian)] (let* ([servlet-custodian (make-servlet-custodian)]
[inst (create-new-instance! [inst (create-new-instance!
instance-table servlet-custodian instance-table servlet-custodian
(make-execution-context (make-execution-context
conn req (lambda () (suspend #t))) conn req suspend)
sema)] sema)]
[servlet-exit-handler (make-servlet-exit-handler inst instance-table)] [servlet-exit-handler (make-servlet-exit-handler inst instance-table)]
[time-bomb (start-timer instance-timeout [time-bomb (start-timer instance-timeout
@ -34,9 +35,10 @@
(reset-timer! time-bomb secs)) (reset-timer! time-bomb secs))
req)]) req)])
(when (response? r) (when (response? r)
(send/back r))))))) (send/back r))))))))
(semaphore-post sema))) (output-respose conn response)
(semaphore-post sema))
;; make-servlet-exit-handler: servlet-instance -> alpha -> void ;; make-servlet-exit-handler: servlet-instance -> alpha -> void
;; exit handler for a servlet ;; exit handler for a servlet
(define (make-servlet-exit-handler inst instance-table) (define (make-servlet-exit-handler inst instance-table)
@ -46,7 +48,7 @@
(execution-context-connection (execution-context-connection
(servlet-instance-context inst))) (servlet-instance-context inst)))
(custodian-shutdown-all (servlet-instance-custodian inst)))) (custodian-shutdown-all (servlet-instance-custodian inst))))
;; make-servlet-exception-handler: host -> exn -> void ;; make-servlet-exception-handler: host -> exn -> void
;; This exception handler traps all unhandled servlet exceptions ;; This exception handler traps all unhandled servlet exceptions
(define (make-servlet-exception-handler inst) (define (make-servlet-exception-handler inst)
@ -61,27 +63,29 @@
(p ,(exn-message the-exn)))) (p ,(exn-message the-exn))))
(request-method req)) (request-method req))
((execution-context-suspend ctxt))))) ((execution-context-suspend ctxt)))))
;; resume-servlet: connection request continuation-reference hash-table -> void ;; resume-servlet: connection request continuation-reference hash-table -> void
;; pull the continuation out of the table and apply it ;; pull the continuation out of the table and apply it
(define (resume-servlet conn req k-ref instance-table) (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 () (lambda ()
(raise (raise
(make-exn:servlet:instance (make-exn:servlet:instance
"" (current-continuation-marks)))))] "" (current-continuation-marks))))))
[k-table (define k-table
(servlet-instance-k-table inst)]) (servlet-instance-k-table inst))
(define response
(let/cc suspend (let/cc suspend
(set-servlet-instance-context! (set-servlet-instance-context!
inst inst
(make-execution-context (make-execution-context
conn req (lambda () (suspend #t)))) conn req suspend))
(semaphore-wait (servlet-instance-mutex inst)) (semaphore-wait (servlet-instance-mutex inst))
((hash-table-get k-table (cadr k-ref) ((hash-table-get k-table (cadr k-ref)
(lambda () (lambda ()
(raise (raise
(make-exn:servlet:continuation (make-exn:servlet:continuation
"" (current-continuation-marks))))) "" (current-continuation-marks)))))
req)) req)))
(semaphore-post (servlet-instance-mutex inst))))) (output-response conn response)
(semaphore-post (servlet-instance-mutex inst))))