From 62b3307fb20827b4041412363ae314bb78406fd2 Mon Sep 17 00:00:00 2001
From: interp <interp>
Date: Wed, 28 Aug 2002 16:44:07 +0000
Subject: [PATCH] * new response body: :HTTP-READER-WRITER-BODY * hand over
 SOCKET:INPORT to SEND-HTTP-RESPONSE * apply this to seval-handler

---
 scheme/httpd/core.scm     | 18 ++++++------
 scheme/httpd/response.scm | 14 ++++++++--
 scheme/httpd/seval.scm    | 58 +++++++++++++++++++--------------------
 scheme/packages.scm       |  1 +
 4 files changed, 51 insertions(+), 40 deletions(-)

diff --git a/scheme/httpd/core.scm b/scheme/httpd/core.scm
index 8cbd384..5ac6c43 100644
--- a/scheme/httpd/core.scm
+++ b/scheme/httpd/core.scm
@@ -157,16 +157,16 @@
 	     (decline))))
 	 (lambda ()
 	   (let* ((req (parse-http-request sock options))
-		  (response 
-		   (with-current-input-port
-		    (socket:inport sock)
-		    ((httpd-options-path-handler options)
+		  (response ((httpd-options-path-handler options)
 			     (http-url:path (request:url req))
-			     req))))
+			     req)))
 	     (values req response)))))
       (lambda (req response)
 
-	(send-http-response req response (socket:outport sock) options)
+	(send-http-response req response 
+			    (socket:inport sock)
+			    (socket:outport sock)
+			    options)
 
 	(http-log req http-status/ok))))))
 
@@ -292,13 +292,13 @@
 
   (write-crlf port))
 
-(define (send-http-response request response port options)
+(define (send-http-response request response input-port output-port options)
 
   (if (not (v0.9-request? request))
-      (send-http-headers response port))
+      (send-http-headers response output-port))
 
   (if (not (string=? (request:method request) "HEAD"))
-      (display-http-body (response-body response) port options)))
+      (display-http-body (response-body response) input-port output-port options)))
 
 (define (send-http-header-fields headers port)
   (for-each (lambda (pair)
diff --git a/scheme/httpd/response.scm b/scheme/httpd/response.scm
index d45c363..c558ee7 100644
--- a/scheme/httpd/response.scm
+++ b/scheme/httpd/response.scm
@@ -20,8 +20,18 @@
   writer-body?
   (proc writer-body-proc))
 
-(define (display-http-body body port options)
-  ((writer-body-proc body) port options))
+(define-record-type :http-reader-writer-body
+  (make-reader-writer-body proc)
+  reader-writer-body?
+  (proc reader-writer-body-proc))
+			   
+
+(define (display-http-body body iport oport options)
+  (cond
+   ((writer-body? body)
+    ((writer-body-proc body) oport options))
+   ((reader-writer-body? body)
+    ((reader-writer-body-proc body) iport oport options))))
 
 
 (define-syntax define-http-status-codes
diff --git a/scheme/httpd/seval.scm b/scheme/httpd/seval.scm
index 35eb48a..a4d22ff 100644
--- a/scheme/httpd/seval.scm
+++ b/scheme/httpd/seval.scm
@@ -81,39 +81,39 @@
       (make-http-error-response http-status/method-not-allowed req)))))
 
 (define (seval path req)
-  (let ((sexp (read-request-sexp req)))
-    (http-syslog (syslog-level debug) "read sexp: ~a" sexp)
     (make-response
      http-status/ok
      (status-code->text http-status/ok)
      (time)
      "text/html"
      '()
-     (make-writer-body
-      (lambda (port options)
-	(with-tag port HEAD ()
-	  (newline port)
-	  (emit-title port "Scheme program output"))
-	(newline port)
-	
-	(with-tag port BODY ()
-	  (newline port)
-	  (do/timeout 
-	   10
-	   (receive vals
-	       ;; Do the computation.
-	       (begin (emit-header port 2 "Output from execution")
-		      (newline port)
-		      (with-tag port PRE ()
-			(newline port)
-			(force-output port); In case we're gunned down.
-			(eval-safely sexp)))
-	     
-	     ;; Pretty-print the returned value(s).
-	     (emit-header port 2 "Return value(s)")
-	     (with-tag port PRE ()
-	       (for-each (lambda (val) (p val port))
-			 vals))))))))))
+     (make-reader-writer-body
+      (lambda (iport oport options)
+	(let ((sexp (read-request-sexp req iport)))
+	  (http-syslog (syslog-level debug) "read sexp: ~a" sexp)
+	  (with-tag oport HEAD ()
+	    (newline oport)
+	    (emit-title oport "Scheme program output"))
+	  (newline oport)
+	  
+	  (with-tag oport BODY ()
+	    (newline oport)
+	    (do/timeout 
+	     10
+	     (receive vals
+		 ;; Do the computation.
+		 (begin (emit-header oport 2 "Output from execution")
+			(newline oport)
+			(with-tag oport PRE ()
+			  (newline oport)
+			  (force-output oport); In case we're gunned down.
+			  (eval-safely sexp)))
+	       
+	       ;; Pretty-print the returned value(s).
+	       (emit-header oport 2 "Return value(s)")
+	       (with-tag oport PRE ()
+		 (for-each (lambda (val) (p val oport))
+			   vals))))))))))
 
 
 ;;; Read an HTTP request entity body from stdin. The Content-length:
@@ -123,7 +123,7 @@
 ;;; string, extract <stuff>, uri-decode it, parse that into an s-expression,
 ;;; and return it.
 
-(define (read-request-sexp req)
+(define (read-request-sexp req iport)
   (cond 
    ((get-header (request:headers req) 'content-length) =>
     (lambda (cl-str)		 ; Take the first Content-length: header,
@@ -133,7 +133,7 @@
 						cl-start
 						(string-length cl-str)))
 		     0)) ; All whitespace?? -- WTF.
-	     (qs (read-string cl))			; Read in CL chars,
+	     (qs (read-string cl iport))			; Read in CL chars,
 	     (q (parse-html-form-query qs))		; and parse them up.
 	     (s (cond ((assoc "program" q) => cdr)
 		      (else (signal 'seval-no-program)))))
diff --git a/scheme/packages.scm b/scheme/packages.scm
index 780f20a..517ffc7 100644
--- a/scheme/packages.scm
+++ b/scheme/packages.scm
@@ -332,6 +332,7 @@
 	  response-body
 
 	  make-writer-body writer-body?
+	  make-reader-writer-body reader-writer-body?
 	  display-http-body
 
 	  ;; Integer reply codes