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
parent
f5b7f76bd6
commit
c97bbfc1db
|
|
@ -305,147 +305,6 @@
|
||||||
(write-crlf port))
|
(write-crlf port))
|
||||||
headers))
|
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).
|
;;; Return my Internet host name (my fully-qualified domain name).
|
||||||
;;; This works only if an actual resolver is behind host-info.
|
;;; This works only if an actual resolver is behind host-info.
|
||||||
;;;
|
;;;
|
||||||
|
|
|
||||||
|
|
@ -1,5 +1,6 @@
|
||||||
;;; This file is part of the Scheme Untergrund Networking package.
|
;;; 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.
|
;;; Copyright (c) 2002 by Mike Sperber.
|
||||||
;;; For copyright information, see the file COPYING which comes with
|
;;; For copyright information, see the file COPYING which comes with
|
||||||
;;; the distribution.
|
;;; the distribution.
|
||||||
|
|
@ -63,3 +64,133 @@
|
||||||
|
|
||||||
(define (status-code->text code)
|
(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)))
|
||||||
|
|
|
||||||
|
|
@ -254,9 +254,7 @@
|
||||||
;; Web server
|
;; Web server
|
||||||
|
|
||||||
(define-interface httpd-core-interface
|
(define-interface httpd-core-interface
|
||||||
(export httpd
|
(export httpd))
|
||||||
make-http-error-response
|
|
||||||
time->http-date-string))
|
|
||||||
|
|
||||||
(define-interface httpd-make-options-interface
|
(define-interface httpd-make-options-interface
|
||||||
(export make-httpd-options
|
(export make-httpd-options
|
||||||
|
|
@ -362,7 +360,10 @@
|
||||||
http-status/not-implemented
|
http-status/not-implemented
|
||||||
http-status/bad-gateway
|
http-status/bad-gateway
|
||||||
http-status/service-unavailable
|
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
|
(define-interface httpd-basic-handlers-interface
|
||||||
(export make-request-handler
|
(export make-request-handler
|
||||||
|
|
@ -751,8 +752,14 @@
|
||||||
|
|
||||||
(define-structure httpd-responses httpd-responses-interface
|
(define-structure httpd-responses httpd-responses-interface
|
||||||
(open scheme
|
(open scheme
|
||||||
|
(subset scsh (format-date write-string time date))
|
||||||
|
syslog
|
||||||
srfi-9
|
srfi-9
|
||||||
defenum-package)
|
defenum-package
|
||||||
|
formats
|
||||||
|
httpd-request
|
||||||
|
httpd-logging
|
||||||
|
httpd-read-options)
|
||||||
(files (httpd response)))
|
(files (httpd response)))
|
||||||
|
|
||||||
(define-structure httpd-basic-handlers httpd-basic-handlers-interface
|
(define-structure httpd-basic-handlers httpd-basic-handlers-interface
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue