adpat cgi-server to new response philosophy
NOTE: There's a FIXME left: nph- scripts won't work at all currently.
This commit is contained in:
interp
parent
b08f418d77
commit
542fea9f55
|
|
@ -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))))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue