diff --git a/collects/web-server/configuration-table b/collects/web-server/configuration-table index 6cd7e4edad..681b3f63d4 100644 --- a/collects/web-server/configuration-table +++ b/collects/web-server/configuration-table @@ -13,7 +13,7 @@ (file-not-found-message "not-found.html") (protocol-message "protocol-error.html")) (timeouts - (default-servlet-timeout 60) + (default-servlet-timeout 120) ;(default-servlet-timeout 300) ;(default-servlet-timeout 10) (password-connection-timeout 300) diff --git a/collects/web-server/servlet-tables.ss b/collects/web-server/servlet-tables.ss index 99ca8fa069..52799c7537 100644 --- a/collects/web-server/servlet-tables.ss +++ b/collects/web-server/servlet-tables.ss @@ -1,11 +1,12 @@ (module servlet-tables mzscheme (require (lib "contract.ss") (lib "url.ss" "net") - (lib "list.ss")) + (lib "list.ss") + "timer.ss") (provide (struct exn:servlet-instance ()) (struct exn:servlet-continuation ()) (struct execution-context (connection request suspend)) - (struct servlet-instance (id k-table custodian context mutex)) + (struct servlet-instance (id k-table custodian context mutex timer)) current-servlet-instance) ;; current-servlet-instance. The server will parameterize @@ -14,7 +15,7 @@ ;; will be in affect for the entire dynamic extent of every ;; continuation associated with that instance. (define current-servlet-instance (make-parameter #f)) - (define-struct servlet-instance (id k-table custodian context mutex)) + (define-struct servlet-instance (id k-table custodian context mutex timer)) (define-struct execution-context (connection request suspend)) ;; Notes: @@ -34,7 +35,7 @@ (provide/contract [continuation-url? (url? . -> . (union boolean? (list/c symbol? number? number?)))] [store-continuation! (procedure? url? servlet-instance? . -> . string?)] - [create-new-instance! (hash-table? custodian? execution-context? semaphore? + [create-new-instance! (hash-table? custodian? execution-context? semaphore? timer? . -> . servlet-instance?)] [remove-instance! (hash-table? servlet-instance? . -> . any)] [clear-continuations! (servlet-instance? . -> . any)] @@ -80,12 +81,12 @@ inst (make-k-table))) - ;; create-new-instance! hash-table custodian execution-context semaphore-> servlet-instance - (define (create-new-instance! instance-table cust ctxt sema) + ;; 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)]) + inst-id (make-k-table) cust ctxt sema timer)]) (hash-table-put! instance-table inst-id inst) inst)) diff --git a/collects/web-server/timer.ss b/collects/web-server/timer.ss index 9e663898e0..0affdc7752 100644 --- a/collects/web-server/timer.ss +++ b/collects/web-server/timer.ss @@ -1,5 +1,5 @@ (module timer mzscheme - (provide timer? start-timer reset-timer) + (provide timer? start-timer reset-timer increment-timer) ; BUG: reducing the timeout is ineffective ; efficiency: too many threads @@ -25,7 +25,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 sec) - (set-timer-expire-seconds! timer (+ sec (current-seconds))))) + (set-timer-expire-seconds! timer (+ sec (current-seconds)))) + + ; increment-timer : timer num -> void + ; add secs to the timer, rather than replace + (define (increment-timer timer sec) + (set-timer-expire-seconds! timer (+ sec (timer-expire-seconds timer))))) diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index 3587a84db5..90884019b0 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -443,7 +443,8 @@ config:instances servlet-custodian (make-execution-context conn req (lambda () (suspend #t))) - sema)] + sema + (start-timer 0 (lambda () (void))))] [real-servlet-path (url-path->path (paths-servlet (host-paths host-info)) (url-path->string (url-path uri)))] @@ -466,7 +467,7 @@ ;; servlet is loaded should be within the dynamic ;; extent of the servlet custodian [servlet-program (cached-load real-servlet-path)]) - + (set-servlet-instance-timer! inst time-bomb) (with-handlers ([(lambda (x) #t) (make-servlet-exception-handler inst host-info)]) @@ -568,14 +569,17 @@ [k-table (servlet-instance-k-table inst)]) (let/cc suspend - (set-servlet-instance-context! - inst - (make-execution-context - conn req (lambda () (suspend #t)))) ; 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)) + (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 ()