+ add option instance-lifetime along with some functions
+ add instance surveillance thread that kills instance after a period of time
This commit is contained in:
interp
parent
bfbeb49125
commit
aa7bcc6186
|
|
@ -93,7 +93,9 @@
|
|||
httpd-logging ;HTTP-SYSLOG
|
||||
shift-reset ;SHIFT and RESET
|
||||
conditions ;exception
|
||||
defrec-package ;define-record
|
||||
defrec-package ;DEFINE-RECORD
|
||||
threads ;SLEEP
|
||||
thread-fluids ;FORK-THREAD
|
||||
scsh ;regexp et al.
|
||||
scheme
|
||||
)
|
||||
|
|
|
|||
|
|
@ -2,16 +2,25 @@
|
|||
;; Copyright Andreas Bernauer, 2002
|
||||
|
||||
|
||||
(define *debug* #f)
|
||||
|
||||
;;; instance-table: entry for every new request on a servlet page
|
||||
(define-record-type instance :instance
|
||||
(make-instance servlet-name continuation-table continuation-table-lock
|
||||
(make-instance servlet-name memo
|
||||
continuation-table continuation-table-lock
|
||||
continuation-counter)
|
||||
instance?
|
||||
(servlet-name instance-servlet-name)
|
||||
(memo instance-memo set-instance-memo!)
|
||||
(continuation-table instance-continuation-table)
|
||||
(continuation-table-lock instance-continuation-table-lock)
|
||||
(continuation-counter instance-continuation-counter))
|
||||
|
||||
(define-record memo
|
||||
(message 'kill) ;kill, killed, adjust-timeout
|
||||
(value #f)
|
||||
(new-memo #f))
|
||||
|
||||
(define-record-type session :session
|
||||
(make-session instance-id return-continuation)
|
||||
session?
|
||||
|
|
@ -21,7 +30,8 @@
|
|||
set-session-return-continuation!))
|
||||
|
||||
(define-record options
|
||||
(cache-plugins? #t))
|
||||
(cache-plugins? #t)
|
||||
(instance-lifetime 10)) ; in seconds
|
||||
|
||||
(define *options* (make-options))
|
||||
;(define *options-lock* (make-lock)) ; currently unused
|
||||
|
|
@ -74,10 +84,12 @@
|
|||
(begin
|
||||
(obtain-lock *instance-table-lock*)
|
||||
;; no access to instance table until new instance-id is saved
|
||||
(let ((instance-id (generate-new-table-id *instance-table*)))
|
||||
(let ((instance-id (generate-new-table-id *instance-table*))
|
||||
(memo (make-memo)))
|
||||
(table-set! *instance-table* instance-id
|
||||
(make-instance 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
|
||||
|
|
@ -89,6 +101,10 @@
|
|||
(decline))
|
||||
(lambda ()
|
||||
(get-plugin-rt-structure path-string servlet-path)))))
|
||||
(fork-thread (instance-surveillance instance-id
|
||||
(+ (time)
|
||||
(options:instance-lifetime *options*))
|
||||
memo))
|
||||
(reset
|
||||
(begin
|
||||
(with-cwd
|
||||
|
|
@ -97,6 +113,37 @@
|
|||
plugin plugin-interface
|
||||
(main req))))))))))
|
||||
|
||||
(define (instance-surveillance instance-id time-to-die memo)
|
||||
(lambda ()
|
||||
(let loop ((time-to-die time-to-die)
|
||||
(memo memo))
|
||||
(format #t "instance-surveillance[~s]: going to sleep until ~a~%"
|
||||
instance-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 "instance-surveillance[~s]: instance already killed, dieing~%"
|
||||
instance-id)
|
||||
)
|
||||
((adjust-timeout) ; new timeout
|
||||
(debug "instance-surveillance[~s]: adjusting timeout~%" instance-id)
|
||||
(loop (memo:value memo)
|
||||
(memo:new-memo memo)))
|
||||
((kill) ; kill instance
|
||||
(debug "instance-surveillance[~s]: killing~%"
|
||||
instance-id)
|
||||
(obtain-lock *instance-table-lock*)
|
||||
(table-set! *instance-table* instance-id #f)
|
||||
(release-lock *instance-table-lock*))
|
||||
(else
|
||||
(format (current-error-port)
|
||||
"instance-surveillance[~s]: unknown message ~s; dieing~%"
|
||||
instance-id (memo:message memo)))))))
|
||||
|
||||
|
||||
;; try to get continuation-table and then the continuation
|
||||
(define resume-url
|
||||
(let ((bad-request
|
||||
|
|
@ -132,7 +179,7 @@ You can try starting at the <A HREF=~a>beginning</a>."
|
|||
(bad-request path-string req)))
|
||||
(bad-request path-string req)))
|
||||
))))
|
||||
|
||||
|
||||
|
||||
(define (send/suspend response-maker)
|
||||
(shift return
|
||||
|
|
@ -173,10 +220,49 @@ You can try starting at the <A HREF=~a>beginning</a>."
|
|||
|
||||
(define (instance-delete! instance-id)
|
||||
(obtain-lock *instance-table-lock*)
|
||||
;; notify surveillance of instance being alread killed (prevents
|
||||
;; surveillance of killing new instance that has the same number by
|
||||
;; accident)
|
||||
(let ((instance (table-ref *instance-table* instance-id)))
|
||||
(memo-killed! (instance-memo instance)))
|
||||
;; why can't table entries be deleted correctly?
|
||||
(table-set! *instance-table* instance-id #f)
|
||||
(release-lock *instance-table-lock*))
|
||||
|
||||
(define (instance-adjust-timeout! instance-id)
|
||||
(obtain-lock *instance-table-lock*)
|
||||
(let* ((instance (table-ref *instance-table* instance-id))
|
||||
(memo (instance-memo instance))
|
||||
(new-memo (make-memo)))
|
||||
;; Do it this way: new values and then new message
|
||||
(set-memo:value memo
|
||||
(+ (time)
|
||||
(options:instance-lifetime *options*)))
|
||||
(set-memo:new-memo memo new-memo)
|
||||
;; FIXME: We change instance entry's value. Do we need locking
|
||||
;; here?
|
||||
(set-instance-memo! instance new-memo)
|
||||
(set-memo:message memo 'adjust-timeout))
|
||||
(release-lock *instance-table-lock*))
|
||||
|
||||
(define (reset-instance-table!)
|
||||
(with-fatal-error-handler
|
||||
(lambda (condtion decline)
|
||||
(release-lock *instance-table-lock*)
|
||||
(decline))
|
||||
(lambda ()
|
||||
(obtain-lock *instance-table-lock*)
|
||||
(table-walk
|
||||
(lambda (instance-id instance)
|
||||
(memo-killed! (instance-memo instance)))
|
||||
*instance-table*)
|
||||
(set! *instance-table* (make-integer-table))
|
||||
(release-lock *instance-table*))))
|
||||
|
||||
;; caller must do locking stuff
|
||||
(define (memo-killed! memo)
|
||||
(set-memo:message memo 'killed))
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ID generation
|
||||
|
|
@ -246,16 +332,6 @@ You can try starting at the <A HREF=~a>beginning</a>."
|
|||
(set! *plugin-table* (make-string-table))
|
||||
(release-lock *plugin-table-lock*))))
|
||||
|
||||
(define (reset-instance-table!)
|
||||
(with-fatal-error-handler
|
||||
(lambda (condtion decline)
|
||||
(release-lock *instance-table-lock*)
|
||||
(decline))
|
||||
(lambda ()
|
||||
(obtain-lock *instance-table-lock*)
|
||||
(set! *instance-table* (make-integer-table))
|
||||
(release-lock *instance-table*))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; SESSION
|
||||
(define *session* (make-thread-cell #f))
|
||||
|
|
@ -313,6 +389,11 @@ You can try starting at the <A HREF=~a>beginning</a>."
|
|||
(define (resume-url? id-url)
|
||||
(regexp-search? *resume-url-regexp* id-url))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; access to options
|
||||
|
||||
(define (set-instance-lifetime! new-lifetime)
|
||||
(set-options:instance-lifetime new-lifetime))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; thread-safe counter
|
||||
|
|
@ -343,9 +424,7 @@ You can try starting at the <A HREF=~a>beginning</a>."
|
|||
|
||||
|
||||
|
||||
|
||||
; instance-table thread safe
|
||||
; continuation-table thread safe
|
||||
; generate-new-instance-id only called if thread safe
|
||||
; generate-new-continuation-id only called if thread safe
|
||||
; respect plugin timestamp
|
||||
(define (debug fmt . args)
|
||||
(if *debug*
|
||||
(format #t "DEBUG: ~?~%" fmt args)
|
||||
(force-output)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue