PR 7533

svn: r631

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)

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))
 

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)))))
 
 
 

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 ()