[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/
BKNR Commits
bknr at bknr.net
Thu Feb 12 23:09:58 UTC 2009
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)))
More information about the Bknr-cvs
mailing list