Revision: 4650 Author: hans URL: http://bknr.net/trac/changeset/4650
Further status message generation improvements
Provide more substitution variables (${error} and ${backtrace} in particular) Add simple (and ugly) internal server error template Rename ACCEPTOR-HANDLE-RETURN-CODE to ACCEPTOR-STATUS-MESSAGE, make it return the HTML message, remove CONTENT argument to simplify things Update documentation
U trunk/thirdparty/hunchentoot/acceptor.lisp U trunk/thirdparty/hunchentoot/doc/index.xml U trunk/thirdparty/hunchentoot/headers.lisp U trunk/thirdparty/hunchentoot/request.lisp U trunk/thirdparty/hunchentoot/taskmaster.lisp U trunk/thirdparty/hunchentoot/test/test-handlers.lisp A trunk/thirdparty/hunchentoot/www/errors/500.html
Modified: trunk/thirdparty/hunchentoot/acceptor.lisp =================================================================== --- trunk/thirdparty/hunchentoot/acceptor.lisp 2011-02-10 22:20:18 UTC (rev 4649) +++ trunk/thirdparty/hunchentoot/acceptor.lisp 2011-02-11 10:10:17 UTC (rev 4650) @@ -543,84 +543,110 @@ (with-debugger (acceptor-dispatch-request *acceptor* *request*))))
-(defgeneric acceptor-handle-return-code (acceptor http-return-code content) +(defgeneric acceptor-status-message (acceptor http-status-code &key &allow-other-keys) (:documentation "This function is called after the request's handler has been - invoked, before starting to send any output to the client. It - converts the HTTP return code that has been determined as the - result of the handler invocation into a content body sent to the - user. The content generated by the handler is passed to this - function as CONTENT argument. For positive return - codes (i.e. ``200 OK''), the CONTENT is typically just sent to the - client. For other return codes, the content can be ignored and/or - processed, depending on the requirements of the acceptor class. - Note that the CONTENT argument can be NIL if the handler wants to - send the data to the client stream itself. + invoked to convert the HTTP-STATUS-CODE to a HTML message to be + displayed to the user. If this function returns a string, that + string is sent to the client instead of the content produced by the + handler, if any.
If an ERROR-TEMPLATE-DIRECTORY is set in the current acceptor and - the directory contains a file corresponding to HTTP-RETURN-CODE, - that file is sent to the client after variable substitution. - Variables are referenced by ${<variable-name>}. Currently, only - the ${script-name} variable is supported which contains the current - URL relative to the server's base URL.")) + the directory contains a file corresponding to HTTP-STATUS-CODE + named <code>.html, that file is sent to the client after variable + substitution. Variables are referenced by ${<variable-name>}.
-(defmethod acceptor-handle-return-code ((acceptor acceptor) http-return-code content) + Additional keyword arguments may be provided which are made + available to the templating logic as substitution variables. These + variables can be interpolated into error message templates in, + which contains the current URL relative to the server and without + GET parameters. + + In addition to the variables corresponding to keyword arguments, + the script-name, lisp-implementation-type, + lisp-implementation-version and hunchentoot-version variables are + available.")) + +(defun make-cooked-message (http-status-code &key error backtrace) + (labels ((cooked-message (format &rest arguments) + (setf (content-type*) "text/html; charset=iso-8859-1") + (format nil "<html><head><title>~D ~A</title></head><body><h1>~:*~A</h1>~?<p><hr>~A</p></body></html>" + http-status-code (reason-phrase http-status-code) + format (mapcar (lambda (arg) + (if (stringp arg) + (escape-for-html arg) + arg)) + arguments) + (address-string)))) + (case http-status-code + ((#.+http-moved-temporarily+ + #.+http-moved-permanently+) + (cooked-message "The document has moved <a href='~A'>here</a>" (header-out :location))) + ((#.+http-authorization-required+) + (cooked-message "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+) + (cooked-message "You don't have permission to access ~A on this server." + (script-name *request*))) + ((#.+http-not-found+) + (cooked-message "The requested URL ~A was not found on this server." + (script-name *request*))) + ((#.+http-bad-request+) + (cooked-message "Your browser sent a request that this server could not understand.")) + ((#.+http-internal-server-error+) + (if *show-lisp-errors-p* + (cooked-message "<pre>~A~@[~%~%Backtrace:~%~%~A~]</pre>" + (escape-for-html (princ-to-string error)) + (when *show-lisp-backtraces-p* + (escape-for-html (princ-to-string backtrace)))) + (cooked-message "An error has occured")))))) + +(defmethod acceptor-status-message ((acceptor t) http-status-code &rest args &key &allow-other-keys) + (apply 'make-cooked-message http-status-code args)) + +(defmethod acceptor-status-message :around ((acceptor acceptor) http-status-code &rest args &key &allow-other-keys) + (handler-case + (call-next-method) + (error (e) + (log-message* :error "error ~A during error processing, sending cooked message to client" e) + (apply 'make-cooked-message http-status-code args)))) + +(defmethod acceptor-status-message ((acceptor acceptor) http-status-code &rest properties &key &allow-other-keys) "Default function to generate error message sent to the client." (labels - ((cooked-message (format &rest arguments) - (setf (content-type*) "text/html; charset=iso-8859-1") - (format nil "<html><head><title>~D ~A</title></head><body><h1>~:*~A</h1>~?<p><hr>~A</p></body></html>" - http-return-code (reason-phrase http-return-code) - format (mapcar (lambda (arg) - (if (stringp arg) - (escape-for-html arg) - arg)) - arguments) - (address-string))) - (substitute-request-context-variables (string) - (cl-ppcre:regex-replace-all "(?i)\$\{([a-z0-9-_]+)\}" - string - (lambda (target-string start end match-start match-end reg-starts reg-ends) - (declare (ignore start end match-start match-end)) - (let ((variable (intern (string-upcase (subseq target-string - (aref reg-starts 0) - (aref reg-ends 0))) - :keyword))) - (case variable - (:script-name (script-name*)) - (otherwise (string variable))))))) + ((substitute-request-context-variables (string) + (let ((properties (append `(:script-name ,(script-name*) + :lisp-implementation-type ,(lisp-implementation-type) + :lisp-implementation-version ,(lisp-implementation-version) + :hunchentoot-version ,*hunchentoot-version*) + properties))) + (cl-ppcre:regex-replace-all "(?i)\$\{([a-z0-9-_]+)\}" + string + (lambda (target-string start end match-start match-end reg-starts reg-ends) + (declare (ignore start end match-start match-end)) + (let ((variable-name (intern (string-upcase (subseq target-string + (aref reg-starts 0) + (aref reg-ends 0))) + :keyword))) + (escape-for-html (princ-to-string (getf properties variable-name variable-name)))))))) (file-contents (file) (let ((buf (make-string (file-length file)))) (read-sequence buf file) buf)) (error-contents-from-template () (let ((error-file-template-pathname (and (acceptor-error-template-directory acceptor) - (probe-file (make-pathname :name (princ-to-string http-return-code) + (probe-file (make-pathname :name (princ-to-string http-status-code) :type "html" :defaults (acceptor-error-template-directory acceptor)))))) (when error-file-template-pathname (with-open-file (file error-file-template-pathname :if-does-not-exist nil :element-type 'character) (when file (substitute-request-context-variables (file-contents file)))))))) - (or (error-contents-from-template) - (case http-return-code - ((#.+http-moved-temporarily+ - #.+http-moved-permanently+) - (cooked-message "The document has moved <a href='~A'>here</a>" (header-out :location))) - ((#.+http-authorization-required+) - (cooked-message "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+) - (cooked-message "You don't have permission to access ~A on this server." - (script-name *request*))) - ((#.+http-not-found+) - (cooked-message "The requested URL ~A was not found on this server." - (script-name *request*))) - ((#.+http-bad-request+) - (cooked-message "Your browser sent a request that this server could not understand.")) - (otherwise - content))))) + (or (unless (< 300 http-status-code) + (call-next-method)) ; don't ever try template for positive return codes + (error-contents-from-template) ; try template + (call-next-method)))) ; fall back to cooked message
(defgeneric acceptor-remove-session (acceptor session) (:documentation
Modified: trunk/thirdparty/hunchentoot/doc/index.xml =================================================================== --- trunk/thirdparty/hunchentoot/doc/index.xml 2011-02-10 22:20:18 UTC (rev 4649) +++ trunk/thirdparty/hunchentoot/doc/index.xml 2011-02-11 10:10:17 UTC (rev 4650) @@ -704,29 +704,31 @@ </clix:description> </clix:function>
- <clix:function name="acceptor-handle-return-code" generic="true"> + <clix:function name="acceptor-status-message" generic="true"> clix:lambda-listacceptor http-return-code content</clix:lambda-list> clix:description This function is called after the request's handler has been - invoked, before starting to send any output to the client. It - converts the HTTP return code that has been determined as the - result of the handler invocation into a content body sent to - the user. The content generated by the handler is passed to - this function as clix:argCONTENT</clix:arg> argument. For - positive return codes (i.e. ``200 OK''), the CONTENT is - typically just sent to the client. For other return codes, - the content can be ignored and/or processed, depending on the - requirements of the acceptor class. Note that the - clix:argCONTENT</clix:arg> argument can be NIL if the - handler wants to send the data to the client stream itself. + invoked to convert the clix:argHTTP-STATUS-CODE</clix:arg> + to a HTML message to be displayed to the user. If this + function returns a string, that string is sent to the client + instead of the content produced by the handler, if any.
- If an ERROR-TEMPLATE-DIRECTORY is set in the current acceptor - and the directory contains a file corresponding to - clix:argHTTP-RETURN-CODE</clix:arg>, that file is sent to - the client after variable substitution. Variables are - referenced by ${<variable-name>}. Currently, only the - ${script-name} variable is supported which contains the - current URL relative to the server's base URL. + If an ERROR-TEMPLATE-DIRECTORY is set in the current + acceptor and the directory contains a file corresponding to + HTTP-STATUS-CODE named <code>.html, that file is sent + to the client after variable substitution. Variables are + referenced by ${<variable-name>}. + + Additional keyword arguments may be provided which are made + available to the templating logic as substitution variables. + These variables can be interpolated into error message + templates in, which contains the current URL relative to the + server and without GET parameters. + + In addition to the variables corresponding to keyword + arguments, the script-name, lisp-implementation-type, + lisp-implementation-version and hunchentoot-version + variables are available. </clix:description> </clix:function>
Modified: trunk/thirdparty/hunchentoot/headers.lisp =================================================================== --- trunk/thirdparty/hunchentoot/headers.lisp 2011-02-10 22:20:18 UTC (rev 4649) +++ trunk/thirdparty/hunchentoot/headers.lisp 2011-02-11 10:10:17 UTC (rev 4650) @@ -145,9 +145,9 @@ (defun send-response (acceptor stream status-code &key headers cookies content) "Send a HTTP response to the STREAM and log the event in ACCEPTOR. - STATUS-CODE is the HTTP status code used in the response. If - CONTENT-LENGTH, HEADERS and COOKIES are used to create the response - header. If CONTENT is provided, it is sent as the response body. + STATUS-CODE is the HTTP status code used in the response. HEADERS + and COOKIES are used to create the response header. If CONTENT is + provided, it is sent as the response body.
If *HEADER-STREAM* is not NIL, the response headers are written to that stream when they are written to the client. @@ -160,8 +160,7 @@ (setf (cdr (assoc :content-length headers)) (content-length*)) (push (cons :content-length (content-length*)) headers))) ;; access log message - (acceptor-log-access acceptor - :return-code status-code) + (acceptor-log-access acceptor :return-code status-code) ;; Read post data to clear stream - Force binary mode to avoid OCTETS-TO-STRING overhead. (raw-post-data :force-binary t) (let* ((client-header-stream (flex:make-flexi-stream stream :external-format :iso-8859-1)) @@ -180,7 +179,8 @@ (format header-stream "~C~C" #\Return #\Linefeed)) ;; now optional content (when content - (write-sequence content stream)) + (write-sequence content stream) + (finish-output stream)) stream)
(defun send-headers ()
Modified: trunk/thirdparty/hunchentoot/request.lisp =================================================================== --- trunk/thirdparty/hunchentoot/request.lisp 2011-02-10 22:20:18 UTC (rev 4649) +++ trunk/thirdparty/hunchentoot/request.lisp 2011-02-11 10:10:17 UTC (rev 4650) @@ -224,12 +224,10 @@ (log-message* *lisp-errors-log-level* "~A~@[~%~A~]" error (when *log-lisp-backtraces-p* backtrace))) (start-output +http-internal-server-error+ - (if *show-lisp-errors-p* - (format nil "<pre>~A~@[~%~%Backtrace:~%~%~A~]</pre>" - (escape-for-html (princ-to-string error)) - (when *show-lisp-backtraces-p* - (escape-for-html (princ-to-string backtrace)))) - "An error has occured")))) + (acceptor-status-message *acceptor* + +http-internal-server-error+ + :error (princ-to-string error) + :backtrace (princ-to-string backtrace))))) (multiple-value-bind (body error backtrace) ;; skip dispatch if bad request (when (eql (return-code *reply*) +http-ok+) @@ -242,9 +240,9 @@ (handler-case (with-debugger (start-output (return-code *reply*) - (acceptor-handle-return-code *acceptor* - (return-code *reply*) - body))) + (or (acceptor-status-message *acceptor* + (return-code *reply*)) + body))) (error (e) ;; error occured while writing to the client. attempt to report. (report-error-to-client e)))))))
Modified: trunk/thirdparty/hunchentoot/taskmaster.lisp =================================================================== --- trunk/thirdparty/hunchentoot/taskmaster.lisp 2011-02-10 22:20:18 UTC (rev 4649) +++ trunk/thirdparty/hunchentoot/taskmaster.lisp 2011-02-11 10:10:17 UTC (rev 4650) @@ -322,8 +322,7 @@ (send-response acceptor (initialize-connection-stream acceptor (make-socket-stream socket acceptor)) +http-service-unavailable+ - :content "<html><head><title>Service unavailable</title></head><body><h1>Service unavailable</h1>Please try later.</body></html>" - :headers '(("Content-Type" . "text/html"))))) + :content (acceptor-status-message acceptor +http-service-unavailable+))))
#-:lispworks (defun client-as-string (socket)
Modified: trunk/thirdparty/hunchentoot/test/test-handlers.lisp =================================================================== --- trunk/thirdparty/hunchentoot/test/test-handlers.lisp 2011-02-10 22:20:18 UTC (rev 4649) +++ trunk/thirdparty/hunchentoot/test/test-handlers.lisp 2011-02-11 10:10:17 UTC (rev 4650) @@ -135,9 +135,9 @@
(defun oops () (with-html - (log-message :error "Oops (error log level).") - (log-message :warning "Oops (warning log level).") - (log-message :info "Oops (info log level).") + (log-message* :error "Oops (error log level).") + (log-message* :warning "Oops (warning log level).") + (log-message* :info "Oops (info log level).") (error "Errors were triggered on purpose. Check your error log.") (:html (:body "You should never see this sentence..."))))
Added: trunk/thirdparty/hunchentoot/www/errors/500.html =================================================================== --- trunk/thirdparty/hunchentoot/www/errors/500.html (rev 0) +++ trunk/thirdparty/hunchentoot/www/errors/500.html 2011-02-11 10:10:17 UTC (rev 4650) @@ -0,0 +1,18 @@ +<html> + <head> + <title>Internal Server Error</title> + </head> + <body> + <h1>Internal Server Error</h1> + An error occured while processing your ${script-name} request. + <hr/> + <h1>Error Message</h1> +<pre>${error}</pre> + <h1>Backtrace</h1> +<pre>${backtrace}</pre> + <hr/> +<a href="http://weitz.de/hunchentoot">Hunchentoot</a> ${hunchentoot-version} running on ${lisp-implementation-type} ${lisp-implementation-version} + <hr/> + <img src="/img/made-with-lisp-logo.jpg" width="300" height="100"/> + </body> +</html>
-
BKNR Commits