diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm index 3665f09..bfd2222 100644 --- a/scheme/httpd/surflets/surflet-handler.scm +++ b/scheme/httpd/surflets/surflet-handler.scm @@ -89,20 +89,9 @@ (path-string (uri-path-list->path path))) (if (or (string=? request-method "GET") (string=? request-method "POST")) - (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)) -; (let ((target (redirect-body-location (response-body response)))) -; (if (relative? target) -; ;; Pefix it with servlet-prefix. -; (make-redirect-response -; (path-list->file-name -; (list (directory-as-file-name servlet-prefix) -; target))) -; response)) - response) + (if (resume-url? path-string) + (resume-url path-string servlet-path req) + (launch-new-instance path-string servlet-path req)) (make-http-error-response http-status/method-not-allowed req request-method))) (make-http-error-response http-status/bad-request req @@ -127,32 +116,21 @@ #f)) ; servlet-data (release-lock *instance-table-lock*) (register-session! instance-id 'no-return) - (let ((servlet - (with-fatal-error-handler - (lambda (condition decline) - (delete-instance! instance-id) - (decline)) - (get-servlet-rt-structure path-string servlet-path)))) - (fork-thread (instance-surveillance instance-id - (+ (time) - (options-instance-lifetime)) - memo)) - (reset - (call-with-current-continuation - (lambda (exit) - (with-handler - (lambda (condition more) - (exit - (make-http-error-response - http-status/bad-gateway req - (format #f "Internal error while executing servlet ~s." path-string) - condition))) - (lambda () - (with-cwd - servlet-path - (with-names-from-rt-structure - servlet servlet-interface - (main req))))))))))) + + (with-fatal-handler + (lambda (condition decline) + (delete-instance! instance-id) + (bad-gateway-error-response req path-string condition)) + (let ((servlet (get-servlet-rt-structure path-string servlet-path))) + (fork-thread + (instance-surveillance instance-id + (+ (time) (options-instance-lifetime)) + memo)) + (reset + (with-cwd servlet-path + (with-names-from-rt-structure + servlet servlet-interface + (main req)))))))) (else ; We'll serve every non-scm file. ;; We need access to SEND-FILE-RESPONSE of ;; HTTPD-FILE-DIR-HANDLERS. In the official SUnet release, we @@ -400,7 +378,7 @@ (let* ((full-servlet-name (absolute-file-name servlet-name directory)) (load-servlet (lambda (cached?) - (with-fatal-error-handler* + (with-fatal-handler* (lambda (condition decline) (if cached? (release-lock *servlet-table-lock*)) (decline)) @@ -546,6 +524,36 @@ (release-lock (counter-lock counter)) result)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Error-Handler +;; +;; Adopted from WITH-FATAL-ERROR-HANDLER, but handles everything that +;; is catchable. We must catch everything because we also want +;; exceptions (and warnings) to be catched (e.g. when the servlet is +;; loaded.) +(define (with-fatal-handler* handler thunk) + (call-with-current-continuation + (lambda (accept) + ((call-with-current-continuation + (lambda (k) + (with-handler (lambda (condition more) + (call-with-current-continuation + (lambda (decline) + (k (lambda () (handler condition decline))))) + (more)) ; Keep looking for a handler. + (lambda () (call-with-values thunk accept))))))))) + +(define-syntax with-fatal-handler + (syntax-rules () + ((with-fatal-handler handler body ...) + (with-fatal-handler* handler + (lambda () body ...))))) + +(define (bad-gateway-error-response req path-string condition) + (make-http-error-response + http-status/bad-gateway req + (format #f "Error in servlet ~s." path-string) + condition)) (define (debug fmt . args) (if *debug*