remove introduced but nerving signal stuff from handlers
This commit is contained in:
parent
62b3307fb2
commit
5bced0b8f7
|
@ -75,74 +75,30 @@
|
|||
;;; 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
|
||||
|
||||
(define (cgi-handler bin-dir . maybe-cgi-bin-path)
|
||||
(let-optionals
|
||||
maybe-cgi-bin-path
|
||||
((cgi-bin-path cgi-default-bin-path))
|
||||
maybe-cgi-bin-path
|
||||
((cgi-bin-path cgi-default-bin-path))
|
||||
|
||||
(let ((request-invariant-cgi-env ; environment variables that never change
|
||||
`(("PATH" . ,(and (getenv "PATH") cgi-bin-path))
|
||||
("SERVER_SOFTWARE" . ,sunet-version-identifier)
|
||||
("SERVER_NAME" . ,(host-info:name (host-info (system-name))))
|
||||
("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)
|
||||
(exit
|
||||
(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"))))))
|
||||
(let ((request-invariant-cgi-env ; environment variables that never change
|
||||
`(("PATH" . ,(and (getenv "PATH") cgi-bin-path))
|
||||
("SERVER_SOFTWARE" . ,sunet-version-identifier)
|
||||
("SERVER_NAME" . ,(host-info:name (host-info (system-name))))
|
||||
("GATEWAY_INTERFACE" . "CGI/1.1"))))
|
||||
(lambda (path req)
|
||||
(if (pair? path) ; Got to have at least one elt.
|
||||
(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))
|
||||
(signal 'cgi-dot-dot-error)))
|
||||
(http-error http-status/bad-request req
|
||||
"CGI scripts may not contain \"..\" elements.")))
|
||||
|
||||
(nph? (string-prefix? "nph-" prog)) ; PROG starts with "nph-" ?
|
||||
; why did we had (string-suffix? "-nph" prog) here?
|
||||
|
@ -167,7 +123,10 @@
|
|||
(if nph?
|
||||
(let ((stat (wait (fork doit))))
|
||||
(if (not (zero? stat))
|
||||
(signal 'cgi-nph-failed-error filename)
|
||||
(make-http-error-response
|
||||
http-status/bad-request req
|
||||
(format #f "Could not execute CGI script ~a."
|
||||
filename))
|
||||
stat)) ;; FIXME! must return http-response object!
|
||||
(cgi-make-response (run/port* doit) req)))
|
||||
|
||||
|
@ -253,7 +212,8 @@
|
|||
(cl-len (string-length cl)))
|
||||
(if first-digit
|
||||
`(("CONTENT_LENGTH" . ,(substring cl first-digit cl-len)))
|
||||
(signal 'cgi-illegal-content-length-error)))))
|
||||
(http-error http-status/bad-request req
|
||||
"Illegal `Content-length:' header.")))))
|
||||
|
||||
(else '()))
|
||||
|
||||
|
@ -284,12 +244,12 @@
|
|||
((null? (cdr stat-lines)) ; One line status header.
|
||||
(car stat-lines))
|
||||
(else ; Vas ist das?
|
||||
(signal 'cgi-multi-status-line-error)))))
|
||||
(extra-headers (delete-headers
|
||||
(delete-headers
|
||||
(delete-headers headers 'content-type)
|
||||
'location)
|
||||
'status)))
|
||||
(http-error http-status/internal-error req
|
||||
"CGI script generated multi-line status header.")))))
|
||||
(extra-headers (delete-headers (delete-headers (delete-headers headers
|
||||
'content-type)
|
||||
'location)
|
||||
'status)))
|
||||
|
||||
(http-syslog (syslog-level debug) "[cgi-server] headers: ~s~%" headers)
|
||||
(http-syslog (syslog-level debug) "[cgi-server] request:method=~a~%"
|
||||
|
@ -302,7 +262,7 @@
|
|||
ctype
|
||||
extra-headers
|
||||
(make-writer-body
|
||||
(lambda (out options) ; what about loc?
|
||||
(lambda (out options) ; what about loc&status?
|
||||
(copy-inport->outport script-port out)
|
||||
(close-input-port script-port))))))
|
||||
|
||||
|
|
|
@ -38,16 +38,6 @@
|
|||
(syntax-rules ()
|
||||
((do/timeout secs body ...) (do/timeout* secs (lambda () body ...)))))
|
||||
|
||||
(define-condition-type 'seval-error '())
|
||||
(define seval-error? (condition-predicate 'seval-error))
|
||||
|
||||
(define-condition-type 'seval-no-content-length-error '(seval-error))
|
||||
(define seval-no-content-length-error?
|
||||
(condition-predicate 'seval-no-content-length-error))
|
||||
|
||||
(define-condition-type 'seval-no-program '(seval-error))
|
||||
(define seval-no-program? (condition-predicate 'seval-no-program))
|
||||
|
||||
;;; The path handler for seval ops.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
@ -55,28 +45,7 @@
|
|||
(let ((request-method (request:method req)))
|
||||
(cond
|
||||
((string=? request-method "POST") ; Could do others also.
|
||||
(call-with-current-continuation
|
||||
(lambda (exit)
|
||||
(begin
|
||||
(with-handler
|
||||
(lambda (condition more)
|
||||
(exit
|
||||
(cond
|
||||
((seval-no-content-length-error? condition)
|
||||
(make-http-error-response
|
||||
http-status/bad-request req
|
||||
"No `Content-length:' field in POST request."))
|
||||
((seval-no-program? condition)
|
||||
(make-http-error-response http-status/bad-request req
|
||||
"No program in entity body."))
|
||||
(else
|
||||
(make-http-error-response
|
||||
http-status/internal-error req
|
||||
"Unknown error while evaluating seval-expression."
|
||||
condition)))))
|
||||
(lambda ()
|
||||
(seval path req)))))))
|
||||
|
||||
(seval path req))
|
||||
(else
|
||||
(make-http-error-response http-status/method-not-allowed req)))))
|
||||
|
||||
|
@ -136,8 +105,8 @@
|
|||
(qs (read-string cl iport)) ; Read in CL chars,
|
||||
(q (parse-html-form-query qs)) ; and parse them up.
|
||||
(s (cond ((assoc "program" q) => cdr)
|
||||
(else (signal 'seval-no-program)))))
|
||||
(else (error "No program in entity body.")))))
|
||||
(http-syslog (syslog-level debug)
|
||||
"Seval sexp: ~s" s)
|
||||
(read (make-string-input-port s)))))
|
||||
(else (signal 'seval-no-content-length-error))))
|
||||
(else (error "No `Content-length:' field in POST request."))))
|
||||
|
|
|
@ -806,7 +806,6 @@
|
|||
srfi-13 ; STRING-SKIP
|
||||
rfc822
|
||||
toothless-eval ; EVAL-SAFELY
|
||||
conditions signals
|
||||
handle ; IGNORE-ERROR
|
||||
parse-html-forms ; PARSE-HTML-FORM-QUERY
|
||||
threads ; SLEEP
|
||||
|
@ -863,7 +862,6 @@
|
|||
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)))
|
||||
|
||||
|
|
|
@ -1,5 +1,5 @@
|
|||
#!/bin/sh
|
||||
echo Content-Type: text/html
|
||||
echo
|
||||
echo Status: 200
|
||||
echo
|
||||
echo "<h2> This is the cgi script. </h2>"
|
||||
|
|
Loading…
Reference in New Issue