diff --git a/scheme/httpd/core.scm b/scheme/httpd/core.scm
index 715b948..69e79d9 100644
--- a/scheme/httpd/core.scm
+++ b/scheme/httpd/core.scm
@@ -305,147 +305,6 @@
(write-crlf port))
headers))
-(define (time->http-date-string time)
- (format-date "~A, ~d-~b-~y ~H:~M:~S GMT" (date time 0)))
-
-;;; (make-http-error-response status-code req [message . extras])
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; Take an http-error condition, and format it into a response to the client.
-;;;
-;;; 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.
-
-;;; MAKE-HTTP-ERROR-RESPONSE is called from error handlers, so to avoid
-;;; infinite looping, if an error occurs while it is running, we just
-;;; silently return. (We no longer need to do this; I have changed
-;;; WITH-FATAL-ERROR-HANDLER* so that this is not necessary, but I'll
-;;; leave it in to play it safe.)
-
-(define (make-http-error-response status-code req . args)
- (ignore-errors
- (lambda () ; Ignore errors -- see note above.
- (apply really-make-http-error-response status-code req args))))
-
-(define (really-make-http-error-response status-code req . args)
- (http-log req status-code)
-
- (let* ((message (and (pair? args) (car args)))
- (extras (if (pair? args) (cdr args) '()))
-
- (generic-title (lambda (port)
- (title-html port
- (status-code->text status-code))))
- (close-html (lambda (port)
- (for-each (lambda (x) (format port "
~s~%" x)) extras)
- (write-string "
\n" port))) - - (create-response - (lambda (headers writer-proc) - (make-response status-code - (status-code->text status-code) - (time) - "text/html" - headers - (make-writer-body writer-proc))))) - - (cond - ;; This error response requires two args: message is the new URI: field, - ;; and the first EXTRA is the older Location: field. - ((or (= status-code http-status/moved-temp) - (= status-code http-status/moved-perm)) - (create-response - (list (cons 'uri message) - (cons 'location (car extras))) - (lambda (port options) - (title-html port "Document moved") - (format port - "This document has ~A moved to a new location.~%" - (if (= status-code http-status/moved-temp) "temporarily" "permanently") - message) - (close-html port)))) - - ((= status-code http-status/bad-request) - (create-response - '() - (lambda (port options) - (generic-title port) - (write-string "
Client sent a query that this server could not understand.\n"
- port)
- (if message (format port "
~%Reason: ~A~%" message))
- (close-html port))))
-
- ((= status-code http-status/unauthorized)
- (create-response
- (list (cons 'WWW-Authenticate message)) ; Vas is das?
- (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)) - (close-html port)))) - - ((= status-code http-status/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)) - (if message (format port "
~%~a~%" message)) - (close-html port)))) - - ((= status-code http-status/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) - (if message (format port "
~%~a~%" message)) - (close-html port)))) - - ((= status-code http-status/internal-error) - (http-syslog (syslog-level error) "internal-error: ~A" message) - (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.~%" - (httpd-options-server-admin options)) - (if message (format port "
~%~a~%" message)) - (close-html port)))) - - ((= status-code http-status/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)) - (if message (format port "
~a~%" message)) - (close-html port)))) - - (else - (http-syslog (syslog-level info) "Skipping unhandled status code ~A.~%" status-code) - (create-response - '() - (lambda (port options) - (generic-title port) - (close-html port))))))) - -(define (title-html out message) - (format out "
~%
~%~%~%" message) - (format out "
\n" port))) + + (create-response + (lambda (headers writer-proc) + (make-response status-code + (status-code->text status-code) + (time) + "text/html" + headers + (make-writer-body writer-proc))))) + + (cond + ;; This error response requires two args: message is the new URI: field, + ;; and the first EXTRA is the older Location: field. + ((or (= status-code http-status/moved-temp) + (= status-code http-status/moved-perm)) + (create-response + (list (cons 'uri message) + (cons 'location (car extras))) + (lambda (port options) + (title-html port "Document moved") + (format port + "This document has ~A moved to a new location.~%" + (if (= status-code http-status/moved-temp) "temporarily" "permanently") + message) + (close-html port)))) + + ((= status-code http-status/bad-request) + (create-response + '() + (lambda (port options) + (generic-title port) + (write-string "
Client sent a query that this server could not understand.\n"
+ port)
+ (if message (format port "
~%Reason: ~A~%" message))
+ (close-html port))))
+
+ ((= status-code http-status/unauthorized)
+ (create-response
+ (list (cons 'WWW-Authenticate message)) ; Vas is das?
+ (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)) + (close-html port)))) + + ((= status-code http-status/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)) + (if message (format port "
~%~a~%" message)) + (close-html port)))) + + ((= status-code http-status/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) + (if message (format port "
~%~a~%" message)) + (close-html port)))) + + ((= status-code http-status/internal-error) + (http-syslog (syslog-level error) "internal-error: ~A" message) + (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.~%" + (httpd-options-server-admin options)) + (if message (format port "
~%~a~%" message)) + (close-html port)))) + + ((= status-code http-status/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)) + (if message (format port "
~a~%" message)) + (close-html port)))) + + (else + (http-syslog (syslog-level info) "Skipping unhandled status code ~A.~%" status-code) + (create-response + '() + (lambda (port options) + (generic-title port) + (close-html port))))))) + +(define (title-html out message) + (format out "
~%
~%~%~%" message) + (format out "