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:descriptionA 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:descriptionContains <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:descriptionContains <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:refREDIRECT</clix:ref> for an example. </clix:description> </clix:function>
+ <clix:function name="handle-http-error"> + clix:lambda-listclix:lkwoptional</clix:lkw> description</clix:lambda-list> + clix:returnsstring (formatted error message)</clix:returns> + clix:description + Default HTTP error handler (see clix:ref*HTTP-ERROR-HANDLER*</clix:ref>). + <p> + Looks at clix:refRETURN-CODE*</clix:ref> and formats corresponding error message with + reason phrase (see clix:refREASON-PHRASE</clix:ref>) and optional + clix:argdescription</clix:arg>. + </p> + </clix:description> + </clix:function> + <clix:function name="handle-static-file"> clix:lambda-listpath clix:lkwoptional</clix:lkw> content-type</clix:lambda-list> clix:returnsnil</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