Redesigning error catching machinery.

Now no malicious servlet should be able to let the server crash.
This commit is contained in:
interp 2002-11-05 10:21:15 +00:00
parent 2ab106745a
commit 47a60a26d3
1 changed files with 49 additions and 41 deletions

View File

@ -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)
(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
(with-fatal-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))
(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
(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-cwd servlet-path
(with-names-from-rt-structure
servlet servlet-interface
(main req)))))))))))
(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*