diff --git a/scheme/httpd/response.scm b/scheme/httpd/response.scm index a2e6173..8d01426 100644 --- a/scheme/httpd/response.scm +++ b/scheme/httpd/response.scm @@ -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 "
~%Further Information: ~A
~%" message)))) - (close-html (lambda (port) - (for-each (lambda (x) (format port "
~s~%" x)) extras) - (write-string "\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 "
~%Further Information:~%")) + (for-each (lambda (x) (format port "
~%~s~%" x)) args) + (write-string "

\n\n\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 new location.~%" + "This document has ~A moved to a new location.~%" (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 "

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 "

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 "

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 - "

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. -

-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.~%
~%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 "~%~%~A~%~%~%~%" message) - (format out "~%

~A

~%" message)) + ;;produce valid XHTML 1.0 Strict + (write-string + " + + \n" out) + (format out "~%~%~A~%~%~%~%" message) + (format out "~%

~A

~%

~%" message)) ;; Creates a redirect response. The server will serve the new file ;; indicated by NEW-LOCATION. NEW-LOCATION must be uri-encoded and