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,51 +126,58 @@
 	    ("GATEWAY_INTERFACE" . "CGI/1.1"))))
      (lambda (path req)
        (if (pair? path)	; Got to have at least one elt.
-	   (let* ((prog (car path))
+	   (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"))))))
 
-		  (filename (or (dotdot-check bin-dir (list prog))
+(define (compute-cgi path req bin-dir request-invariant-cgi-env)
-				(http-error http-status/bad-request req
+  (let* ((prog (car path))
-					    (format #f "CGI scripts may not contain \"..\" elements."))))
 
-		  (nph? (string-prefix? "nph-" prog))	; PROG starts with "nph-" ? 
+	 (filename (or (dotdot-check bin-dir (list prog))
+		       (signal 'cgi-dot-dot-error)))
+
+	 (nph? (string-prefix? "nph-" prog))	; PROG starts with "nph-" ? 
 					; why did we had (string-suffix? "-nph" prog) here?
 
-		  (search (http-url:search (request:url req)))	; Compute the
+	 (search (http-url:search (request:url req)))	; Compute the
-		  (argv (if (and search (not (string-index search #\=)))	; argv list.
+	 (argv (if (and search (not (string-index search #\=)))	; argv list.
-			    (split-and-decode-search-spec search)
+		   (split-and-decode-search-spec search)
-			    '()))
+		   '()))
 
-		  (env (cgi-env req bin-dir (cdr path) request-invariant-cgi-env))
+	 (env (cgi-env req bin-dir (cdr path) request-invariant-cgi-env))
 
-		  (doit (lambda ()
+	 (doit (lambda ()
-			  (dup->inport  (current-input-port) 0)
+		 (dup->inport  (current-input-port) 0)
-			  (dup->outport (current-output-port) 1)
+		 (dup->outport (current-output-port) 1)
-			  (apply exec/env filename env argv))))
+		 (apply exec/env filename env argv))))
 
-	     (http-syslog (syslog-level debug) "[cgi-server] search: ~s, argv: ~s~%" search argv)
+    (http-syslog (syslog-level debug) "[cgi-server] search: ~s, argv: ~s~%" search argv)
-	     (let ((request-method (request:method req)))
+    (let ((request-method (request:method req)))
-	       (cond 
+      (cond 
-		((or (string=? request-method "GET")
+       ((or (string=? request-method "GET")
-		     (string=? request-method "POST"))	; Could do others also.
+	    (string=? request-method "POST"))	; Could do others also.
-		 (if nph?
+	(if nph?
-		     (let ((stat (wait (fork doit))))
+	    (let ((stat (wait (fork doit))))
-		       (if (not (zero? stat))
+	      (if (not (zero? stat))
-			   (http-error http-status/bad-request req
+		  (signal 'cgi-nph-failed-error filename) 
-				       (format #f "Could not execute CGI script ~a."
+		  stat))		;; FIXME! must return http-response object!
-					       filename))
+	    (cgi-make-response (run/port* doit) req)))
-			   stat))
+       
-		     (cgi-send-response (run/port* doit) req)))
+       (else (make-http-error-response http-status/method-not-allowed req))))))
-		
-		(else (http-error http-status/method-not-allowed req)))))
-	   
-	   (http-error http-status/bad-request req "Empty CGI script"))))))
 
 
-  (define (split-and-decode-search-spec s)
+(define (split-and-decode-search-spec s)
-    (let recur ((i 0))
+  (let recur ((i 0))
-      (cond
+    (cond
      ((string-index s #\+ i) => (lambda (j) (cons (unescape-uri s i j)
-					     (recur (+ j 1)))))
+						  (recur (+ j 1)))))
      (else (list (unescape-uri s i (string-length s)))))))
 
 
@@ -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
+			   (signal 'cgi-illegal-content-length-error)))))
-				       req
-				       "Illegal Content-length: header.")))))
 		  
 		  (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
+		    (signal 'cgi-multi-status-line-error))))))
-				"CGI script generated multi-line status header")))))
-	 (out (current-output-port)))
     
     (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).
+    (make-response ;code message seconds mime extras body
-    (if (not (v0.9-request? req))
+     http-status/ok
-	(begin
+     (status-code->text http-status/ok)
-	  (format out "HTTP/1.0 ~a\r~%" stat)
+     (time)
-	  (if ctype (format out "Content-type: ~a\r~%" ctype))
+     ctype
-	  (if loc   (format out "Location: ~a\r~%" loc))
+     '()
-	  (write-crlf out)))
+     (make-writer-body
-
+      (lambda (out options)		; what about loc?
-    (http-syslog (syslog-level debug) "[cgi-server] request:method=~a~%" (request:method req))
+	(copy-inport->outport script-port out)
-    ;; Copy the response body back to the client and close the script port
+	(close-input-port script-port))))))
-    ;; (unless it's a bodiless HEAD transaction).
-    (if (not (string=? (request:method req) "HEAD"))
-	(begin
-	  (copy-inport->outport script-port out)
-	  (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)))