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