diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index 5d40d74..2c9e496 100644 --- a/scheme/httpd/surflets/surflet-handler.scm +++ b/scheme/httpd/surflets/surflet-handler.scm @@ -34,12 +34,26 @@ set-session-return-continuation!)) (define-record options + servlet-path + servlet-prefix (cache-servlets? #t) (instance-lifetime 600)) ; in seconds -(define *options* (make-options)) +(define *options* (make-thread-cell #f)) ;(define *options-lock* (make-lock)) ; currently unused +(define (make-fluid-selector selector) + (lambda () (selector (thread-cell-ref *options*)))) +(define (make-fluid-setter setter) + (lambda (value) + (setter (thread-cell-ref *options*) value))) +(define options-servlet-path (make-fluid-selector options:servlet-path)) +(define options-servlet-prefix (make-fluid-selector options:servlet-prefix)) +(define options-cache-servlets? (make-fluid-selector options:cache-servlets?)) +(define options-instance-lifetime (make-fluid-selector options:instance-lifetime)) +(define set-options-cache-servlets? (make-fluid-setter set-options:cache-servlets?)) +(define set-options-instance-lifetime (make-fluid-setter set-options:instance-lifetime)) + (define *instance-table* (make-integer-table)) ; instance-id is index (define *instance-table-lock* (make-lock)) @@ -54,6 +68,7 @@ ;; servlet-prefix gives virtual prefixed path to servlets (define (servlet-handler servlet-path servlet-prefix) (lambda (path req) + (thread-cell-set! *options* (make-options servlet-path servlet-prefix)) (if (pair? path) ; need at least one element (let ((request-method (request:method req)) (path-string (uri-path-list->path path))) @@ -110,13 +125,13 @@ (register-session! instance-id 'no-return) (let ((servlet (with-fatal-error-handler* (lambda (condition decline) - (instance-delete! instance-id) + (delete-instance! instance-id) (decline)) (lambda () (get-servlet-rt-structure path-string servlet-path))))) (fork-thread (instance-surveillance instance-id (+ (time) - (options:instance-lifetime *options*)) + (options-instance-lifetime)) memo)) (reset (begin @@ -226,7 +241,7 @@ "The URL refers to a servlet, whose instance is no longer alive."))))) (define (send/finish response) - (instance-delete! (session-instance-id)) + (delete-instance! (session-instance-id)) (shift unused response)) (define (send response) @@ -244,7 +259,7 @@ (thread-safe-counter-next! (instance-continuation-counter instance))) -(define (instance-delete! instance-id) +(define (delete-instance! 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 @@ -263,7 +278,7 @@ ;; Do it this way: new values and then new message (set-memo:value memo (+ (time) - (options:instance-lifetime *options*))) + (options-instance-lifetime))) (set-memo:new-memo memo new-memo) ;; I don't think we need locking here. Do you agree? (set-instance-memo! instance new-memo) @@ -294,6 +309,33 @@ *instance-table*) (release-lock *instance-table-lock*) instances)) + +(define (get-continuations instance-id) + (let ((instance (instance-lookup instance-id))) + (if instance + (let ((continuation-table-lock (instance-continuation-table-lock instance)) + (continuation-table (instance-continuation-table instance)) + (continuations '())) + (obtain-lock continuation-table-lock) + (table-walk + (lambda (continuation-id continuation-entry) + (set! continuations (cons (cons continuation-id continuation-entry) + continuations))) + continuation-table) + (release-lock continuation-table-lock) + continuations) + '()))) + +(define (delete-continuation! instance-id continuation-id) + (let ((instance (instance-lookup instance-id))) + (if instance + (let ((continuation-table-lock (instance-continuation-table-lock instance)) + (continuation-table (instance-continuation-table instance)) + (continuations '())) + (obtain-lock continuation-table-lock) + (if (table-ref continuation-table continuation-id) + (table-set! continuation-table continuation-id #f)) + (release-lock continuation-table-lock))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -335,7 +377,7 @@ ;; only now the lock may be released (release-lock *servlet-table-lock*))) servlet-structure)))))) - (if (options:cache-servlets? *options*) + (if (options-cache-servlets?) (begin ;; The lock is only obtained and released, if servlets are ;; cached. LOAD-SERVLET gets the CACHED? parameter, so @@ -436,15 +478,6 @@ (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 *options* new-lifetime)) - -(define (get-instance-lifetime) - (options:instance-lifetime *options*)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; thread-safe counter