diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index 8b0545c..321a47c 100644 --- a/scheme/httpd/surflets/surflet-handler.scm +++ b/scheme/httpd/surflets/surflet-handler.scm @@ -21,6 +21,10 @@ (value #f) (new-memo #f)) +;; caller must do locking stuff +(define (memo-killed! memo) + (set-memo:message memo 'killed)) + (define-record-type session :session (make-session instance-id return-continuation) session? @@ -31,7 +35,7 @@ (define-record options (cache-plugins? #t) - (instance-lifetime 60)) ; in seconds + (instance-lifetime 600)) ; in seconds (define *options* (make-options)) ;(define *options-lock* (make-lock)) ; currently unused @@ -47,7 +51,8 @@ (lambda () (random-integer 1073741824)))) ; I hope, 1+ billion is enough.... -(define (servlet-handler servlet-path) +;; servlet-prefix gives virtual prefixed path to servlets +(define (servlet-handler servlet-path servlet-prefix) (lambda (path req) (if (pair? path) ; need at least one element (let ((request-method (request:method req)) @@ -69,9 +74,16 @@ ((or (string=? request-method "GET") ; (string=? request-method "POST")) ; do this at later time ) - (if (resume-url? path-string) - (resume-url path-string servlet-path req) - (launch-new-instance path-string servlet-path req))) + (let ((response + (if (resume-url? path-string) + (resume-url path-string servlet-path req) + (launch-new-instance path-string servlet-path req)))) + (if (redirect-body? (response-body response)) + ;; prefix with servlet-path + (make-redirect-response + (string-join (file-name-as-directory servlet-prefix) + (redirect-body-location (response-body response)))) + response))) (else (make-http-error-response http-status/method-not-allowed req request-method)))) @@ -117,7 +129,7 @@ (lambda () (let loop ((time-to-die time-to-die) (memo memo)) - (debug "instance-surveillance[~s]: going to sleep until ~a~%" + (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) @@ -125,22 +137,22 @@ ;; check state of the world (case (memo:message memo) ((killed) ; too late - (debug "instance-surveillance[~s]: instance already killed, dieing~%" + (debug "instance-surveillance[~s]: instance already killed, dieing" instance-id) ) ((adjust-timeout) ; new timeout - (debug "instance-surveillance[~s]: adjusting timeout~%" instance-id) + (debug "instance-surveillance[~s]: adjusting timeout" instance-id) (loop (memo:value memo) (memo:new-memo memo))) ((kill) ; kill instance - (debug "instance-surveillance[~s]: killing~%" + (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-surveillance[~s]: unknown message ~s; dieing" instance-id (memo:message memo))))))) @@ -193,19 +205,24 @@ (shift return (let* ((instance-id (session-instance-id)) (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))))))) + ;; the session might be deleted in the meanwhile + (if instance + (begin + (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))))) + (make-http-error-response http-status/not-found #f + "The URL refers to a servlet, whose instance is no longer alive."))))) (define (send/finish response) (instance-delete! (session-instance-id)) @@ -267,10 +284,16 @@ (set! *instance-table* (make-integer-table)) (release-lock *instance-table*)))) -;; caller must do locking stuff -(define (memo-killed! memo) - (set-memo:message memo 'killed)) - +(define (get-instances) + (obtain-lock *instance-table-lock*) + (let ((instances '())) + (table-walk + (lambda (instance-id instance-entry) + (set! instances (cons (cons instance-id instance-entry) instances))) + *instance-table*) + (release-lock *instance-table-lock*) + instances)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ID generation @@ -311,7 +334,6 @@ ;; only now the lock may be released (release-lock *plugin-table-lock*))) plugin-structure)))))) - (if (options:cache-plugins? *options*) (begin ;; The lock is only obtained and released, if plugins are