Revision: 4250 Author: edi URL: http://bknr.net/trac/changeset/4250
Checkpoint
U trunk/thirdparty/hunchentoot/acceptor.lisp U trunk/thirdparty/hunchentoot/misc.lisp U trunk/thirdparty/hunchentoot/packages.lisp U trunk/thirdparty/hunchentoot/request.lisp U trunk/thirdparty/hunchentoot/specials.lisp U trunk/thirdparty/hunchentoot/test/test-handlers.lisp
Modified: trunk/thirdparty/hunchentoot/acceptor.lisp =================================================================== --- trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-12 22:33:37 UTC (rev 4249) +++ trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-12 23:09:58 UTC (rev 4250) @@ -44,10 +44,12 @@ :documentation "Determines which class of request objects is created when a request comes in and should be (a symbol naming) a class which inherits from REQUEST.") - (request-dispatcher :initarg :request-dispatcher - :accessor acceptor-request-dispatcher - :documentation "The dispatcher function used by -this acceptor.") + (handler-selector :initarg :handler-selector + :accessor acceptor-handler-selector + :documentation "The handler selector function +used by this acceptor. A function which accepts a REQUEST object and +calls a request handler of its choice (and returns its return +value).") (connection-dispatcher :initarg :connection-dispatcher :reader acceptor-connection-dispatcher :documentation "The connection dispatcher that is @@ -121,7 +123,7 @@ :port 80 :name (gensym) :request-class 'request - :request-dispatcher 'dispatch-request + :handler-selector 'list-handler-selector :connection-dispatcher (make-instance (cond (*supports-threads-p* 'one-thread-per-connection-dispatcher) (t 'single-threaded-connection-dispatcher))) :output-chunking-p t @@ -322,7 +324,7 @@ ;; skip dispatch if bad request (when (eql (return-code) +http-ok+) ;; now do the work - (funcall (acceptor-request-dispatcher *acceptor*) *request* *reply*)))) + (funcall (acceptor-handler-selector *acceptor*) *request*)))) (when error (setf (return-code *reply*) +http-internal-server-error+)) @@ -406,12 +408,12 @@ (defmethod accept-connections ((acceptor acceptor)) (mp:process-unstop (acceptor-process acceptor)))
-;;; TODO -(defgeneric dispatch-request (request reply) - (:documentation "") - (:method (request reply) - (loop for dispatcher in *dispatch-table* - for action = (funcall dispatcher request) - when action return (funcall action) - finally (setf (return-code reply) +http-not-found+)))) +(defun list-handler-selector (request) + "The default handler selector which selects a request handler based +on a list of individual request dispatchers all of which can either +return a handler or neglect by returning NIL." + (loop for dispatcher in *dispatch-table* + for action = (funcall dispatcher request) + when action return (funcall action) + finally (setf (return-code *reply*) +http-not-found+)))
Modified: trunk/thirdparty/hunchentoot/misc.lisp =================================================================== --- trunk/thirdparty/hunchentoot/misc.lisp 2009-02-12 22:33:37 UTC (rev 4249) +++ trunk/thirdparty/hunchentoot/misc.lisp 2009-02-12 23:09:58 UTC (rev 4250) @@ -128,6 +128,12 @@ (and (scan scanner (script-name request)) handler))))
+(defun abort-request-handler (&optional result) + "This function can be called by a request handler at any time to +immediately abort handling the request. This works as if the handler +had returned RESULT. See the source code of REDIRECT for an example." + (throw 'handler-done result)) + (defun handle-static-file (path &optional content-type) "A function which acts like a Hunchentoot handler for the file denoted by PATH. Send a content type header corresponding to @@ -138,7 +144,7 @@ (fad:directory-exists-p path)) ;; does not exist (setf (return-code) +http-not-found+) - (throw 'handler-done nil)) + (abort-request-handler)) (let ((time (or (file-write-date path) (get-universal-time)))) (setf (content-type) (or content-type (mime-type path) @@ -203,7 +209,7 @@ (loop for component in (rest script-path-directory) always (stringp component)))) (setf (return-code) +http-forbidden+) - (throw 'handler-done nil)) + (abort-request-handler)) (handle-static-file (merge-pathnames script-path base-path) content-type)))) (create-prefix-dispatcher uri-prefix #'handler)))
@@ -248,7 +254,7 @@ (setq url (add-cookie-value-to-url url :replace-ampersands-p nil))) (setf (header-out :location) url (return-code *reply*) code) - (throw 'handler-done nil))) + (abort-request-handler)))
(defun require-authorization (&optional (realm "Hunchentoot")) "Sends back appropriate headers to require basic HTTP authentication @@ -257,4 +263,4 @@ (format nil "Basic realm="~A"" (quote-string realm)) (return-code *reply*) +http-authorization-required+) - (throw 'handler-done nil)) + (abort-request-handler))
Modified: trunk/thirdparty/hunchentoot/packages.lisp =================================================================== --- trunk/thirdparty/hunchentoot/packages.lisp 2009-02-12 22:33:37 UTC (rev 4249) +++ trunk/thirdparty/hunchentoot/packages.lisp 2009-02-12 23:09:58 UTC (rev 4250) @@ -116,9 +116,11 @@ "+HTTP-UNSUPPORTED-MEDIA-TYPE+" "+HTTP-USE-PROXY+" "+HTTP-VERSION-NOT-SUPPORTED+" + "ABORT-REQUEST-HANDLER" "ACCEPTOR" "ACCEPTOR-ACCESS-LOGGER" "ACCEPTOR-ADDRESS" + "ACCEPTOR-HANDLER-SELECTOR" "ACCEPTOR-INPUT-CHUNKING-P" "ACCEPTOR-MESSAGE-LOGGER" "ACCEPTOR-NAME" @@ -127,7 +129,6 @@ "ACCEPTOR-PORT" "ACCEPTOR-READ-TIMEOUT" "ACCEPTOR-REQUEST-CLASS" - "ACCEPTOR-REQUEST-DISPATCHER" "ACCEPTOR-SSL-P" "ACCEPTOR-SSL-CERTIFICATE-FILE" "ACCEPTOR-SSL-PRIVATEKEY-FILE" @@ -159,7 +160,6 @@ "DELETE-AUX-REQUEST-VALUE" "DELETE-SESSION-VALUE" "DISPATCH-EASY-HANDLERS" - "DISPATCH-REQUEST" "ESCAPE-FOR-HTML" "EXECUTE-ACCEPTOR" "GET-PARAMETER" @@ -168,7 +168,6 @@ "HANDLE-INCOMING-CONNECTION" "HANDLE-IF-MODIFIED-SINCE" "HANDLE-STATIC-FILE" - "HANDLER-DONE" "HEADER-IN" "HEADER-IN*" "HEADER-OUT"
Modified: trunk/thirdparty/hunchentoot/request.lisp =================================================================== --- trunk/thirdparty/hunchentoot/request.lisp 2009-02-12 22:33:37 UTC (rev 4249) +++ trunk/thirdparty/hunchentoot/request.lisp 2009-02-12 23:09:58 UTC (rev 4250) @@ -397,7 +397,7 @@ (when (and if-modified-since (equal if-modified-since time-string)) (setf (return-code) +http-not-modified+) - (throw 'handler-done nil)) + (abort-request-handler)) (values)))
(defun external-format-from-content-type (content-type)
Modified: trunk/thirdparty/hunchentoot/specials.lisp =================================================================== --- trunk/thirdparty/hunchentoot/specials.lisp 2009-02-12 22:33:37 UTC (rev 4249) +++ trunk/thirdparty/hunchentoot/specials.lisp 2009-02-12 23:09:58 UTC (rev 4250) @@ -255,7 +255,7 @@ #+:openmcl "http://openmcl.clozure.com/" "A link to the website of the underlying Lisp implementation.")
-(defvar *dispatch-table* (list 'default-dispatcher) +(defvar *dispatch-table* (list 'dispatch-easy-handlers 'default-dispatcher) "A global list of dispatch functions.")
(defvar *default-handler* 'default-handler
Modified: trunk/thirdparty/hunchentoot/test/test-handlers.lisp =================================================================== --- trunk/thirdparty/hunchentoot/test/test-handlers.lisp 2009-02-12 22:33:37 UTC (rev 4249) +++ trunk/thirdparty/hunchentoot/test/test-handlers.lisp 2009-02-12 23:09:58 UTC (rev 4250) @@ -161,7 +161,7 @@ " cookie test") (:p "You might have to reload this page to see the cookie value.") (info-table (cookie-in "pumpkin") - (mapcar #'car (cookies-in*))))))) + (mapcar 'car (cookies-in*)))))))
(defun session-test () (let ((new-foo-value (post-parameter "new-foo-value"))) @@ -200,7 +200,7 @@ :value (or (session-value 'bar) "")))) (info-table (session-cookie-name *acceptor*) (cookie-in (session-cookie-name *acceptor*)) - (mapcar #'car (cookies-in*)) + (mapcar 'car (cookies-in*)) (session-value 'foo) (session-value 'bar))))))
@@ -225,10 +225,10 @@ :name "foo"))) (case method (:get (info-table (query-string*) - (map 'list #'char-code (get-parameter "foo")) + (map 'list 'char-code (get-parameter "foo")) (get-parameter "foo"))) (:post (info-table (raw-post-data) - (map 'list #'char-code (post-parameter "foo")) + (map 'list 'char-code (post-parameter "foo")) (post-parameter "foo"))))))))
(defun parameter-test-latin1-get () @@ -262,7 +262,7 @@ :type nil :defaults *tmp-test-directory*))) ;; strip directory info sent by Windows browsers - (when (search "Windows" (user-agent) :test #'char-equal) + (when (search "Windows" (user-agent) :test 'char-equal) (setq file-name (cl-ppcre:regex-replace ".*\\" file-name ""))) (rename-file path (ensure-directories-exist new-path)) (push (list new-path file-name content-type) *tmp-test-files*)))))) @@ -328,7 +328,7 @@ (let* ((path (get-parameter "path")) (file-info (and path (find (pathname path) *tmp-test-files* - :key #'first :test #'equal)))) + :key 'first :test 'equal)))) (unless file-info (setf (return-code *reply*) +http-not-found+) @@ -444,7 +444,7 @@ (:input :type "checkbox" :name "team" :value player - :checked (member player team :test #'string=) + :checked (member player team :test 'string=) (esc player)) (:br))))) (:tr @@ -541,7 +541,7 @@ :defaults *this-file*) "text/plain")) (mapcar (lambda (args) - (apply #'create-prefix-dispatcher args)) + (apply 'create-prefix-dispatcher args)) '(("/hunchentoot/test/form-test.html" form-test) ("/hunchentoot/test/forbidden.html" forbidden) ("/hunchentoot/test/info.html" info) @@ -561,4 +561,4 @@ ("/hunchentoot/test/utf8-string.txt" stream-direct-utf-8-string) ("/hunchentoot/test/files/" send-file) ("/hunchentoot/test" menu))) - (list #'default-dispatcher))) + (list 'default-dispatcher)))