diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm index 934b562..d4eba02 100644 --- a/scheme/httpd/surflets/packages.scm +++ b/scheme/httpd/surflets/packages.scm @@ -129,6 +129,7 @@ instance-session-id set-session-lifetime! adjust-timeout! + session-adjust-timeout! session-alive? session-surflet-name ;; FIXME: This is too much and should be restricted: @@ -374,6 +375,7 @@ locks ;MAKE-LOCK et al. profiling ;PROFILE-SPACE rt-module-language ;get structures dynamically + search-trees scheme-with-scsh ;regexp et al. shift-reset ;SHIFT and RESET srfi-6 ;string-ports diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index 36e802d..bd1472e 100644 --- a/scheme/httpd/surflets/surflet-handler.scm +++ b/scheme/httpd/surflets/surflet-handler.scm @@ -118,57 +118,36 @@ ;;; SESSION-SURVEILLANCE (define (timeout-queue-register-session! session-id timeout) - (set! *timeout-queue* (queue-add *timeout-queue* session-id timeout))) + (search-tree-set! *timeout-queue* (cons session-id timeout) 'ignore)) (define (timeout-queue-remove-session! session-id) - (set! *timeout-queue* (queue-delete *timeout-queue* session-id))) + (search-tree-set! *timeout-queue* (cons session-id 0) #f)) (define (timeout-queue-adjust-session-timeout! session-id new-timeout) - (set! *timeout-queue* (queue-delete *timeout-queue* session-id)) - (set! *timeout-queue* - (queue-add *timeout-queue* session-id new-timeout))) + (search-tree-set! *timeout-queue* (cons session-id new-timeout) 'ignore)) (define *timeout-queue*) (define (surveillance-thread) - (set! *timeout-queue* (empty-queue)) + (set! *timeout-queue* (make-search-tree (lambda (p q) (eq? (car p) (car q))) + (lambda (p q) + (< (cdr p) (cdr q))))) (let lp () (with-lock *session-table-lock* (lambda () (let ((now (time))) (let lp2 () - (if (not (queue-empty? *timeout-queue*)) - (let ((session-id.time (queue-head *timeout-queue*))) + (receive (session-id.time ignore) (search-tree-min *timeout-queue*) + (if session-id.time (if (<= (cdr session-id.time) now) (let ((session-id (car session-id.time))) (table-set! *session-table* session-id #f) - (set! *timeout-queue* - (queue-delete *timeout-queue* session-id)) + (pop-search-tree-min! *timeout-queue*) (lp2))))))))) (sleep 1000) (lp))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; actually an alist with a head operation on the second argument. -(define (empty-queue) - '()) - -(define queue-empty? null?) - -(define (queue-add q key value) - (alist-cons key value q)) - -(define (queue-delete key q) - (alist-delete! q key)) - -(define (queue-head q) - (let lp ((maybe-min (car q)) (q q)) - (if (null? q) - maybe-min - (if (< (cdar q) (cdr maybe-min)) - (lp (car q) (cdr q)) - (lp maybe-min (cdr q)))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; doesn't belong to here... (define (with-lock lock thunk)