Handle `Location:' and `Status:' headers of CGI program's output correctly.

scheme/httpd/cgi-server.scm

@@ -76,7 +76,7 @@
 (define cgi-default-bin-path "/bin:/usr/bin:/usr/ucb:/usr/bsd:/usr/local/bin")
 
 ;;; The path handler for CGI scripts. (car path) is the script to run.
-;;; cgi-bin-path is used, if no PATH-variable isn't defined
+;;; cgi-bin-path is used, if PATH-variable isn't defined
 
 (define (cgi-handler bin-dir . maybe-cgi-bin-path)
   (let-optionals
@@ -136,7 +136,7 @@
 	       (make-http-error-response http-status/not-found req
 					 "File or directory doesn't exist."))
 	      (else
-	       (cgi-make-response (run/port* doit) req)))))
+	       (cgi-make-response (run/port* doit) path req)))))
        
        (else (make-http-error-response http-status/method-not-allowed req))))))
 
@@ -241,19 +241,12 @@
 ;;; The script isn't an "nph-" script, so we read the response, and mutate
 ;;; it into a real HTTP response, which we then send back to the HTTP client.
 
-(define (cgi-make-response script-port req)
+(define (cgi-make-response script-port path req)
   (let* ((headers (read-rfc822-headers script-port))
 	 (ctype (get-header headers 'content-type))	; The script headers
 	 (loc   (get-header headers 'location))
-	 (stat  (let ((stat-lines (get-header-lines headers 'status)))
+	 (stat  (extract-status-code-and-text 
-		  (cond 
+		 (get-header-lines headers 'status) req))
-		   ((not (pair? stat-lines))	    ; No status header.
-		    "200 The idiot CGI script left out the status line.")
-		   ((null? (cdr stat-lines)) 	    ; One line status header.
-		    (car stat-lines))
-		   (else			    ; Vas ist das?
-		    (http-error http-status/internal-error req
-				"CGI script generated multi-line status header.")))))
 	 (extra-headers (delete-headers (delete-headers (delete-headers headers 
 									'content-type)
 							'location)
@@ -262,16 +255,45 @@
     (http-syslog (syslog-level debug) "[cgi-server] headers: ~s~%" headers)
     (http-syslog (syslog-level debug) "[cgi-server] request:method=~a~%" 
 		 (request:method req))
-    ;; Send the response header back to the client
+    (write (list 'status-code stat))
-    (make-response ;code message seconds mime extras body
+    (if loc
-     http-status/ok
+	(if (uri-like? (string-trim loc))
-     (status-code->text http-status/ok)
+	    (make-http-error-response http-status/moved-perm req
-     (time)
+				      loc loc)
-     ctype
+	    (make-redirect-response (string-trim loc)))
-     extra-headers
+	;; Send the response header back to the client
-     (make-writer-body
+	(make-response ;code message seconds mime extras body
-      (lambda (out options)		; what about loc&status?
+	 (car stat)			; code
-	(copy-inport->outport script-port out)
+	 (cdr stat)			; text
-	(close-input-port script-port))))))
+	 (time)
+	 ctype
+	 extra-headers
+	 (make-writer-body
+	  (lambda (out options)		; what about status?
+	    (copy-inport->outport script-port out)
+	    (close-input-port script-port)))))))
 
 
+;; shouldn't this be in uri?
+(define (uri-like? loc)
+  (receive (proto path search frag)
+      (parse-uri loc)
+    (if proto #t #f)))
+
+(define (extract-status-code-and-text stat-lines req)
+  (cond 
+   ((not (pair? stat-lines))	    ; No status header.
+    (cons 200 "The idiot CGI script left out the status line."))
+   ((null? (cdr stat-lines)) 	    ; One line status header.
+    (with-fatal-error-handler*
+       (lambda (c d)
+	 (http-error http-status/internal-error req
+		     "CGI script generated an invalid status header."
+		     (car stat-lines) c))
+       (lambda ()
+	 (let ((status (string-trim (car stat-lines))))
+	   (cons (string->number (substring status 0 3))	; number
+		 (substring/shared status 4))))))		; text
+   (else			    ; Vas ist das?
+    (http-error http-status/internal-error req
+		"CGI script generated multi-line status header."))))