diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index 961a808..8b0545c 100644 --- a/scheme/httpd/surflets/surflet-handler.scm +++ b/scheme/httpd/surflets/surflet-handler.scm @@ -2,7 +2,7 @@ ;; Copyright Andreas Bernauer, 2002 -(define *debug* #f) +(define *debug* #t) ;;; instance-table: entry for every new request on a servlet page (define-record-type instance :instance @@ -31,7 +31,7 @@ (define-record options (cache-plugins? #t) - (instance-lifetime 10)) ; in seconds + (instance-lifetime 60)) ; in seconds (define *options* (make-options)) ;(define *options-lock* (make-lock)) ; currently unused @@ -53,19 +53,19 @@ (let ((request-method (request:method req)) (path-string (uri-path-list->path path))) (cond - ((string=? path-string "profile") ; triggers profiling - (http-syslog (syslog-level debug) - "profiling: triggered in servlet-handler [~a]" - (profile-space)) ; PROFILE - (make-http-error-response http-status/accepted req "profiled")) - ((string=? path-string "reset") ; triggers cache clearing - (http-syslog (syslog-level debug) - "servlet-handler: clearing plugin cache") - (reset-plugin-cache!) - (http-syslog (syslog-level debug) - "servlet-handler: clearing instance table") - (reset-instance-table!) - (make-http-error-response http-status/accepted req "plugin cache cleared")) +; ((string=? path-string "profile") ; triggers profiling +; (http-syslog (syslog-level debug) +; "profiling: triggered in servlet-handler [~a]" +; (profile-space)) ; PROFILE +; (make-http-error-response http-status/accepted req "profiled")) +; ((string=? path-string "reset") ; triggers cache clearing +; (http-syslog (syslog-level debug) +; "servlet-handler: clearing plugin cache") +; (reset-plugin-cache!) +; (http-syslog (syslog-level debug) +; "servlet-handler: clearing instance table") +; (reset-instance-table!) +; (make-http-error-response http-status/accepted req "plugin cache cleared")) ((or (string=? request-method "GET") ; (string=? request-method "POST")) ; do this at later time ) @@ -117,8 +117,8 @@ (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))) + (debug "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)))) @@ -150,8 +150,16 @@ (lambda (path-string req) (make-http-error-response http-status/bad-request req - (format #f "The servlet does not accept any requests any more or your URL is illformed.
-You can try starting at the beginning." + (format #f + "
+

There may be several reasons, why your request was denied: +

+

+

In any case, you may try to restart the servlet from the beginning

" (resume-url-servlet-name path-string))))) (lookup-continuation-table (lambda (instance continuation-table continuation-id) @@ -184,20 +192,20 @@ You can try starting at the beginning." (define (send/suspend response-maker) (shift return (let* ((instance-id (session-instance-id)) - (instance (instance-lookup instance-id)) - (continuations-table (instance-continuation-table instance)) - (continuation-table-lock (instance-continuation-table-lock instance)) - (continuation-counter (instance-next-continuation-counter instance))) - (obtain-lock continuation-table-lock) - (let ((continuation-id (generate-new-table-id continuations-table))) - (table-set! continuations-table continuation-id return) - (release-lock continuation-table-lock) - (let ((new-url (make-resume-url (instance-servlet-name instance) - instance-id - continuation-counter - continuation-id))) - (response-maker new-url)))))) - + (instance (instance-lookup instance-id))) + (instance-adjust-timeout! instance-id) + (let ((continuations-table (instance-continuation-table instance)) + (continuation-table-lock (instance-continuation-table-lock instance)) + (continuation-counter (instance-next-continuation-counter instance))) + (obtain-lock continuation-table-lock) + (let ((continuation-id (generate-new-table-id continuations-table))) + (table-set! continuations-table continuation-id return) + (release-lock continuation-table-lock) + (let ((new-url (make-resume-url (instance-servlet-name instance) + instance-id + continuation-counter + continuation-id))) + (response-maker new-url))))))) (define (send/finish response) (instance-delete! (session-instance-id)) @@ -239,8 +247,7 @@ You can try starting at the beginning." (+ (time) (options:instance-lifetime *options*))) (set-memo:new-memo memo new-memo) - ;; FIXME: We change instance entry's value. Do we need locking - ;; here? + ;; I don't think we need locking here. Do you agree? (set-instance-memo! instance new-memo) (set-memo:message memo 'adjust-timeout)) (release-lock *instance-table-lock*)) @@ -252,6 +259,7 @@ You can try starting at the beginning." (decline)) (lambda () (obtain-lock *instance-table-lock*) + ;; notify instance killing (table-walk (lambda (instance-id instance) (memo-killed! (instance-memo instance))) @@ -322,6 +330,22 @@ You can try starting at the beginning." (load-plugin #t)))) (load-plugin #f)))) +(define (get-loaded-plugins) + (obtain-lock *plugin-table-lock*) + (let ((loaded-plugins '())) + (table-walk + (lambda (plugin-path rt-structure) + (set! loaded-plugins (cons plugin-path loaded-plugins))) + *plugin-table*) + (release-lock *plugin-table-lock*) + loaded-plugins)) + +(define (unload-plugin plugin-name) + (obtain-lock *plugin-table-lock*) + (if (table-ref *plugin-table* plugin-name) + (table-set! *plugin-table* plugin-name #f)) + (release-lock *plugin-table-lock*)) + (define (reset-plugin-cache!) (with-fatal-error-handler* (lambda (condition decline) @@ -393,7 +417,10 @@ You can try starting at the beginning." ;; access to options (define (set-instance-lifetime! new-lifetime) - (set-options:instance-lifetime new-lifetime)) + (set-options:instance-lifetime *options* new-lifetime)) + +(define (get-instance-lifetime) + (options:instance-lifetime *options*)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; thread-safe counter