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

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

@ -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,7 +192,10 @@
;; 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?
(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
@ -190,20 +203,15 @@
host-info))
(request-uri req))
(request-method req)))]
[exn:servlet-continuation?
[exn:servlet:continuation?
(lambda (the-exn)
(output-response/method
conn
((responders-file-not-found (host-responders
host-info))
(request-uri req))
(request-method req)))])
((exn:servlet:continuation-expiration-handler the-exn) req))])
(let* ([last-inst (thread-cell-ref current-servlet-instance)]
[inst
(hash-table-get config:instances (first k-ref)
(hash-table-get config:instances uk-instance
(lambda ()
(raise
(make-exn:servlet-instance
(make-exn:servlet:instance
"" (current-continuation-marks)))))]
[k-table
(servlet-instance-k-table inst)])
@ -220,20 +228,24 @@
(increment-timer (servlet-instance-timer inst)
(timeouts-default-servlet
(host-timeouts host-info)))
(let ([k*salt
(hash-table-get k-table (second k-ref)
(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)))))])
(if (= (second k*salt) (third k-ref))
((first k*salt) req)
(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))))))
(make-exn:servlet:continuation
"" (current-continuation-marks)
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 "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)

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

@ -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)
(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 (request-uri (execution-context-request ctxt))
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)))))
((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)
(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))
(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)))))))))
;; ************************************************************