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

Thread safety through delimited continuations

Browse Source 
svn: r6308
This commit is contained in:
Jay McCarthy 2007-05-25 17:37:26 +00:00
parent cb6d8fec8b
commit 36a8fe7fd7
1 changed files with 23 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
collects/web-server/prototype-web-server/server.ss
View File

@ -23,8 +23,6 @@
(define myprint printf #;(lambda _ (void))) (define myprint printf #;(lambda _ (void)))
(define thread-connection-state (make-thread-cell #f))
(define-struct connection-state (conn req))
(define top-cust (current-custodian)) (define top-cust (current-custodian))
;; Parameter Parsing ;; Parameter Parsing
@ -69,7 +67,7 @@
(gen-file-not-found-responder "not-found.html")]) (gen-file-not-found-responder "not-found.html")])
;; ************************************************************ ;; ************************************************************
;; dispatch: connection request host -> void ;; dispatch: connection request -> void
;; trivial dispatcher ;; trivial dispatcher
(define (dispatch conn req) (define (dispatch conn req)
(define-values (uri method path) (decompose-request req)) (define-values (uri method path) (decompose-request req))
@ -85,7 +83,7 @@
;; ************************************************************ ;; ************************************************************
;; SERVING SERVLETS ;; SERVING SERVLETS
;; servlet-content-producer: connection request host -> void ;; servlet-content-producer: connection request -> void
(define (servlet-content-producer conn req) (define (servlet-content-producer conn req)
(myprint "servlet-content-producer~n") (myprint "servlet-content-producer~n")
(let ([meth (request-method req)]) (let ([meth (request-method req)])
@ -97,27 +95,23 @@
'() (list "ignored")) '() (list "ignored"))
meth) meth)
(let ([uri (request-uri req)]) (let ([uri (request-uri req)])
(thread-cell-set! thread-connection-state
(make-connection-state conn req))
(with-handlers ([void (with-handlers ([void
(lambda (the-exn) (lambda (the-exn)
(output-response/method (output-response/method
(connection-state-conn (thread-cell-ref thread-connection-state)) conn
(responders-servlet-loading uri the-exn) (responders-servlet-loading uri the-exn)
(request-method (request-method req)))])
(connection-state-req
(thread-cell-ref thread-connection-state)))))])
(cond (cond
[(resume-session? uri) [(resume-session? uri)
=> (lambda (session-id) => (lambda (session-id)
(resume-session session-id))] (resume-session session-id conn req))]
[else [else
(begin-session)])))))) (begin-session conn req)]))))))
;; begin-session: connection request host-info ;; begin-session: connection request
(define (begin-session) (define (begin-session conn req)
(myprint "begin-session~n") (myprint "begin-session~n")
(let ([uri (request-uri (connection-state-req (thread-cell-ref thread-connection-state)))]) (let ([uri (request-uri req)])
(let-values ([(a-path url-servlet-path url-path-suffix) (let-values ([(a-path url-servlet-path url-path-suffix)
(url->servlet-path servlet-root uri)]) (url->servlet-path servlet-root uri)])
(myprint "a-path = ~s~n" a-path) (myprint "a-path = ~s~n" a-path)
@ -129,7 +123,7 @@
(parameterize ([current-custodian cust] (parameterize ([current-custodian cust]
[current-namespace ns] [current-namespace ns]
[current-session ses]) [current-session ses])
(let* ([module-name `(file ,(path->string a-path))]) (let ([module-name `(file ,(path->string a-path))])
(myprint "dynamic-require ...~n") (myprint "dynamic-require ...~n")
(with-handlers ([exn:fail:contract? (with-handlers ([exn:fail:contract?
(lambda _ (lambda _
@ -137,15 +131,15 @@
(let ([start (dynamic-require module-name 'start)]) (let ([start (dynamic-require module-name 'start)])
(run-start start-servlet start))))) (run-start start-servlet start)))))
(myprint "resume-session~n") (myprint "resume-session~n")
(resume-session (session-id ses)))) (resume-session (session-id ses)
conn req)))
(output-response/method (output-response/method
(connection-state-conn (thread-cell-ref thread-connection-state)) conn
(responders-file-not-found uri) (responders-file-not-found uri)
(request-method (connection-state-req (thread-cell-ref thread-connection-state)))))))) (request-method req))))))
;; ************************************************************ ;; resume-session: number connection request
;; resume-session: connection request number host-info (define (resume-session ses-id conn req)
(define (resume-session ses-id)
; XXX Check if session is for same servlet! ; XXX Check if session is for same servlet!
(myprint "resume-session: ses-id = ~s~n" ses-id) (myprint "resume-session: ses-id = ~s~n" ses-id)
(cond (cond
@ -156,23 +150,16 @@
(with-handlers ([void (with-handlers ([void
(lambda (the-exn) (lambda (the-exn)
(output-response/method (output-response/method
(connection-state-conn (thread-cell-ref thread-connection-state)) conn
(responders-servlet (responders-servlet (request-uri req) the-exn)
(request-uri (request-method req)))])
(connection-state-req
(thread-cell-ref thread-connection-state)))
the-exn)
(request-method
(connection-state-req (thread-cell-ref thread-connection-state)))))])
(printf "session-handler ~S~n" (session-handler ses)) (printf "session-handler ~S~n" (session-handler ses))
(output-response (output-response conn
(connection-state-conn (thread-cell-ref thread-connection-state)) (xexpr+extras->xexpr
(xexpr+extras->xexpr ((session-handler ses) req))))))]
((session-handler ses)
(connection-state-req (thread-cell-ref thread-connection-state))))))))]
[else [else
(myprint "resume-session: Unknown ses~n") (myprint "resume-session: Unknown ses~n")
;; TODO: should just start a new session here. ;; TODO: should just start a new session here.
(begin-session)])) (begin-session conn req)]))
dispatch)) dispatch))