diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm
index 89a3d97..e01becc 100644
--- a/scheme/httpd/surflets/packages.scm
+++ b/scheme/httpd/surflets/packages.scm
@@ -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
)
diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm
index 52e2cc1..961a808 100644
--- a/scheme/httpd/surflets/surflet-handler.scm
+++ b/scheme/httpd/surflets/surflet-handler.scm
@@ -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 beginning."
(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 beginning."
(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 beginning."
(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 beginning."
(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 beginning."
-
-; 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
\ No newline at end of file
+(define (debug fmt . args)
+ (if *debug*
+ (format #t "DEBUG: ~?~%" fmt args)
+ (force-output)))