Introducing error when send/suspend like operations used outside of servlet-instance
svn: r857
This commit is contained in:
Jay McCarthy
parent
b57b871b79
commit
c73537ff13
|
|
@ -141,7 +141,7 @@
|
|||
(execution-context-connection
|
||||
(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)
|
||||
|
|
@ -156,8 +156,8 @@
|
|||
(lambda (req)
|
||||
((responders-file-not-found (host-responders
|
||||
host-info))
|
||||
(request-uri req))))
|
||||
|
||||
(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
|
||||
|
|
@ -209,170 +209,170 @@
|
|||
(paths-servlet (host-paths host-info))
|
||||
(url-path->string (url-path uri)))]
|
||||
[the-servlet (cached-load real-servlet-path)])
|
||||
(with-handlers ([exn:servlet:instance?
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((servlet-instance-expiration-handler the-servlet) 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
|
||||
(let ([last-inst (thread-cell-ref current-servlet-instance)])
|
||||
(thread-cell-set! current-servlet-instance #f)
|
||||
(with-handlers ([exn:servlet:instance?
|
||||
(lambda (the-exn)
|
||||
(output-response/method
|
||||
conn
|
||||
((servlet-instance-expiration-handler the-servlet) req)
|
||||
(request-method req)))]
|
||||
[exn:servlet:continuation?
|
||||
(lambda (the-exn)
|
||||
((exn:servlet:continuation-expiration-handler the-exn) req))])
|
||||
(let* ([inst
|
||||
(hash-table-get config:instances uk-instance
|
||||
(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))
|
||||
)))))
|
||||
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
;; Paul's ugly loading code:
|
||||
|
||||
;; cached-load : path -> script, namespace
|
||||
;; timestamps are no longer checked for performance. The cache must be explicitly
|
||||
;; refreshed (see dispatch).
|
||||
(define (cached-load servlet-path)
|
||||
(let ([entry-id (string->symbol (path->string servlet-path))])
|
||||
(cache-table-lookup!
|
||||
(unbox config:scripts)
|
||||
entry-id
|
||||
(lambda ()
|
||||
(reload-servlet-script servlet-path)))))
|
||||
|
||||
;; exn:i/o:filesystem:servlet-not-found =
|
||||
;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym)
|
||||
(define-struct (exn:fail:filesystem:exists:servlet
|
||||
exn:fail:filesystem:exists) ())
|
||||
|
||||
;; reload-servlet-script : str -> cache-entry
|
||||
;; The servlet is not cached in the servlet-table, so reload it from the filesystem.
|
||||
(define (reload-servlet-script servlet-filename)
|
||||
(cond
|
||||
[(load-servlet/path servlet-filename)
|
||||
=> (lambda (entry)
|
||||
entry)]
|
||||
[else
|
||||
(raise (make-exn:fail:filesystem:exists:servlet
|
||||
(string->immutable-string (format "Couldn't find ~a" servlet-filename))
|
||||
(current-continuation-marks) ))]))
|
||||
|
||||
;; load-servlet/path path -> (union #f cache-entry)
|
||||
;; given a string path to a filename attempt to load a servlet
|
||||
;; A servlet-file will contain either
|
||||
;;;; A signed-unit-servlet
|
||||
;;;; A module servlet, currently only 'v1
|
||||
;;;;;; (XXX: I don't know what 'typed-model-split-store0 was, so it was removed.)
|
||||
;;;; A response
|
||||
(define (load-servlet/path a-path)
|
||||
(define (v0.servlet->v1.lambda servlet)
|
||||
(lambda (initial-request)
|
||||
(invoke-unit/sig servlet servlet^)))
|
||||
(define (v0.response->v1.lambda response-path response)
|
||||
(letrec ([go (lambda ()
|
||||
(begin
|
||||
(set! go (lambda () (load/use-compiled a-path)))
|
||||
response))])
|
||||
(lambda (initial-request) (go))))
|
||||
(define (v1.module->v1.lambda timeout start)
|
||||
(lambda (initial-request)
|
||||
(adjust-timeout! timeout)
|
||||
(start initial-request)))
|
||||
(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)))))
|
||||
(semaphore-post (servlet-instance-mutex inst))))
|
||||
(thread-cell-set! current-servlet-instance last-inst)))))
|
||||
|
||||
(parameterize ([current-namespace (config:make-servlet-namespace)])
|
||||
(and (file-exists? a-path)
|
||||
(let ([s (load/use-compiled a-path)])
|
||||
(cond
|
||||
;; signed-unit servlet
|
||||
; MF: I'd also like to test that s has the correct import signature.
|
||||
[(unit/sig? s)
|
||||
(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)
|
||||
;; module servlet
|
||||
[(void? s)
|
||||
(let* ([module-name `(file ,(path->string a-path))]
|
||||
[version (dynamic-require module-name 'interface-version)])
|
||||
(case version
|
||||
[(v1)
|
||||
(let ([timeout (dynamic-require module-name 'timeout)]
|
||||
[start (dynamic-require module-name 'start)])
|
||||
(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
|
||||
(raise (format "unknown servlet version ~e" version))]))]
|
||||
;; response
|
||||
[(response? s)
|
||||
(make-servlet (v0.response->v1.lambda s a-path)
|
||||
(current-namespace)
|
||||
(make-default-servlet-instance-expiration-handler host-info))]
|
||||
[else
|
||||
(raise 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)])))))
|
||||
;; ************************************************************
|
||||
;; ************************************************************
|
||||
;; Paul's ugly loading code:
|
||||
|
||||
;; cached-load : path -> script, namespace
|
||||
;; timestamps are no longer checked for performance. The cache must be explicitly
|
||||
;; refreshed (see dispatch).
|
||||
(define (cached-load servlet-path)
|
||||
(let ([entry-id (string->symbol (path->string servlet-path))])
|
||||
(cache-table-lookup!
|
||||
(unbox config:scripts)
|
||||
entry-id
|
||||
(lambda ()
|
||||
(reload-servlet-script servlet-path)))))
|
||||
|
||||
;; exn:i/o:filesystem:servlet-not-found =
|
||||
;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym)
|
||||
(define-struct (exn:fail:filesystem:exists:servlet
|
||||
exn:fail:filesystem:exists) ())
|
||||
|
||||
;; reload-servlet-script : str -> cache-entry
|
||||
;; The servlet is not cached in the servlet-table, so reload it from the filesystem.
|
||||
(define (reload-servlet-script servlet-filename)
|
||||
(cond
|
||||
[(load-servlet/path servlet-filename)
|
||||
=> (lambda (entry)
|
||||
entry)]
|
||||
[else
|
||||
(raise (make-exn:fail:filesystem:exists:servlet
|
||||
(string->immutable-string (format "Couldn't find ~a" servlet-filename))
|
||||
(current-continuation-marks) ))]))
|
||||
|
||||
;; load-servlet/path path -> (union #f cache-entry)
|
||||
;; given a string path to a filename attempt to load a servlet
|
||||
;; A servlet-file will contain either
|
||||
;;;; A signed-unit-servlet
|
||||
;;;; A module servlet, currently only 'v1
|
||||
;;;;;; (XXX: I don't know what 'typed-model-split-store0 was, so it was removed.)
|
||||
;;;; A response
|
||||
(define (load-servlet/path a-path)
|
||||
(define (v0.servlet->v1.lambda servlet)
|
||||
(lambda (initial-request)
|
||||
(invoke-unit/sig servlet servlet^)))
|
||||
(define (v0.response->v1.lambda response-path response)
|
||||
(letrec ([go (lambda ()
|
||||
(begin
|
||||
(set! go (lambda () (load/use-compiled a-path)))
|
||||
response))])
|
||||
(lambda (initial-request) (go))))
|
||||
(define (v1.module->v1.lambda timeout start)
|
||||
(lambda (initial-request)
|
||||
(adjust-timeout! timeout)
|
||||
(start initial-request)))
|
||||
|
||||
(parameterize ([current-namespace (config:make-servlet-namespace)])
|
||||
(and (file-exists? a-path)
|
||||
(let ([s (load/use-compiled a-path)])
|
||||
(cond
|
||||
;; signed-unit servlet
|
||||
; MF: I'd also like to test that s has the correct import signature.
|
||||
[(unit/sig? s)
|
||||
(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)
|
||||
;; module servlet
|
||||
[(void? s)
|
||||
(let* ([module-name `(file ,(path->string a-path))]
|
||||
[version (dynamic-require module-name 'interface-version)])
|
||||
(case version
|
||||
[(v1)
|
||||
(let ([timeout (dynamic-require module-name 'timeout)]
|
||||
[start (dynamic-require module-name 'start)])
|
||||
(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
|
||||
(raise (format "unknown servlet version ~e" version))]))]
|
||||
;; response
|
||||
[(response? s)
|
||||
(make-servlet (v0.response->v1.lambda s a-path)
|
||||
(current-namespace)
|
||||
(make-default-servlet-instance-expiration-handler host-info))]
|
||||
[else
|
||||
(raise 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)])))))
|
||||
|
||||
(define servlet-bin?
|
||||
(let ([svt-bin-re (regexp "^/servlets(;id.*\\*.*\\*.*)?/.*")])
|
||||
(lambda (str)
|
||||
(regexp-match svt-bin-re str))))
|
||||
|
||||
;; return dispatcher
|
||||
(lambda (conn req)
|
||||
(let-values ([(uri method path) (decompose-request req)])
|
||||
(cond [(string=? "/conf/refresh-servlets" path)
|
||||
;; more here - this is broken - only out of date or specifically mentioned
|
||||
;; scripts should be flushed. This destroys persistent state!
|
||||
(cache-table-clear! (unbox config:scripts))
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-servlets-refreshed (host-responders host-info)))
|
||||
method)]
|
||||
[(servlet-bin? path)
|
||||
(adjust-connection-timeout!
|
||||
conn
|
||||
(timeouts-servlet-connection (host-timeouts host-info)))
|
||||
;; more here - make timeouts proportional to size of bindings
|
||||
(servlet-content-producer conn req host-info)]
|
||||
[else
|
||||
(next-dispatcher)])))))
|
||||
|
||||
;; return dispatcher
|
||||
(lambda (conn req)
|
||||
(let-values ([(uri method path) (decompose-request req)])
|
||||
(cond [(string=? "/conf/refresh-servlets" path)
|
||||
;; more here - this is broken - only out of date or specifically mentioned
|
||||
;; scripts should be flushed. This destroys persistent state!
|
||||
(cache-table-clear! (unbox config:scripts))
|
||||
(output-response/method
|
||||
conn
|
||||
((responders-servlets-refreshed (host-responders host-info)))
|
||||
method)]
|
||||
[(servlet-bin? path)
|
||||
(adjust-connection-timeout!
|
||||
conn
|
||||
(timeouts-servlet-connection (host-timeouts host-info)))
|
||||
;; more here - make timeouts proportional to size of bindings
|
||||
(servlet-content-producer conn req host-info)]
|
||||
[else
|
||||
(next-dispatcher)])))))
|
||||
|
|
@ -4,6 +4,7 @@
|
|||
(lib "list.ss")
|
||||
"timer.ss")
|
||||
(provide (struct exn:servlet:instance ())
|
||||
(struct exn:servlet:current-instance ())
|
||||
(struct exn:servlet:continuation (expiration-handler))
|
||||
(struct servlet (handler namespace instance-expiration-handler))
|
||||
(struct execution-context (connection request suspend))
|
||||
|
|
@ -46,6 +47,8 @@
|
|||
(define-struct (exn:servlet:instance exn) ())
|
||||
;; not found in the continuatin table
|
||||
(define-struct (exn:servlet:continuation exn) (expiration-handler))
|
||||
;; not in dynamic extent of servlet
|
||||
(define-struct (exn:servlet:current-instance exn) ())
|
||||
|
||||
(define-values (make-k-table reset-k-table get-k-id!)
|
||||
(let ([id-slot 'next-k-id])
|
||||
|
|
|
|||
|
|
@ -32,23 +32,32 @@
|
|||
(define current-servlet-continuation-expiration-handler
|
||||
(make-parameter #f))
|
||||
|
||||
;; get-current-servlet-instance : -> servlet
|
||||
(define (get-current-servlet-instance)
|
||||
(let ([inst (thread-cell-ref current-servlet-instance)])
|
||||
(unless inst
|
||||
(raise (make-exn:servlet:current-instance
|
||||
"(lib \"servlet.ss\" \"web-server\") used outside the dynamic-extent of a servlet-instance"
|
||||
(current-continuation-marks))))
|
||||
inst))
|
||||
|
||||
;; adjust-timeout! : sec -> void
|
||||
;; adjust the timeout on the servlet
|
||||
(define (adjust-timeout! secs)
|
||||
(reset-timer (servlet-instance-timer (thread-cell-ref current-servlet-instance))
|
||||
(reset-timer (servlet-instance-timer (get-current-servlet-instance))
|
||||
secs))
|
||||
|
||||
;; send/back: response -> void
|
||||
;; send a response and don't clear the continuation table
|
||||
(define (send/back resp)
|
||||
(let ([ctxt (servlet-instance-context (thread-cell-ref current-servlet-instance))])
|
||||
(let ([ctxt (servlet-instance-context (get-current-servlet-instance))])
|
||||
(output-response (execution-context-connection ctxt) resp)
|
||||
((execution-context-suspend ctxt))))
|
||||
|
||||
;; send/finish: response -> void
|
||||
;; send a response and clear the continuation table
|
||||
(define (send/finish resp)
|
||||
(clear-continuations! (thread-cell-ref current-servlet-instance))
|
||||
(clear-continuations! (get-current-servlet-instance))
|
||||
; If we readjust the timeout to something small, the session will expire shortly
|
||||
; we cannot wait for send/back to return, because it doesn't
|
||||
; Also, we cannot get the initial-connection-timeout variable from here
|
||||
|
|
@ -61,7 +70,7 @@
|
|||
(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)]
|
||||
(let* ([inst (get-current-servlet-instance)]
|
||||
[ctxt (servlet-instance-context inst)]
|
||||
[k-url (store-continuation!
|
||||
k expiration-handler
|
||||
|
|
@ -75,7 +84,7 @@
|
|||
;; clear the continuation table, then behave like send/suspend
|
||||
(define send/forward
|
||||
(opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)])
|
||||
(clear-continuations! (thread-cell-ref current-servlet-instance))
|
||||
(clear-continuations! (get-current-servlet-instance))
|
||||
(send/suspend response-generator expiration-handler)))
|
||||
|
||||
;; send/suspend/callback : xexpr/callback? -> void
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user