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-listacceptor </clix:lambda-list> - clix:returnsrequest-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-listacceptor + </clix:lambda-list> + clix:returnsrequest-dispatcher + </clix:returns> + </clix:listed-accessor> + clix:description These are accessors for various slots of clix:refACCEPTOR</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-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. + + 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 ${&lt;variable-name&gt;}. 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>