adpat cgi-server to new response philosophy

NOTE: There's a FIXME left: nph- scripts won't work at all currently.

scheme/httpd/cgi-server.scm

@@ -75,6 +75,41 @@
 ;;; path for scripts 
 (define cgi-default-bin-path "/bin:/usr/bin:/usr/ucb:/usr/bsd:/usr/local/bin")
 
+(define-condition-type 'cgi-error '())
+(define cgi-error? (condition-predicate 'cgi-error))
+
+(define-condition-type 'cgi-illegal-content-length-error '(cgi-error))
+(define cgi-illegal-content-length-error? 
+  (condition-predicate 'cgi-illegal-content-length-error))
+
+(define-condition-type 'cgi-dot-dot-error? '(cgi-error))
+(define cgi-dot-dot-error? (condition-predicate 'cgi-dot-dot-error?))
+
+(define-condition-type 'cgi-nph-failed-error '(cgi-error))
+(define cgi-nph-failed-error? (condition-predicate 'cgi-nph-failed-error))
+(define cgi-nph-failed-error-filename cadr)
+
+(define-condition-type 'cgi-multi-status-line-error '(cgi-error))
+(define cgi-multi-status-line-error? (condition-predicate 'cgi-multi-status-line-error))
+
+(define (create-error-response condition req)
+  (cond 
+   ((cgi-illegal-content-length-error? condition)
+    (make-http-error-response http-status/bad-request req 
+			      "Illegal `Content-length:' header."))
+   ((cgi-dot-dot-error? condition)
+    (make-http-error-response http-status/bad-request req 
+			      "CGI scripts may not contain \"..\" elements."))
+   ((cgi-nph-failed-error? condition)
+    (make-http-error-response http-status/bad-request req
+			      (format #f "Could not execute CGI script ~a." 
+				      (cgi-nph-failed-error-filename condition))))
+   ((cgi-multi-status-line-error? condition)
+    (make-http-error-response http-status/internal-error req
+			      "CGI script generated multi-line status header."))
+   (else
+    (make-http-error-response http-status/bad-gateway req
+			      "Error while executing CGI."))))
 
 ;;; 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
@@ -91,11 +126,22 @@
 	    ("GATEWAY_INTERFACE" . "CGI/1.1"))))
      (lambda (path req)
        (if (pair? path)	; Got to have at least one elt.
+	   (call-with-current-continuation
+	    (lambda (exit)
+	      (with-handler
+	       (lambda (condition more)
+		 (if (cgi-error? condition)
+		     (create-error-response condition req)
+		     (make-http-error-response http-status/internal-error req)))
+	       (lambda ()
+		 (compute-cgi path req bin-dir request-invariant-cgi-env)))))
+	   (make-http-error-response http-status/bad-request req "Empty CGI script"))))))
+
+(define (compute-cgi path req bin-dir request-invariant-cgi-env)
   (let* ((prog (car path))
 
 	 (filename (or (dotdot-check bin-dir (list prog))
-				(http-error http-status/bad-request req
-					    (format #f "CGI scripts may not contain \"..\" elements."))))
+		       (signal 'cgi-dot-dot-error)))
 
 	 (nph? (string-prefix? "nph-" prog))	; PROG starts with "nph-" ? 
 					; why did we had (string-suffix? "-nph" prog) here?
@@ -120,18 +166,14 @@
 	(if nph?
 	    (let ((stat (wait (fork doit))))
 	      (if (not (zero? stat))
-			   (http-error http-status/bad-request req
-				       (format #f "Could not execute CGI script ~a."
-					       filename))
-			   stat))
-		     (cgi-send-response (run/port* doit) req)))
+		  (signal 'cgi-nph-failed-error filename) 
+		  stat))		;; FIXME! must return http-response object!
+	    (cgi-make-response (run/port* doit) req)))
        
-		(else (http-error http-status/method-not-allowed req)))))
-	   
-	   (http-error http-status/bad-request req "Empty CGI script"))))))
+       (else (make-http-error-response http-status/method-not-allowed req))))))
 
 
-  (define (split-and-decode-search-spec s)
+(define (split-and-decode-search-spec s)
   (let recur ((i 0))
     (cond
      ((string-index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
@@ -151,7 +193,7 @@
 ;;; Suppose the URL is
 ;;;   //machine/cgi-bin/test-script/foo/bar?quux%20a+b=c
 ;;; then:
-;;;   PATH_INFO -- extra info after the script-name path prefix. "/foo/bar"
+;;   PATH_INFO -- extra info after the script-name path prefix. "/foo/bar"
 ;;;   PATH_TRANSLATED -- non-virtual version of above.  "/u/Web/foo/bar/"
 ;;;   SCRIPT_NAME virtual path to script "/cgi-bin/test-script"
 ;;;   QUERY_STRING -- not decoded "quux%20a+b=c"
@@ -210,9 +252,7 @@
 			   (cl-len (string-length cl)))
 		       (if first-digit
 			   `(("CONTENT_LENGTH" . ,(substring cl first-digit cl-len)))
-			   (http-error http-status/bad-request
-				       req
-				       "Illegal Content-length: header.")))))
+			   (signal 'cgi-illegal-content-length-error)))))
 		  
 		  (else '()))
 	  
@@ -232,7 +272,7 @@
 ;;; 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-send-response script-port req)
+(define (cgi-make-response script-port req)
   (let* ((headers (read-rfc822-headers script-port))
 	 (ctype (get-header headers 'content-type))	; The script headers
 	 (loc   (get-header headers 'location))
@@ -243,26 +283,21 @@
 		   ((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")))))
-	 (out (current-output-port)))
+		    (signal 'cgi-multi-status-line-error))))))
     
     (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
-    ;; (unless it's a headerless HTTP 0.9 response).
-    (if (not (v0.9-request? req))
-	(begin
-	  (format out "HTTP/1.0 ~a\r~%" stat)
-	  (if ctype (format out "Content-type: ~a\r~%" ctype))
-	  (if loc   (format out "Location: ~a\r~%" loc))
-	  (write-crlf out)))
-
-    (http-syslog (syslog-level debug) "[cgi-server] request:method=~a~%" (request:method req))
-    ;; Copy the response body back to the client and close the script port
-    ;; (unless it's a bodiless HEAD transaction).
-    (if (not (string=? (request:method req) "HEAD"))
-	(begin
+    (make-response ;code message seconds mime extras body
+     http-status/ok
+     (status-code->text http-status/ok)
+     (time)
+     ctype
+     '()
+     (make-writer-body
+      (lambda (out options)		; what about loc?
 	(copy-inport->outport script-port out)
-	  (close-input-port script-port)))))
+	(close-input-port script-port))))))
 
 

scheme/packages.scm

@@ -859,6 +859,7 @@
 	format-net              ; FORMAT-INTERNET-HOST-ADDRESS
 	sunet-utilities         ; host-name-or-empty
 	let-opt                 ; let-optionals
+	conditions handle signals	; define-condition-type, with-handler et al.
 	scheme)
   (files (httpd cgi-server)))