From 9dac2674b4261c02d80bcafe6f0fb7add8d3bc5d Mon Sep 17 00:00:00 2001
From: sperber <sperber>
Date: Tue, 14 Jan 2003 13:23:29 +0000
Subject: [PATCH] Introduce new response type :HTTP-NPH-RESPONSE for nph-...
 CGI scripts.

---
 scheme/httpd/core.scm     | 45 ++++++++++++++++++++++-----------------
 scheme/httpd/response.scm |  9 ++++++++
 scheme/packages.scm       |  3 +++
 3 files changed, 37 insertions(+), 20 deletions(-)

diff --git a/scheme/httpd/core.scm b/scheme/httpd/core.scm
index 044033c..f50a3a4 100644
--- a/scheme/httpd/core.scm
+++ b/scheme/httpd/core.scm
@@ -170,12 +170,15 @@
 	       (let ((response ((httpd-options-request-handler options)
 				(http-url-path (request-url req))
 				req)))
-	       (if (eq? (response-code response) 
-			(status-code redirect))
-		   (redirect-loop (redirect-request req response sock options))
-		   (values req response))))))))
+		 (cond
+		  ((nph-response? response)
+		   (values req response))
+		  ((eq? (response-code response) (status-code redirect))
+		   (redirect-loop (redirect-request req response sock options)))
+		  (else
+		   (values req response)))))))))
       (lambda (req response)
-
+	
 	(send-http-response req response 
 			    (socket:inport sock)
 			    (socket:outport sock)
@@ -332,21 +335,23 @@
   (write-crlf port))
 
 (define (send-http-response request response input-port output-port options)
-
-  (if request
-      (begin
-	(if (not (v0.9-request? request))
-	    (send-http-headers response output-port))
-
-	(if (not (string=? (request-method request) "HEAD"))
-	    (display-http-body (response-body response) input-port output-port options))
-
-	(http-log request (response-code response)))
-      (begin
-	;; We have a bad request error. Try to report this headerless.
-	(display-http-body (response-body response) input-port output-port options)
-	;; no CLF-logging
-	)))
+  (cond
+   ((not request)
+    ;; We have a bad request error. Try to report this headerless.
+    (display-http-body (response-body response) input-port output-port options)
+    ;; no CLF-logging
+    )
+   ((nph-response? response)
+    (display-http-body (nph-response-body response) input-port output-port options)
+    (http-log request (response-code response)))
+   (else
+    (if (not (v0.9-request? request))
+	(send-http-headers response output-port))
+    
+    (if (not (string=? (request-method request) "HEAD"))
+	(display-http-body (response-body response) input-port output-port options))
+    
+    (http-log request (response-code response)))))
 
 (define (send-http-header-fields headers port)
   (for-each (lambda (pair)
diff --git a/scheme/httpd/response.scm b/scheme/httpd/response.scm
index 7e82481..7a7d6f7 100644
--- a/scheme/httpd/response.scm
+++ b/scheme/httpd/response.scm
@@ -15,6 +15,15 @@
   (extras response-extras)
   (body response-body))
 
+;; This is mainly for nph-... CGI scripts.
+;; This means that the body will output the entire MIME message, not
+;; just the part after the headers.
+
+(define-record-type http-nph-response :http-nph-response
+  (make-nph-response body)
+  nph-response?
+  (body nph-response-body))
+
 (define-record-type http-writer-body :http-writer-body
   (make-writer-body proc)
   writer-body?
diff --git a/scheme/packages.scm b/scheme/packages.scm
index 062d862..7e4f271 100644
--- a/scheme/packages.scm
+++ b/scheme/packages.scm
@@ -273,6 +273,9 @@
 	  response-extras
 	  response-body
 
+	  make-nph-response nph-response?
+	  nph-response-body
+
 	  make-writer-body writer-body?
 	  make-reader-writer-body reader-writer-body?
 	  make-redirect-body redirect-body? redirect-body-location