[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/
BKNR Commits
bknr at bknr.net
Fri Feb 11 10:10:17 UTC 2011
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-list>acceptor 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:arg>CONTENT</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:arg>CONTENT</clix:arg> argument can be NIL if the
- handler wants to send the data to the client stream itself.
+ invoked to convert the <clix:arg>HTTP-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:arg>HTTP-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>
More information about the Bknr-cvs
mailing list