From 26683bd822e5d86792c4f0a1ed0d8040fc9156a9 Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Sat, 26 Oct 2002 15:35:20 +0000
Subject: [PATCH] * Move error handling of the servlets to the right point,
 i.e. after   the reset. * Remove redirect 'feature'. It is not well tought
 out.

---
 scheme/httpd/surflets/surflet-handler.scm | 61 ++++++++++++-----------
 1 file changed, 31 insertions(+), 30 deletions(-)

diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm
index d32c953..1c3bd2b 100644
--- a/scheme/httpd/surflets/surflet-handler.scm
+++ b/scheme/httpd/surflets/surflet-handler.scm
@@ -79,8 +79,9 @@
     (lambda ()
       (random-integer 1073741824))))	; I hope, 1+ billion is enough....
 
-;; servlet-prefix gives virtual prefixed path to servlets
-(define (servlet-handler servlet-path servlet-prefix)
+;; Servlet-prefix gives virtual prefixed path to servlets. Currently,
+;; it is ignored.
+(define (servlet-handler servlet-path . servlet-prefix)
   (set-thread-fluid! *options* (make-default-options servlet-path servlet-prefix))
   (lambda (path req)
     (if (pair? path)			; need at least one element
@@ -89,26 +90,19 @@
 	  (if (or (string=? request-method "GET")
 		  (string=? request-method "POST"))
 	      (let ((response 
-		     (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)
-			     condition)))
-			 (lambda ()
-			   (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))
-		    ;; Pefix it with servlet-prefix.
-		    (make-redirect-response 
-		     (path-list->file-name
-		      (list (directory-as-file-name servlet-prefix)
-			    (redirect-body-location (response-body response)))))
-		    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)
 	      (make-http-error-response http-status/method-not-allowed req 
 					request-method)))
 	(make-http-error-response http-status/bad-request req 
@@ -144,12 +138,21 @@
 					       (options-instance-lifetime))
 					    memo))
 	(reset
-	 (begin
-	   (with-cwd
-	       servlet-path
-	       (with-names-from-rt-structure 
-		servlet servlet-interface 
-		(main req))))))))
+	 (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)))))))))))
    (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
@@ -544,8 +547,6 @@
     result))
 
 
-
-
 (define (debug fmt . args)
   (if *debug*
       (format #t "DEBUG: ~?~%" fmt args)