Redesigning error catching machinery.

Now no malicious servlet should be able to let the server crash.

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)
-		     (if (resume-url? path-string)
+		  (resume-url path-string servlet-path req)
-			 (resume-url path-string servlet-path req)
+		  (launch-new-instance 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)
 	      (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)
+       (lambda (condition decline)
-		(delete-instance! instance-id)
+	 (delete-instance! instance-id)
-		(decline)) 
+	 (bad-gateway-error-response req path-string condition))
-	      (get-servlet-rt-structure path-string servlet-path))))
+       (let ((servlet (get-servlet-rt-structure path-string servlet-path)))
-	(fork-thread (instance-surveillance instance-id
+	 (fork-thread 
-					    (+ (time)
+	  (instance-surveillance instance-id
-					       (options-instance-lifetime))
+				 (+ (time) (options-instance-lifetime))
-					    memo))
+				 memo))
-	(reset
+	 (reset
-	 (call-with-current-continuation
+	  (with-cwd servlet-path
-	  (lambda (exit)
+	    (with-names-from-rt-structure 
-	    (with-handler
+	     servlet servlet-interface 
-	     (lambda (condition more)
+	     (main req))))))))
-	       (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)))))))))))
    (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*