From 1c99e77b91ee89d9a821796c1fce49b21ff70fb7 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sun, 16 Oct 2005 17:08:25 +0000 Subject: [PATCH] Adding web-cells svn: r1095 --- collects/web-server/dispatch-servlets.ss | 760 ++++++++++++----------- collects/web-server/servlet.ss | 35 +- collects/web-server/web-cells.ss | 245 ++++++++ 3 files changed, 649 insertions(+), 391 deletions(-) create mode 100644 collects/web-server/web-cells.ss diff --git a/collects/web-server/dispatch-servlets.ss b/collects/web-server/dispatch-servlets.ss index 459bd1fc72..f54748fc04 100644 --- a/collects/web-server/dispatch-servlets.ss +++ b/collects/web-server/dispatch-servlets.ss @@ -19,384 +19,386 @@ (define interface-version 'v1) (define (gen-dispatcher host-info config:instances config:scripts config:make-servlet-namespace) - ;; ************************************************************ - ;; ************************************************************ - ;; SERVING SERVLETS - - ;; servlet-content-producer: connection request host -> void - (define (servlet-content-producer conn req host-info) - (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) - host-info)) - (cond - [(continuation-url? uri) - => (lambda (k-ref) - (invoke-servlet-continuation conn req k-ref host-info))] - [else - (servlet-content-producer/path conn req host-info uri)]))))) - - ;; read-bindings/handled: connection symbol url headers host -> (listof (list (symbol string)) - ;; read the bindings and handle any exceptions - (define (read-bindings/handled conn meth uri headers host-info) - (with-handlers ([exn? (lambda (e) - (output-response/method - conn - ;((responders-protocol (host-responders host-info)) - ; (exn-message e)) - ((responders-servlet-loading (host-responders - host-info)) - uri e) - - - meth) - '())]) - (read-bindings conn meth uri headers))) - - ;; servlet-content-producer/path: connection request host 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 host-info uri) - (with-handlers (;; couldn't find the servlet - [exn:fail:filesystem:exists:servlet? - (lambda (the-exn) - (output-response/method - conn - ((responders-file-not-found (host-responders - host-info)) - (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 - (host-responders host-info)) - uri the-exn) - (request-method req)))]) - (let ([sema (make-semaphore 0)] - [last-inst (thread-cell-ref current-servlet-instance)]) - (let/cc suspend - (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 - (paths-servlet (host-paths host-info)) - (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 host-info)] - [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 - (host-timeouts host-info)) - (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 host-info)]) - ;; 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 : host -> (request -> response) - (define (make-default-servlet-continuation-expiration-handler host-info) - (lambda (req) - (send/back + ;; ************************************************************ + ;; ************************************************************ + ;; SERVING SERVLETS + + ;; servlet-content-producer: connection request host -> void + (define (servlet-content-producer conn req host-info) + (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) + host-info)) + (cond + [(continuation-url? uri) + => (lambda (k-ref) + (invoke-servlet-continuation conn req k-ref host-info))] + [else + (servlet-content-producer/path conn req host-info uri)]))))) + + ;; read-bindings/handled: connection symbol url headers host -> (listof (list (symbol string)) + ;; read the bindings and handle any exceptions + (define (read-bindings/handled conn meth uri headers host-info) + (with-handlers ([exn? (lambda (e) + (output-response/method + conn + ;((responders-protocol (host-responders host-info)) + ; (exn-message e)) + ((responders-servlet-loading (host-responders + host-info)) + uri e) + + + meth) + '())]) + (read-bindings conn meth uri headers))) + + ;; servlet-content-producer/path: connection request host 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 host-info uri) + (with-handlers (;; couldn't find the servlet + [exn:fail:filesystem:exists:servlet? + (lambda (the-exn) + (output-response/method + conn + ((responders-file-not-found (host-responders + host-info)) + (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 + (host-responders host-info)) + 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 + (paths-servlet (host-paths host-info)) + (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 host-info)] + [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 + (host-timeouts host-info)) + (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 host-info)]) + ;; 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 : host -> (request -> response) + (define (make-default-servlet-continuation-expiration-handler host-info) + (lambda (req) + (send/back + ((responders-file-not-found (host-responders + host-info)) + (request-uri req))))) + + + ;; make-default-server-instance-expiration-handler : host -> (request -> response) + (define (make-default-servlet-instance-expiration-handler host-info) + (lambda (req) ((responders-file-not-found (host-responders host-info)) - (request-uri req))))) - - - ;; make-default-server-instance-expiration-handler : host -> (request -> response) - (define (make-default-servlet-instance-expiration-handler host-info) - (lambda (req) - ((responders-file-not-found (host-responders - host-info)) - (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 - ;; 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 host-info) - (lambda (the-exn) - (let* ([ctxt (servlet-instance-context inst)] - [req (execution-context-request ctxt)] - [resp ((responders-servlet (host-responders - host-info)) - (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 - ;; host -> void - ;; pull the continuation out of the table and apply it - (define (invoke-servlet-continuation conn req k-ref host-info) - (let-values ([(uk-instance uk-id uk-salt) (apply values k-ref)]) - (let* ([uri (request-uri req)] - [real-servlet-path (url-path->path - (paths-servlet (host-paths host-info)) - (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 host-info)] - [default-servlet-continuation-expiration-handler - (make-default-servlet-continuation-expiration-handler host-info)] - [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 - (host-timeouts host-info)) - (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) - servlet-custodian - (current-namespace) - (timeouts-default-servlet - (host-timeouts host-info)) - (make-default-servlet-instance-expiration-handler host-info)))] - [(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 - (host-timeouts host-info)) - (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 + (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 + ;; 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 host-info) + (lambda (the-exn) + (let* ([ctxt (servlet-instance-context inst)] + [req (execution-context-request ctxt)] + [resp ((responders-servlet (host-responders + host-info)) + (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 + ;; host -> void + ;; pull the continuation out of the table and apply it + (define (invoke-servlet-continuation conn req k-ref host-info) + (let-values ([(uk-instance uk-id uk-salt) (apply values k-ref)]) + (let* ([uri (request-uri req)] + [real-servlet-path (url-path->path + (paths-servlet (host-paths host-info)) + (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 host-info)] + [default-servlet-continuation-expiration-handler + (make-default-servlet-continuation-expiration-handler host-info)] + [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 + (host-timeouts host-info)) + (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) + servlet-custodian + (current-namespace) + (timeouts-default-servlet + (host-timeouts host-info)) + (make-default-servlet-instance-expiration-handler host-info)))] + [(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 + (host-timeouts host-info)) + (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 diff --git a/collects/web-server/servlet.ss b/collects/web-server/servlet.ss index dcc2e0ef63..01b1f0e84c 100644 --- a/collects/web-server/servlet.ss +++ b/collects/web-server/servlet.ss @@ -6,11 +6,13 @@ "response.ss" "servlet-helpers.ss" "xexpr-callback.ss" - "timer.ss") + "timer.ss" + "web-cells.ss") ;; 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 + [redirect/get (-> request?)] [adjust-timeout! (number? . -> . any)] [send/back (any/c . -> . any)] [send/finish (any/c . -> . any)] @@ -18,14 +20,22 @@ [send/forward (((string? . -> . any/c)) ((request? . -> . any/c)) . opt-> . request?)] ;;; validate-xexpr/callback is not checked anywhere: [send/suspend/callback (xexpr/callback? . -> . any)]) - + (provide clear-continuation-table! send/suspend/dispatch current-servlet-continuation-expiration-handler + (all-from "web-cells.ss") (all-from "servlet-helpers.ss") (all-from "xexpr-callback.ss")) + ;; ************************************************************ + ;; HIGHER-LEVEL EXPORTS + + ; redirect/get : -> request + (define (redirect/get) + (send/suspend (lambda (k-url) (redirect-to k-url temporarily)))) + ;; ************************************************************ ;; EXPORTS @@ -72,16 +82,17 @@ ;; send a response and apply the continuation to the next request (define send/suspend (opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)]) - (let/cc k - (let* ([inst (get-current-servlet-instance)] - [ctxt (servlet-instance-context inst)] - [k-url (store-continuation! - k expiration-handler - (request-uri (execution-context-request ctxt)) - inst)] - [response (response-generator k-url)]) - (output-response (execution-context-connection ctxt) response) - ((execution-context-suspend ctxt)))))) + (with-frame-after + (let/cc k + (let* ([inst (get-current-servlet-instance)] + [ctxt (servlet-instance-context inst)] + [k-url (store-continuation! + k expiration-handler + (request-uri (execution-context-request ctxt)) + inst)] + [response (response-generator k-url)]) + (output-response (execution-context-connection ctxt) response) + ((execution-context-suspend ctxt))))))) ;; send/forward: (url -> response) [(request -> response)] -> request ;; clear the continuation table, then behave like send/suspend diff --git a/collects/web-server/web-cells.ss b/collects/web-server/web-cells.ss new file mode 100644 index 0000000000..4f2251a177 --- /dev/null +++ b/collects/web-server/web-cells.ss @@ -0,0 +1,245 @@ +(module web-cells mzscheme + (require (lib "struct.ss")) + + (define-struct (exn:fail:frame:top exn) ()) + (define (exn:fail:frame:top-raise) + (raise (make-exn:fail:frame:top + "Reached top of stack" + (current-continuation-marks)))) + (provide exn:fail:frame:top?) + + ;; frames + (define-struct frame ()) + (define-struct (frame:empty frame) ()) + ; frame:ns : (alist * (box frame) * namespace) + (define-struct (frame:ns frame) (annotations boxed-parent namespace)) + + ; frame:ns?/raise : frame -> frame + (define (frame:ns?/raise f) + (if (frame:ns? f) + f + (exn:fail:frame:top-raise))) + + ; make-frame/parent : (box frame) -> frame:ns + (define (make-frame/parent parent-frame-box) + (make-frame:ns (list) parent-frame-box (make-namespace 'empty))) + + ; search-frames : frame:ns (frame:ns -> boolean?) -> frame + ; Returns the first frame in the stack that matches the predicate + (define (search-frames a-frame predicate?) + (if (predicate? a-frame) + a-frame + (search-frames (frame:ns?/raise + (unbox (frame:ns-boxed-parent a-frame))) + predicate?))) + + ; frame-ref : frame:ns symbol -> any + ; Lookups up the variable in the frame and its parent(s) + (define (frame-ref a-frame var) + #;(printf "~S~n" (list (namespace-mapped-symbols (frame:ns-namespace a-frame)) var)) + (namespace-variable-value + var #f + (lambda () + (frame-ref (frame:ns?/raise + (unbox (frame:ns-boxed-parent a-frame))) + var)) + (frame:ns-namespace a-frame))) + + ; frame-set? : frame:ns symbol -> boolean + (define (frame-set? a-frame var) + (not + (not + (namespace-variable-value + var #f + (lambda () #f) + (frame:ns-namespace a-frame))))) + + ; frame-set! : frame:ns symbol any -> void + ; Sets the variable in the frame to a value + (define (frame-set! a-frame var val) + (namespace-set-variable-value! + var val + #t (frame:ns-namespace a-frame))) + + ;; frame stacks + + (define *global-root-id* (gensym)) + (define *session-root-id* (gensym)) + + ; *frame-stack* : (box frame) + (define *frame-stack* + (make-parameter + (box (copy-struct frame:ns (make-frame/parent (box (make-frame:empty))) + [frame:ns-annotations (list (cons *global-root-id* #t))])))) + + ; annotation-present? : symbol frame:ns -> boolean + (define (annotation-present? i a-frame) + (not (not (assq i (frame:ns-annotations a-frame))))) + + ; global-root? : frame:ns -> boolean + (define (global-root? a-frame) + (annotation-present? *global-root-id* a-frame)) + + ; session-root? : frame:ns -> boolean + (define (session-root? a-frame) + (annotation-present? *session-root-id* a-frame)) + + ; make-frame/top : -> frame:ns + (define (make-frame/top) + (let* ([cur-top-box (*frame-stack*)] + [cur-top (unbox cur-top-box)]) + (cond + #;[(not (frame:ns? cur-top)) + ; Construct global + (copy-struct frame:ns (make-frame/parent cur-top-box) + [frame:ns-annotations (list (cons *global-root-id* #t))])] + [(global-root? cur-top) + ; Construct session + (copy-struct frame:ns (make-frame/parent cur-top-box) + [frame:ns-annotations (list (cons *session-root-id* #t))])] + [else + ; Construct normal + (make-frame/parent cur-top-box)]))) + + ; push-frame! : -> void + ; Pushs a new frame onto the session stack + (define (push-frame!) + (*frame-stack* (box (make-frame/top)))) + + ; pop-frame! : -> void + ; Pops the frame from the stack + (define (pop-frame!) + (*frame-stack* (frame:ns-boxed-parent (unbox (*frame-stack*))))) + + ; save-stack/push/return : (-> 'a) -> 'a + ; Pushes a frame after the thunk's execution with the same parent as the call site + (define (save-stack/push/return thunk) + (let ([initial-stack (*frame-stack*)]) + (begin0 (thunk) + (*frame-stack* initial-stack) + (push-frame!)))) + + ; syntax version of above + (define-syntax with-frame-after + (syntax-rules () + [(_ body ...) + (save-stack/push/return (lambda () body ...))])) + + ; parameterized-push : (-> 'a) -> 'a + (define (parameterized-push thunk) + (parameterize ([*frame-stack* (box (make-frame/top))]) + (thunk))) + + ; syntax version of above + (define-syntax with-frame + (syntax-rules () + [(_ body ...) + (parameterized-push (lambda () body ...))])) + + ; search-stack : (frame -> boolean) -> frame + (define (search-stack predicate?) + (search-frames (frame:ns?/raise (unbox (*frame-stack*))) + predicate?)) + + ; cells + (define-struct cell (id)) + (define-struct (cell:global cell) ()) + (define-struct (cell:session cell) ()) + (define-struct (cell:local cell) ()) + + ; ext:make-'a 'b -> 'a + (define (ext:make-cell:global default) + (let ([new-name (gensym)]) + (frame-set! (search-stack global-root?) + new-name default) + (make-cell:global new-name))) + (define (ext:make-cell:session default) + (let ([new-name (gensym)]) + (frame-set! (search-stack global-root?) + new-name default) + (make-cell:session new-name))) + (define (ext:make-cell:local default) + (let ([new-name (gensym)]) + (frame-set! (search-stack global-root?) + new-name default) + (make-cell:local new-name))) + + ; cell:global-ref : cell:global -> any + ; returns the value of the global cell + (define (cell:global-ref gc) + (frame-ref (search-stack global-root?) + (cell-id gc))) + ; cell:global-set! : cell:global any -> void + ; sets the value of the global cell + (define (cell:global-set! gc nv) + (frame-set! (search-stack global-root?) + (cell-id gc) + nv)) + + ; cell:session-ref : cell:session -> any + ; returns the value of the session cell + (define (cell:session-ref sc) + (frame-ref (search-stack session-root?) + (cell-id sc))) + ; cell:session-set! : cell:session any -> void + ; sets the value of the session cell + (define (cell:session-set! sc nv) + (frame-set! (search-stack session-root?) + (cell-id sc) + nv)) + + ; cell:local-ref : cell:local -> any + ; returns the value of the local cell + (define (cell:local-ref lc) + (frame-ref (search-stack frame?) + (cell-id lc))) + ; cell:local-set! : cell:local any -> void + ; sets the value of the local cell at the last place it was set, including the default + (define (cell:local-set! lc nv) + (frame-set! (search-stack + (lambda (f) (frame-set? f (cell-id lc)))) + (cell-id lc) + nv)) + ; cell:local-mask : cell:local any -> void + ; masks the local cell to the given value + (define (cell:local-mask lc nv) + (frame-set! (search-stack frame?) + (cell-id lc) + nv)) + + ; cell-ref : cell -> any + (define (cell-ref c) + (cond + [(cell:global? c) (cell:global-ref c)] + [(cell:session? c) (cell:session-ref c)] + [(cell:local? c) (cell:local-ref c)])) + +; ;; linking parameters to cells +; (define *parameter-links* (ext:make-cell:session (list))) +; (define-struct parameter-link (parameter cell)) +; +; ; link-parameter : parameter cell -> void +; (define (link-parameter p c) +; (cell:session-set! *parameter-links* +; (cons (make-parameter-link p c) +; (cell:session-ref *parameter-links*)))) +; +; ; reinstall-linked-parameters : -> void +; (define (reinstall-linked-parameters) +; (for-each (lambda (link) +; ((parameter-link-parameter link) +; (cell-ref (parameter-link-cell link)))) +; (cell:session-ref *parameter-links*))) + + (provide with-frame + with-frame-after + (rename ext:make-cell:global make-web-cell:global) + (rename cell:global-ref web-cell:global-ref) + (rename cell:global-set! web-cell:global-set!) + (rename ext:make-cell:session make-web-cell:session) + (rename cell:session-ref web-cell:session-ref) + (rename cell:session-set! web-cell:session-set!) + (rename ext:make-cell:local make-web-cell:local) + (rename cell:local-ref web-cell:local-ref) + (rename cell:local-set! web-cell:local-set!) + (rename cell:local-mask web-cell:local-mask))) \ No newline at end of file