From c73537ff139848d71b28da34a0e7ef661a98bd70 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 15 Sep 2005 17:01:04 +0000 Subject: [PATCH] Introducing error when send/suspend like operations used outside of servlet-instance svn: r857 --- collects/web-server/dispatch-servlets.ss | 324 +++++++++++------------ collects/web-server/servlet-tables.ss | 3 + collects/web-server/servlet.ss | 19 +- 3 files changed, 179 insertions(+), 167 deletions(-) diff --git a/collects/web-server/dispatch-servlets.ss b/collects/web-server/dispatch-servlets.ss index 41dd788b30..303a9aaea1 100644 --- a/collects/web-server/dispatch-servlets.ss +++ b/collects/web-server/dispatch-servlets.ss @@ -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)]))))) \ No newline at end of file + + ;; 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)]))))) \ No newline at end of file diff --git a/collects/web-server/servlet-tables.ss b/collects/web-server/servlet-tables.ss index 7e2f6df874..2a42ec86ac 100644 --- a/collects/web-server/servlet-tables.ss +++ b/collects/web-server/servlet-tables.ss @@ -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]) diff --git a/collects/web-server/servlet.ss b/collects/web-server/servlet.ss index b84fd21033..e3b050d5f9 100644 --- a/collects/web-server/servlet.ss +++ b/collects/web-server/servlet.ss @@ -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