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

Introducing error when send/suspend like operations used outside of servlet-instance

Browse Source 
svn: r857
This commit is contained in:
Jay McCarthy 2005-09-15 17:01:04 +00:00
parent b57b871b79
commit c73537ff13
3 changed files with 179 additions and 167 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -141,7 +141,7 @@
(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) ;; make-default-server-continuation-expiration-handler : host -> (request -> response)
(define (make-default-servlet-continuation-expiration-handler host-info) (define (make-default-servlet-continuation-expiration-handler host-info)
(lambda (req) (lambda (req)
@ -156,8 +156,8 @@
(lambda (req) (lambda (req)
((responders-file-not-found (host-responders ((responders-file-not-found (host-responders
host-info)) host-info))
(request-uri req)))) (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
@ -209,170 +209,170 @@
(paths-servlet (host-paths host-info)) (paths-servlet (host-paths host-info))
(url-path->string (url-path uri)))] (url-path->string (url-path uri)))]
[the-servlet (cached-load real-servlet-path)]) [the-servlet (cached-load real-servlet-path)])
(with-handlers ([exn:servlet:instance? (let ([last-inst (thread-cell-ref current-servlet-instance)])
(lambda (the-exn) (thread-cell-set! current-servlet-instance #f)
(output-response/method (with-handlers ([exn:servlet:instance?
conn (lambda (the-exn)
((servlet-instance-expiration-handler the-servlet) req) (output-response/method
(request-method req)))] conn
[exn:servlet:continuation? ((servlet-instance-expiration-handler the-servlet) req)
(lambda (the-exn) (request-method req)))]
((exn:servlet:continuation-expiration-handler the-exn) req))]) [exn:servlet:continuation?
(let* ([last-inst (thread-cell-ref current-servlet-instance)] (lambda (the-exn)
[inst ((exn:servlet:continuation-expiration-handler the-exn) req))])
(hash-table-get config:instances uk-instance (let* ([inst
(lambda () (hash-table-get config:instances uk-instance
(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 () (lambda ()
(raise (raise
(make-exn:servlet:continuation (make-exn:servlet:instance
"" (current-continuation-marks) "" (current-continuation-marks)))))]
default-servlet-continuation-expiration-handler)))))]) [k-table
(if (and k (= k-salt uk-salt)) (servlet-instance-k-table inst)])
(k req) (let/cc suspend
(raise ; We don't use call-with-semaphore or dynamic-wind because we
(make-exn:servlet:continuation ; always call a continuation. The exit-handler above ensures that
"" (current-continuation-marks) ; the post is done.
k-expiration-handler))))) (semaphore-wait (servlet-instance-mutex inst))
(thread-cell-set! current-servlet-instance last-inst) (thread-cell-set! current-servlet-instance inst)
(semaphore-post (servlet-instance-mutex inst)) (set-servlet-instance-context!
))))) inst
(make-execution-context
;; ************************************************************ conn req (lambda () (suspend #t))))
;; ************************************************************ (increment-timer (servlet-instance-timer inst)
;; Paul's ugly loading code: (timeouts-default-servlet
(host-timeouts host-info)))
;; cached-load : path -> script, namespace (let-values ([(k k-expiration-handler k-salt)
;; timestamps are no longer checked for performance. The cache must be explicitly (apply values
;; refreshed (see dispatch). (hash-table-get
(define (cached-load servlet-path) k-table uk-id
(let ([entry-id (string->symbol (path->string servlet-path))]) (lambda ()
(cache-table-lookup! (raise
(unbox config:scripts) (make-exn:servlet:continuation
entry-id "" (current-continuation-marks)
(lambda () default-servlet-continuation-expiration-handler)))))])
(reload-servlet-script servlet-path))))) (if (and k (= k-salt uk-salt))
(k req)
;; exn:i/o:filesystem:servlet-not-found = (raise
;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym) (make-exn:servlet:continuation
(define-struct (exn:fail:filesystem:exists:servlet "" (current-continuation-marks)
exn:fail:filesystem:exists) ()) k-expiration-handler)))))
(semaphore-post (servlet-instance-mutex inst))))
;; reload-servlet-script : str -> cache-entry (thread-cell-set! current-servlet-instance last-inst)))))
;; 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)]) ;; Paul's ugly loading code:
(cond
;; signed-unit servlet ;; cached-load : path -> script, namespace
; MF: I'd also like to test that s has the correct import signature. ;; timestamps are no longer checked for performance. The cache must be explicitly
[(unit/sig? s) ;; refreshed (see dispatch).
(make-servlet (v0.servlet->v1.lambda s) (define (cached-load servlet-path)
(current-namespace) (let ([entry-id (string->symbol (path->string servlet-path))])
(make-default-servlet-instance-expiration-handler host-info))] (cache-table-lookup!
; FIX - reason about exceptions from dynamic require (catch and report if not already) (unbox config:scripts)
;; module servlet entry-id
[(void? s) (lambda ()
(let* ([module-name `(file ,(path->string a-path))] (reload-servlet-script servlet-path)))))
[version (dynamic-require module-name 'interface-version)])
(case version ;; exn:i/o:filesystem:servlet-not-found =
[(v1) ;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym)
(let ([timeout (dynamic-require module-name 'timeout)] (define-struct (exn:fail:filesystem:exists:servlet
[start (dynamic-require module-name 'start)]) exn:fail:filesystem:exists) ())
(make-servlet (v1.module->v1.lambda timeout start)
(current-namespace) ;; reload-servlet-script : str -> cache-entry
(make-default-servlet-instance-expiration-handler host-info)))] ;; The servlet is not cached in the servlet-table, so reload it from the filesystem.
[(v2) ; XXX: Undocumented (define (reload-servlet-script servlet-filename)
(let ([timeout (dynamic-require module-name 'timeout)] (cond
[instance-expiration-handler (dynamic-require module-name 'instance-expiration-handler)] [(load-servlet/path servlet-filename)
[start (dynamic-require module-name 'start)]) => (lambda (entry)
(make-servlet (v1.module->v1.lambda timeout start) entry)]
(current-namespace) [else
instance-expiration-handler))] (raise (make-exn:fail:filesystem:exists:servlet
[else (string->immutable-string (format "Couldn't find ~a" servlet-filename))
(raise (format "unknown servlet version ~e" version))]))] (current-continuation-marks) ))]))
;; response
[(response? s) ;; load-servlet/path path -> (union #f cache-entry)
(make-servlet (v0.response->v1.lambda s a-path) ;; given a string path to a filename attempt to load a servlet
(current-namespace) ;; A servlet-file will contain either
(make-default-servlet-instance-expiration-handler host-info))] ;;;; A signed-unit-servlet
[else ;;;; A module servlet, currently only 'v1
(raise 'load-servlet/path "Loading ~e produced ~n~e~n instead of a servlet." a-path s)]))))) ;;;;;; (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? (define servlet-bin?
(let ([svt-bin-re (regexp "^/servlets(;id.*\\*.*\\*.*)?/.*")]) (let ([svt-bin-re (regexp "^/servlets(;id.*\\*.*\\*.*)?/.*")])
(lambda (str) (lambda (str)
(regexp-match svt-bin-re str)))) (regexp-match svt-bin-re str))))
;; return dispatcher ;; return dispatcher
(lambda (conn req) (lambda (conn req)
(let-values ([(uri method path) (decompose-request req)]) (let-values ([(uri method path) (decompose-request req)])
(cond [(string=? "/conf/refresh-servlets" path) (cond [(string=? "/conf/refresh-servlets" path)
;; more here - this is broken - only out of date or specifically mentioned ;; more here - this is broken - only out of date or specifically mentioned
;; scripts should be flushed. This destroys persistent state! ;; scripts should be flushed. This destroys persistent state!
(cache-table-clear! (unbox config:scripts)) (cache-table-clear! (unbox config:scripts))
(output-response/method (output-response/method
conn conn
((responders-servlets-refreshed (host-responders host-info))) ((responders-servlets-refreshed (host-responders host-info)))
method)] method)]
[(servlet-bin? path) [(servlet-bin? path)
(adjust-connection-timeout! (adjust-connection-timeout!
conn conn
(timeouts-servlet-connection (host-timeouts host-info))) (timeouts-servlet-connection (host-timeouts host-info)))
;; more here - make timeouts proportional to size of bindings ;; more here - make timeouts proportional to size of bindings
(servlet-content-producer conn req host-info)] (servlet-content-producer conn req host-info)]
[else [else
(next-dispatcher)]))))) (next-dispatcher)])))))

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

@ -4,6 +4,7 @@
(lib "list.ss") (lib "list.ss")
"timer.ss") "timer.ss")
(provide (struct exn:servlet:instance ()) (provide (struct exn:servlet:instance ())
(struct exn:servlet:current-instance ())
(struct exn:servlet:continuation (expiration-handler)) (struct exn:servlet:continuation (expiration-handler))
(struct servlet (handler namespace instance-expiration-handler)) (struct servlet (handler namespace instance-expiration-handler))
(struct execution-context (connection request suspend)) (struct execution-context (connection request suspend))
@ -46,6 +47,8 @@
(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) (expiration-handler)) (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!) (define-values (make-k-table reset-k-table get-k-id!)
(let ([id-slot 'next-k-id]) (let ([id-slot 'next-k-id])

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

@ -32,23 +32,32 @@
(define current-servlet-continuation-expiration-handler (define current-servlet-continuation-expiration-handler
(make-parameter #f)) (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-timeout! : sec -> void
;; adjust the timeout on the servlet ;; adjust the timeout on the servlet
(define (adjust-timeout! secs) (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)) secs))
;; send/back: response -> void ;; send/back: response -> void
;; send a response and don't clear the continuation table ;; send a response and don't clear the continuation table
(define (send/back resp) (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) (output-response (execution-context-connection ctxt) resp)
((execution-context-suspend ctxt)))) ((execution-context-suspend ctxt))))
;; send/finish: response -> void ;; send/finish: response -> void
;; send a response and clear the continuation table ;; send a response and clear the continuation table
(define (send/finish resp) (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 ; 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 ; we cannot wait for send/back to return, because it doesn't
; Also, we cannot get the initial-connection-timeout variable from here ; Also, we cannot get the initial-connection-timeout variable from here
@ -61,7 +70,7 @@
(define send/suspend (define send/suspend
(opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)]) (opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)])
(let/cc k (let/cc k
(let* ([inst (thread-cell-ref current-servlet-instance)] (let* ([inst (get-current-servlet-instance)]
[ctxt (servlet-instance-context inst)] [ctxt (servlet-instance-context inst)]
[k-url (store-continuation! [k-url (store-continuation!
k expiration-handler k expiration-handler
@ -75,7 +84,7 @@
;; clear the continuation table, then behave like send/suspend ;; clear the continuation table, then behave like send/suspend
(define send/forward (define send/forward
(opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)]) (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 response-generator expiration-handler)))
;; send/suspend/callback : xexpr/callback? -> void ;; send/suspend/callback : xexpr/callback? -> void