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))
|
||||
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.
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue