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

remove introduced but nerving signal stuff from handlers

This commit is contained in:
interp 2002-08-29 08:32:39 +00:00
parent 62b3307fb2
commit 5bced0b8f7
4 changed files with 31 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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))
(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"))))))
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.
(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))))))

37
scheme/httpd/seval.scm
View File

@ -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."))))

2
scheme/packages.scm
View File

@ -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)))

2
web-server/root/cgi-bin/comments.sh
View File

@ -1,5 +1,5 @@
#!/bin/sh
echo Content-Type: text/html
echo
echo Status: 200
echo
echo "<h2> This is the cgi script. </h2>"