From da98e19193ddd0e8207e3af1dfd1f1435e536df6 Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Tue, 14 Jan 2003 11:27:42 +0000
Subject: [PATCH] Force the result of the servlet to be printed into a
 string-port. The servlet programmer is (nearly) unaware of this.

This removes the problem that arises if send/suspend is called in HTTPD
while transmitting data to the browser.
---
 scheme/httpd/surflets/packages.scm        |  1 +
 scheme/httpd/surflets/surflet-handler.scm | 27 ++++++++++++++++++++++-
 scheme/httpd/surflets/surflets.scm        |  7 +++---
 3 files changed, 30 insertions(+), 5 deletions(-)

diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm
index a742ee5..09bf3f7 100644
--- a/scheme/httpd/surflets/packages.scm
+++ b/scheme/httpd/surflets/packages.scm
@@ -127,6 +127,7 @@
 	sxml-to-html			;SXML->HTML
 	scsh				;regexp et al.
 ;	httpd-file-directory-handlers	;send-file-response
+	srfi-6				;string-ports
 	handle
 	scheme
 	)
diff --git a/scheme/httpd/surflets/surflet-handler.scm b/scheme/httpd/surflets/surflet-handler.scm
index 03cdba3..c54add9 100644
--- a/scheme/httpd/surflets/surflet-handler.scm
+++ b/scheme/httpd/surflets/surflet-handler.scm
@@ -246,7 +246,7 @@
 						     session-id 
 						     continuation-counter
 						     continuation-id)))
-		       (response-maker new-url)))))
+		       (make-servlet-response (response-maker new-url))))))
 	       (make-error-response (status-code not-found) #f
 					 "The URL refers to a servlet, whose session is no longer alive.")))))
 
@@ -257,6 +257,31 @@
 (define (send response)
   (shift unsused response))
 
+(define (make-servlet-response response)
+  (let ((servlet-out-port (open-output-string))
+	(servlet-in-port #f) ;; FIXME: no input-port available
+	(options #f))			;; FIXME: No access to httpd-options :-(
+    (if (writer-body? (response-body response))
+	(begin
+	  ;; Error-handler is already installed.
+	  ;; Force string-output to resolve all send/... calls. 
+	  (display-http-body (response-body response)
+			     servlet-in-port servlet-out-port 
+			     options)
+	  ;; Create write-out-response for webserver.
+	  (make-response
+	   (response-code response)
+	   (response-message response)
+	   (response-seconds response)
+	   (response-mime response)
+	   (response-extras response)
+	   (make-writer-body
+	    (lambda (out options)
+	      (display (get-output-string servlet-out-port) out)))))
+	(make-error-response (status-code bad-gateway) #f 
+			     "The servlet returned an invalid response object (no writer-body)."))))
+
+    
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; access to session-table
 (define (session-lookup session-id)
diff --git a/scheme/httpd/surflets/surflets.scm b/scheme/httpd/surflets/surflets.scm
index 02d852f..90a6db6 100644
--- a/scheme/httpd/surflets/surflets.scm
+++ b/scheme/httpd/surflets/surflets.scm
@@ -4,10 +4,9 @@
 (define (send-html/suspend html-tree-maker)
   (send/suspend 
    (lambda (new-url)
-     (let ((html-page (servlet-XML->HTML #f (html-tree-maker new-url))))
-       (make-usual-html-response
-	(lambda (out options)
-	  (display html-page out)))))))
+     (make-usual-html-response
+      (lambda (out options)
+	(display (servlet-XML->HTML #f (html-tree-maker new-url)) out))))))
 
 (define (send-html/finish html-tree)
   (do-sending send/finish html-tree))