diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index 7f2ed3c9d1..f07f5c5fa6 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -16,7 +16,8 @@ "../managers/lru.ss" "../managers/none.ss" "../private/servlet.ss" - "../private/cache-table.ss") + "../private/cache-table.ss" + "../private/util.ss") (provide/contract [interface-version dispatcher-interface-version?]) (provide make) @@ -41,23 +42,13 @@ (adjust-connection-timeout! conn timeouts-servlet-connection) - ; XXX Allow servlet to respond - (case meth - [(head) - (output-response/method - conn - (make-response/full - 200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE - '() (list "ignored")) - meth)] + (cond + [(continuation-url? uri) + => (match-lambda + [(list instance-id k-id salt) + (invoke-servlet-continuation conn req instance-id k-id salt)])] [else - (cond - [(continuation-url? uri) - => (match-lambda - [(list instance-id k-id salt) - (invoke-servlet-continuation conn req instance-id k-id salt)])] - [else - (servlet-content-producer/path conn req uri)])])) + (servlet-content-producer/path conn req uri)])) ;; servlet-content-producer/path: connection request url -> void ;; This is not a continuation url so the loading behavior is determined @@ -84,7 +75,7 @@ (exn-message e) (exn-continuation-marks e))))]) (url->path uri))) - (parameterize ([current-directory (get-servlet-base-dir servlet-path)] + (parameterize ([current-directory (directory-part servlet-path)] [current-custodian instance-custodian] [exit-handler (lambda (v) @@ -101,7 +92,10 @@ (define instance-id ((manager-create-instance manager) (make-servlet-instance-data servlet-mutex) (exit-handler))) (parameterize ([current-servlet-instance-id instance-id]) (with-handlers ([(lambda (x) #t) - (make-servlet-exception-handler)]) + (lambda (exn) + (responders-servlet + (request-uri req) + exn))]) ((servlet-handler the-servlet) req)))))))) servlet-prompt))))) (output-response conn response)) @@ -110,22 +104,6 @@ (define (default-servlet-instance-expiration-handler req) (next-dispatcher)) - ;; make-servlet-exception-handler: servlet-instance -> exn -> void - (define ((make-servlet-exception-handler) the-exn) - (responders-servlet - (request-uri (execution-context-request (current-execution-context))) - the-exn)) - - ;; path -> path - ;; The actual servlet's parent directory. - (define (get-servlet-base-dir servlet-path) - (let loop ([path servlet-path]) - (define-values (base name must-be-dir?) (split-path path)) - (or (if must-be-dir? - (and (directory-exists? path) path) - (and (directory-exists? base) base)) - (loop base)))) - (define (invoke-servlet-continuation conn req instance-id k-id salt) (define uri (request-uri req)) (define-values (servlet-path _) (url->path uri)) @@ -134,7 +112,7 @@ (define data ((manager-instance-lookup-data manager) instance-id)) (define response (parameterize ([current-servlet the-servlet] - [current-directory (get-servlet-base-dir servlet-path)] + [current-directory (directory-part servlet-path)] [current-servlet-instance-id instance-id] [current-custodian (servlet-custodian the-servlet)] [current-namespace (servlet-namespace the-servlet)] @@ -190,25 +168,21 @@ (format "Couldn't find ~a" servlet-filename) (current-continuation-marks) ))])) - ;; load-servlet/path path -> (or/c #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 - ;;;; A response + (define (v0.response->v1.lambda response response-path) + (define go + (box + (lambda () + (set-box! go (lambda () (load/use-compiled response-path))) + response))) + (lambda (initial-request) + ((unbox go)))) + (define (v1.module->v1.lambda timeout start) + (lambda (initial-request) + (adjust-timeout! timeout) + (start initial-request))) + + ;; load-servlet/path path -> servlet (define (load-servlet/path a-path) - (define (v0.response->v1.lambda response-path response) - (define go - (box - (lambda () - (set-box! go (lambda () (load/use-compiled a-path))) - response))) - (lambda (initial-request) - ((unbox go)))) - (define (v1.module->v1.lambda timeout start) - (lambda (initial-request) - (adjust-timeout! timeout) - (start initial-request))) (parameterize ([current-namespace (config:make-servlet-namespace #:additional-specs '((lib "servlet.ss" "web-server") @@ -220,7 +194,6 @@ (define s (load/use-compiled a-path)) (cond ; XXX - 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)]) @@ -254,7 +227,6 @@ start))] [else (error 'load-servlet/path "unknown servlet version ~e" version)]))] - ;; response [(response? s) (make-servlet (current-custodian) (current-namespace)