suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Rewrite of timeout manager and fixing of connection mutex bug on kill

Browse Source 
svn: r684
This commit is contained in:
Jay McCarthy 2005-08-26 14:49:52 +00:00
parent 0309108a41
commit 7ada980df0
6 changed files with 89 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/web-server/configuration-table
View File

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

18
collects/web-server/connection-manager.ss
View File

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

4
collects/web-server/dispatch-servlets.ss
View File

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

6
collects/web-server/timer-structs.ss
View File

@ -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?])]))
[struct timer ([evt evt?]
[expire-seconds number?]
[action (-> void)])]))

96
collects/web-server/timer.ss
View File

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

4
collects/web-server/web-server-unit.ss
View File

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