From 5bced0b8f7e4ed84d7e15fe8184b1753245c05f6 Mon Sep 17 00:00:00 2001 From: interp Date: Thu, 29 Aug 2002 08:32:39 +0000 Subject: [PATCH] remove introduced but nerving signal stuff from handlers --- scheme/httpd/cgi-server.scm | 94 +++++++++-------------------- scheme/httpd/seval.scm | 37 +----------- scheme/packages.scm | 2 - web-server/root/cgi-bin/comments.sh | 2 +- 4 files changed, 31 insertions(+), 104 deletions(-) diff --git a/scheme/httpd/cgi-server.scm b/scheme/httpd/cgi-server.scm index c3c8ca8..045f08d 100644 --- a/scheme/httpd/cgi-server.scm +++ b/scheme/httpd/cgi-server.scm @@ -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)))))) diff --git a/scheme/httpd/seval.scm b/scheme/httpd/seval.scm index a4d22ff..4697fba 100644 --- a/scheme/httpd/seval.scm +++ b/scheme/httpd/seval.scm @@ -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.")))) diff --git a/scheme/packages.scm b/scheme/packages.scm index 517ffc7..d010874 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -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))) diff --git a/web-server/root/cgi-bin/comments.sh b/web-server/root/cgi-bin/comments.sh index 6e796e8..f3e9815 100755 --- a/web-server/root/cgi-bin/comments.sh +++ b/web-server/root/cgi-bin/comments.sh @@ -1,5 +1,5 @@ #!/bin/sh echo Content-Type: text/html -echo +echo Status: 200 echo echo "

This is the cgi script.

"