From 9875ed685e9048a0d8689a20c2b7fb2c8e397ce7 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 22 Nov 2005 21:51:22 +0000 Subject: [PATCH] pr7202, servlet-url svn: r1374 --- collects/web-server/dispatch-servlets.ss | 705 +++++++++++------------ collects/web-server/servlet-helpers.ss | 186 +++++- collects/web-server/servlet-tables.ss | 6 +- collects/web-server/servlet.ss | 16 +- 4 files changed, 517 insertions(+), 396 deletions(-) diff --git a/collects/web-server/dispatch-servlets.ss b/collects/web-server/dispatch-servlets.ss index a94a2c3b7a..baefe6e213 100644 --- a/collects/web-server/dispatch-servlets.ss +++ b/collects/web-server/dispatch-servlets.ss @@ -20,358 +20,353 @@ responders-servlets-refreshed responders-servlet-loading responders-servlet responders-file-not-found timeouts-servlet-connection timeouts-default-servlet) - ;; ************************************************************ - ;; ************************************************************ - ;; SERVING SERVLETS - - ;; servlet-content-producer: connection request -> void - (define (servlet-content-producer conn req) - (let ([meth (request-method req)]) - (if (eq? meth 'head) - (output-response/method - conn - (make-response/full - 200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE - '() (list "ignored")) - meth) - (let ([uri (request-uri req)]) - (set-request-bindings/raw! - req - (read-bindings/handled conn meth uri (request-headers req))) - (cond - [(continuation-url? uri) - => (lambda (k-ref) - (invoke-servlet-continuation conn req k-ref))] - [else - (servlet-content-producer/path conn req uri)]))))) - - ;; read-bindings/handled: connection symbol url headers -> (listof (list (symbol string)) - ;; read the bindings and handle any exceptions - (define (read-bindings/handled conn meth uri headers) - (with-handlers ([exn? (lambda (e) - (output-response/method conn (responders-servlet-loading uri e) meth) - '())]) - (read-bindings conn meth uri headers))) - - ;; servlet-content-producer/path: connection request url -> void - ;; This is not a continuation url so the loading behavior is determined - ;; by the url path. Build the servlet path and then load the servlet - (define (servlet-content-producer/path conn req uri) - (with-handlers (;; couldn't find the servlet - [exn:fail:filesystem:exists:servlet? - (lambda (the-exn) - (output-response/method conn (responders-file-not-found (request-uri req)) (request-method req)))] - ;; servlet won't load (e.g. syntax error) - [(lambda (x) #t) - (lambda (the-exn) - (output-response/method conn (responders-servlet-loading uri the-exn) (request-method req)))]) - (let ([sema (make-semaphore 0)] - [last-inst (thread-cell-ref current-servlet-instance)]) - (let/cc suspend - ; Create the session frame - (with-frame - (let* ([servlet-custodian (make-servlet-custodian)] - [inst (create-new-instance! - config:instances servlet-custodian - (make-execution-context - conn req (lambda () (suspend #t))) - sema - (start-timer 0 void))] - [real-servlet-path (with-handlers ([void (lambda (e) - (raise (make-exn:fail:filesystem:exists:servlet - (exn-message e) - (exn-continuation-marks e))))]) - (url-path->path - servlet-root - (url-path->string (url-path uri))))] - [servlet-exit-handler (make-servlet-exit-handler inst)]) - (parameterize ([current-directory (get-servlet-base-dir real-servlet-path)] - [current-custodian servlet-custodian] - [current-servlet-continuation-expiration-handler - (make-default-servlet-continuation-expiration-handler)] - [exit-handler servlet-exit-handler]) - (thread-cell-set! current-servlet-instance inst) - (let (;; timer thread must be within the dynamic extent of - ;; servlet custodian - [time-bomb (start-timer timeouts-default-servlet - (lambda () - (servlet-exit-handler #f)))] - ;; any resources (e.g. threads) created when the - ;; servlet is loaded should be within the dynamic - ;; extent of the servlet custodian - [the-servlet (cached-load real-servlet-path)]) - (parameterize ([current-namespace (servlet-namespace the-servlet)]) - (set-servlet-instance-timer! inst time-bomb) - (with-handlers ([(lambda (x) #t) - (make-servlet-exception-handler inst)]) - ;; Two possibilities: - ;; - module servlet. start : Request -> Void handles - ;; output-response via send/finish, etc. - ;; - unit/sig or simple xexpr servlet. These must produce a - ;; response, which is then output by the server. - ;; Here, we do not know if the servlet was a module, - ;; unit/sig, or Xexpr; we do know whether it produces a - ;; response. - (let ([r ((servlet-handler the-servlet) req)]) - (when (response? r) - (send/back r)))))))))) - (thread-cell-set! current-servlet-instance last-inst) - (semaphore-post sema)))) - - ;; make-servlet-exit-handler: servlet-instance -> alpha -> void - ;; exit handler for a servlet - (define (make-servlet-exit-handler inst) - (lambda (x) - (remove-instance! config:instances inst) - (kill-connection! - (execution-context-connection - (servlet-instance-context inst))) - (custodian-shutdown-all (servlet-instance-custodian inst)))) - - ;; make-default-server-continuation-expiration-handler : -> (request -> response) - (define (make-default-servlet-continuation-expiration-handler) - (lambda (req) - (send/back - (responders-file-not-found - (request-uri req))))) - - - ;; make-default-server-instance-expiration-handler : -> (request -> response) - (define (make-default-servlet-instance-expiration-handler) - (lambda (req) - (responders-file-not-found - (request-uri req)))) - - ;; make-servlet-exception-handler: servlet-instance -> exn -> void - ;; This exception handler traps all unhandled servlet exceptions - ;; * Must occur within the dynamic extent of the servlet - ;; custodian since several connection custodians will typically - ;; be shutdown during the dynamic extent of a continuation - ;; * Use the connection from the current-servlet-context in case - ;; the exception is raised while invoking a continuation. - ;; * Use the suspend from the servlet-instanct-context which is - ;; closed over the current tcp ports which may need to be - ;; closed for an http 1.0 request. - ;; * Also, suspend will post to the semaphore so that future - ;; requests won't be blocked. - ;; * This fixes PR# 7066 - (define (make-servlet-exception-handler inst) - (lambda (the-exn) - (let* ([ctxt (servlet-instance-context inst)] - [req (execution-context-request ctxt)] - [resp (responders-servlet - (request-uri req) - the-exn)]) - ;; Don't handle twice - (with-handlers ([exn:fail? (lambda (exn) (void))]) - (output-response/method - (execution-context-connection ctxt) - resp (request-method req))) - ((execution-context-suspend ctxt))))) - - ;; path -> path - ;; The actual servlet's parent directory. - (define (get-servlet-base-dir servlet-path) - (let loop ((path servlet-path)) - (let-values ([(base name must-be-dir?) (split-path path)]) - (if must-be-dir? - (or (and (directory-exists? path) path) - (loop base)) - (or (and (directory-exists? base) base) - (loop base)))))) - - ;; invoke-servlet-continuation: connection request continuation-reference -> void - ;; pull the continuation out of the table and apply it - (define (invoke-servlet-continuation conn req k-ref) - (let-values ([(uk-instance uk-id uk-salt) (apply values k-ref)]) - (let* ([uri (request-uri req)] - [real-servlet-path (url-path->path - servlet-root - (url-path->string (url-path uri)))] - [the-servlet (cached-load real-servlet-path)]) - (parameterize ([current-custodian (servlet-custodian the-servlet)]) - (let ([default-servlet-instance-expiration-handler - (make-default-servlet-instance-expiration-handler)] - [default-servlet-continuation-expiration-handler - (make-default-servlet-continuation-expiration-handler)] - [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))] - [exn:servlet:no-current-instance? - (lambda (the-exn) - (output-response/method - conn - ((default-servlet-instance-expiration-handler) req) - (request-method req)))]) - (let* ([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) - (servlet-connection-interval-timeout the-servlet)) - (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)))))) - - ;; ************************************************************ - ;; ************************************************************ - ;; 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))) - (let ([servlet-custodian (make-servlet-custodian)]) - (parameterize ([current-namespace (config:make-servlet-namespace)] - [current-custodian servlet-custodian]) - (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) - servlet-custodian - (current-namespace) - timeouts-default-servlet - (make-default-servlet-instance-expiration-handler))] - ; 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) - servlet-custodian - (current-namespace) - timeouts-default-servlet - (make-default-servlet-instance-expiration-handler)))] - [(v2-transitional) ; 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) - servlet-custodian - (current-namespace) - timeout - instance-expiration-handler))] - [else - (raise (format "unknown servlet version ~e" version))]))] - ;; response - [(response? s) - (make-servlet (v0.response->v1.lambda s a-path) - servlet-custodian - (current-namespace) - timeouts-default-servlet - (make-default-servlet-instance-expiration-handler))] - [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) - method)] - [(servlet-bin? path) - (adjust-connection-timeout! - conn - timeouts-servlet-connection) - ;; more here - make timeouts proportional to size of bindings - (servlet-content-producer conn req)] - [else - (next-dispatcher)]))))) \ No newline at end of file + ;; ************************************************************ + ;; ************************************************************ + ;; SERVING SERVLETS + + ;; servlet-content-producer: connection request -> void + (define (servlet-content-producer conn req) + (let ([meth (request-method req)]) + (if (eq? meth 'head) + (output-response/method + conn + (make-response/full + 200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE + '() (list "ignored")) + meth) + (let ([uri (request-uri req)]) + (set-request-bindings/raw! + req + (read-bindings/handled conn meth uri (request-headers req))) + (cond + [(continuation-url? uri) + => (lambda (k-ref) + (invoke-servlet-continuation conn req k-ref))] + [else + (servlet-content-producer/path conn req uri)]))))) + + ;; read-bindings/handled: connection symbol url headers -> (listof (list (symbol string)) + ;; read the bindings and handle any exceptions + (define (read-bindings/handled conn meth uri headers) + (with-handlers ([exn? (lambda (e) + (output-response/method conn (responders-servlet-loading uri e) meth) + '())]) + (read-bindings conn meth uri headers))) + + ;; servlet-content-producer/path: connection request url -> void + ;; This is not a continuation url so the loading behavior is determined + ;; by the url path. Build the servlet path and then load the servlet + (define (servlet-content-producer/path conn req uri) + (with-handlers (;; couldn't find the servlet + [exn:fail:filesystem:exists:servlet? + (lambda (the-exn) + (output-response/method conn (responders-file-not-found (request-uri req)) (request-method req)))] + ;; servlet won't load (e.g. syntax error) + [(lambda (x) #t) + (lambda (the-exn) + (output-response/method conn (responders-servlet-loading uri the-exn) (request-method req)))]) + (let ([sema (make-semaphore 0)] + [last-inst (thread-cell-ref current-servlet-instance)]) + (let/cc suspend + ; Create the session frame + (with-frame + (let* ([servlet-custodian (make-servlet-custodian)] + [inst (create-new-instance! + config:instances servlet-custodian + (make-execution-context + conn req (lambda () (suspend #t))) + sema + (start-timer 0 void))] + [real-servlet-path (with-handlers ([void (lambda (e) + (raise (make-exn:fail:filesystem:exists:servlet + (exn-message e) + (exn-continuation-marks e))))]) + (url-path->path + servlet-root + (url-path->string (url-path uri))))] + [servlet-exit-handler (make-servlet-exit-handler inst)]) + (parameterize ([current-directory (get-servlet-base-dir real-servlet-path)] + [current-custodian servlet-custodian] + [exit-handler servlet-exit-handler]) + (thread-cell-set! current-servlet-instance inst) + (let (;; timer thread must be within the dynamic extent of + ;; servlet custodian + [time-bomb (start-timer timeouts-default-servlet + (lambda () + (servlet-exit-handler #f)))] + ;; any resources (e.g. threads) created when the + ;; servlet is loaded should be within the dynamic + ;; extent of the servlet custodian + [the-servlet (cached-load real-servlet-path)]) + (parameterize ([current-namespace (servlet-namespace the-servlet)] + [current-servlet-continuation-expiration-handler + (servlet-instance-expiration-handler the-servlet)]) + (set-servlet-instance-timer! inst time-bomb) + (with-handlers ([(lambda (x) #t) + (make-servlet-exception-handler inst)]) + ;; Two possibilities: + ;; - module servlet. start : Request -> Void handles + ;; output-response via send/finish, etc. + ;; - unit/sig or simple xexpr servlet. These must produce a + ;; response, which is then output by the server. + ;; Here, we do not know if the servlet was a module, + ;; unit/sig, or Xexpr; we do know whether it produces a + ;; response. + (let ([r ((servlet-handler the-servlet) req)]) + (when (response? r) + (send/back r)))))))))) + (thread-cell-set! current-servlet-instance last-inst) + (semaphore-post sema)))) + + ;; make-servlet-exit-handler: servlet-instance -> alpha -> void + ;; exit handler for a servlet + (define (make-servlet-exit-handler inst) + (lambda (x) + (remove-instance! config:instances inst) + (kill-connection! + (execution-context-connection + (servlet-instance-context inst))) + (custodian-shutdown-all (servlet-instance-custodian inst)))) + + ;; make-default-server-instance-expiration-handler : -> (request -> response) + (define (make-default-servlet-instance-expiration-handler) + (lambda (req) + (responders-file-not-found + (request-uri req)))) + + ;; make-servlet-exception-handler: servlet-instance -> exn -> void + ;; This exception handler traps all unhandled servlet exceptions + ;; * Must occur within the dynamic extent of the servlet + ;; custodian since several connection custodians will typically + ;; be shutdown during the dynamic extent of a continuation + ;; * Use the connection from the current-servlet-context in case + ;; the exception is raised while invoking a continuation. + ;; * Use the suspend from the servlet-instanct-context which is + ;; closed over the current tcp ports which may need to be + ;; closed for an http 1.0 request. + ;; * Also, suspend will post to the semaphore so that future + ;; requests won't be blocked. + ;; * This fixes PR# 7066 + (define (make-servlet-exception-handler inst) + (lambda (the-exn) + (let* ([ctxt (servlet-instance-context inst)] + [req (execution-context-request ctxt)] + [resp (responders-servlet + (request-uri req) + the-exn)]) + ;; Don't handle twice + (with-handlers ([exn:fail? (lambda (exn) (void))]) + (output-response/method + (execution-context-connection ctxt) + resp (request-method req))) + ((execution-context-suspend ctxt))))) + + ;; path -> path + ;; The actual servlet's parent directory. + (define (get-servlet-base-dir servlet-path) + (let loop ((path servlet-path)) + (let-values ([(base name must-be-dir?) (split-path path)]) + (if must-be-dir? + (or (and (directory-exists? path) path) + (loop base)) + (or (and (directory-exists? base) base) + (loop base)))))) + + ;; invoke-servlet-continuation: connection request continuation-reference -> void + ;; pull the continuation out of the table and apply it + (define (invoke-servlet-continuation conn req k-ref) + (let-values ([(uk-instance uk-id uk-salt) (apply values k-ref)]) + (let* ([uri (request-uri req)] + [real-servlet-path (url-path->path + servlet-root + (url-path->string (url-path uri)))] + [the-servlet (cached-load real-servlet-path)]) + (parameterize ([current-custodian (servlet-custodian the-servlet)]) + (let ([default-servlet-instance-expiration-handler + (make-default-servlet-instance-expiration-handler)] + [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) + (let ([handler (exn:servlet:continuation-expiration-handler the-exn)]) + (if (eq? handler (servlet-instance-expiration-handler the-servlet)) + (output-response/method + conn (handler req) (request-method req)) + (handler req))))] + [exn:servlet:no-current-instance? + (lambda (the-exn) + (output-response/method + conn + ((default-servlet-instance-expiration-handler) req) + (request-method req)))]) + (let* ([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) + (servlet-connection-interval-timeout the-servlet)) + (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) + (servlet-instance-expiration-handler the-servlet))))))]) + (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)))))) + + ;; ************************************************************ + ;; ************************************************************ + ;; 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))) + (let ([servlet-custodian (make-servlet-custodian)]) + (parameterize ([current-namespace (config:make-servlet-namespace)] + [current-custodian servlet-custodian]) + (and (file-exists? a-path) + ; XXX load/use-compiled breaks errortrace + (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) + servlet-custodian + (current-namespace) + timeouts-default-servlet + (make-default-servlet-instance-expiration-handler))] + ; 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) + servlet-custodian + (current-namespace) + timeouts-default-servlet + (make-default-servlet-instance-expiration-handler)))] + [(v2-transitional) ; 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) + servlet-custodian + (current-namespace) + timeout + instance-expiration-handler))] + [else + (raise (format "unknown servlet version ~e" version))]))] + ;; response + [(response? s) + (make-servlet (v0.response->v1.lambda s a-path) + servlet-custodian + (current-namespace) + timeouts-default-servlet + (make-default-servlet-instance-expiration-handler))] + [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) + method)] + [(servlet-bin? path) + (adjust-connection-timeout! + conn + timeouts-servlet-connection) + ;; more here - make timeouts proportional to size of bindings + (servlet-content-producer conn req)] + [else + (next-dispatcher)]))))) \ No newline at end of file diff --git a/collects/web-server/servlet-helpers.ss b/collects/web-server/servlet-helpers.ss index 2c01362ee6..921259c2be 100644 --- a/collects/web-server/servlet-helpers.ss +++ b/collects/web-server/servlet-helpers.ss @@ -3,10 +3,12 @@ (lib "etc.ss") (lib "xml.ss" "xml") (lib "base64.ss" "net") - (lib "url.ss" "net")) + (lib "url.ss" "net") + (lib "struct.ss")) (require "util.ss" "response.ss" - "request-parsing.ss") + "request-parsing.ss" + "servlet-tables.ss") (provide get-host extract-binding/single extract-bindings @@ -23,6 +25,136 @@ (rename get-parsed-bindings request-bindings) translate-escapes) + ;; URL parsing + (provide (struct servlet-url (protocol host port servlets-root instance-id k-id nonce servlet-path extra-path)) + servlet-url->url-string + servlet-url->url-string/no-continuation + servlet-url->servlet-url/no-extra-path + request->servlet-url + uri->servlet-url) + (define-struct servlet-url (protocol host port servlets-root instance-id k-id nonce servlet-path extra-path)) + (define (servlet-url->url-string/no-continuation su) + (url->string + (make-url (servlet-url-protocol su) + #f + #f ;(servlet-url-host su) + #f ;(servlet-url-port su) + (append (servlet-url-servlets-root su) + (servlet-url-servlet-path su) + (servlet-url-extra-path su)) + empty + #f))) + (define (servlet-url->url-string su) + (url->string + (make-url (servlet-url-protocol su) + #f + #f ;(servlet-url-host su) + #f ;(servlet-url-port su) + (append (reverse (rest (reverse (servlet-url-servlets-root su)))) + (list (make-path/param (first (reverse (servlet-url-servlets-root su))) + (format "~a*~a*~a" + (servlet-url-instance-id su) + (servlet-url-k-id su) + (servlet-url-nonce su)))) + (servlet-url-servlet-path su) + (servlet-url-extra-path su)) + empty + #f))) + (define (servlet-url->servlet-url/no-extra-path su) + (copy-struct servlet-url su + [servlet-url-extra-path empty])) + (define (request->servlet-url req) + (uri->servlet-url (request-uri req) + (request-host-ip req) + (request-host-port req))) + (define uri->servlet-url + (opt-lambda (uri [default-host #f] [default-port #f]) + (let-values ([(k-instance k-id k-salt) + (let ([k-parts (continuation-url? uri)]) + (if k-parts + (apply values k-parts) + (values #f #f #f)))]) + (let loop ([path (url-path uri)] + [servlets-root empty] + [found-servlets-root? #f] + [servlet-path empty] + [found-servlet-path? #f] + [extra-path empty]) + #;(printf "~S~n" (list path + servlets-root found-servlets-root? + servlet-path found-servlet-path? + extra-path)) + (let ([top (if (empty? path) + #f + (first path))]) + (cond + ;; Find the servlets-root + [(and top + (not found-servlets-root?) + ; XXX: Ack! + (not (or (and (not (empty? servlets-root)) + (string=? "servlets" (first (reverse servlets-root)))) + (path/param? top)))) + (loop (rest path) + (append servlets-root (list top)) #f + servlet-path #f + extra-path)] + ;;; if there is a continuation part + [(and top + (not found-servlets-root?) + (path/param? top)) + (loop (rest path) + (append servlets-root (list (path/param-path top))) #t + servlet-path #f + extra-path)] + ;;; if there is not + [(and top + (not found-servlets-root?) + ; XXX: Ack! + (not (empty? servlets-root)) + (string=? "servlets" (first (reverse servlets-root)))) + (loop path + servlets-root #t + servlet-path #f + extra-path)] + ;; Find the servlet path + [(and top + found-servlets-root? + (not found-servlet-path?) + (not (and (string? top) + (regexp-match ".ss$" top)))) + (loop (rest path) + servlets-root #t + (append servlet-path (list top)) #f + extra-path)] + [(and top + found-servlets-root? + (not found-servlet-path?) + (and (string? top) + (regexp-match ".ss$" top))) + (loop (rest path) + servlets-root #t + (append servlet-path (list top)) #t + extra-path)] + ;; Compute the servlet-url + [(and found-servlets-root? + found-servlet-path?) + (make-servlet-url (url-scheme uri) + (or (url-host uri) default-host) + (or (url-port uri) default-port) + servlets-root + k-instance + k-id + k-salt + servlet-path + path)] + [(empty? path) + (error 'request->servlet-url "Not servlet-url: ~S; parsed: ~S" (url->string uri) + (list path + servlets-root found-servlets-root? + servlet-path found-servlet-path? + extra-path))])))))) + ;; get-host : Url (listof (cons Symbol String)) -> Symbol ;; host names are case insesitive---Internet RFC 1034 (define DEFAULT-HOST-NAME ') @@ -33,14 +165,14 @@ => (lambda (h) (string->symbol (bytes->string/utf-8 (cdr h))))] [else DEFAULT-HOST-NAME])) - + ;; get-parsed-bindings : request -> (listof (cons sym str)) (define (get-parsed-bindings r) (let ([x (request-bindings/raw r)]) (if (list? x) x (parse-bindings x)))) - + ;; parse-bindings : (U #f String) -> (listof (cons Symbol String)) (define (parse-bindings raw) (if (string? raw) @@ -59,7 +191,7 @@ (find-amp (add1 amp-end)))) (find= (add1 key-end))))))) null)) - + ; extract-binding/single : sym (listof (cons str str)) -> str (define (extract-binding/single name bindings) (let ([lst (extract-bindings name bindings)]) @@ -68,18 +200,18 @@ (error 'extract-binding/single "~a not found in ~a" name bindings)] [(null? (cdr lst)) (car lst)] [else (error 'extract-binding/single "~a occurs multiple times in ~a" name bindings)]))) - + ; extract-bindings : sym (listof (cons str str)) -> (listof str) (define (extract-bindings name bindings) (map cdr (filter (lambda (x) (equal? name (car x))) bindings))) - + ; exists-binding? : sym (listof (cons sym str)) -> bool ; for checkboxes (define (exists-binding? name bindings) (if (assq name bindings) #t #f)) - + ; build-suspender : (listof html) (listof html) [(listof (cons sym str))] [(listof (cons sym str))] -> str -> response (define build-suspender (opt-lambda (title content [body-attributes '([bgcolor "white"])] [head-attributes null]) @@ -91,15 +223,15 @@ (title . ,title)) (body ,body-attributes (form ([action ,k-url] [method "post"]) - . ,content)))))) - + ,@content)))))) + ; redirection-status = (make-redirection-status nat str) (define-struct redirection-status (code message)) - + (define permanently (make-redirection-status 301 "Moved Permanently")) (define temporarily (make-redirection-status 302 "Moved Temporarily")) (define see-other (make-redirection-status 303 "See Other")) - + ; : str [redirection-status] -> response (define redirect-to (opt-lambda (uri [perm/temp permanently]) @@ -107,19 +239,19 @@ (redirection-status-message perm/temp) (current-seconds) #"text/html" `((location . ,uri)) (list (redirect-page uri))))) - + ; : str -> str (define (redirect-page url) (xexpr->string `(html (head (meta ((http-equiv "refresh") (url ,url))) "Redirect to " ,url) (body (p "Redirecting to " (a ([href ,url]) ,url)))))) - + ; make-html-response/incremental : ((string -> void) -> void) -> response/incremental (define (make-html-response/incremental chunk-maker) (make-response/incremental 200 "Okay" (current-seconds) #"text/html" '() chunk-maker)) - + ; : (response -> doesn't) -> void ; to report exceptions that occur later to the browser ; this must be called at the begining of a servlet @@ -131,13 +263,13 @@ (body ([bgcolor "white"]) (p "The following error occured: " (pre ,(exn->string exn))))))))) - + ; Authentication - + (define AUTHENTICATION-REGEXP (regexp "([^:]*):(.*)")) (define (match-authentication x) (regexp-match AUTHENTICATION-REGEXP x)) ;:(define match-authentication (type: (str -> (union false (list str str str))))) - + ; extract-user-pass : (listof (cons sym bytes)) -> (U #f (cons str str)) ;; Notes (GregP) ;; 1. This is Basic Authentication (RFC 1945 SECTION 11.1) @@ -150,19 +282,17 @@ (and pass-pair (let ([basic-credentials (cdr pass-pair)]) (cond - [(and (basic? basic-credentials) - (match-authentication - (base64-decode (subbytes basic-credentials 6 (bytes-length basic-credentials)))) + [(and (basic? basic-credentials) + (match-authentication + (base64-decode (subbytes basic-credentials 6 (bytes-length basic-credentials)))) ) - => (lambda (user-pass) - (cons (cadr user-pass) (caddr user-pass)))] - [else #f]))))) - + => (lambda (user-pass) + (cons (cadr user-pass) (caddr user-pass)))] + [else #f]))))) + ;; basic?: bytes -> (union (listof bytes) #f) ;; does the second part of the authorization header start with #"Basic " (define basic? (let ([basic-regexp (byte-regexp #"^Basic .*")]) (lambda (some-bytes) - (regexp-match basic-regexp some-bytes)))) - - ) + (regexp-match basic-regexp some-bytes))))) \ No newline at end of file diff --git a/collects/web-server/servlet-tables.ss b/collects/web-server/servlet-tables.ss index 95bb4f5b2c..2342799d17 100644 --- a/collects/web-server/servlet-tables.ss +++ b/collects/web-server/servlet-tables.ss @@ -175,8 +175,4 @@ (url-port in-url) new-path '() - (url-fragment in-url)))) - - ;; ************************************************** - - ) + (url-fragment in-url))))) diff --git a/collects/web-server/servlet.ss b/collects/web-server/servlet.ss index 580e068d8a..d01d2ad075 100644 --- a/collects/web-server/servlet.ss +++ b/collects/web-server/servlet.ss @@ -31,6 +31,13 @@ [(procedure? p-exp) (p->a p-exp)] [else p-exp])) + ;; get-current-servlet-instance : -> servlet + (define (get-current-servlet-instance) + (let ([inst (thread-cell-ref current-servlet-instance)]) + (unless inst + (raise (make-exn:servlet:no-current-instance "" (current-continuation-marks)))) + inst)) + ;; Weak contracts: the input is checked in output-response, and a message is ;; sent directly to the client (Web browser) instead of the terminal/log. (provide/contract @@ -59,14 +66,7 @@ ;; current-servlet-continuation-expiration-handler : request -> response (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:no-current-instance "" (current-continuation-marks)))) - inst)) - + ;; adjust-timeout! : sec -> void ;; adjust the timeout on the servlet (define (adjust-timeout! secs)