make more pleasent error messages

This commit is contained in:
interp 2002-09-03 12:45:39 +00:00
parent 1694d372c5
commit 80257c0822
6 changed files with 37 additions and 13 deletions

View File

@ -138,7 +138,8 @@
(else (else
(cgi-make-response (run/port* doit) path req))))) (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) (define (split-and-decode-search-spec s)

View File

@ -161,7 +161,9 @@
(else (make-http-error-response http-status/forbidden req))))) (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) (define (directory-index-serve-response fname file-path req)
(file-serve-response (string-append fname "index.html") file-path req)) (file-serve-response (string-append fname "index.html") file-path req))
@ -396,7 +398,8 @@
(emit-tag port 'hr) (emit-tag port 'hr)
(format port "~d files" n-files)))))))))))) (format port "~d files" n-files))))))))))))
(else (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) (define (index-or-directory-serve-response fname file-path req)
(let ((index-fname (string-append fname "index.html"))) (let ((index-fname (string-append fname "index.html")))

View File

@ -167,7 +167,9 @@
(with-tag out address () (with-tag out address ()
(write-string address out))))))) (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 (define split-header-line
(let ((split (infix-splitter (make-regexp "(, *)|( +)|( *\t *)"))) (let ((split (infix-splitter (make-regexp "(, *)|( +)|( *\t *)")))

View File

@ -99,6 +99,9 @@
(generic-title (lambda (port) (generic-title (lambda (port)
(title-html port (title-html port
(status-code->text status-code)))) (status-code->text status-code))))
(send-message (lambda (port)
(if message
(format port "<BR>~%Further Information: ~A<BR>~%" message))))
(close-html (lambda (port) (close-html (lambda (port)
(for-each (lambda (x) (format port "<BR>~s~%" x)) extras) (for-each (lambda (x) (format port "<BR>~s~%" x)) extras)
(write-string "</BODY>\n" port))) (write-string "</BODY>\n" port)))
@ -135,17 +138,19 @@
(generic-title port) (generic-title port)
(write-string "<P>Client sent a query that this server could not understand.\n" (write-string "<P>Client sent a query that this server could not understand.\n"
port) port)
(if message (format port "<BR>~%Reason: ~A~%" message)) (send-message port)
(close-html port)))) (close-html port))))
((= status-code http-status/unauthorized) ((= status-code http-status/unauthorized)
(create-response (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) (lambda (port options)
(title-html port "Authorization Required") (title-html port "Authorization Required")
(write-string "<P>Browser not authentication-capable or\n" port) (write-string "<P>Browser not authentication-capable or\n" port)
(write-string "authentication failed.\n" port) (write-string "authentication failed.\n" port)
(if message (format port "~a~%" message)) (send-message port)
(close-html port)))) (close-html port))))
((= status-code http-status/forbidden) ((= status-code http-status/forbidden)
@ -157,7 +162,7 @@
"Your client does not have permission to perform a ~A~%" "Your client does not have permission to perform a ~A~%"
(request:method req)) (request:method req))
(format port "operation on url ~a.~%" (request:uri req)) (format port "operation on url ~a.~%" (request:uri req))
(if message (format port "<P>~%~a~%" message)) (send-message port)
(close-html port)))) (close-html port))))
((= status-code http-status/not-found) ((= status-code http-status/not-found)
@ -168,7 +173,7 @@
(write-string (write-string
"<P>The requested URL was not found on this server.\n" "<P>The requested URL was not found on this server.\n"
port) port)
(if message (format port "<P>~%~a~%" message)) (send-message port)
(close-html port)))) (close-html port))))
((= status-code http-status/internal-error) ((= 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 Please inform the server administrator, ~A, of the circumstances leading to
the error, and time it occured.~%" the error, and time it occured.~%"
(httpd-options-server-admin options)) (httpd-options-server-admin options))
(if message (format port "<P>~%~a~%" message)) (send-message port)
(close-html port)))) (close-html port))))
((= status-code http-status/not-implemented) ((= status-code http-status/not-implemented)
@ -194,7 +199,17 @@ the error, and time it occured.~%"
(format port "This server does not currently implement (format port "This server does not currently implement
the requested method (~A).~%" the requested method (~A).~%"
(request:method req)) (request:method req))
(if message (format port "<P>~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)))) (close-html port))))
(else (else
@ -203,6 +218,7 @@ the requested method (~A).~%"
'() '()
(lambda (port options) (lambda (port options)
(generic-title port) (generic-title port)
(send-message port)
(close-html port))))))) (close-html port)))))))
(define (title-html out message) (define (title-html out message)

View File

@ -68,7 +68,9 @@
(with-tag out address () (with-tag out address ()
(display address out))))))) (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) (define (cat-man-page key section out)
(let ((title (if section (let ((title (if section

View File

@ -47,7 +47,7 @@
((string=? request-method "POST") ; Could do others also. ((string=? request-method "POST") ; Could do others also.
(seval path req)) (seval path req))
(else (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) (define (seval path req)
(make-response (make-response