+ use search-trees for timeout-queue
+ export session-adjust-timeout! for admin-surflet.scm
This commit is contained in:
parent
61c3a4c216
commit
213090a51d
|
@ -129,6 +129,7 @@
|
||||||
instance-session-id
|
instance-session-id
|
||||||
set-session-lifetime!
|
set-session-lifetime!
|
||||||
adjust-timeout!
|
adjust-timeout!
|
||||||
|
session-adjust-timeout!
|
||||||
session-alive?
|
session-alive?
|
||||||
session-surflet-name
|
session-surflet-name
|
||||||
;; FIXME: This is too much and should be restricted:
|
;; FIXME: This is too much and should be restricted:
|
||||||
|
@ -374,6 +375,7 @@
|
||||||
locks ;MAKE-LOCK et al.
|
locks ;MAKE-LOCK et al.
|
||||||
profiling ;PROFILE-SPACE
|
profiling ;PROFILE-SPACE
|
||||||
rt-module-language ;get structures dynamically
|
rt-module-language ;get structures dynamically
|
||||||
|
search-trees
|
||||||
scheme-with-scsh ;regexp et al.
|
scheme-with-scsh ;regexp et al.
|
||||||
shift-reset ;SHIFT and RESET
|
shift-reset ;SHIFT and RESET
|
||||||
srfi-6 ;string-ports
|
srfi-6 ;string-ports
|
||||||
|
|
|
@ -118,57 +118,36 @@
|
||||||
|
|
||||||
;;; SESSION-SURVEILLANCE
|
;;; SESSION-SURVEILLANCE
|
||||||
(define (timeout-queue-register-session! session-id timeout)
|
(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)
|
(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)
|
(define (timeout-queue-adjust-session-timeout! session-id new-timeout)
|
||||||
(set! *timeout-queue* (queue-delete *timeout-queue* session-id))
|
(search-tree-set! *timeout-queue* (cons session-id new-timeout) 'ignore))
|
||||||
(set! *timeout-queue*
|
|
||||||
(queue-add *timeout-queue* session-id new-timeout)))
|
|
||||||
|
|
||||||
(define *timeout-queue*)
|
(define *timeout-queue*)
|
||||||
|
|
||||||
(define (surveillance-thread)
|
(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 ()
|
(let lp ()
|
||||||
(with-lock *session-table-lock*
|
(with-lock *session-table-lock*
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let ((now (time)))
|
(let ((now (time)))
|
||||||
(let lp2 ()
|
(let lp2 ()
|
||||||
(if (not (queue-empty? *timeout-queue*))
|
(receive (session-id.time ignore) (search-tree-min *timeout-queue*)
|
||||||
(let ((session-id.time (queue-head *timeout-queue*)))
|
(if session-id.time
|
||||||
(if (<= (cdr session-id.time) now)
|
(if (<= (cdr session-id.time) now)
|
||||||
(let ((session-id (car session-id.time)))
|
(let ((session-id (car session-id.time)))
|
||||||
(table-set! *session-table* session-id #f)
|
(table-set! *session-table* session-id #f)
|
||||||
(set! *timeout-queue*
|
(pop-search-tree-min! *timeout-queue*)
|
||||||
(queue-delete *timeout-queue* session-id))
|
|
||||||
(lp2)))))))))
|
(lp2)))))))))
|
||||||
(sleep 1000)
|
(sleep 1000)
|
||||||
(lp)))
|
(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...
|
;; doesn't belong to here...
|
||||||
(define (with-lock lock thunk)
|
(define (with-lock lock thunk)
|
||||||
|
|
Loading…
Reference in New Issue