diff --git a/scheme/httpd/cgi-server.scm b/scheme/httpd/cgi-server.scm index fad2c51..c8e3d4a 100644 --- a/scheme/httpd/cgi-server.scm +++ b/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)) - (http-error http-status/bad-request req - (format #f "CGI scripts may not contain \"..\" elements.")))) +(define (compute-cgi path req bin-dir request-invariant-cgi-env) + (let* ((prog (car path)) - (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 - (argv (if (and search (not (string-index search #\=))) ; argv list. - (split-and-decode-search-spec search) - '())) + (search (http-url:search (request:url req))) ; Compute the + (argv (if (and search (not (string-index search #\=))) ; argv list. + (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 () - (dup->inport (current-input-port) 0) - (dup->outport (current-output-port) 1) - (apply exec/env filename env argv)))) + (doit (lambda () + (dup->inport (current-input-port) 0) + (dup->outport (current-output-port) 1) + (apply exec/env filename env argv)))) - (http-syslog (syslog-level debug) "[cgi-server] search: ~s, argv: ~s~%" search argv) - (let ((request-method (request:method req))) - (cond - ((or (string=? request-method "GET") - (string=? request-method "POST")) ; Could do others also. - (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))) - - (else (http-error http-status/method-not-allowed req))))) - - (http-error http-status/bad-request req "Empty CGI script")))))) + (http-syslog (syslog-level debug) "[cgi-server] search: ~s, argv: ~s~%" search argv) + (let ((request-method (request:method req))) + (cond + ((or (string=? request-method "GET") + (string=? request-method "POST")) ; Could do others also. + (if nph? + (let ((stat (wait (fork doit)))) + (if (not (zero? stat)) + (signal 'cgi-nph-failed-error filename) + stat)) ;; FIXME! must return http-response object! + (cgi-make-response (run/port* doit) req))) + + (else (make-http-error-response http-status/method-not-allowed req)))))) - (define (split-and-decode-search-spec s) - (let recur ((i 0)) - (cond +(define (split-and-decode-search-spec s) + (let recur ((i 0)) + (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 - 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 - (copy-inport->outport script-port out) - (close-input-port script-port))))) + (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)))))) diff --git a/scheme/packages.scm b/scheme/packages.scm index 27b0a06..870c9d8 100644 --- a/scheme/packages.scm +++ b/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)))