diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index 05ab43f..44e2955 100644 --- a/scheme/httpd/surflets/surflet-handler.scm +++ b/scheme/httpd/surflets/surflet-handler.scm @@ -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. @@ -117,40 +116,71 @@ )) -;;; 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))))))) - +;;; SESSION-SURVEILLANCE +(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 ;; is the virtual path, SURFLET-PATH a string pointing to the real @@ -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)