From c97bbfc1db908e11f868796a468bf1426bd6f676 Mon Sep 17 00:00:00 2001
From: sperber
Date: Tue, 27 Aug 2002 09:39:05 +0000
Subject: [PATCH] Move MAKE-HTTP-ERROR-RESPONSE from HTTPD-CORE to
HTTPD-RESPONSES. Elide REALLY-MAKE-HTTP-ERROR-RESPONSE in the process.
---
scheme/httpd/core.scm | 141 --------------------------------------
scheme/httpd/response.scm | 133 ++++++++++++++++++++++++++++++++++-
scheme/packages.scm | 17 +++--
3 files changed, 144 insertions(+), 147 deletions(-)
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 "
~%~%~A~%~%~%~%" message)
- (format out "~%~A
~%" message))
-
;;; Return my Internet host name (my fully-qualified domain name).
;;; This works only if an actual resolver is behind host-info.
;;;
diff --git a/scheme/httpd/response.scm b/scheme/httpd/response.scm
index dd18256..d45c363 100644
--- a/scheme/httpd/response.scm
+++ b/scheme/httpd/response.scm
@@ -1,5 +1,6 @@
;;; This file is part of the Scheme Untergrund Networking package.
+;;; Copyright (c) 1994 by Brian D. Carlstrom and Olin Shivers.
;;; Copyright (c) 2002 by Mike Sperber.
;;; For copyright information, see the file COPYING which comes with
;;; the distribution.
@@ -62,4 +63,134 @@
(gateway-timeout 504 "Gateway Timeout"))
(define (status-code->text code)
- (cdr (assv code http-status-text-table)))
\ No newline at end of file
+ (cdr (assv code http-status-text-table)))
+
+;;; (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.
+
+(define (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 "