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

Elide REALLY-MAKE-HTTP-ERROR-RESPONSE in the process.
This commit is contained in:
sperber 2002-08-27 09:39:05 +00:00
parent f5b7f76bd6
commit c97bbfc1db
3 changed files with 144 additions and 147 deletions

View File

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

View File

@ -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.
@ -63,3 +64,133 @@
(define (status-code->text code)
(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)))

View File

@ -254,9 +254,7 @@
;; Web server
(define-interface httpd-core-interface
(export httpd
make-http-error-response
time->http-date-string))
(export httpd))
(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