scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

use DEFINE-RECORD-TYPE instead of DEFINE-RECORD

This commit is contained in:
interp 2002-10-21 08:25:58 +00:00
parent f0106b48e7
commit d02d0e19d2
1 changed files with 27 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
scheme/httpd/surflets/surflet-handler.scm
View File

@ -18,10 +18,15 @@
(continuation-counter instance-continuation-counter) (continuation-counter instance-continuation-counter)
(servlet-data instance-servlet-data set-instance-servlet-data!)) (servlet-data instance-servlet-data set-instance-servlet-data!))
(define-record memo (define-record-type memo :memo
(message 'kill) ;kill, killed, adjust-timeout (make-memo message value new-memo)
(value #f) memo?
(new-memo #f)) (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 ;; caller must do locking stuff
(define (memo-killed! memo) (define (memo-killed! memo)
@ -35,11 +40,17 @@
(return-continuation really-session-return-continuation (return-continuation really-session-return-continuation
set-session-return-continuation!)) set-session-return-continuation!))
(define-record options (define-record-type options :options
servlet-path (make-options servlet-path servlet-prefix cache-servlets? instance-lifetime)
servlet-prefix options?
(cache-servlets? #t) (servlet-path options:servlet-path set-options:servlet-path)
(instance-lifetime 600)) ; in seconds (servlet-prefix options:servlet-prefix set-options:servlet-prefix)
(cache-servlets? options:cache-servlets? set-options:cache-servlets?)
;; instance lifetime is in seconds
(instance-lifetime options:instance-lifetime set-options:instance-lifetime))
(define (make-default-options servlet-path servlet-prefix)
(make-options servlet-path servlet-prefix #t 600))
(define *options* (make-preserved-thread-fluid #f)) (define *options* (make-preserved-thread-fluid #f))
;; preserved thread fluid because between different calls to ;; preserved thread fluid because between different calls to
@ -70,7 +81,7 @@
;; servlet-prefix gives virtual prefixed path to servlets ;; servlet-prefix gives virtual prefixed path to servlets
(define (servlet-handler servlet-path servlet-prefix) (define (servlet-handler servlet-path servlet-prefix)
(set-thread-fluid! *options* (make-options servlet-path servlet-prefix)) (set-thread-fluid! *options* (make-default-options servlet-path servlet-prefix))
(lambda (path req) (lambda (path req)
(if (pair? path) ; need at least one element (if (pair? path) ; need at least one element
(let ((request-method (request:method req)) (let ((request-method (request:method req))
@ -111,7 +122,7 @@
(obtain-lock *instance-table-lock*) (obtain-lock *instance-table-lock*)
;; no access to instance table until new instance-id is saved ;; 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))) (memo (make-default-memo)))
(table-set! *instance-table* instance-id (table-set! *instance-table* instance-id
(make-instance path-string ; used to make (make-instance path-string ; used to make
; redirections to origin ; redirections to origin
@ -285,7 +296,7 @@
(obtain-lock *instance-table-lock*) (obtain-lock *instance-table-lock*)
(let* ((instance (table-ref *instance-table* instance-id)) (let* ((instance (table-ref *instance-table* instance-id))
(memo (instance-memo instance)) (memo (instance-memo instance))
(new-memo (make-memo))) (new-memo (make-default-memo)))
;; Do it this way: new values and then new message ;; Do it this way: new values and then new message
(set-memo:value memo (set-memo:value memo
(+ (time) (+ (time)
@ -296,6 +307,10 @@
(set-memo:message memo 'adjust-timeout)) (set-memo:message memo 'adjust-timeout))
(release-lock *instance-table-lock*)) (release-lock *instance-table-lock*))
;; adjusts the timeout of the current instance
(define (adjust-timeout)
(instance-adjust-timeout! (session-instance-id)))
(define (reset-instance-table!) (define (reset-instance-table!)
(with-fatal-error-handler (with-fatal-error-handler
(lambda (condtion decline) (lambda (condtion decline)