Move MAKE-HTTP-ERROR-RESPONSE from HTTPD-CORE to HTTPD-RESPONSES.

Elide REALLY-MAKE-HTTP-ERROR-RESPONSE in the process.

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 "<BR>~s~%" x)) extras)
-		       (write-string "</BODY>\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 <A HREF=\"~A\">new location</A>.~%"
-		 (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 "<P>Client sent a query that this server could not understand.\n"
-		       port)
-	 (if message (format port "<BR>~%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 "<P>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 "<P>~%~a~%" message))
-	 (close-html port))))
-       
-     ((= status-code http-status/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)
-	 (if message (format port "<P>~%~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.
-<P>
-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 "<P>~%~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 "<P>~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 "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
-  (format out "<BODY>~%<H1>~A</H1>~%" message))
-
 ;;; Return my Internet host name (my fully-qualified domain name).
 ;;; This works only if an actual resolver is behind host-info.
 ;;;

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)))
+  (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 "<BR>~s~%" x)) extras)
+		       (write-string "</BODY>\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 <A HREF=\"~A\">new location</A>.~%"
+		 (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 "<P>Client sent a query that this server could not understand.\n"
+		       port)
+	 (if message (format port "<BR>~%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 "<P>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 "<P>~%~a~%" message))
+	 (close-html port))))
+       
+     ((= status-code http-status/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)
+	 (if message (format port "<P>~%~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.
+<P>
+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 "<P>~%~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 "<P>~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 "<HEAD>~%<TITLE>~%~A~%</TITLE>~%</HEAD>~%~%" message)
+  (format out "<BODY>~%<H1>~A</H1>~%" message))
+
+(define (time->http-date-string time)
+  (format-date "~A, ~d-~b-~y ~H:~M:~S GMT" (date time 0)))

scheme/packages.scm

@@ -254,9 +254,7 @@
 ;; Web server
 
 (define-interface httpd-core-interface
-  (export httpd
+  (export httpd))
-	  make-http-error-response
-	  time->http-date-string))
 
 (define-interface httpd-make-options-interface
   (export make-httpd-options
@@ -362,7 +360,10 @@
 	  http-status/not-implemented
 	  http-status/bad-gateway
 	  http-status/service-unavailable
-	  http-status/gateway-timeout))
+	  http-status/gateway-timeout
+
+	  make-http-error-response
+	  time->http-date-string))
 
 (define-interface httpd-basic-handlers-interface
   (export make-request-handler
@@ -751,8 +752,14 @@
 
 (define-structure httpd-responses httpd-responses-interface
   (open scheme
+	(subset scsh (format-date write-string time date))
+	syslog
 	srfi-9
-	defenum-package)
+	defenum-package
+	formats
+	httpd-request
+	httpd-logging
+	httpd-read-options)
   (files (httpd response)))
 
 (define-structure httpd-basic-handlers httpd-basic-handlers-interface