[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/
BKNR Commits
bknr at bknr.net
Wed Feb 9 17:07:09 UTC 2011
Revision: 4644
Author: hans
URL: http://bknr.net/trac/changeset/4644
Add skeleton file tree to be served by Hunchentoot in its default
configuration.
Make error pages customizable through files.
Add new :document-root argument to acceptor to specify where files should
be served from.
U trunk/thirdparty/hunchentoot/acceptor.lisp
U trunk/thirdparty/hunchentoot/doc/index.xml
U trunk/thirdparty/hunchentoot/easy-handlers.lisp
U trunk/thirdparty/hunchentoot/misc.lisp
A trunk/thirdparty/hunchentoot/www/
A trunk/thirdparty/hunchentoot/www/errors/
A trunk/thirdparty/hunchentoot/www/errors/404.html
A trunk/thirdparty/hunchentoot/www/img/
A trunk/thirdparty/hunchentoot/www/img/made-with-lisp-logo.jpg
A trunk/thirdparty/hunchentoot/www/index.html
Modified: trunk/thirdparty/hunchentoot/acceptor.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/acceptor.lisp 2011-02-07 17:42:05 UTC (rev 4643)
+++ trunk/thirdparty/hunchentoot/acceptor.lisp 2011-02-09 17:07:08 UTC (rev 4644)
@@ -29,6 +29,10 @@
(in-package :hunchentoot)
+(eval-when (:load-toplevel)
+ (defun default-document-directory (&optional sub-directory)
+ (asdf:system-relative-pathname :hunchentoot (format nil "www/~@[~A~]" sub-directory))))
+
(defclass acceptor ()
((port :initarg :port
:reader acceptor-port
@@ -124,7 +128,20 @@
:documentation "Pathname of the server error
log file which is used to log informational,
warning and error messages in a free-text
-format intended for human inspection"))
+format intended for human inspection")
+ (error-template-directory :initarg :error-template-directory
+ :accessor acceptor-error-template-directory
+ :documentation "Directory pathname that
+ contains error message template files for server-generated error
+ messages. Files must be named <return-code>.html with <return-code>
+ representing the HTTP return code that the file applies to,
+ i.e. 404.html would be used as the content for a HTTP 404 Not found
+ response.")
+ (document-root :initarg :document-root
+ :accessor acceptor-document-root
+ :documentation "Directory pathname that points to
+files that are served by the acceptor if no more specific
+acceptor-dispatch-request method handles the request."))
(:default-initargs
:address nil
:port 80
@@ -139,7 +156,9 @@
:read-timeout *default-connection-timeout*
:write-timeout *default-connection-timeout*
:access-log-pathname nil
- :message-log-pathname nil)
+ :message-log-pathname nil
+ :document-root (load-time-value (default-document-directory))
+ :error-template-directory (load-time-value (default-document-directory "errors/")))
(:documentation "To create a Hunchentoot webserver, you make an
instance of this class and use the generic function START to start it
\(and STOP to stop it). Use the :PORT initarg if you don't want to
@@ -457,7 +476,12 @@
(defmethod acceptor-dispatch-request ((acceptor acceptor) request)
"Detault implementation of the request dispatch method, generates a +http-not-found+ error+."
(declare (ignore request))
- (setf (return-code *reply*) +http-not-found+))
+ (if (acceptor-document-root acceptor)
+ (handle-static-file (merge-pathnames (if (equal (script-name*) "/")
+ "index.html"
+ (subseq (script-name*) 1))
+ (acceptor-document-root acceptor)))
+ (setf (return-code *reply*) +http-not-found+)))
(defmethod handle-request ((*acceptor* acceptor) (*request* request))
"Standard method for request handling. Calls the request dispatcher
@@ -493,41 +517,72 @@
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."))
+ send the data to the client stream itself.
+ 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."))
+
(defmethod acceptor-handle-return-code ((acceptor acceptor) http-return-code content)
"Default function to generate error message sent to the client."
- (flet ((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))))
- (case http-return-code
- ((#.+http-internal-server-error+
- #.+http-ok+)
- content)
- ((#.+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. ~
+ (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)))))))
+ (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)
+ :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))))
+ ((#.+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)))))
(defgeneric acceptor-remove-session (acceptor session)
(:documentation
Modified: trunk/thirdparty/hunchentoot/doc/index.xml
===================================================================
--- trunk/thirdparty/hunchentoot/doc/index.xml 2011-02-07 17:42:05 UTC (rev 4643)
+++ trunk/thirdparty/hunchentoot/doc/index.xml 2011-02-09 17:07:08 UTC (rev 4644)
@@ -475,10 +475,10 @@
</clix:returns>
</clix:listed-accessor>
- <clix:listed-accessor generic='true' name='acceptor-request-dispatcher'>
+ <clix:listed-accessor generic='true' name='acceptor-error-template-directory'>
<clix:lambda-list>acceptor
</clix:lambda-list>
- <clix:returns>request-dispatcher
+ <clix:returns>(or pathname null)
</clix:returns>
</clix:listed-accessor>
@@ -531,6 +531,13 @@
</clix:returns>
</clix:listed-accessor>
+ <clix:listed-accessor generic='true' name='acceptor-request-dispatcher'>
+ <clix:lambda-list>acceptor
+ </clix:lambda-list>
+ <clix:returns>request-dispatcher
+ </clix:returns>
+ </clix:listed-accessor>
+
<clix:description>
These are accessors for various slots of <clix:ref>ACCEPTOR</clix:ref>
objects. See the docstrings of these slots for more information and
@@ -685,6 +692,32 @@
</clix:description>
</clix:function>
+ <clix:function name="acceptor-handle-return-code" 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.
+
+ 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.
+ </clix:description>
+ </clix:function>
+
</clix:subchapter>
<clix:subchapter name="taskmasters" title="Taskmasters">
Modified: trunk/thirdparty/hunchentoot/easy-handlers.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/easy-handlers.lisp 2011-02-07 17:42:05 UTC (rev 4643)
+++ trunk/thirdparty/hunchentoot/easy-handlers.lisp 2011-02-09 17:07:08 UTC (rev 4644)
@@ -29,7 +29,7 @@
(in-package :hunchentoot)
-(defvar *dispatch-table* (list 'dispatch-easy-handlers 'default-dispatcher)
+(defvar *dispatch-table* (list 'dispatch-easy-handlers)
"A global list of dispatch functions.")
(defvar *easy-handler-alist* nil
@@ -339,4 +339,4 @@
(loop for dispatcher in *dispatch-table*
for action = (funcall dispatcher request)
when action return (funcall action)
- finally (setf (return-code *reply*) +http-not-found+)))
+ finally (call-next-method)))
Modified: trunk/thirdparty/hunchentoot/misc.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/misc.lisp 2011-02-07 17:42:05 UTC (rev 4643)
+++ trunk/thirdparty/hunchentoot/misc.lisp 2011-02-09 17:07:08 UTC (rev 4644)
@@ -145,28 +145,29 @@
bytes-to-send (1+ (- end start))))
bytes-to-send))
-(defun handle-static-file (path &optional content-type)
+(defun handle-static-file (pathname &optional content-type)
"A function which acts like a Hunchentoot handler for the file
-denoted by PATH. Sends a content type header corresponding to
+denoted by PATHNAME. Sends a content type header corresponding to
CONTENT-TYPE or \(if that is NIL) tries to determine the content type
via the file's suffix."
- (when (or (wild-pathname-p path)
- (not (fad:file-exists-p path))
- (fad:directory-exists-p path))
+ (when (or (wild-pathname-p pathname)
+ (not (fad:file-exists-p pathname))
+ (fad:directory-exists-p pathname))
;; file does not exist
(setf (return-code*) +http-not-found+)
(abort-request-handler))
- (let ((time (or (file-write-date path) (get-universal-time)))
+ (let ((time (or (file-write-date pathname)
+ (get-universal-time)))
bytes-to-send)
- (setf (content-type*) (or content-type
- (mime-type path)
- "application/octet-stream"))
(handle-if-modified-since time)
- (with-open-file (file path
- :direction :input
- :element-type 'octet
- :if-does-not-exist nil)
- (setf (header-out :content-range) (format nil "bytes 0-~D/*" (file-length file))
+ (with-open-file (file pathname
+ :direction :input
+ :element-type 'octet
+ :if-does-not-exist nil)
+ (setf (content-type*) (or content-type
+ (mime-type pathname)
+ "application/octet-stream")
+ (header-out :content-range) (format nil "bytes 0-~D/*" (file-length file))
(header-out :last-modified) (rfc-1123-date time)
bytes-to-send (maybe-handle-range-header file)
(content-length*) bytes-to-send)
Added: trunk/thirdparty/hunchentoot/www/errors/404.html
===================================================================
--- trunk/thirdparty/hunchentoot/www/errors/404.html (rev 0)
+++ trunk/thirdparty/hunchentoot/www/errors/404.html 2011-02-09 17:07:08 UTC (rev 4644)
@@ -0,0 +1,9 @@
+<html>
+ <head>
+ <title>Not found</title>
+ </head>
+ <body>
+ Resource ${script-name} not found.
+ <img src="/img/made-with-lisp-logo.jpg" width="300" height="100"/>
+ </body>
+</html>
Added: trunk/thirdparty/hunchentoot/www/img/made-with-lisp-logo.jpg
===================================================================
(Binary files differ)
Property changes on: trunk/thirdparty/hunchentoot/www/img/made-with-lisp-logo.jpg
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: trunk/thirdparty/hunchentoot/www/index.html
===================================================================
--- trunk/thirdparty/hunchentoot/www/index.html (rev 0)
+++ trunk/thirdparty/hunchentoot/www/index.html 2011-02-09 17:07:08 UTC (rev 4644)
@@ -0,0 +1,17 @@
+<html>
+ <head>
+ <title>Welcome to Hunchentoot!</title>
+ </head>
+ <body>
+ <h1>Welcome</h1>
+ <p>
+ When you're reading this message, Hunchentoot has been properly installed.
+ </p>
+ <p>
+ Please read the <a href="../doc/index.html">documentation</a>.
+ </p>
+ <p>
+ <img src="img/made-with-lisp-logo.jpg" width="300" height="100"/>
+ </p>
+ </body>
+</html>
More information about the Bknr-cvs
mailing list