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
scheme/httpd
response.scm

146
scheme/httpd/response.scm
View File

@ -142,149 +142,139 @@
(else
(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
;;; even had a chance to parse and construct the request. This is only used
;;; 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
(status-code-message code))))
(send-message (lambda (port)
(if message
(format port "<BR>~%Further Information: ~A<BR>~%" message))))
(close-html (lambda (port)
(for-each (lambda (x) (format port "<BR>~s~%" x)) extras)
(write-string "</BODY>\n" port)))
(define (make-error-response code req . extras)
(let*
((generic-title (lambda (port)
(title-html port
(status-code-message code))))
(close-html (lambda (port args)
(if (not (null? args))
(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
(lambda (headers writer-proc)
(make-response code
#f
(time)
"text/html"
headers
(make-writer-body writer-proc)))))
(create-response
(lambda (headers writer-proc)
(make-response code
#f
(time)
"text/html"
headers
(make-writer-body writer-proc)))))
(cond
;; This error response requires one arg:
;; message is the Location field.
;; the Location field's field value must be a single absolute URI
;; the value of the Location field header,
;; which must be a single absolute URI
((or (eq? code (status-code found));302
(eq? code (status-code see-other));303
(eq? code (status-code temp-redirect));307
(eq? code (status-code moved-perm)));301
(create-response
(list (cons 'location message))
(list (cons 'location (car extras)))
(lambda (port options)
(title-html port "Document moved")
(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))
"permanently"
"temporarily")
message)
(close-html port))))
(car extras))
(close-html port (cdr extras)))))
((eq? code (status-code bad-request))
(create-response
((eq? code (status-code bad-request))
(create-response
'()
(lambda (port options)
(generic-title port)
(write-string "<P>Client sent a query that this server could not understand.\n"
port)
(send-message port)
(close-html port))))
(lambda (port options)
(generic-title port)
(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)
(close-html port extras))))
;; 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))
(create-response
'()
(list (cons 'allow (cadr extras)))
(lambda (port options)
(generic-title port)
(write-string "<P>Method not allowed.\n" port)
(send-message port)
(close-html port))))
(format port "The method ~A is not allowed on the requested resource.~%" (car extras))
(close-html port (cddr extras)))))
;; 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))
(create-response
(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(?)
(list (cons 'WWW-Authenticate (car extras)))
(lambda (port options)
(title-html port "Authorization Required")
(write-string "<P>Browser not authentication-capable or\n" port)
(write-string "authentication failed.\n" port)
(send-message port)
(close-html port))))
(title-html port "Authentication Required")
(write-string "Client not authentication-capable or authentication failed.\n" port)
(close-html port (cdr extras)))))
((eq? code (status-code forbidden))
(create-response
'()
(lambda (port options)
(title-html port "Request not allowed.")
(format port
"Your client does not have permission to perform a ~A~%"
(request-method req))
(format port "operation on url ~a.~%" (request-uri req))
(send-message port)
(close-html port))))
(write-string "The request the client sent is not allowed.\n" port)
(close-html port extras))))
((eq? code (status-code not-found))
(create-response
'()
(lambda (port options)
(title-html port "URL not found")
(write-string
"<P>The requested URL was not found on this server.\n"
port)
(send-message port)
(close-html port))))
(title-html port "Resource not found")
(write-string "The requested resource was not found on this server.\n" port)
(close-html port extras))))
((eq? code (status-code internal-error))
(create-response
'()
(lambda (port options)
(generic-title port)
(format port "The server encountered an internal error or
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.~%"
(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.~%"
(or (httpd-options-server-admin options)
"[no mail address available]"))
(send-message port)
(close-html port))))
(close-html port extras))))
;; This error response requires one arg:
;; the unimplemented method
((eq? code (status-code not-implemented))
(create-response
'()
(lambda (port options)
(generic-title port)
(format port "This server does not currently implement
the requested method (~A).~%"
(request-method req))
(send-message port)
(close-html port))))
(format port "This server does not recognize or does not implement the requested method \"~A\".~%"
(car extras))
(close-html port (cdr extras)))))
((eq? code (status-code 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)))))))
(format port "This server recieved an invalid response from the upstream server it accessed in attempting to fulfill the request.~%")
(close-html port extras)))))))
(define (title-html out message)
(format out "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
(format out "<BODY>~%<H1>~A</H1>~%" message))
;;produce valid XHTML 1.0 Strict
(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
;; indicated by NEW-LOCATION. NEW-LOCATION must be uri-encoded and