From 80257c082274a3d64e70918338e7ff1bd0d95a8d Mon Sep 17 00:00:00 2001 From: interp Date: Tue, 3 Sep 2002 12:45:39 +0000 Subject: [PATCH] make more pleasent error messages --- scheme/httpd/cgi-server.scm | 3 ++- scheme/httpd/file-dir-handler.scm | 7 +++++-- scheme/httpd/info-gateway.scm | 4 +++- scheme/httpd/response.scm | 30 +++++++++++++++++++++++------- scheme/httpd/rman-gateway.scm | 4 +++- scheme/httpd/seval.scm | 2 +- 6 files changed, 37 insertions(+), 13 deletions(-) diff --git a/scheme/httpd/cgi-server.scm b/scheme/httpd/cgi-server.scm index 2c0cbfe..4dda10e 100644 --- a/scheme/httpd/cgi-server.scm +++ b/scheme/httpd/cgi-server.scm @@ -138,7 +138,8 @@ (else (cgi-make-response (run/port* doit) path req))))) - (else (make-http-error-response http-status/method-not-allowed req)))))) + (else + (make-http-error-response http-status/method-not-allowed req request-method)))))) (define (split-and-decode-search-spec s) diff --git a/scheme/httpd/file-dir-handler.scm b/scheme/httpd/file-dir-handler.scm index fa1e09e..f01d45e 100644 --- a/scheme/httpd/file-dir-handler.scm +++ b/scheme/httpd/file-dir-handler.scm @@ -161,7 +161,9 @@ (else (make-http-error-response http-status/forbidden req))))) - (else (make-http-error-response http-status/method-not-allowed req)))))) + (else + (make-http-error-response http-status/method-not-allowed req + request-method)))))) (define (directory-index-serve-response fname file-path req) (file-serve-response (string-append fname "index.html") file-path req)) @@ -396,7 +398,8 @@ (emit-tag port 'hr) (format port "~d files" n-files)))))))))))) (else - (make-http-error-response http-status/method-not-allowed req))))) + (make-http-error-response http-status/method-not-allowed req + request-method))))) (define (index-or-directory-serve-response fname file-path req) (let ((index-fname (string-append fname "index.html"))) diff --git a/scheme/httpd/info-gateway.scm b/scheme/httpd/info-gateway.scm index 1f56d69..9592221 100644 --- a/scheme/httpd/info-gateway.scm +++ b/scheme/httpd/info-gateway.scm @@ -167,7 +167,9 @@ (with-tag out address () (write-string address out))))))) - (else (http-error http-status/method-not-allowed req))))))) + (else + (make-http-error-response http-status/method-not-allowed req + request-method))))))) (define split-header-line (let ((split (infix-splitter (make-regexp "(, *)|( +)|( *\t *)"))) diff --git a/scheme/httpd/response.scm b/scheme/httpd/response.scm index 499e2d0..74bc184 100644 --- a/scheme/httpd/response.scm +++ b/scheme/httpd/response.scm @@ -99,6 +99,9 @@ (generic-title (lambda (port) (title-html port (status-code->text status-code)))) + (send-message (lambda (port) + (if message + (format port "
~%Further Information: ~A
~%" message)))) (close-html (lambda (port) (for-each (lambda (x) (format port "
~s~%" x)) extras) (write-string "\n" port))) @@ -135,17 +138,19 @@ (generic-title port) (write-string "

Client sent a query that this server could not understand.\n" port) - (if message (format port "
~%Reason: ~A~%" message)) + (send-message port) (close-html port)))) ((= status-code http-status/unauthorized) (create-response - (list (cons 'WWW-Authenticate message)) ; Vas is das? + (list (cons 'WWW-Authenticate message)) ; Vas is das? + ;; Vas das is? See: http://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html#sec14.47 + ;; message should be a challenge(?) (lambda (port options) (title-html port "Authorization Required") (write-string "

Browser not authentication-capable or\n" port) (write-string "authentication failed.\n" port) - (if message (format port "~a~%" message)) + (send-message port) (close-html port)))) ((= status-code http-status/forbidden) @@ -157,7 +162,7 @@ "Your client does not have permission to perform a ~A~%" (request:method req)) (format port "operation on url ~a.~%" (request:uri req)) - (if message (format port "

~%~a~%" message)) + (send-message port) (close-html port)))) ((= status-code http-status/not-found) @@ -168,7 +173,7 @@ (write-string "

The requested URL was not found on this server.\n" port) - (if message (format port "

~%~a~%" message)) + (send-message port) (close-html port)))) ((= status-code http-status/internal-error) @@ -183,7 +188,7 @@ misconfiguration and was unable to complete your request. Please inform the server administrator, ~A, of the circumstances leading to the error, and time it occured.~%" (httpd-options-server-admin options)) - (if message (format port "

~%~a~%" message)) + (send-message port) (close-html port)))) ((= status-code http-status/not-implemented) @@ -194,7 +199,17 @@ the error, and time it occured.~%" (format port "This server does not currently implement the requested method (~A).~%" (request:method req)) - (if message (format port "

~a~%" message)) + (send-message port) + (close-html port)))) + + ((= status-code http-status/bad-gateway) + (create-response + '() + (lambda (port options) + (generic-title port) + (format port "An error occured while waiting for the +response of a gateway.~%") + (send-message port) (close-html port)))) (else @@ -203,6 +218,7 @@ the requested method (~A).~%" '() (lambda (port options) (generic-title port) + (send-message port) (close-html port))))))) (define (title-html out message) diff --git a/scheme/httpd/rman-gateway.scm b/scheme/httpd/rman-gateway.scm index 7681193..55afad3 100644 --- a/scheme/httpd/rman-gateway.scm +++ b/scheme/httpd/rman-gateway.scm @@ -68,7 +68,9 @@ (with-tag out address () (display address out))))))) - (else (http-error http-status/method-not-allowed req))))))) + (else + (make-http-error-response http-status/method-not-allowed req + request-method))))))) (define (cat-man-page key section out) (let ((title (if section diff --git a/scheme/httpd/seval.scm b/scheme/httpd/seval.scm index 4697fba..7254b5d 100644 --- a/scheme/httpd/seval.scm +++ b/scheme/httpd/seval.scm @@ -47,7 +47,7 @@ ((string=? request-method "POST") ; Could do others also. (seval path req)) (else - (make-http-error-response http-status/method-not-allowed req))))) + (make-http-error-response http-status/method-not-allowed req request-method))))) (define (seval path req) (make-response