From 34cd19c52ea8bbba5fc7cd38f541bf58251c68e3 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 13 May 2006 06:05:04 +0000 Subject: [PATCH] allowing different continuation managers svn: r2930 --- collects/web-server/connection-manager.ss | 2 +- collects/web-server/dispatch-servlets.ss | 496 +++++++++--------- collects/web-server/managers/manager.ss | 15 + collects/web-server/managers/timeouts.ss | 113 ++++ collects/web-server/private/servlet.ss | 31 ++ collects/web-server/private/url.ss | 12 +- collects/web-server/servlet-env.ss | 15 +- collects/web-server/servlet-tables.ss | 111 ---- collects/web-server/servlet.ss | 51 +- collects/web-server/timer.ss | 8 +- .../tools/backend-servlet-testing.ss | 7 +- collects/web-server/tools/backend.ss | 12 +- .../tools/servlet-testing-framework.ss | 11 +- 13 files changed, 456 insertions(+), 428 deletions(-) create mode 100644 collects/web-server/managers/manager.ss create mode 100644 collects/web-server/managers/timeouts.ss create mode 100644 collects/web-server/private/servlet.ss delete mode 100644 collects/web-server/servlet-tables.ss diff --git a/collects/web-server/connection-manager.ss b/collects/web-server/connection-manager.ss index 8b2c98eebf..59e823e276 100644 --- a/collects/web-server/connection-manager.ss +++ b/collects/web-server/connection-manager.ss @@ -44,4 +44,4 @@ ;; adjust-connection-timeout!: connection number -> void ;; change the expiration time for this connection (define (adjust-connection-timeout! conn time) - (reset-timer (connection-timer conn) time))) \ No newline at end of file + (reset-timer! (connection-timer conn) time))) \ No newline at end of file diff --git a/collects/web-server/dispatch-servlets.ss b/collects/web-server/dispatch-servlets.ss index bcee7eb4da..b0b6f84879 100644 --- a/collects/web-server/dispatch-servlets.ss +++ b/collects/web-server/dispatch-servlets.ss @@ -1,16 +1,19 @@ (module dispatch-servlets mzscheme (require (lib "url.ss" "net") + (lib "plt-match.ss") + (lib "class.ss") (lib "unitsig.ss")) (require "dispatch.ss" "web-server-structs.ss" "connection-manager.ss" "response.ss" - "servlet-tables.ss" "servlet.ss" "sig.ss" - "timer.ss" "util.ss" + "managers/manager.ss" + "managers/timeouts.ss" "private/url.ss" + "private/servlet.ss" "private/cache-table.ss") (provide interface-version gen-dispatcher) @@ -27,24 +30,27 @@ ;; 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)]))))) + (define meth (request-method req)) + (define uri (request-uri req)) + (case meth + [(head) + (output-response/method + conn + (make-response/full + 200 "Okay" (current-seconds) TEXT/HTML-MIME-TYPE + '() (list "ignored")) + meth)] + [else + (set-request-bindings/raw! + req + (read-bindings/handled conn meth uri (request-headers req))) + (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)])])) ;; read-bindings/handled: connection symbol url headers -> (listof (list (symbol string)) ;; read the bindings and handle any exceptions @@ -66,74 +72,71 @@ [(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)))) + (define servlet-mutex (make-semaphore 0)) + (define last-servlet (thread-cell-ref current-servlet)) + (define last-servlet-instance-id (thread-cell-ref current-servlet-instance-id)) + (let/cc suspend + ; Create the session frame + (with-frame + (define instance-custodian (make-servlet-custodian)) + (define 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))))) + (parameterize ([current-directory (get-servlet-base-dir servlet-path)] + [current-custodian instance-custodian] + [exit-handler + (lambda _ + (kill-connection! conn) + (custodian-shutdown-all instance-custodian))]) + ;; any resources (e.g. threads) created when the + ;; servlet is loaded should be within the dynamic + ;; extent of the servlet custodian + (define the-servlet (cached-load servlet-path)) + (thread-cell-set! current-servlet the-servlet) + (parameterize ([current-namespace (servlet-namespace the-servlet)]) + (define manager (servlet-manager the-servlet)) + (define data + (make-servlet-instance-data + servlet-mutex + (make-execution-context + conn req (lambda () (suspend #t))))) + (define the-exit-handler + (lambda _ + (kill-connection! + (execution-context-connection + (servlet-instance-data-context + data))) + (custodian-shutdown-all instance-custodian))) + (parameterize ([exit-handler the-exit-handler]) + (define instance-id (send manager create-instance data the-exit-handler)) + (thread-cell-set! current-servlet-instance-id instance-id) + (with-handlers ([(lambda (x) #t) + (make-servlet-exception-handler data)]) + ;; 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. + (define r ((servlet-handler the-servlet) req)) + (when (response? r) + (send/back r)))))))) + (thread-cell-set! current-servlet last-servlet) + (thread-cell-set! current-servlet-instance-id last-servlet-instance-id) + (semaphore-post servlet-mutex))) - ;; 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)))) + ;; default-server-instance-expiration-handler : (request -> response) + (define (default-servlet-instance-expiration-handler req) + (responders-file-not-found + (request-uri req))) ;; make-servlet-exception-handler: servlet-instance -> exn -> void ;; This exception handler traps all unhandled servlet exceptions @@ -148,101 +151,81 @@ ;; * 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))))) + (define ((make-servlet-exception-handler inst-data) the-exn) + (define context (servlet-instance-data-context inst-data)) + (define request (execution-context-request context)) + (define resp + (responders-servlet + (request-uri request) + the-exn)) + ;; Don't handle twice + (with-handlers ([exn:fail? (lambda (exn) (void))]) + (output-response/method + (execution-context-connection context) + resp (request-method request))) + ((execution-context-suspend context))) ;; 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)))))) + (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)))) ;; 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)))))) + (define (invoke-servlet-continuation conn req instance-id k-id salt) + (define uri (request-uri req)) + (define servlet-path + (url-path->path + servlet-root + (url-path->string (url-path uri)))) + (define last-servlet (thread-cell-ref current-servlet)) + (define last-servlet-instance-id (thread-cell-ref current-servlet-instance-id)) + (define the-servlet (cached-load servlet-path)) + (define manager (servlet-manager the-servlet)) + (thread-cell-set! current-servlet the-servlet) + (thread-cell-set! current-servlet-instance-id instance-id) + (parameterize ([current-custodian (servlet-custodian the-servlet)]) + (with-handlers ([exn:fail:servlet-manager:no-instance? + (lambda (the-exn) + (output-response/method + conn + ((exn:fail:servlet-manager:no-instance-expiration-handler the-exn) + req) + (request-method req)))] + [exn:fail:servlet-manager:no-continuation? + (lambda (the-exn) + (output-response/method + conn + ((exn:fail:servlet-manager:no-continuation-expiration-handler the-exn) + req) + (request-method req)))] + [exn:fail:servlet:instance? + (lambda (the-exn) + (output-response/method + conn + (default-servlet-instance-expiration-handler + req) + (request-method req)))]) + (define data (send manager instance-lookup-data instance-id)) + ; 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-data-mutex data)) + (let/cc suspend + (define k (send manager continuation-lookup instance-id k-id salt)) + (set-servlet-instance-data-context! + data + (make-execution-context + conn req (lambda () (suspend #t)))) + (k req)) + (semaphore-post (servlet-instance-data-mutex data)))) + (thread-cell-set! current-servlet-instance-id last-servlet-instance-id) + (thread-cell-set! current-servlet last-servlet)) ;; ************************************************************ ;; ************************************************************ @@ -252,12 +235,12 @@ ;; 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))))) + (define 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) @@ -297,77 +280,88 @@ (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)])))))) + (parameterize ([current-namespace (config:make-servlet-namespace)] + [current-custodian (make-servlet-custodian)]) + ; XXX load/use-compiled breaks errortrace + (define 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 (current-custodian) + (current-namespace) + (make-object timeout-manager% + default-servlet-instance-expiration-handler + timeouts-servlet-connection + timeouts-default-servlet) + (v0.servlet->v1.lambda s))] + ; 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 (current-custodian) + (current-namespace) + (make-object timeout-manager% + default-servlet-instance-expiration-handler + timeouts-servlet-connection + timeouts-default-servlet) + (v1.module->v1.lambda timeout start)))] + [(v2-transitional) ; XXX: Undocumented + (let ([start (dynamic-require module-name 'start)] + [manager (with-handlers + ([exn:fail:contract? + (lambda (exn) + (define timeout (dynamic-require module-name 'timeout)) + (define instance-expiration-handler + (dynamic-require module-name 'instance-expiration-handler)) + (make-object timeout-manager% + instance-expiration-handler + timeouts-servlet-connection + timeout))]) + (dynamic-require module-name 'manager))]) + (make-servlet (current-custodian) + (current-namespace) + manager + start))] + [else + (error 'load-servlet/path "unknown servlet version ~e" version)]))] + ;; response + [(response? s) + (make-servlet (current-custodian) + (current-namespace) + (make-object timeout-manager% + default-servlet-instance-expiration-handler + timeouts-servlet-connection + timeouts-default-servlet) + (v0.response->v1.lambda s a-path))] + [else + (error '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)))) + (define svt-bin-re (regexp "^/servlets(;.*\\*.*\\*.*)?/.*")) + (define (servlet-bin? 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 + (define-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/managers/manager.ss b/collects/web-server/managers/manager.ss new file mode 100644 index 0000000000..c22f4f4c02 --- /dev/null +++ b/collects/web-server/managers/manager.ss @@ -0,0 +1,15 @@ +(module manager mzscheme + (require (lib "class.ss")) + (provide (all-defined)) + + (define manager<%> + (interface () + create-instance + adjust-timeout! + instance-lookup-data + clear-continuations! + continuation-store! + continuation-lookup)) + + (define-struct (exn:fail:servlet-manager:no-instance exn:fail) (expiration-handler)) + (define-struct (exn:fail:servlet-manager:no-continuation exn:fail) (expiration-handler))) \ No newline at end of file diff --git a/collects/web-server/managers/timeouts.ss b/collects/web-server/managers/timeouts.ss new file mode 100644 index 0000000000..94e2250ece --- /dev/null +++ b/collects/web-server/managers/timeouts.ss @@ -0,0 +1,113 @@ +(module timeouts mzscheme + (require (lib "class.ss") + (lib "plt-match.ss")) + (require "manager.ss") + (require "../timer.ss") + (provide timeout-manager%) + + ;; Utility + (define (make-counter) + (let ([i 0]) + (lambda () + (set! i (add1 i)) + i))) + + (define timeout-manager% + (class* object% (manager<%>) + (init-field instance-expiration-handler + instance-timer-length + continuation-timer-length) + (public create-instance + adjust-timeout! + instance-lookup-data + clear-continuations! + continuation-store! + continuation-lookup) + + ;; Instances + (define instances (make-hash-table)) + (define next-instance-id (make-counter)) + + (define-struct instance (data k-table timer)) + (define (create-instance data expire-fn) + (define instance-id (next-instance-id)) + (hash-table-put! instances + instance-id + (make-instance data + (create-k-table) + (start-timer instance-timer-length + (lambda () + (expire-fn) + (hash-table-remove! instances instance-id))))) + instance-id) + (define (adjust-timeout! instance-id secs) + (reset-timer! (instance-timer (instance-lookup instance-id)) + secs)) + + (define (instance-lookup instance-id) + (define instance + (hash-table-get instances instance-id + (lambda () + (raise (make-exn:fail:servlet-manager:no-instance + (format "No instance for id: ~a" instance-id) + (current-continuation-marks) + instance-expiration-handler))))) + (increment-timer! (instance-timer instance) + instance-timer-length) + instance) + + ;; Continuation table + (define-struct k-table (next-id-fn htable)) + (define (create-k-table) + (make-k-table (make-counter) (make-hash-table))) + + ;; Interface + (define (instance-lookup-data instance-id) + (instance-data (instance-lookup instance-id))) + + (define (clear-continuations! instance-id) + (match (instance-lookup instance-id) + [(struct instance (data (and k-table (struct k-table (next-id-fn htable))) instance-timer)) + (hash-table-for-each + htable + (match-lambda* + [(list k-id (list salt k expiration-handler k-timer)) + (hash-table-put! htable k-id + (list salt #f expiration-handler k-timer))]))])) + + (define (continuation-store! instance-id k expiration-handler) + (match (instance-lookup instance-id) + [(struct instance (data (struct k-table (next-id-fn htable)) instance-timer)) + (define k-id (next-id-fn)) + (define salt (random 100000000)) + (hash-table-put! htable + k-id + (list salt k expiration-handler + (start-timer continuation-timer-length + (lambda () + (hash-table-put! htable k-id + (list salt #f expiration-handler + (start-timer 0 void))))))) + (list k-id salt)])) + (define (continuation-lookup instance-id a-k-id a-salt) + (match (instance-lookup instance-id) + [(struct instance (data (struct k-table (next-id-fn htable)) instance-timer)) + (match + (hash-table-get htable a-k-id + (lambda () + (raise (make-exn:fail:servlet-manager:no-continuation + (format "No continuation for id: ~a" a-k-id) + (current-continuation-marks) + instance-expiration-handler)))) + [(list salt k expiration-handler k-timer) + (increment-timer! k-timer + continuation-timer-length) + (if (or (not (eq? salt a-salt)) + (not k)) + (raise (make-exn:fail:servlet-manager:no-continuation + (format "No continuation for id: ~a" a-k-id) + (current-continuation-marks) + expiration-handler)) + k)])])) + + (super-new)))) \ No newline at end of file diff --git a/collects/web-server/private/servlet.ss b/collects/web-server/private/servlet.ss new file mode 100644 index 0000000000..806b7318b9 --- /dev/null +++ b/collects/web-server/private/servlet.ss @@ -0,0 +1,31 @@ +(module servlet mzscheme + (require (lib "class.ss")) + (require "../managers/manager.ss") + + (define-struct (exn:fail:servlet:instance exn:fail) ()) + (define-struct servlet (custodian namespace manager handler)) + (define-struct servlet-instance-data (mutex context)) + + (define-struct execution-context (connection request suspend)) + + (define current-servlet (make-thread-cell #f)) + (define current-servlet-instance-id (make-thread-cell #f)) + + (define (get-current-servlet-instance-id) + (define instance-id (thread-cell-ref current-servlet-instance-id)) + (unless instance-id + (raise (make-exn:fail:servlet:instance "" (current-continuation-marks)))) + instance-id) + + (define (current-servlet-manager) + (define servlet (thread-cell-ref current-servlet)) + (unless servlet + (raise (make-exn:fail:servlet:instance "" (current-continuation-marks)))) + (servlet-manager servlet)) + + (define (current-servlet-instance-data) + (define manager (current-servlet-manager)) + (define instance-id (thread-cell-ref current-servlet-instance-id)) + (send manager instance-lookup-data instance-id)) + + (provide (all-defined))) \ No newline at end of file diff --git a/collects/web-server/private/url.ss b/collects/web-server/private/url.ss index 772313754c..6306ddb0a5 100644 --- a/collects/web-server/private/url.ss +++ b/collects/web-server/private/url.ss @@ -7,8 +7,8 @@ (provide match-url-params) (provide/contract - [continuation-url? (url? . -> . (or/c boolean? (list/c symbol? number? number?)))] - [embed-ids ((list/c symbol? number? number?) url? . -> . string?)]) + [continuation-url? (url? . -> . (or/c boolean? (list/c number? number? number?)))] + [embed-ids ((list/c number? number? number?) url? . -> . string?)]) ;; ******************************************************************************** ;; Parameter Embedding @@ -35,11 +35,13 @@ #f (match (match-url-params (first k-params)) [(list s instance k-id salt) - (let ([k-id/n (string->number k-id)] + (let ([instance/n (string->number instance)] + [k-id/n (string->number k-id)] [salt/n (string->number salt)]) - (if (and (number? k-id/n) + (if (and (number? instance/n) + (number? k-id/n) (number? salt/n)) - (list (string->symbol instance) + (list instance/n k-id/n salt/n) ; XXX: Maybe log this in some way? diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 72bd05311d..170b92dcf7 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -1,12 +1,14 @@ (module servlet-env mzscheme (require (lib "sendurl.ss" "net") + (lib "class.ss") (lib "unitsig.ss")) (require "configuration.ss" "web-server.ss" "sig.ss" - "servlet-tables.ss" "util.ss" "response.ss" + "managers/timeouts.ss" + "private/servlet.ss" "private/cache-table.ss") (require "servlet.ss") (provide (rename on-web:syntax on-web) @@ -61,13 +63,14 @@ "default-web-root" "." the-path))) (lambda () - (make-servlet the-servlet - (make-custodian) + (make-servlet (make-custodian) (i:make-servlet-namespace) - 30 - (lambda (request) + (make-object timeout-manager% + (lambda (request) `(html (head "Return to the interaction window.") - (body (p "Return to the interaction window."))))))) + (body (p "Return to the interaction window.")))) + 30 30) + the-servlet))) (unit/sig web-config^ (import) (define port the-port) diff --git a/collects/web-server/servlet-tables.ss b/collects/web-server/servlet-tables.ss deleted file mode 100644 index 3b877ccebf..0000000000 --- a/collects/web-server/servlet-tables.ss +++ /dev/null @@ -1,111 +0,0 @@ -(module servlet-tables mzscheme - (require (lib "contract.ss")) - (require "timer.ss") - (provide (struct exn:servlet:instance ()) - (struct exn:servlet:no-current-instance ()) - (struct exn:servlet:continuation (expiration-handler)) - (struct servlet (handler custodian namespace connection-interval-timeout instance-expiration-handler)) - (struct execution-context (connection request suspend)) - (struct servlet-instance (id k-table custodian context mutex timer)) - current-servlet-instance) - - ;; current-servlet-instance. The server will parameterize - ;; over the current-servlet-instance before invoking a servlet - ;; or invoking a continuation. The current-servlet-instance - ;; will be in affect for the entire dynamic extent of every - ;; continuation associated with that instance. - (define current-servlet-instance (make-thread-cell #f)) - (define-struct servlet (handler custodian namespace connection-interval-timeout instance-expiration-handler)) - (define-struct servlet-instance (id k-table custodian context mutex timer)) - (define-struct execution-context (connection request suspend)) - - ;; Notes: - ;; * The servlet-instance-id is the key used for finding the servlet-instance in - ;; instance table. - ;; * The servlet-instance-k-table stores continuations that were created - ;; during this instance. - ;; * The servlet-instance-execution-context stores the context in which the - ;; instance is executing. The servlet-instance can have only one - ;; execution-context at any particular time. The execution-context will be - ;; updated whenever a continuation associated with this instance is - ;; invoked. - ;; * The servlet-instance-mutex is used to guarentee mutual-exclusion in the - ;; case when it is attempted to invoke multiple continuations - ;; simultaneously. - (provide/contract - [store-continuation! (procedure? procedure? servlet-instance? . -> . (list/c symbol? integer? integer?))] - [create-new-instance! (hash-table? custodian? execution-context? semaphore? timer? - . -> . servlet-instance?)] - [remove-instance! (hash-table? servlet-instance? . -> . any)] - [clear-continuations! (servlet-instance? . -> . any)]) - - ;; not found in the instance table - (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:no-current-instance exn) ()) - - (define-values (make-k-table reset-k-table get-k-id!) - (let ([id-slot 'next-k-id]) - (values - - ;; make-k-table: -> (hash-table-of (continuation x expiration handler x salt)) - ;; Create a continuation table with an initial value for the next - ;; continuation id. - (lambda () - (let ([k-table (make-hash-table)]) - (hash-table-put! k-table id-slot 0) - k-table)) - - ;; reset-k-table : hash-table -> (hash-table-of (#f x expiration handler x salt )) - ;; Remove the continuations from the k-table - (lambda (k-table0) - (let ([k-table1 (make-hash-table)] - [next-id (hash-table-get k-table0 id-slot)]) - (hash-table-for-each - k-table0 - (lambda (id v) - (if (eq? id id-slot) - ; Save old next-id - (hash-table-put! k-table1 id v) - ; Replace continuations with #f - (hash-table-put! k-table1 id (list* #f (cdr v)))))) - k-table1)) - - ;; get-k-id!: hash-table -> number - ;; get the current-continuation id and increment the internal value - (lambda (k-table) - (let ([id (hash-table-get k-table id-slot)]) - (hash-table-put! k-table id-slot (add1 id)) - id))))) - - ;; store-continuation!: continuation expiration-handler servlet-instance -> (list symbol? integer? integer?) - ;; store a continuation in a k-table for the provided servlet-instance - (define (store-continuation! k expiration-handler inst) - (let ([k-table (servlet-instance-k-table inst)]) - (let ([next-k-id (get-k-id! k-table)] - [salt (random 100000000)]) - (hash-table-put! k-table next-k-id (list k expiration-handler salt)) - (list (servlet-instance-id inst) next-k-id salt)))) - - ;; clear-continuations!: servlet-instance -> void - ;; replace the k-table for the given servlet-instance - (define (clear-continuations! inst) - (set-servlet-instance-k-table! - inst - (reset-k-table - (servlet-instance-k-table inst)))) - - ;; create-new-instance! hash-table custodian execution-context semaphore -> servlet-instance - (define (create-new-instance! instance-table cust ctxt sema timer) - (let* ([inst-id (string->symbol (symbol->string (gensym 'id)))] - [inst - (make-servlet-instance - inst-id (make-k-table) cust ctxt sema timer)]) - (hash-table-put! instance-table inst-id inst) - inst)) - - ;; remove-instance!: hash-table servlet-instance -> void - (define (remove-instance! instance-table inst) - (hash-table-remove! instance-table (servlet-instance-id inst)))) \ No newline at end of file diff --git a/collects/web-server/servlet.ss b/collects/web-server/servlet.ss index b4ae2533c4..57745a0a87 100644 --- a/collects/web-server/servlet.ss +++ b/collects/web-server/servlet.ss @@ -1,9 +1,10 @@ (module servlet mzscheme (require (lib "contract.ss") + (lib "class.ss") (lib "etc.ss") (lib "xml.ss" "xml")) - (require "servlet-tables.ss" - "response.ss" + (require "response.ss" + "private/servlet.ss" "private/url.ss" "servlet-helpers.ss" "timer.ss" @@ -11,7 +12,7 @@ ;; CONTRACT HELPERS (define servlet-response? any/c) - + (define (xexpr/callback? x) (correct-xexpr? x (lambda () #t) @@ -20,7 +21,7 @@ #t (begin ((error-display-handler) (exn-message exn) exn) #f))))) - + (define response-generator? (string? . -> . servlet-response?)) @@ -38,7 +39,7 @@ ;; ************************************************************ ;; HELPERS - + ;; replace-procedures : (proc -> url) xexpr/callbacks? -> xexpr? ;; Change procedures to the send/suspend of a k-url (define (xexpr/callback->xexpr p->a p-exp) @@ -46,14 +47,7 @@ [(list? p-exp) (map (lambda (p-e) (xexpr/callback->xexpr p->a p-e)) p-exp)] [(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)) + [else p-exp])) ;; 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. @@ -93,19 +87,18 @@ ;; adjust-timeout! : sec -> void ;; adjust the timeout on the servlet (define (adjust-timeout! secs) - (reset-timer (servlet-instance-timer (get-current-servlet-instance)) - secs)) + (send (current-servlet-manager) adjust-timeout! (get-current-servlet-instance-id) secs)) ;; ext:clear-continuations! -> void (define (clear-continuation-table!) - (clear-continuations! (get-current-servlet-instance))) + (send (current-servlet-manager) clear-continuations! (get-current-servlet-instance-id))) ;; send/back: response -> void ;; send a response and don't clear the continuation table (define (send/back resp) - (let ([ctxt (servlet-instance-context (get-current-servlet-instance))]) - (output-response (execution-context-connection ctxt) resp) - ((execution-context-suspend ctxt)))) + (define ctxt (servlet-instance-data-context (current-servlet-instance-data))) + (output-response (execution-context-connection ctxt) resp) + ((execution-context-suspend ctxt))) ;; send/finish: response -> void ;; send a response and clear the continuation table @@ -124,16 +117,16 @@ (opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)]) (with-frame-after (let/cc k - (let* ([inst (get-current-servlet-instance)] - [ctxt (servlet-instance-context inst)] - [k-embedding (store-continuation! k expiration-handler inst)] - [k-url (embed-ids - k-embedding - (request-uri (execution-context-request ctxt)))] - [k-url ((current-url-transform) k-url)] - [response (response-generator k-url)]) - (output-response (execution-context-connection ctxt) response) - ((execution-context-suspend ctxt))))))) + (define instance-id (get-current-servlet-instance-id)) + (define ctxt (servlet-instance-data-context (current-servlet-instance-data))) + (define k-embedding (send (current-servlet-manager) continuation-store! instance-id k expiration-handler)) + (define k-url ((current-url-transform) + (embed-ids + (list* instance-id k-embedding) + (request-uri (execution-context-request ctxt))))) + (define 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/timer.ss b/collects/web-server/timer.ss index a01018c617..ca6fd2f332 100644 --- a/collects/web-server/timer.ss +++ b/collects/web-server/timer.ss @@ -3,7 +3,7 @@ (require (lib "list.ss") (lib "async-channel.ss")) (provide timer? - start-timer reset-timer increment-timer + start-timer reset-timer! increment-timer! cancel-timer! start-timer-manager) @@ -73,12 +73,12 @@ ; reset-timer : timer num -> void ; to cause timer to expire after sec from the adjust-msec-to-live's application - (define (reset-timer timer secs) + (define (reset-timer! timer secs) (revise-timer! timer (* 1000 secs) (timer-action timer))) - ; increment-timer : timer num -> void + ; increment-timer! : timer num -> void ; add secs to the timer, rather than replace - (define (increment-timer timer secs) + (define (increment-timer! timer secs) (revise-timer! timer (+ (- (timer-expire-seconds timer) (current-inexact-milliseconds)) (* 1000 secs)) diff --git a/collects/web-server/tools/backend-servlet-testing.ss b/collects/web-server/tools/backend-servlet-testing.ss index 8021c70f24..28d638c9d3 100644 --- a/collects/web-server/tools/backend-servlet-testing.ss +++ b/collects/web-server/tools/backend-servlet-testing.ss @@ -1,12 +1,11 @@ (module backend-servlet-testing mzscheme (require (lib "connection-manager.ss" "web-server") - (lib "servlet-tables.ss" "web-server") (lib "request-parsing.ss" "web-server") "backend.ss" (lib "url.ss" "net") (lib "xml.ss" "xml") (lib "match.ss") - ) + (lib "private/url.ss" "web-server")) (provide run-servlet simple-start-servlet simple-resume-servlet) @@ -92,6 +91,4 @@ ;; Produce a new request, with an url (define (new-request/url new-url) (make-request - 'get new-url '() (url-query new-url) "a-host-ip" "a-client-ip")) - - ) + 'get new-url '() (url-query new-url) "a-host-ip" "a-client-ip"))) \ No newline at end of file diff --git a/collects/web-server/tools/backend.ss b/collects/web-server/tools/backend.ss index dc8984741c..1eeadb2848 100644 --- a/collects/web-server/tools/backend.ss +++ b/collects/web-server/tools/backend.ss @@ -1,9 +1,7 @@ (module backend mzscheme (require (lib "servlet.ss" "web-server") - (lib "servlet-tables.ss" "web-server") (lib "timer.ss" "web-server") (lib "response.ss" "web-server") - (all-except (lib "request-parsing.ss" "web-server") request-bindings) (lib "connection-manager.ss" "web-server")) (provide start-servlet resume-servlet) @@ -33,7 +31,7 @@ (with-handlers ([(lambda (x) #t) (make-servlet-exception-handler inst)]) (let ([r (svt (lambda (secs) - (reset-timer time-bomb secs)) + (reset-timer! time-bomb secs)) req)]) (when (response? r) (send/back r))))))) @@ -70,7 +68,7 @@ (let* ([inst (hash-table-get instance-table (car k-ref) (lambda () (raise - (make-exn:servlet-instance + (make-exn:servlet:instance "" (current-continuation-marks)))))] [k-table (servlet-instance-k-table inst)]) @@ -83,9 +81,7 @@ ((hash-table-get k-table (cadr k-ref) (lambda () (raise - (make-exn:servlet-continuation + (make-exn:servlet:continuation "" (current-continuation-marks))))) req)) - (semaphore-post (servlet-instance-mutex inst)))) - ) - + (semaphore-post (servlet-instance-mutex inst))))) \ No newline at end of file diff --git a/collects/web-server/tools/servlet-testing-framework.ss b/collects/web-server/tools/servlet-testing-framework.ss index 580b5c9a48..2a5af6dff7 100644 --- a/collects/web-server/tools/servlet-testing-framework.ss +++ b/collects/web-server/tools/servlet-testing-framework.ss @@ -3,7 +3,7 @@ ;; server was written with the assumption that continuations exist across ;; threads; this is not the case in the exp Web server. As a result, only one ;; thread should be used at a time. - +;; ;; Since the real send/* are used, with their full continuation table, one can ;; use this to fully pretend to be a Web browser, including back buttons and ;; cloning Web pages. @@ -17,10 +17,7 @@ (lib "servlet.ss" "web-server") (lib "servlet-tables.ss" "web-server") (lib "connection-manager.ss" "web-server") - (lib "timer.ss" "web-server") - (all-except (lib "request-parsing.ss" "web-server") - request-bindings) - ) + (lib "timer.ss" "web-server")) (provide start-servlet resume-servlet resume-servlet/headers) @@ -134,6 +131,4 @@ ;; Produce a new request, with bindings (define (new-request/bindings bs) (make-request 'get (string->url "http://www.example.com/") '() bs - "a-host-ip" "a-client-ip")) - - ) + "a-host-ip" "a-client-ip")))