So there was the need to handle the HTTP 500 error in two different
ways depending on the current request string. So I threw error
formatting code from START-OUTPUT and PROCESS-REQUEST to a separate
function for start. Then I tried to make this function
context-depended so I set the default value of *HTTP-ERROR-HANDLER* to
this function and put error detection and handling code to
HANDLE-REQUEST.
Now HANDLE-REQUST responds to lisp and http errors by calling
*HTTP-ERROR-HANDLER* and passing to it condition and backtrace in case
of lisp error and dispatcher's return value in case of HTTP error.
This error handler looks at RETURN-CODE* and formats corresponding
error message. START-OUTPUT and PROCESS-REQUEST now just write what
HANDLE-REQUEST returns.
Now I can do something like (let ((*http-error-handler*
'custom-handler-for-this-site... in the dispatcher.
There is little problem with compatibility: *HTTP-ERROR-HANDLER* takes
error code as single argument before but now it taking error
description string as single argument (can take return-code from reply
object). I have no idea to save backward compatibility here.
Here is a draft patch:
diff --git a/acceptor.lisp b/acceptor.lisp
index f90aa55..9f15947 100644
--- a/acceptor.lisp
+++ b/acceptor.lisp
@@ -421,6 +421,32 @@ chunked encoding, but acceptor is configured to
not use it.")))))
(mp:process-unstop (acceptor-process acceptor))
nil)
+(defun handle-http-error (&optional description)
+ "Standard HTTP error handler. Looks at return code and
+formats corresponding error message. Return value is error message
+typically shown in user's web browser."
+ (let* ((return-code (return-code*))
+ (reason-phrase (reason-phrase return-code)))
+ (format nil "<html><head><title>~D
~A</title></head><body><h1>~:*~A</h1><hr /><p>~A</p><p>~A</p><hr
/><p>~A</p></body></html>"
+ return-code reason-phrase
+ (case return-code
+ ((#.+http-moved-temporarily+ #.+http-moved-permanently+)
+ (format nil "The document has moved <a href='~A'>here</a>"
+ (header-out :location)))
+ ((#.+http-authorization-required+)
+ "The server could not verify that you are authorized
to access the document requested. Either you supplied the wrong
credentials \(e.g., bad password), or your browser doesn't understand
how to supply the credentials required.")
+ ((#.+http-forbidden+)
+ (format nil "You don't have permission to access ~A on
this server."
+ (script-name *request*)))
+ ((#.+http-not-found+)
+ (format nil "The requested URL ~A was not found on this server."
+ (script-name *request*)))
+ ((#.+http-bad-request+)
+ "Your browser sent a request that this server could
not understand.")
+ (otherwise ""))
+ (or description "")
+ (address-string))))
+
(defun list-request-dispatcher (request)
"The default request dispatcher which selects a request handler
based on a list of individual request dispatchers all of which can
@@ -433,8 +459,8 @@ either return a handler or neglect by returning NIL."
(defmethod handle-request ((*acceptor* acceptor) (*request* request))
"Standard method for request handling. Calls the request dispatcher
of *ACCEPTOR* to determine how the request should be handled. Also
-sets up standard error handling which catches any errors within the
-handler."
+calls http error handler if return code is error code and sets up standard
+error handling which catches any errors within the handler"
(handler-bind ((error
(lambda (cond)
(when *log-lisp-errors-p*
@@ -447,11 +473,30 @@ handler."
;; the stream
(when *headers-sent*
(setq *close-hunchentoot-stream* t))
+ (setf (return-code*) +http-internal-server-error+)
(throw 'handler-done
- (values nil cond (and *show-lisp-backtraces-p*
(get-backtrace))))))
+ ;; A dispatcher can serve separate web-sites and
+ ;; set custom error pages for them by setting
+ ;; *http-error-handler* variable.
+ (funcall
+ *http-error-handler*
+ (let ((description
+ (format nil
+ "~A~%~A"
+ (if *show-lisp-errors-p* cond "")
+ (if
*show-lisp-backtraces-p* (get-backtrace) ""))))
+ (regex-replace-all "\\n"
(escape-for-html description) (format nil "<br />~%")))))))
(warning
(lambda (cond)
(when *log-lisp-warnings-p*
(log-message *lisp-warnings-log-level* "~A" cond)))))
- (with-debugger
- (funcall (acceptor-request-dispatcher *acceptor*) *request*))))
+ (let ((content (funcall (acceptor-request-dispatcher *acceptor*)
*request*)))
+ ;; Call HTTP error handler when return code is not in approved
+ ;; list and http error handling is turned on.
+ ;; Pass dispatcher's output to error handler's input so
+ ;; dispatcher can format its own error description.
+ (if (or
+ (member (return-code*) *approved-return-codes*)
+ (null *handle-http-errors-p*))
+ content
+ (funcall *http-error-handler* content)))))
diff --git a/doc/index.xml b/doc/index.xml
index df46c7c..a10a38f 100644
--- a/doc/index.xml
+++ b/doc/index.xml
@@ -1619,7 +1619,9 @@ The default method calls the
acceptor's <a href="#request-dispatch">request dispatcher</a>, but you
can of course implement a different behaviour. The default method
also sets up <a href="#logging">standard error handling</a> for
-the <a href="#handlers">handler</a>.
+the <a href="#handlers">handler</a> and calls
<clix:ref>*HTTP-ERROR-HANDLER*</clix:ref>
+(with passing dispatcher's return value to it) if the request dispatcher
+sets return code that not in <clix:ref>*APPROVED-RETURN-CODES*</clix:ref>
</p>
<p>
Might be a good place to bind or rebind special variables which can
@@ -2698,18 +2700,16 @@ see <clix:ref>*HANDLE-HTTP-ERRORS-P*</clix:ref>.
<clix:special-variable name='*handle-http-errors-p*'>
<clix:description>A generalized boolean that determines whether
return codes which
are not in <clix:ref>*APPROVED-RETURN-CODES*</clix:ref> are treated
specially. When its value
-is true (the default), either a default body for the return code or
-the result of calling <clix:ref>*HTTP-ERROR-HANDLER*</clix:ref> is
used. When the value is
-<code>NIL</code>, no special action is taken and you are expected to
supply your
-own response body to describe the error.
+is true (the default), the result of calling
<clix:ref>*HTTP-ERROR-HANDLER*</clix:ref> is used to
+format error message. When the value is <code>NIL</code>, no special
action is taken and you are
+expected to supply your own response body to describe the error.
</clix:description>
</clix:special-variable>
<clix:special-variable name='*http-error-handler*'>
- <clix:description>Contains <code>NIL</code> (the default) or a
function of one argument which is
-called if the content handler has set a return code which is not in
-<clix:ref>*APPROVED-RETURN-CODES*</clix:ref>
-and <clix:ref>*HANDLE-HTTP-ERRORS*</clix:ref> is true.
+ <clix:description>Contains <code>handle-http-error</code> (the
default) or a function of one
+argument (error description) which is called if the content handler
has set a return code which is not in
+<clix:ref>*APPROVED-RETURN-CODES*</clix:ref> and
<clix:ref>*HANDLE-HTTP-ERRORS-P*</clix:ref> is true.
</clix:description>
</clix:special-variable>
@@ -2777,6 +2777,19 @@ source code of <clix:ref>REDIRECT</clix:ref>
for an example.
</clix:description>
</clix:function>
+ <clix:function name="handle-http-error">
+ <clix:lambda-list><clix:lkw>optional</clix:lkw>
description</clix:lambda-list>
+ <clix:returns>string (formatted error message)</clix:returns>
+ <clix:description>
+ Default HTTP error handler (see
<clix:ref>*HTTP-ERROR-HANDLER*</clix:ref>).
+ <p>
+ Looks at <clix:ref>RETURN-CODE*</clix:ref> and formats
corresponding error message with
+ reason phrase (see <clix:ref>REASON-PHRASE</clix:ref>) and optional
+ <clix:arg>description</clix:arg>.
+ </p>
+ </clix:description>
+ </clix:function>
+
<clix:function name="handle-static-file">
<clix:lambda-list>path <clix:lkw>optional</clix:lkw>
content-type</clix:lambda-list>
<clix:returns>nil</clix:returns>
diff --git a/headers.lisp b/headers.lisp
index 89df868..0ae2320 100644
--- a/headers.lisp
+++ b/headers.lisp
@@ -74,9 +74,8 @@ writes them directly to the client as an HTTP header line.")
(request *request*))
"Sends all headers and maybe the content body to
*HUNCHENTOOT-STREAM*. Returns immediately and does nothing if called
-more than once per request. Handles the supported return codes
-accordingly. Called by PROCESS-REQUEST and/or SEND-HEADERS. Returns
-the stream to write to."
+more than once per request. Called by PROCESS-REQUEST and/or SEND-HEADERS.
+Returns the stream to write to."
;; send headers only once
(when *headers-sent*
(return-from start-output))
@@ -135,41 +134,6 @@ the stream to write to."
content-modified-p t
return-code +http-internal-server-error+
reason-phrase (reason-phrase return-code)))
- (unless (or (not *handle-http-errors-p*)
- (member return-code *approved-return-codes*))
- ;; call error handler, if any - should return NIL if it can't
- ;; handle the error
- (let (error-handled-p)
- (when *http-error-handler*
- (setq error-handled-p (funcall *http-error-handler* return-code)
- content (or error-handled-p content)
- content-modified-p (or content-modified-p error-handled-p)))
- ;; handle common return codes other than 200, which weren't
- ;; handled by the error handler
- (unless error-handled-p
- (setf (content-type*)
- "text/html; charset=iso-8859-1"
- content-modified-p t
- content
- (format nil "<html><head><title>~D
~A</title></head><body><h1>~:*~A</h1>~A<p><hr>~A</p></body></html>"
- return-code reason-phrase
- (case return-code
- ((#.+http-internal-server-error+) content)
- ((#.+http-moved-temporarily+
#.+http-moved-permanently+)
- (format nil "The document has moved <a
href='~A'>here</a>"
- (escape-for-html (header-out :location))))
- ((#.+http-authorization-required+)
- "The server could not verify that you are
authorized to access the document requested. Either you supplied the
wrong credentials \(e.g., bad password), or your browser doesn't
understand how to supply the credentials required.")
- ((#.+http-forbidden+)
- (format nil "You don't have permission to
access ~A on this server."
- (escape-for-html (script-name request))))
- ((#.+http-not-found+)
- (format nil "The requested URL ~A was not
found on this server."
- (escape-for-html (script-name request))))
- ((#.+http-bad-request+)
- "Your browser sent a request that this
server could not understand.")
- (otherwise ""))
- (address-string))))))
;; start with status line
(let ((first-line
(format nil "HTTP/1.1 ~D ~A" return-code reason-phrase)))
diff --git a/request.lisp b/request.lisp
index ea0e2a7..1ef7daa 100644
--- a/request.lisp
+++ b/request.lisp
@@ -216,22 +216,7 @@ doing."
(unwind-protect
(with-mapped-conditions ()
(let* ((*request* request))
- (multiple-value-bind (body error backtrace)
- ;; skip dispatch if bad request
- (when (eql (return-code *reply*) +http-ok+)
- (catch 'handler-done
- (handle-request *acceptor* *request*)))
- (when error
- (setf (return-code *reply*)
- +http-internal-server-error+))
- (start-output :content (cond ((and error *show-lisp-errors-p*)
- (format nil
"<pre>~A~@[~%~%Backtrace:~A~]</pre>"
- (escape-for-html
(format nil "~A" error))
- (when
*show-lisp-backtraces-p*
-
(escape-for-html (format nil "~A" backtrace)))))
- (error
- "An error has occured.")
- (t body))))))
+ (start-output :content (catch 'handler-done
(handle-request *acceptor* *request*)))))
(dolist (path *tmp-files*)
(when (and (pathnamep path) (probe-file path))
;; the handler may have chosen to (re)move the uploaded
diff --git a/specials.lisp b/specials.lisp
index 7759ad5..84ccf66 100644
--- a/specials.lisp
+++ b/specials.lisp
@@ -270,10 +270,11 @@ DEFAULT-DISPATCHER.")
"An alist of \(URI acceptor-names function) lists defined by
DEFINE-EASY-HANDLER.")
-(defvar *http-error-handler* nil
- "Contains NIL \(the default) or a function of one argument which is
-called if the content handler has set a return code which is not in
-*APPROVED-RETURN-CODES* and *HANDLE-HTTP-ERRORS* is true.")
+(defvar *http-error-handler* 'handle-http-error
+ "Contains 'handle-http-error (by default) or a function of one
+argument (error description) which is called if the content handler
+has set a return code which is not in *APPROVED-RETURN-CODES* and
+*HANDLE-HTTP-ERRORS* is true")
(defvar *handle-http-errors-p* t
"A generalized boolean that determines whether return codes which
