From 7ada980df05fb5c6453b599d9caf837a369f5a40 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 26 Aug 2005 14:49:52 +0000 Subject: [PATCH] Rewrite of timeout manager and fixing of connection mutex bug on kill svn: r684 --- collects/web-server/configuration-table | 2 +- collects/web-server/connection-manager.ss | 18 ++--- collects/web-server/dispatch-servlets.ss | 4 +- collects/web-server/timer-structs.ss | 6 +- collects/web-server/timer.ss | 96 +++++++++++++++++------ collects/web-server/web-server-unit.ss | 4 +- 6 files changed, 89 insertions(+), 41 deletions(-) diff --git a/collects/web-server/configuration-table b/collects/web-server/configuration-table index a588d9814f..9d1e069d7c 100644 --- a/collects/web-server/configuration-table +++ b/collects/web-server/configuration-table @@ -21,7 +21,7 @@ (collect-garbage "collect-garbage.html")) (timeouts - (default-servlet-timeout 120) + (default-servlet-timeout 30) (password-connection-timeout 300) (servlet-connection-timeout 86400) (file-per-byte-connection-timeout 1/20) diff --git a/collects/web-server/connection-manager.ss b/collects/web-server/connection-manager.ss index 6003d8d07a..ded464b81b 100644 --- a/collects/web-server/connection-manager.ss +++ b/collects/web-server/connection-manager.ss @@ -15,8 +15,9 @@ [adjust-connection-timeout! (connection? number? . -> . void)]) ;; start-connection-manager: custodian -> void - ;; does nothing - (define start-connection-manager void) + ;; calls the timer manager + (define (start-connection-manager custodian) + (start-timer-manager custodian)) ;; new-connection: number i-port o-port custodian -> connection ;; ask the connection manager for a new connection @@ -31,14 +32,11 @@ ;; kill-connection!: connection -> void ;; kill this connection - (define (kill-connection! conn-demned) - (call-with-semaphore - (connection-mutex conn-demned) - (lambda () - (close-output-port (connection-o-port conn-demned)) - (close-input-port (connection-i-port conn-demned)) - (set-connection-close?! conn-demned #t) - (custodian-shutdown-all (connection-custodian conn-demned))))) + (define (kill-connection! conn-demned) + (close-output-port (connection-o-port conn-demned)) + (close-input-port (connection-i-port conn-demned)) + (set-connection-close?! conn-demned #t) + (custodian-shutdown-all (connection-custodian conn-demned))) ;; adjust-connection-timeout!: connection number -> void ;; change the expiration time for this connection diff --git a/collects/web-server/dispatch-servlets.ss b/collects/web-server/dispatch-servlets.ss index 2a23558b15..9e8cfc1127 100644 --- a/collects/web-server/dispatch-servlets.ss +++ b/collects/web-server/dispatch-servlets.ss @@ -94,7 +94,7 @@ (make-execution-context conn req (lambda () (suspend #t))) sema - (start-timer 0 (lambda () (void))))] + (start-timer 0 void))] [real-servlet-path (url-path->path (paths-servlet (host-paths host-info)) (url-path->string (url-path uri)))] @@ -326,7 +326,7 @@ (define servlet-bin? - (let ([svt-bin-re (regexp "^/servlets/.*")]) + (let ([svt-bin-re (regexp "^/servlets(;id.*\\*.*\\*.*)?/.*")]) (lambda (str) (regexp-match svt-bin-re str)))) diff --git a/collects/web-server/timer-structs.ss b/collects/web-server/timer-structs.ss index 1e6b020f3b..061b65de51 100644 --- a/collects/web-server/timer-structs.ss +++ b/collects/web-server/timer-structs.ss @@ -1,6 +1,8 @@ (module timer-structs mzscheme (require (lib "contract.ss")) - (define-struct timer (expire-seconds)) + (define-struct timer (evt expire-seconds action)) (provide/contract - [struct timer ([expire-seconds number?])])) \ No newline at end of file + [struct timer ([evt evt?] + [expire-seconds number?] + [action (-> void)])])) \ No newline at end of file diff --git a/collects/web-server/timer.ss b/collects/web-server/timer.ss index 0818f1f1fb..6d2c8d0b29 100644 --- a/collects/web-server/timer.ss +++ b/collects/web-server/timer.ss @@ -1,37 +1,87 @@ (module timer mzscheme (require "timer-structs.ss") - (provide timer? start-timer reset-timer increment-timer) + (require (lib "list.ss")) + (provide timer? + start-timer reset-timer increment-timer + start-timer-manager) - ; BUG: reducing the timeout is ineffective - ; efficiency: too many threads + (define timer-ch (make-channel)) + + ; start-timer-manager : custodian -> void + ; Thanks to Matthew! + ; The timer manager thread + (define (start-timer-manager server-custodian) + (parameterize ([current-custodian server-custodian]) + (thread + (lambda () + (let loop ([timers null]) + ;; Wait for either... + (apply sync + ;; ... a timer-request message ... + (handle-evt + timer-ch + (lambda (req) + ;; represent a req as a (timer-list -> timer-list) function: + ;; add/remove/change timer evet: + (loop (req timers)))) + ;; ... or a timer + (map (lambda (timer) + (handle-evt + (timer-evt timer) + (lambda (_) + ;; execute timer + ((timer-action timer)) + (loop (remq timer timers))))) + timers)))))) + (void)) + + ;; Limitation on this add-timer: thunk cannot make timer + ;; requests directly, because it's executed directly by + ;; the timer-manager thread + ;; add-timer : number (-> void) -> timer + (define (add-timer msecs thunk) + (let* ([now (current-inexact-milliseconds)] + [timer + (make-timer (alarm-evt (+ now msecs)) + (+ now msecs) + thunk)]) + (channel-put timer-ch + (lambda (timers) + (cons timer timers))) + timer)) + + ; revise-timer! : timer msecs (-> void) -> timer + ; revise the timer to ring msecs from now + (define (revise-timer! timer msecs thunk) + (let ([now (current-inexact-milliseconds)]) + (channel-put + timer-ch + (lambda (timers) + (set-timer-evt! timer (alarm-evt (+ now msecs))) + (set-timer-expire-seconds! timer (+ now msecs)) + (set-timer-action! timer thunk) + timers)))) + + (define (cancel-timer! timer) + (revise-timer! timer 0 void)) ; start-timer : num (-> void) -> timer - ; to make a timer that calls to-do after msec from make-timer's application - (define (start-timer sec to-do) - (let ([timer (make-timer (+ (current-seconds) sec))]) - (letrec ([snooze - (lambda () - (let ([remaining (- (timer-expire-seconds timer) (current-seconds))]) - (cond - [(<= remaining 0) - ; use call-in-nested-thread or something when a single thread is used for all timeouts - (to-do)] - [else (sleep remaining) - (snooze)])))]) - (thread snooze)) - timer)) + ; to make a timer that calls to-do after sec from make-timer's application + (define (start-timer secs to-do) + (add-timer (* 1000 secs) to-do)) ; 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)))) + (define (reset-timer timer secs) + (revise-timer! timer (* 1000 secs) (timer-action timer))) ; 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))))) - - + (define (increment-timer timer secs) + (revise-timer! timer + (+ (timer-expire-seconds timer) + (* 1000 secs)) + (timer-action timer)))) ; --- timeout plan diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index 93a511febe..7dc3f7d3ee 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -97,11 +97,10 @@ ;; serve-ports : input-port output-port -> void ;; returns immediately, spawning a thread to handle ;; the connection - ;; NOTE: this doesn't use a connection manager since - ;; connection managers don't do anything anyways. -robby ;; NOTE: (GregP) should allow the user to pass in a connection-custodian (define (serve-ports ip op) (let ([server-cust (make-custodian)]) + (start-connection-manager server-cust) (parameterize ([current-custodian server-cust] [current-server-custodian server-cust]) (let ([connection-cust (make-custodian)]) @@ -118,7 +117,6 @@ (with-handlers ([exn:fail:network? (lambda (e) (set-connection-close?! conn #t) - ; XXX: Can this block on the mutex? (kill-connection! conn) (raise e))]) (serve-connection conn))))))