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

Adding code to make instance expiration handlers

Browse Source 
svn: r772
This commit is contained in:
Jay McCarthy 2005-09-05 15:30:46 +00:00
parent 9f528d0288
commit 1e36a07fc3
3 changed files with 57 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -104,17 +104,17 @@
(make-default-servlet-continuation-expiration-handler host-info)] (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 (;; timer thread must be within the dynamic extent of
;; servlet custodian ;; servlet custodian
[(time-bomb) (start-timer (timeouts-default-servlet [time-bomb (start-timer (timeouts-default-servlet
(host-timeouts host-info)) (host-timeouts host-info))
(lambda () (lambda ()
(servlet-exit-handler #f)))] (servlet-exit-handler #f)))]
;; 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
[(servlet-program servlet-namespace) (cached-load real-servlet-path)]) [the-servlet (cached-load real-servlet-path)])
(parameterize ([current-namespace servlet-namespace]) (parameterize ([current-namespace (servlet-namespace the-servlet)])
(set-servlet-instance-timer! inst time-bomb) (set-servlet-instance-timer! inst time-bomb)
(with-handlers ([(lambda (x) #t) (with-handlers ([(lambda (x) #t)
(make-servlet-exception-handler inst host-info)]) (make-servlet-exception-handler inst host-info)])
@ -126,7 +126,7 @@
;; 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.
(let ([r (servlet-program req)]) (let ([r ((servlet-handler the-servlet) req)])
(when (response? r) (when (response? r)
(send/back r))))))))) (send/back r)))))))))
(thread-cell-set! current-servlet-instance last-inst) (thread-cell-set! current-servlet-instance last-inst)
@ -149,6 +149,14 @@
((responders-file-not-found (host-responders ((responders-file-not-found (host-responders
host-info)) host-info))
(request-uri req))))) (request-uri req)))))
;; make-default-server-instance-expiration-handler : host -> (request -> response)
(define (make-default-servlet-instance-expiration-handler host-info)
(lambda (req)
((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
@ -194,15 +202,18 @@
;; 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)
(let-values ([(uk-instance uk-id uk-salt) (apply values k-ref)]) (let-values ([(uk-instance uk-id uk-salt) (apply values k-ref)])
(let ([default-servlet-continuation-expiration-handler (let* ([uri (request-uri req)]
(make-default-servlet-continuation-expiration-handler host-info)]) [default-servlet-continuation-expiration-handler
(make-default-servlet-continuation-expiration-handler host-info)]
[real-servlet-path (url-path->path
(paths-servlet (host-paths host-info))
(url-path->string (url-path uri)))]
[the-servlet (cached-load real-servlet-path)])
(with-handlers ([exn:servlet:instance? (with-handlers ([exn:servlet:instance?
(lambda (the-exn) (lambda (the-exn)
(output-response/method (output-response/method
conn conn
((responders-file-not-found (host-responders ((servlet-instance-expiration-handler the-servlet) req)
host-info))
(request-uri req))
(request-method req)))] (request-method req)))]
[exn:servlet:continuation? [exn:servlet:continuation?
(lambda (the-exn) (lambda (the-exn)
@ -251,22 +262,17 @@
;; ************************************************************ ;; ************************************************************
;; ************************************************************ ;; ************************************************************
;; Paul's ugly loading code: ;; Paul's ugly loading code:
(define make-cache-entry cons)
(define cache-entry-servlet car)
(define cache-entry-namespace cdr)
;; cached-load : path -> script, namespace ;; cached-load : path -> script, namespace
;; timestamps are no longer checked for performance. The cache must be explicitly ;; timestamps are no longer checked for performance. The cache must be explicitly
;; refreshed (see dispatch). ;; refreshed (see dispatch).
(define (cached-load servlet-path) (define (cached-load servlet-path)
(let* ([entry-id (string->symbol (path->string servlet-path))] (let ([entry-id (string->symbol (path->string servlet-path))])
[entry (cache-table-lookup! (cache-table-lookup!
(unbox config:scripts) (unbox config:scripts)
entry-id entry-id
(lambda () (lambda ()
(reload-servlet-script servlet-path)))]) (reload-servlet-script servlet-path)))))
(values (cache-entry-servlet entry)
(cache-entry-namespace entry))))
;; exn:i/o:filesystem:servlet-not-found = ;; exn:i/o:filesystem:servlet-not-found =
;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym) ;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym)
@ -314,7 +320,9 @@
;; signed-unit servlet ;; signed-unit servlet
; MF: I'd also like to test that s has the correct import signature. ; MF: I'd also like to test that s has the correct import signature.
[(unit/sig? s) [(unit/sig? s)
(make-cache-entry (v0.servlet->v1.lambda s) (current-namespace))] (make-servlet (v0.servlet->v1.lambda s)
(current-namespace)
(make-default-servlet-instance-expiration-handler host-info))]
; FIX - reason about exceptions from dynamic require (catch and report if not already) ; FIX - reason about exceptions from dynamic require (catch and report if not already)
;; module servlet ;; module servlet
[(void? s) [(void? s)
@ -324,12 +332,23 @@
[(v1) [(v1)
(let ([timeout (dynamic-require module-name 'timeout)] (let ([timeout (dynamic-require module-name 'timeout)]
[start (dynamic-require module-name 'start)]) [start (dynamic-require module-name 'start)])
(make-cache-entry (v1.module->v1.lambda timeout start) (current-namespace)))] (make-servlet (v1.module->v1.lambda timeout start)
(current-namespace)
(make-default-servlet-instance-expiration-handler host-info)))]
[(v2) ; XXX: Undocumented
(let ([timeout (dynamic-require module-name 'timeout)]
[instance-expiration-handler (dynamic-require module-name 'instance-expiration-handler)]
[start (dynamic-require module-name 'start)])
(make-servlet (v1.module->v1.lambda timeout start)
(current-namespace)
instance-expiration-handler))]
[else [else
(raise (format "unknown servlet version ~e" version))]))] (raise (format "unknown servlet version ~e" version))]))]
;; response ;; response
[(response? s) [(response? s)
(make-cache-entry (v0.response->v1.lambda s a-path) (current-namespace))] (make-servlet (v0.response->v1.lambda s a-path)
(current-namespace)
(make-default-servlet-instance-expiration-handler host-info))]
[else [else
(raise 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)]))))) (raise 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)])))))

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

@ -64,7 +64,11 @@
"default-web-root" "." "default-web-root" "."
the-path))) the-path)))
(lambda () (lambda ()
(cons the-servlet (i:make-servlet-namespace)))) (make-servlet the-servlet
(i:make-servlet-namespace)
(lambda (request)
`(html (head "Return to the interaction window.")
(body (p "Return to the interaction window.")))))))
(unit/sig web-config^ (unit/sig web-config^
(import) (import)
(define port the-port) (define port the-port)

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

@ -5,6 +5,7 @@
"timer.ss") "timer.ss")
(provide (struct exn:servlet:instance ()) (provide (struct exn:servlet:instance ())
(struct exn:servlet:continuation (expiration-handler)) (struct exn:servlet:continuation (expiration-handler))
(struct servlet (handler namespace instance-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)
@ -15,6 +16,7 @@
;; will be in affect for the entire dynamic extent of every ;; will be in affect for the entire dynamic extent of every
;; continuation associated with that instance. ;; continuation associated with that instance.
(define current-servlet-instance (make-thread-cell #f)) (define current-servlet-instance (make-thread-cell #f))
(define-struct servlet (handler namespace instance-expiration-handler))
(define-struct servlet-instance (id k-table custodian context mutex timer)) (define-struct servlet-instance (id k-table custodian context mutex timer))
(define-struct execution-context (connection request suspend)) (define-struct execution-context (connection request suspend))