Adding expiration replacement primitives
svn: r723
This commit is contained in:
Jay McCarthy
parent
f0707745e6
commit
33d90e70f7
|
|
@ -99,6 +99,8 @@
|
|||
[servlet-exit-handler (make-servlet-exit-handler inst)])
|
||||
(parameterize ([current-directory (get-servlet-base-dir real-servlet-path)]
|
||||
[current-custodian servlet-custodian]
|
||||
[current-servlet-continuation-expiration-handler
|
||||
(make-default-servlet-continuation-expiration-handler host-info)]
|
||||
[exit-handler servlet-exit-handler])
|
||||
(thread-cell-set! current-servlet-instance inst)
|
||||
(let-values (;; timer thread must be within the dynamic extent of
|
||||
|
|
@ -139,6 +141,14 @@
|
|||
(servlet-instance-context 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
|
||||
;; This exception handler traps all unhandled servlet exceptions
|
||||
;; * Must occur within the dynamic extent of the servlet
|
||||
|
|
@ -182,58 +192,60 @@
|
|||
;; host -> void
|
||||
;; pull the continuation out of the table and apply it
|
||||
(define (invoke-servlet-continuation conn req k-ref host-info)
|
||||
(with-handlers ([exn:servlet-instance?
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-file-not-found (host-responders
|
||||
host-info))
|
||||
(request-uri req))
|
||||
(request-method req)))]
|
||||
[exn:servlet-continuation?
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-file-not-found (host-responders
|
||||
host-info))
|
||||
(request-uri req))
|
||||
(request-method req)))])
|
||||
(let* ([last-inst (thread-cell-ref current-servlet-instance)]
|
||||
[inst
|
||||
(hash-table-get config:instances (first k-ref)
|
||||
(lambda ()
|
||||
(raise
|
||||
(make-exn:servlet-instance
|
||||
"" (current-continuation-marks)))))]
|
||||
[k-table
|
||||
(servlet-instance-k-table inst)])
|
||||
(let/cc suspend
|
||||
; 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-mutex inst))
|
||||
(thread-cell-set! current-servlet-instance inst)
|
||||
(set-servlet-instance-context!
|
||||
inst
|
||||
(make-execution-context
|
||||
conn req (lambda () (suspend #t))))
|
||||
(increment-timer (servlet-instance-timer inst)
|
||||
(timeouts-default-servlet
|
||||
(host-timeouts host-info)))
|
||||
(let ([k*salt
|
||||
(hash-table-get k-table (second k-ref)
|
||||
(lambda ()
|
||||
(raise
|
||||
(make-exn:servlet-continuation
|
||||
"" (current-continuation-marks)))))])
|
||||
(if (= (second k*salt) (third k-ref))
|
||||
((first k*salt) req)
|
||||
(raise
|
||||
(make-exn:servlet-continuation
|
||||
"" (current-continuation-marks))))))
|
||||
(thread-cell-set! current-servlet-instance last-inst)
|
||||
(semaphore-post (servlet-instance-mutex inst))
|
||||
)))
|
||||
(let-values ([(uk-instance uk-id uk-salt) (apply values k-ref)])
|
||||
(let ([default-servlet-continuation-expiration-handler
|
||||
(make-default-servlet-continuation-expiration-handler host-info)])
|
||||
(with-handlers ([exn:servlet:instance?
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-file-not-found (host-responders
|
||||
host-info))
|
||||
(request-uri req))
|
||||
(request-method req)))]
|
||||
[exn:servlet:continuation?
|
||||
(lambda (the-exn)
|
||||
((exn:servlet:continuation-expiration-handler the-exn) req))])
|
||||
(let* ([last-inst (thread-cell-ref current-servlet-instance)]
|
||||
[inst
|
||||
(hash-table-get config:instances uk-instance
|
||||
(lambda ()
|
||||
(raise
|
||||
(make-exn:servlet:instance
|
||||
"" (current-continuation-marks)))))]
|
||||
[k-table
|
||||
(servlet-instance-k-table inst)])
|
||||
(let/cc suspend
|
||||
; 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-mutex inst))
|
||||
(thread-cell-set! current-servlet-instance inst)
|
||||
(set-servlet-instance-context!
|
||||
inst
|
||||
(make-execution-context
|
||||
conn req (lambda () (suspend #t))))
|
||||
(increment-timer (servlet-instance-timer inst)
|
||||
(timeouts-default-servlet
|
||||
(host-timeouts host-info)))
|
||||
(let-values ([(k k-expiration-handler k-salt)
|
||||
(apply values
|
||||
(hash-table-get
|
||||
k-table uk-id
|
||||
(lambda ()
|
||||
(raise
|
||||
(make-exn:servlet:continuation
|
||||
"" (current-continuation-marks)
|
||||
default-servlet-continuation-expiration-handler)))))])
|
||||
(if (and k (= k-salt uk-salt))
|
||||
(k req)
|
||||
(raise
|
||||
(make-exn:servlet:continuation
|
||||
"" (current-continuation-marks)
|
||||
k-expiration-handler)))))
|
||||
(thread-cell-set! current-servlet-instance last-inst)
|
||||
(semaphore-post (servlet-instance-mutex inst))
|
||||
)))))
|
||||
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@
|
|||
(lib "url.ss" "net")
|
||||
(lib "list.ss")
|
||||
"timer.ss")
|
||||
(provide (struct exn:servlet-instance ())
|
||||
(struct exn:servlet-continuation ())
|
||||
(provide (struct exn:servlet:instance ())
|
||||
(struct exn:servlet:continuation (expiration-handler))
|
||||
(struct execution-context (connection request suspend))
|
||||
(struct servlet-instance (id k-table custodian context mutex timer))
|
||||
current-servlet-instance)
|
||||
|
|
@ -34,22 +34,22 @@
|
|||
|
||||
(provide/contract
|
||||
[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?
|
||||
. -> . servlet-instance?)]
|
||||
[remove-instance! (hash-table? servlet-instance? . -> . any)]
|
||||
[clear-continuations! (servlet-instance? . -> . any)])
|
||||
|
||||
;; not found in the instance table
|
||||
(define-struct (exn:servlet-instance exn) ())
|
||||
(define-struct (exn:servlet:instance exn) ())
|
||||
;; 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])
|
||||
(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
|
||||
;; continuation id.
|
||||
(lambda ()
|
||||
|
|
@ -57,6 +57,21 @@
|
|||
(hash-table-put! k-table id-slot 0)
|
||||
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 the current-continuation id and increment the internal value
|
||||
(lambda (k-table)
|
||||
|
|
@ -64,13 +79,13 @@
|
|||
(hash-table-put! k-table id-slot (add1 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
|
||||
(define (store-continuation! k uri inst)
|
||||
(define (store-continuation! k expiration-handler uri inst)
|
||||
(let ([k-table (servlet-instance-k-table inst)])
|
||||
(let ([next-k-id (get-k-id! k-table)]
|
||||
[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))))
|
||||
|
||||
;; clear-continuations!: servlet-instance -> void
|
||||
|
|
@ -78,7 +93,8 @@
|
|||
(define (clear-continuations! inst)
|
||||
(set-servlet-instance-k-table!
|
||||
inst
|
||||
(make-k-table)))
|
||||
(reset-k-table
|
||||
(servlet-instance-k-table inst))))
|
||||
|
||||
;; create-new-instance! hash-table custodian execution-context semaphore -> servlet-instance
|
||||
(define (create-new-instance! instance-table cust ctxt sema timer)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
;; Default choice for writing module servlets
|
||||
(module servlet mzscheme
|
||||
(require (lib "contract.ss")
|
||||
"servlet-tables.ss"
|
||||
(lib "etc.ss"))
|
||||
(require "servlet-tables.ss"
|
||||
"response.ss"
|
||||
"servlet-helpers.ss"
|
||||
"xexpr-callback.ss"
|
||||
|
|
@ -13,19 +14,24 @@
|
|||
[adjust-timeout! (number? . -> . any)]
|
||||
[send/back (any/c . -> . any)]
|
||||
[send/finish (any/c . -> . any)]
|
||||
[send/suspend ((string? . -> . any/c) . -> . request?)]
|
||||
[send/forward ((string? . -> . any/c) . -> . request?)]
|
||||
[send/suspend (((string? . -> . any/c)) ((request? . -> . any/c)) . opt-> . request?)]
|
||||
[send/forward (((string? . -> . any/c)) ((request? . -> . any/c)) . opt-> . request?)]
|
||||
;;; validate-xexpr/callback is not checked anywhere:
|
||||
[send/suspend/callback (xexpr/callback? . -> . any)])
|
||||
|
||||
(provide
|
||||
send/suspend/dispatch
|
||||
current-servlet-continuation-expiration-handler
|
||||
(all-from "servlet-helpers.ss")
|
||||
(all-from "xexpr-callback.ss"))
|
||||
|
||||
;; ************************************************************
|
||||
;; EXPORTS
|
||||
|
||||
;; current-servlet-continuation-expiration-handler : request -> response
|
||||
(define current-servlet-continuation-expiration-handler
|
||||
(make-parameter #f))
|
||||
|
||||
;; adjust-timeout! : sec -> void
|
||||
;; adjust the timeout on the servlet
|
||||
(define (adjust-timeout! secs)
|
||||
|
|
@ -45,24 +51,27 @@
|
|||
(clear-continuations! (thread-cell-ref current-servlet-instance))
|
||||
(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
|
||||
(define (send/suspend response-generator)
|
||||
(let/cc k
|
||||
(let* ([inst (thread-cell-ref current-servlet-instance)]
|
||||
[ctxt (servlet-instance-context inst)]
|
||||
[k-url (store-continuation!
|
||||
k (request-uri (execution-context-request ctxt))
|
||||
inst)]
|
||||
[response (response-generator k-url)])
|
||||
(output-response (execution-context-connection ctxt) response)
|
||||
((execution-context-suspend ctxt)))))
|
||||
(define send/suspend
|
||||
(opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)])
|
||||
(let/cc k
|
||||
(let* ([inst (thread-cell-ref current-servlet-instance)]
|
||||
[ctxt (servlet-instance-context inst)]
|
||||
[k-url (store-continuation!
|
||||
k expiration-handler
|
||||
(request-uri (execution-context-request ctxt))
|
||||
inst)]
|
||||
[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
|
||||
(define (send/forward response-generator)
|
||||
(clear-continuations! (thread-cell-ref current-servlet-instance))
|
||||
(send/suspend response-generator))
|
||||
(define send/forward
|
||||
(opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)])
|
||||
(clear-continuations! (thread-cell-ref current-servlet-instance))
|
||||
(send/suspend response-generator expiration-handler)))
|
||||
|
||||
;; send/suspend/callback : xexpr/callback? -> void
|
||||
;; send/back a response with callbacks in it; send/suspend those callbacks.
|
||||
|
|
@ -71,15 +80,15 @@
|
|||
(lambda (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
|
||||
;; procedures to continuation urls
|
||||
(define (send/suspend/dispatch response-generator)
|
||||
(let/ec k0
|
||||
(send/back
|
||||
(response-generator
|
||||
(lambda (proc)
|
||||
(let/ec k1 (k0 (proc (send/suspend k1)))))))))
|
||||
(opt-lambda (proc [expiration-handler (current-servlet-continuation-expiration-handler)])
|
||||
(let/ec k1 (k0 (proc (send/suspend k1 expiration-handler)))))))))
|
||||
|
||||
|
||||
;; ************************************************************
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user