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

Adding expiration replacement primitives

Browse Source 
svn: r723
This commit is contained in:
Jay McCarthy 2005-08-31 20:11:34 +00:00
parent f0707745e6
commit 33d90e70f7
3 changed files with 122 additions and 85 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

118
collects/web-server/dispatch-servlets.ss
View File

@ -99,6 +99,8 @@
[servlet-exit-handler (make-servlet-exit-handler inst)]) [servlet-exit-handler (make-servlet-exit-handler inst)])
(parameterize ([current-directory (get-servlet-base-dir real-servlet-path)] (parameterize ([current-directory (get-servlet-base-dir real-servlet-path)]
[current-custodian servlet-custodian] [current-custodian servlet-custodian]
[current-servlet-continuation-expiration-handler
(make-default-servlet-continuation-expiration-handler host-info)]
[exit-handler servlet-exit-handler]) [exit-handler servlet-exit-handler])
(thread-cell-set! current-servlet-instance inst) (thread-cell-set! current-servlet-instance inst)
(let-values (;; timer thread must be within the dynamic extent of (let-values (;; timer thread must be within the dynamic extent of
@ -138,7 +140,15 @@
(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-default-server-continuation-expiration-handler : host -> (request -> response)
(define (make-default-servlet-continuation-expiration-handler host-info)
(lambda (req)
(send/back
((responders-file-not-found (host-responders
host-info))
(request-uri req)))))
;; 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
;; * Must occur within the dynamic extent of the servlet ;; * Must occur within the dynamic extent of the servlet
@ -182,58 +192,60 @@
;; host -> void ;; host -> void
;; pull the continuation out of the table and apply it ;; pull the continuation out of the table and apply it
(define (invoke-servlet-continuation conn req k-ref host-info) (define (invoke-servlet-continuation conn req k-ref host-info)
(with-handlers ([exn:servlet-instance? (let-values ([(uk-instance uk-id uk-salt) (apply values k-ref)])
(lambda (the-exn) (let ([default-servlet-continuation-expiration-handler
(output-response/method (make-default-servlet-continuation-expiration-handler host-info)])
conn (with-handlers ([exn:servlet:instance?
((responders-file-not-found (host-responders (lambda (the-exn)
host-info)) (output-response/method
(request-uri req)) conn
(request-method req)))] ((responders-file-not-found (host-responders
[exn:servlet-continuation? host-info))
(lambda (the-exn) (request-uri req))
(output-response/method (request-method req)))]
conn [exn:servlet:continuation?
((responders-file-not-found (host-responders (lambda (the-exn)
host-info)) ((exn:servlet:continuation-expiration-handler the-exn) req))])
(request-uri req)) (let* ([last-inst (thread-cell-ref current-servlet-instance)]
(request-method req)))]) [inst
(let* ([last-inst (thread-cell-ref current-servlet-instance)] (hash-table-get config:instances uk-instance
[inst (lambda ()
(hash-table-get config:instances (first k-ref) (raise
(lambda () (make-exn:servlet:instance
(raise "" (current-continuation-marks)))))]
(make-exn:servlet-instance [k-table
"" (current-continuation-marks)))))] (servlet-instance-k-table inst)])
[k-table (let/cc suspend
(servlet-instance-k-table inst)]) ; We don't use call-with-semaphore or dynamic-wind because we
(let/cc suspend ; always call a continuation. The exit-handler above ensures that
; We don't use call-with-semaphore or dynamic-wind because we ; the post is done.
; always call a continuation. The exit-handler above ensures that (semaphore-wait (servlet-instance-mutex inst))
; the post is done. (thread-cell-set! current-servlet-instance inst)
(semaphore-wait (servlet-instance-mutex inst)) (set-servlet-instance-context!
(thread-cell-set! current-servlet-instance inst) inst
(set-servlet-instance-context! (make-execution-context
inst conn req (lambda () (suspend #t))))
(make-execution-context (increment-timer (servlet-instance-timer inst)
conn req (lambda () (suspend #t)))) (timeouts-default-servlet
(increment-timer (servlet-instance-timer inst) (host-timeouts host-info)))
(timeouts-default-servlet (let-values ([(k k-expiration-handler k-salt)
(host-timeouts host-info))) (apply values
(let ([k*salt (hash-table-get
(hash-table-get k-table (second k-ref) k-table uk-id
(lambda () (lambda ()
(raise (raise
(make-exn:servlet-continuation (make-exn:servlet:continuation
"" (current-continuation-marks)))))]) "" (current-continuation-marks)
(if (= (second k*salt) (third k-ref)) default-servlet-continuation-expiration-handler)))))])
((first k*salt) req) (if (and k (= k-salt uk-salt))
(raise (k req)
(make-exn:servlet-continuation (raise
"" (current-continuation-marks)))))) (make-exn:servlet:continuation
(thread-cell-set! current-servlet-instance last-inst) "" (current-continuation-marks)
(semaphore-post (servlet-instance-mutex inst)) k-expiration-handler)))))
))) (thread-cell-set! current-servlet-instance last-inst)
(semaphore-post (servlet-instance-mutex inst))
)))))
;; ************************************************************ ;; ************************************************************
;; ************************************************************ ;; ************************************************************

38
collects/web-server/servlet-tables.ss
View File

@ -3,8 +3,8 @@
(lib "url.ss" "net") (lib "url.ss" "net")
(lib "list.ss") (lib "list.ss")
"timer.ss") "timer.ss")
(provide (struct exn:servlet-instance ()) (provide (struct exn:servlet:instance ())
(struct exn:servlet-continuation ()) (struct exn:servlet:continuation (expiration-handler))
(struct execution-context (connection request suspend)) (struct execution-context (connection request suspend))
(struct servlet-instance (id k-table custodian context mutex timer)) (struct servlet-instance (id k-table custodian context mutex timer))
current-servlet-instance) current-servlet-instance)
@ -34,28 +34,43 @@
(provide/contract (provide/contract
[continuation-url? (url? . -> . (union boolean? (list/c symbol? number? number?)))] [continuation-url? (url? . -> . (union boolean? (list/c symbol? number? number?)))]
[store-continuation! (procedure? url? servlet-instance? . -> . string?)] [store-continuation! (procedure? procedure? url? servlet-instance? . -> . string?)]
[create-new-instance! (hash-table? custodian? execution-context? semaphore? timer? [create-new-instance! (hash-table? custodian? execution-context? semaphore? timer?
. -> . servlet-instance?)] . -> . servlet-instance?)]
[remove-instance! (hash-table? servlet-instance? . -> . any)] [remove-instance! (hash-table? servlet-instance? . -> . any)]
[clear-continuations! (servlet-instance? . -> . any)]) [clear-continuations! (servlet-instance? . -> . any)])
;; not found in the instance table ;; not found in the instance table
(define-struct (exn:servlet-instance exn) ()) (define-struct (exn:servlet:instance exn) ())
;; not found in the continuatin table ;; not found in the continuatin table
(define-struct (exn:servlet-continuation exn) ()) (define-struct (exn:servlet:continuation exn) (expiration-handler))
(define-values (make-k-table get-k-id!) (define-values (make-k-table reset-k-table get-k-id!)
(let ([id-slot 'next-k-id]) (let ([id-slot 'next-k-id])
(values (values
;; make-k-table: -> (hash-table-of continuation) ;; make-k-table: -> (hash-table-of (continuation x expiration handler x salt))
;; Create a continuation table with an initial value for the next ;; Create a continuation table with an initial value for the next
;; continuation id. ;; continuation id.
(lambda () (lambda ()
(let ([k-table (make-hash-table)]) (let ([k-table (make-hash-table)])
(hash-table-put! k-table id-slot 0) (hash-table-put! k-table id-slot 0)
k-table)) k-table))
;; reset-k-table : hash-table -> (hash-table-of (#f x expiration handler x salt ))
;; Remove the continuations from the k-table
(lambda (k-table0)
(let ([k-table1 (make-hash-table)]
[next-id (hash-table-get k-table0 id-slot)])
(hash-table-for-each
k-table0
(lambda (id v)
(if (eq? id id-slot)
; Save old next-id
(hash-table-put! k-table1 id v)
; Replace continuations with #f
(hash-table-put! k-table1 id (list* #f (cdr v))))))
k-table1))
;; get-k-id!: hash-table -> number ;; get-k-id!: hash-table -> number
;; get the current-continuation id and increment the internal value ;; get the current-continuation id and increment the internal value
@ -64,13 +79,13 @@
(hash-table-put! k-table id-slot (add1 id)) (hash-table-put! k-table id-slot (add1 id))
id))))) id)))))
;; store-continuation!: continuation execution-context servlet-instance -> url-string ;; store-continuation!: continuation expiration-handler uri servlet-instance -> url-string
;; store a continuation in a k-table for the provided servlet-instance ;; store a continuation in a k-table for the provided servlet-instance
(define (store-continuation! k uri inst) (define (store-continuation! k expiration-handler uri inst)
(let ([k-table (servlet-instance-k-table inst)]) (let ([k-table (servlet-instance-k-table inst)])
(let ([next-k-id (get-k-id! k-table)] (let ([next-k-id (get-k-id! k-table)]
[salt (random 100000000)]) [salt (random 100000000)])
(hash-table-put! k-table next-k-id (list k salt)) (hash-table-put! k-table next-k-id (list k expiration-handler salt))
(embed-ids (servlet-instance-id inst) next-k-id salt uri)))) (embed-ids (servlet-instance-id inst) next-k-id salt uri))))
;; clear-continuations!: servlet-instance -> void ;; clear-continuations!: servlet-instance -> void
@ -78,7 +93,8 @@
(define (clear-continuations! inst) (define (clear-continuations! inst)
(set-servlet-instance-k-table! (set-servlet-instance-k-table!
inst inst
(make-k-table))) (reset-k-table
(servlet-instance-k-table inst))))
;; create-new-instance! hash-table custodian execution-context semaphore -> servlet-instance ;; create-new-instance! hash-table custodian execution-context semaphore -> servlet-instance
(define (create-new-instance! instance-table cust ctxt sema timer) (define (create-new-instance! instance-table cust ctxt sema timer)

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

@ -1,7 +1,8 @@
;; Default choice for writing module servlets ;; Default choice for writing module servlets
(module servlet mzscheme (module servlet mzscheme
(require (lib "contract.ss") (require (lib "contract.ss")
"servlet-tables.ss" (lib "etc.ss"))
(require "servlet-tables.ss"
"response.ss" "response.ss"
"servlet-helpers.ss" "servlet-helpers.ss"
"xexpr-callback.ss" "xexpr-callback.ss"
@ -13,19 +14,24 @@
[adjust-timeout! (number? . -> . any)] [adjust-timeout! (number? . -> . any)]
[send/back (any/c . -> . any)] [send/back (any/c . -> . any)]
[send/finish (any/c . -> . any)] [send/finish (any/c . -> . any)]
[send/suspend ((string? . -> . any/c) . -> . request?)] [send/suspend (((string? . -> . any/c)) ((request? . -> . any/c)) . opt-> . request?)]
[send/forward ((string? . -> . any/c) . -> . request?)] [send/forward (((string? . -> . any/c)) ((request? . -> . any/c)) . opt-> . request?)]
;;; validate-xexpr/callback is not checked anywhere: ;;; validate-xexpr/callback is not checked anywhere:
[send/suspend/callback (xexpr/callback? . -> . any)]) [send/suspend/callback (xexpr/callback? . -> . any)])
(provide (provide
send/suspend/dispatch send/suspend/dispatch
current-servlet-continuation-expiration-handler
(all-from "servlet-helpers.ss") (all-from "servlet-helpers.ss")
(all-from "xexpr-callback.ss")) (all-from "xexpr-callback.ss"))
;; ************************************************************ ;; ************************************************************
;; EXPORTS ;; EXPORTS
;; current-servlet-continuation-expiration-handler : request -> response
(define current-servlet-continuation-expiration-handler
(make-parameter #f))
;; 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)
@ -45,24 +51,27 @@
(clear-continuations! (thread-cell-ref current-servlet-instance)) (clear-continuations! (thread-cell-ref current-servlet-instance))
(send/back resp)) (send/back resp))
;; send/suspend: (url -> response) -> request ;; send/suspend: (url -> response) [(request -> response)] -> request
;; send a response and apply the continuation to the next request ;; send a response and apply the continuation to the next request
(define (send/suspend response-generator) (define send/suspend
(let/cc k (opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)])
(let* ([inst (thread-cell-ref current-servlet-instance)] (let/cc k
[ctxt (servlet-instance-context inst)] (let* ([inst (thread-cell-ref current-servlet-instance)]
[k-url (store-continuation! [ctxt (servlet-instance-context inst)]
k (request-uri (execution-context-request ctxt)) [k-url (store-continuation!
inst)] k expiration-handler
[response (response-generator k-url)]) (request-uri (execution-context-request ctxt))
(output-response (execution-context-connection ctxt) response) inst)]
((execution-context-suspend ctxt))))) [response (response-generator k-url)])
(output-response (execution-context-connection ctxt) response)
((execution-context-suspend ctxt))))))
;; send/forward: (url -> 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
(define (send/forward response-generator) (define send/forward
(clear-continuations! (thread-cell-ref current-servlet-instance)) (opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)])
(send/suspend response-generator)) (clear-continuations! (thread-cell-ref current-servlet-instance))
(send/suspend response-generator expiration-handler)))
;; send/suspend/callback : xexpr/callback? -> void ;; send/suspend/callback : xexpr/callback? -> void
;; send/back a response with callbacks in it; send/suspend those callbacks. ;; send/back a response with callbacks in it; send/suspend those callbacks.
@ -71,15 +80,15 @@
(lambda (embed/url) (lambda (embed/url)
(replace-procedures p-exp embed/url)))) (replace-procedures p-exp embed/url))))
;; send/suspend/dispatch : ((proc -> url) -> response) -> request ;; send/suspend/dispatch : ((proc -> url) -> response) [(request -> response)] -> request
;; send/back a response generated from a procedure that may convert ;; send/back a response generated from a procedure that may convert
;; procedures to continuation urls ;; procedures to continuation urls
(define (send/suspend/dispatch response-generator) (define (send/suspend/dispatch response-generator)
(let/ec k0 (let/ec k0
(send/back (send/back
(response-generator (response-generator
(lambda (proc) (opt-lambda (proc [expiration-handler (current-servlet-continuation-expiration-handler)])
(let/ec k1 (k0 (proc (send/suspend k1))))))))) (let/ec k1 (k0 (proc (send/suspend k1 expiration-handler)))))))))
;; ************************************************************ ;; ************************************************************