scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

This commit is contained in:
interp 2002-09-02 13:43:03 +00:00
parent ff56fa6ec1
commit 9baec4fbf0
1 changed files with 45 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
scheme/httpd/cgi-server.scm
View File

@ -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)))
(cond
((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.")))))
(stat (extract-status-code-and-text
(get-header-lines headers 'status) req))
(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
(make-response ;code message seconds mime extras body
http-status/ok
(status-code->text http-status/ok)
(time)
ctype
extra-headers
(make-writer-body
(lambda (out options) ; what about loc&status?
(copy-inport->outport script-port out)
(close-input-port script-port))))))
(write (list 'status-code stat))
(if loc
(if (uri-like? (string-trim loc))
(make-http-error-response http-status/moved-perm req
loc loc)
(make-redirect-response (string-trim loc)))
;; Send the response header back to the client
(make-response ;code message seconds mime extras body
(car stat) ; code
(cdr stat) ; text
(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."))))