From 33d90e70f7f44477afa8692ad9c988f8534bfc5e Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 31 Aug 2005 20:11:34 +0000 Subject: [PATCH] Adding expiration replacement primitives svn: r723 --- collects/web-server/dispatch-servlets.ss | 118 +++++++++++++---------- collects/web-server/servlet-tables.ss | 38 +++++--- collects/web-server/servlet.ss | 51 ++++++---- 3 files changed, 122 insertions(+), 85 deletions(-) diff --git a/collects/web-server/dispatch-servlets.ss b/collects/web-server/dispatch-servlets.ss index 7ab6396d67..a3decb7563 100644 --- a/collects/web-server/dispatch-servlets.ss +++ b/collects/web-server/dispatch-servlets.ss @@ -99,6 +99,8 @@ [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-values (;; timer thread must be within the dynamic extent of @@ -138,7 +140,15 @@ (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-servlet-exception-handler: host -> exn -> void ;; This exception handler traps all unhandled servlet exceptions ;; * Must occur within the dynamic extent of the servlet @@ -182,58 +192,60 @@ ;; host -> void ;; pull the continuation out of the table and apply it (define (invoke-servlet-continuation conn req k-ref host-info) - (with-handlers ([exn:servlet-instance? - (lambda (the-exn) - (output-response/method - conn - ((responders-file-not-found (host-responders - host-info)) - (request-uri req)) - (request-method req)))] - [exn:servlet-continuation? - (lambda (the-exn) - (output-response/method - conn - ((responders-file-not-found (host-responders - host-info)) - (request-uri req)) - (request-method req)))]) - (let* ([last-inst (thread-cell-ref current-servlet-instance)] - [inst - (hash-table-get config:instances (first k-ref) - (lambda () - (raise - (make-exn:servlet-instance - "" (current-continuation-marks)))))] - [k-table - (servlet-instance-k-table inst)]) - (let/cc suspend - ; We don't use call-with-semaphore or dynamic-wind because we - ; always call a continuation. The exit-handler above ensures that - ; the post is done. - (semaphore-wait (servlet-instance-mutex inst)) - (thread-cell-set! current-servlet-instance inst) - (set-servlet-instance-context! - inst - (make-execution-context - conn req (lambda () (suspend #t)))) - (increment-timer (servlet-instance-timer inst) - (timeouts-default-servlet - (host-timeouts host-info))) - (let ([k*salt - (hash-table-get k-table (second k-ref) - (lambda () - (raise - (make-exn:servlet-continuation - "" (current-continuation-marks)))))]) - (if (= (second k*salt) (third k-ref)) - ((first k*salt) req) - (raise - (make-exn:servlet-continuation - "" (current-continuation-marks)))))) - (thread-cell-set! current-servlet-instance last-inst) - (semaphore-post (servlet-instance-mutex inst)) - ))) + (let-values ([(uk-instance uk-id uk-salt) (apply values k-ref)]) + (let ([default-servlet-continuation-expiration-handler + (make-default-servlet-continuation-expiration-handler host-info)]) + (with-handlers ([exn:servlet:instance? + (lambda (the-exn) + (output-response/method + conn + ((responders-file-not-found (host-responders + host-info)) + (request-uri req)) + (request-method req)))] + [exn:servlet:continuation? + (lambda (the-exn) + ((exn:servlet:continuation-expiration-handler the-exn) req))]) + (let* ([last-inst (thread-cell-ref current-servlet-instance)] + [inst + (hash-table-get config:instances uk-instance + (lambda () + (raise + (make-exn:servlet:instance + "" (current-continuation-marks)))))] + [k-table + (servlet-instance-k-table inst)]) + (let/cc suspend + ; We don't use call-with-semaphore or dynamic-wind because we + ; always call a continuation. The exit-handler above ensures that + ; the post is done. + (semaphore-wait (servlet-instance-mutex inst)) + (thread-cell-set! current-servlet-instance inst) + (set-servlet-instance-context! + inst + (make-execution-context + conn req (lambda () (suspend #t)))) + (increment-timer (servlet-instance-timer inst) + (timeouts-default-servlet + (host-timeouts host-info))) + (let-values ([(k k-expiration-handler k-salt) + (apply values + (hash-table-get + k-table uk-id + (lambda () + (raise + (make-exn:servlet:continuation + "" (current-continuation-marks) + default-servlet-continuation-expiration-handler)))))]) + (if (and k (= k-salt uk-salt)) + (k req) + (raise + (make-exn:servlet:continuation + "" (current-continuation-marks) + k-expiration-handler))))) + (thread-cell-set! current-servlet-instance last-inst) + (semaphore-post (servlet-instance-mutex inst)) + ))))) ;; ************************************************************ ;; ************************************************************ diff --git a/collects/web-server/servlet-tables.ss b/collects/web-server/servlet-tables.ss index 1511aca805..5c30c0932c 100644 --- a/collects/web-server/servlet-tables.ss +++ b/collects/web-server/servlet-tables.ss @@ -3,8 +3,8 @@ (lib "url.ss" "net") (lib "list.ss") "timer.ss") - (provide (struct exn:servlet-instance ()) - (struct exn:servlet-continuation ()) + (provide (struct exn:servlet:instance ()) + (struct exn:servlet:continuation (expiration-handler)) (struct execution-context (connection request suspend)) (struct servlet-instance (id k-table custodian context mutex timer)) current-servlet-instance) @@ -34,28 +34,43 @@ (provide/contract [continuation-url? (url? . -> . (union boolean? (list/c symbol? number? number?)))] - [store-continuation! (procedure? url? servlet-instance? . -> . string?)] + [store-continuation! (procedure? procedure? url? servlet-instance? . -> . string?)] [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) ()) + (define-struct (exn:servlet:instance exn) ()) ;; not found in the continuatin table - (define-struct (exn:servlet-continuation exn) ()) + (define-struct (exn:servlet:continuation exn) (expiration-handler)) - (define-values (make-k-table get-k-id!) + (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) + ;; 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 @@ -64,13 +79,13 @@ (hash-table-put! k-table id-slot (add1 id)) id))))) - ;; store-continuation!: continuation execution-context servlet-instance -> url-string + ;; store-continuation!: continuation expiration-handler uri servlet-instance -> url-string ;; store a continuation in a k-table for the provided servlet-instance - (define (store-continuation! k uri inst) + (define (store-continuation! k expiration-handler uri 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 salt)) + (hash-table-put! k-table next-k-id (list k expiration-handler salt)) (embed-ids (servlet-instance-id inst) next-k-id salt uri)))) ;; clear-continuations!: servlet-instance -> void @@ -78,7 +93,8 @@ (define (clear-continuations! inst) (set-servlet-instance-k-table! inst - (make-k-table))) + (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) diff --git a/collects/web-server/servlet.ss b/collects/web-server/servlet.ss index c36515ab9d..21b4c9c130 100644 --- a/collects/web-server/servlet.ss +++ b/collects/web-server/servlet.ss @@ -1,7 +1,8 @@ ;; Default choice for writing module servlets (module servlet mzscheme (require (lib "contract.ss") - "servlet-tables.ss" + (lib "etc.ss")) + (require "servlet-tables.ss" "response.ss" "servlet-helpers.ss" "xexpr-callback.ss" @@ -13,19 +14,24 @@ [adjust-timeout! (number? . -> . any)] [send/back (any/c . -> . any)] [send/finish (any/c . -> . any)] - [send/suspend ((string? . -> . any/c) . -> . request?)] - [send/forward ((string? . -> . any/c) . -> . request?)] + [send/suspend (((string? . -> . any/c)) ((request? . -> . any/c)) . opt-> . request?)] + [send/forward (((string? . -> . any/c)) ((request? . -> . any/c)) . opt-> . request?)] ;;; validate-xexpr/callback is not checked anywhere: [send/suspend/callback (xexpr/callback? . -> . any)]) (provide send/suspend/dispatch + current-servlet-continuation-expiration-handler (all-from "servlet-helpers.ss") (all-from "xexpr-callback.ss")) ;; ************************************************************ ;; EXPORTS + ;; current-servlet-continuation-expiration-handler : request -> response + (define current-servlet-continuation-expiration-handler + (make-parameter #f)) + ;; adjust-timeout! : sec -> void ;; adjust the timeout on the servlet (define (adjust-timeout! secs) @@ -45,24 +51,27 @@ (clear-continuations! (thread-cell-ref current-servlet-instance)) (send/back resp)) - ;; send/suspend: (url -> response) -> request + ;; send/suspend: (url -> response) [(request -> response)] -> request ;; send a response and apply the continuation to the next request - (define (send/suspend response-generator) - (let/cc k - (let* ([inst (thread-cell-ref current-servlet-instance)] - [ctxt (servlet-instance-context inst)] - [k-url (store-continuation! - k (request-uri (execution-context-request ctxt)) - inst)] - [response (response-generator k-url)]) - (output-response (execution-context-connection ctxt) response) - ((execution-context-suspend ctxt))))) + (define send/suspend + (opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)]) + (let/cc k + (let* ([inst (thread-cell-ref current-servlet-instance)] + [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 + ;; send/forward: (url -> response) [(request -> response)] -> request ;; clear the continuation table, then behave like send/suspend - (define (send/forward response-generator) - (clear-continuations! (thread-cell-ref current-servlet-instance)) - (send/suspend response-generator)) + (define send/forward + (opt-lambda (response-generator [expiration-handler (current-servlet-continuation-expiration-handler)]) + (clear-continuations! (thread-cell-ref current-servlet-instance)) + (send/suspend response-generator expiration-handler))) ;; send/suspend/callback : xexpr/callback? -> void ;; send/back a response with callbacks in it; send/suspend those callbacks. @@ -71,15 +80,15 @@ (lambda (embed/url) (replace-procedures p-exp embed/url)))) - ;; send/suspend/dispatch : ((proc -> url) -> response) -> request + ;; send/suspend/dispatch : ((proc -> url) -> response) [(request -> response)] -> request ;; send/back a response generated from a procedure that may convert ;; procedures to continuation urls (define (send/suspend/dispatch response-generator) (let/ec k0 (send/back (response-generator - (lambda (proc) - (let/ec k1 (k0 (proc (send/suspend k1))))))))) + (opt-lambda (proc [expiration-handler (current-servlet-continuation-expiration-handler)]) + (let/ec k1 (k0 (proc (send/suspend k1 expiration-handler))))))))) ;; ************************************************************