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

changes to make-error-response: 

(1)no special treatment of first "optional" argument
- rationale: a different number of args is required depending on the
specific error code

(2)use close-html to write out all _effectively_ optional args

(3)generated html-pages are valid XHTML 1.0 Strict

(4)require header Allow for 405 errors

(5)more exact descriptions of errors in generated html-pages

TODO: handle calls of make-error-response with too little args
This commit is contained in:
vibr 2004-07-30 22:25:03 +00:00
parent 63e4761c58
commit 7c7be57a22
1 changed files with 68 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

146
scheme/httpd/response.scm
View File

@ -142,149 +142,139 @@
(else (else
(loop (+ i 1))))))) (loop (+ i 1)))))))
;;; (make-error-response status-code req [message . extras]) ;;; (make-error-response status-code req [extras])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; As a special case, request REQ is allowed to be #f, meaning we haven't ;;; As a special case, request REQ is allowed to be #f, meaning we haven't
;;; even had a chance to parse and construct the request. This is only used ;;; even had a chance to parse and construct the request. This is only used
;;; for 400 BAD-REQUEST error report. ;;; for 400 BAD-REQUEST error report.
(define (make-error-response code req . args)
(let* ((message (and (pair? args) (car args)))
(extras (if (pair? args) (cdr args) '()))
(generic-title (lambda (port)
(title-html port (define (make-error-response code req . extras)
(status-code-message code)))) (let*
(send-message (lambda (port) ((generic-title (lambda (port)
(if message (title-html port
(format port "<BR>~%Further Information: ~A<BR>~%" message)))) (status-code-message code))))
(close-html (lambda (port) (close-html (lambda (port args)
(for-each (lambda (x) (format port "<BR>~s~%" x)) extras) (if (not (null? args))
(write-string "</BODY>\n" port))) (format port "<br/>~%Further Information:~%"))
(for-each (lambda (x) (format port "<br/>~%~s~%" x)) args)
(write-string "</p>\n</body>\n</html>\n" port)))
(create-response (create-response
(lambda (headers writer-proc) (lambda (headers writer-proc)
(make-response code (make-response code
#f #f
(time) (time)
"text/html" "text/html"
headers headers
(make-writer-body writer-proc))))) (make-writer-body writer-proc)))))
(cond (cond
;; This error response requires one arg: ;; This error response requires one arg:
;; message is the Location field. ;; the value of the Location field header,
;; the Location field's field value must be a single absolute URI ;; which must be a single absolute URI
((or (eq? code (status-code found));302 ((or (eq? code (status-code found));302
(eq? code (status-code see-other));303 (eq? code (status-code see-other));303
(eq? code (status-code temp-redirect));307 (eq? code (status-code temp-redirect));307
(eq? code (status-code moved-perm)));301 (eq? code (status-code moved-perm)));301
(create-response (create-response
(list (cons 'location message)) (list (cons 'location (car extras)))
(lambda (port options) (lambda (port options)
(title-html port "Document moved") (title-html port "Document moved")
(format port (format port
"This document has ~A moved to a <A HREF=\"~A\">new location</A>.~%" "This document has ~A moved to a <a href=\"~A\">new location</a>.~%"
(if (eq? code (status-code moved-perm)) (if (eq? code (status-code moved-perm))
"permanently" "permanently"
"temporarily") "temporarily")
message) (car extras))
(close-html port)))) (close-html port (cdr extras)))))
((eq? code (status-code bad-request)) ((eq? code (status-code bad-request))
(create-response (create-response
'() '()
(lambda (port options) (lambda (port options)
(generic-title port) (generic-title port)
(write-string "<P>Client sent a query that this server could not understand.\n" (write-string "The request the client sent could not be understood by this server due to malformed syntax.\n Report to client maintainer.\n" port)
port) (close-html port extras))))
(send-message port)
(close-html port))))
;; This error response requires two args:
;; the first one is the disallowed method;
;; the second one is the value of the Allow field header,
;; which must be a list of valid methods for the requested resource
((eq? code (status-code method-not-allowed)) ((eq? code (status-code method-not-allowed))
(create-response (create-response
'() (list (cons 'allow (cadr extras)))
(lambda (port options) (lambda (port options)
(generic-title port) (generic-title port)
(write-string "<P>Method not allowed.\n" port) (format port "The method ~A is not allowed on the requested resource.~%" (car extras))
(send-message port) (close-html port (cddr extras)))))
(close-html port))))
;; This error response requires one arg:
;; the value of the WWW-Authenticate header field,
;; which must be a challenge (as described in RFC 2617)
((eq? code (status-code unauthorized)) ((eq? code (status-code unauthorized))
(create-response (create-response
(list (cons 'WWW-Authenticate message)) ; Vas is das? (list (cons 'WWW-Authenticate (car extras)))
;; 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 "Authentication Required")
(write-string "<P>Browser not authentication-capable or\n" port) (write-string "Client not authentication-capable or authentication failed.\n" port)
(write-string "authentication failed.\n" port) (close-html port (cdr extras)))))
(send-message port)
(close-html port))))
((eq? code (status-code forbidden)) ((eq? code (status-code forbidden))
(create-response (create-response
'() '()
(lambda (port options) (lambda (port options)
(title-html port "Request not allowed.") (title-html port "Request not allowed.")
(format port (write-string "The request the client sent is not allowed.\n" port)
"Your client does not have permission to perform a ~A~%" (close-html port extras))))
(request-method req))
(format port "operation on url ~a.~%" (request-uri req))
(send-message port)
(close-html port))))
((eq? code (status-code not-found)) ((eq? code (status-code not-found))
(create-response (create-response
'() '()
(lambda (port options) (lambda (port options)
(title-html port "URL not found") (title-html port "Resource not found")
(write-string (write-string "The requested resource was not found on this server.\n" port)
"<P>The requested URL was not found on this server.\n" (close-html port extras))))
port)
(send-message port)
(close-html port))))
((eq? code (status-code internal-error)) ((eq? code (status-code internal-error))
(create-response (create-response
'() '()
(lambda (port options) (lambda (port options)
(generic-title port) (generic-title port)
(format port "The server encountered an internal error or (format port "This server encountered an internal error or misconfiguration and was unable to complete your request.~%<br/>~%Please inform the server administrator ~A of the circumstances leading to the error, and the time it occured.~%"
misconfiguration and was unable to complete your request.
<P>
Please inform the server administrator, ~A, of the circumstances leading to
the error, and time it occured.~%"
(or (httpd-options-server-admin options) (or (httpd-options-server-admin options)
"[no mail address available]")) "[no mail address available]"))
(send-message port) (close-html port extras))))
(close-html port))))
;; This error response requires one arg:
;; the unimplemented method
((eq? code (status-code not-implemented)) ((eq? code (status-code not-implemented))
(create-response (create-response
'() '()
(lambda (port options) (lambda (port options)
(generic-title port) (generic-title port)
(format port "This server does not currently implement (format port "This server does not recognize or does not implement the requested method \"~A\".~%"
the requested method (~A).~%" (car extras))
(request-method req)) (close-html port (cdr extras)))))
(send-message port)
(close-html port))))
((eq? code (status-code bad-gateway)) ((eq? code (status-code bad-gateway))
(create-response (create-response
'() '()
(lambda (port options) (lambda (port options)
(generic-title port) (generic-title port)
(format port "An error occured while waiting for the (format port "This server recieved an invalid response from the upstream server it accessed in attempting to fulfill the request.~%")
response of a gateway.~%") (close-html port extras)))))))
(send-message port)
(close-html port)))))))
(define (title-html out message) (define (title-html out message)
(format out "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message) ;;produce valid XHTML 1.0 Strict
(format out "<BODY>~%<H1>~A</H1>~%" message)) (write-string
"<?xml version=\"1.0\" encoding=\"iso-8859-1\" ?>
<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">
<html xmlns=\"http://www.w3.org/1999/xhtml\" lang=\"en\" xml:lang=\"en\">\n" out)
(format out "<head>~%<title>~%~A~%</title>~%</head>~%~%" message)
(format out "<body>~%<h1>~A</h1>~%<p>~%" message))
;; Creates a redirect response. The server will serve the new file ;; Creates a redirect response. The server will serve the new file
;; indicated by NEW-LOCATION. NEW-LOCATION must be uri-encoded and ;; indicated by NEW-LOCATION. NEW-LOCATION must be uri-encoded and