scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Fix handling of session timeouts by using the session-id as the only 

key.
This commit is contained in:
mainzelm 2006-08-01 15:19:19 +00:00
parent ef819fa581
commit 8a2351a190
1 changed files with 9 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
scheme/httpd/surflets/surflet-handler.scm
View File

@ -120,28 +120,26 @@
(define *timeout-queue*) (define *timeout-queue*)
(define (timeout-queue-register-session! session-id timeout) (define (timeout-queue-register-session! session-id timeout)
(search-tree-set! *timeout-queue* (cons session-id timeout) 'ignore)) (search-tree-set! *timeout-queue* session-id timeout))
(define (timeout-queue-remove-session! session-id) (define (timeout-queue-remove-session! session-id)
(search-tree-set! *timeout-queue* (cons session-id 0) #f)) (search-tree-set! *timeout-queue* session-id #f))
(define (timeout-queue-adjust-session-timeout! session-id new-timeout) (define (timeout-queue-adjust-session-timeout! session-id new-timeout)
(search-tree-set! *timeout-queue* (cons session-id new-timeout) 'ignore)) (search-tree-set! *timeout-queue* session-id new-timeout))
(define (surveillance-thread) (define (surveillance-thread)
(set! *timeout-queue* (make-search-tree (lambda (p q) (eq? (car p) (car q))) (set! *timeout-queue* (make-search-tree = <))
(lambda (p q)
(< (cdr p) (cdr q)))))
(let lp () (let lp ()
(with-lock *session-table-lock* (with-lock *session-table-lock*
(let ((now (time))) (let ((now (time)))
(let lp2 () (let lp2 ()
(receive (session-id.time ignore) (search-tree-min *timeout-queue*) (receive (session-id time) (search-tree-min *timeout-queue*)
(if session-id.time (if session-id
(if (<= (cdr session-id.time) now) (if (<= time now)
(let ((session-id (car session-id.time))) (begin
(table-set! *session-table* session-id #f) (timeout-queue-remove-session! session-id)
(pop-search-tree-min! *timeout-queue*) (pop-search-tree-min! *timeout-queue*)
(lp2)))))))) (lp2))))))))
(sleep 1000) (sleep 1000)