Replaced implementation of surveillance thread: We have now only one
thread which checks every second for sessions to be deleted.
This commit is contained in:
mainzelm
parent
3de0a9c480
commit
b93e275415
|
|
@ -41,6 +41,7 @@
|
|||
(define (surflet-handler surflet-path . maybe-options)
|
||||
(let-optionals maybe-options ((options (make-default-surflet-options)))
|
||||
(set-thread-fluid! *options* options)
|
||||
(spawn surveillance-thread)
|
||||
(lambda (path req)
|
||||
(if (pair? path) ; need at least one element
|
||||
(let ((request-method (request-method req))
|
||||
|
|
@ -73,12 +74,10 @@
|
|||
((string=? (file-name-extension path-string) ".scm")
|
||||
(obtain-lock *session-table-lock*)
|
||||
;; no access to session table until new session-id is saved
|
||||
(let ((session-id (generate-new-table-id *session-table*))
|
||||
(memo (make-default-memo)))
|
||||
(let ((session-id (generate-new-table-id *session-table*)))
|
||||
(table-set! *session-table* session-id
|
||||
(make-session path-string ; used to make
|
||||
; redirections to origin
|
||||
memo
|
||||
(make-integer-table) ; continuation table
|
||||
(make-lock) ; continuation table lock
|
||||
(make-thread-safe-counter) ; continuation counter
|
||||
|
|
@ -92,10 +91,10 @@
|
|||
(delete-session! session-id)
|
||||
(bad-gateway-error-response s-req path-string condition))
|
||||
(let ((surflet (get-surflet-rt-structure path-string surflet-path)))
|
||||
(fork-thread
|
||||
(session-surveillance session-id
|
||||
(+ (time) (options-session-lifetime))
|
||||
memo))
|
||||
(timeout-queue-register-session!
|
||||
session-id
|
||||
(+ (time) (options-session-lifetime)))
|
||||
|
||||
(reset
|
||||
(with-fatal-error-handler
|
||||
;; Catch conditions that occur while running the surflet.
|
||||
|
|
@ -118,38 +117,69 @@
|
|||
|
||||
|
||||
;;; SESSION-SURVEILLANCE
|
||||
;; Returns surveillance procedure to be fork-threaded, that kills a
|
||||
;; session after TIME-TO-DIE (seconds) has expired. MEMO contains
|
||||
;; current status of session.
|
||||
(define (session-surveillance session-id time-to-die memo)
|
||||
(lambda ()
|
||||
(let loop ((time-to-die time-to-die)
|
||||
(memo memo))
|
||||
(debug "session-surveillance[~s]: going to sleep until ~a"
|
||||
session-id (format-date "~c" (date time-to-die)))
|
||||
(let ((seconds-to-sleep (- time-to-die (time))))
|
||||
(if (positive? seconds-to-sleep)
|
||||
(sleep (* 1000 seconds-to-sleep))))
|
||||
;; check state of the world
|
||||
(case (memo:message memo)
|
||||
((killed) ; too late
|
||||
(debug "session-surveillance[~s]: session already killed, dieing"
|
||||
session-id)
|
||||
)
|
||||
((adjust-timeout) ; new timeout
|
||||
(debug "session-surveillance[~s]: adjusting timeout" session-id)
|
||||
(loop (memo:value memo)
|
||||
(memo:new-memo memo)))
|
||||
((kill) ; kill session
|
||||
(debug "session-surveillance[~s]: killing"
|
||||
session-id)
|
||||
(obtain-lock *session-table-lock*)
|
||||
(table-set! *session-table* session-id #f)
|
||||
(release-lock *session-table-lock*))
|
||||
(else
|
||||
(format (current-error-port)
|
||||
"session-surveillance[~s]: unknown message ~s; dieing"
|
||||
session-id (memo:message memo)))))))
|
||||
(define (timeout-queue-register-session! session-id timeout)
|
||||
(set! *timeout-queue* (queue-add *timeout-queue* session-id timeout)))
|
||||
|
||||
(define (timeout-queue-remove-session! session-id)
|
||||
(set! *timeout-queue* (queue-delete *timeout-queue* session-id)))
|
||||
|
||||
(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)))
|
||||
|
||||
(define *timeout-queue*)
|
||||
|
||||
(define (surveillance-thread)
|
||||
(set! *timeout-queue* (empty-queue))
|
||||
(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*)))
|
||||
(if (<= (cdr session-id.time) now)
|
||||
(let ((session-id (car session-id.time)))
|
||||
(debug "session-surveillance[~s]: killing"
|
||||
session-id)
|
||||
(table-set! *session-table* session-id #f)
|
||||
(set! *timeout-queue*
|
||||
(queue-delete *timeout-queue* session-id))
|
||||
(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)
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(obtain-lock lock))
|
||||
thunk
|
||||
(lambda ()
|
||||
(release-lock lock))))
|
||||
|
||||
;;; RESUME-URL
|
||||
;; Resumes a suspended URL and returns a (HTTP-)RESPONSE. PATH-STRING
|
||||
|
|
@ -319,7 +349,7 @@
|
|||
(let ((session (table-ref *session-table* session-id)))
|
||||
(if session
|
||||
(begin
|
||||
(memo-killed! (session-memo session))
|
||||
(timeout-queue-remove-session! session-id)
|
||||
(table-set! *session-table* session-id #f))))
|
||||
;; else: somebody was faster than we
|
||||
(release-lock *session-table-lock*))
|
||||
|
|
@ -332,22 +362,14 @@
|
|||
(:optional maybe-time-to-live (options-session-lifetime))))
|
||||
|
||||
(define (really-session-adjust-timeout! session-id time-to-live)
|
||||
(obtain-lock *session-table-lock*)
|
||||
(let ((session (table-ref *session-table* session-id))
|
||||
(new-memo (make-default-memo)))
|
||||
(if session
|
||||
(let ((memo (session-memo session)))
|
||||
;; Do it this way: new values and then new message
|
||||
(set-memo:value memo
|
||||
(+ (time) time-to-live))
|
||||
(set-memo:new-memo memo new-memo)
|
||||
;; I don't think we need locking here. Do you agree?
|
||||
(set-session-memo! session new-memo)
|
||||
(set-memo:message memo 'adjust-timeout)
|
||||
(release-lock *session-table-lock*))
|
||||
(begin
|
||||
(release-lock *session-table-lock*)
|
||||
(error "There is no session with this ID" session-id)))))
|
||||
(with-lock *session-table-lock*
|
||||
(lambda ()
|
||||
(let ((session (table-ref *session-table* session-id)))
|
||||
(if session
|
||||
(timeout-queue-adjust-session-timeout!
|
||||
session-id
|
||||
(+ (time) time-to-live))
|
||||
(error "There is no session with this ID" session-id))))))
|
||||
|
||||
;;; ADJUST-TIMEOUT!
|
||||
;; Resets time-to-die of current session. The argument must be
|
||||
|
|
@ -369,7 +391,7 @@
|
|||
;; notify session killing
|
||||
(table-walk
|
||||
(lambda (session-id session)
|
||||
(memo-killed! (session-memo session)))
|
||||
(timeout-queue-remove-session! session-id))
|
||||
*session-table*)
|
||||
(set! *session-table* (make-integer-table))
|
||||
(release-lock *session-table*)))
|
||||
|
|
@ -617,34 +639,17 @@
|
|||
|
||||
;;; SESSION: session-table entry for every new request on a surflet page
|
||||
(define-record-type session :session
|
||||
(make-session surflet-name memo
|
||||
(make-session surflet-name
|
||||
continuation-table continuation-table-lock
|
||||
continuation-counter
|
||||
session-data)
|
||||
session?
|
||||
(surflet-name session-surflet-name)
|
||||
(memo session-memo set-session-memo!)
|
||||
(continuation-table session-continuation-table)
|
||||
(continuation-table-lock session-continuation-table-lock)
|
||||
(continuation-counter session-continuation-counter)
|
||||
(session-data session-session-data set-session-session-data!))
|
||||
|
||||
;;; MEMO: Information for session surveiller about session status
|
||||
(define-record-type memo :memo
|
||||
(make-memo message value new-memo)
|
||||
memo?
|
||||
(message memo:message set-memo:message) ;kill, killed, adjust-timeout
|
||||
(value memo:value set-memo:value)
|
||||
(new-memo memo:new-memo set-memo:new-memo))
|
||||
|
||||
(define (make-default-memo)
|
||||
(make-memo 'kill #f #f))
|
||||
|
||||
;; caller must do locking stuff
|
||||
(define (memo-killed! memo)
|
||||
(set-memo:message memo 'killed))
|
||||
|
||||
|
||||
;;; INSTANCE: Every request corresponds to an instance.
|
||||
(define-record-type instance :instance
|
||||
(make-instance session-id)
|
||||
|
|
@ -652,7 +657,6 @@
|
|||
(session-id really-instance-session-id
|
||||
set-instance-session-id!))
|
||||
|
||||
|
||||
;;; OPTIONS: options for the surflet-handler
|
||||
(define-record-type surflet-options :suflet-options
|
||||
(make-surflet-options cache-surflets? session-lifetime)
|
||||
|
|
|
|||
Loading…
Reference in New Issue