[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/
BKNR Commits
bknr at bknr.net
Wed Feb 18 14:57:40 UTC 2009
Revision: 4279
Author: hans
URL: http://bknr.net/trac/changeset/4279
Warn about unbound *session-secret* when sessions are first used, not upon
startup.
Rename handler-selector to request-dispatcher.
Make PROCESS-REQUEST a generic function and export it so that applications
can bind special variables early in the request processing chain.
U trunk/thirdparty/hunchentoot/acceptor.lisp
U trunk/thirdparty/hunchentoot/packages.lisp
U trunk/thirdparty/hunchentoot/request.lisp
U trunk/thirdparty/hunchentoot/session.lisp
Modified: trunk/thirdparty/hunchentoot/acceptor.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-18 00:32:16 UTC (rev 4278)
+++ trunk/thirdparty/hunchentoot/acceptor.lisp 2009-02-18 14:57:40 UTC (rev 4279)
@@ -62,13 +62,13 @@
objects is created when a request is served in and should be \(a
symbol naming) a class which inherits from REPLY. The default is the
symbol REPLY.")
- (handler-selector :initarg :handler-selector
- :accessor acceptor-handler-selector
- :documentation "A designator for the handler
-selector function used by this acceptor. A function which accepts a
+ (request-dispatcher :initarg :request-dispatcher
+ :accessor acceptor-request-dispatcher
+ :documentation "A designator for the request
+dispatcher 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). The default is the unexported symbol
-LIST-HANDLER-SELECTOR which works through the list *DISPATCH-TABLE*.")
+LIST-REQUEST-DISPATCHER which works through the list *DISPATCH-TABLE*.")
(taskmaster :initarg :taskmaster
:reader acceptor-taskmaster
:documentation "The taskmaster \(i.e. an instance of a
@@ -151,7 +151,7 @@
:name (gensym)
:request-class 'request
:reply-class 'reply
- :handler-selector 'list-handler-selector
+ :request-dispatcher 'list-request-dispatcher
:taskmaster (make-instance (cond (*supports-threads-p* 'one-thread-per-connection-taskmaster)
(t 'single-threaded-taskmaster)))
:output-chunking-p t
@@ -230,11 +230,6 @@
;; general implementation
-(defmethod start :before ((acceptor acceptor))
- (unless (boundp '*session-secret*)
- (hunchentoot-warn "Session secret is unbound. Using Lisp's RANDOM function to initialize it.")
- (reset-session-secret)))
-
(defmethod start ((acceptor acceptor))
(start-listening acceptor)
(let ((taskmaster (acceptor-taskmaster acceptor)))
@@ -286,7 +281,6 @@
(defmethod process-connection ((*acceptor* acceptor) (socket t))
(let ((*hunchentoot-stream*
(initialize-connection-stream *acceptor* (make-socket-stream socket *acceptor*))))
- (print *hunchentoot-stream*)
(unwind-protect
;; process requests until either the acceptor is shut down,
;; *CLOSE-HUNCHENTOOT-STREAM* has been set to T by the
@@ -337,53 +331,6 @@
(ignore-errors
(force-output *hunchentoot-stream*)
(close *hunchentoot-stream* :abort t))))))
-
-(defun process-request (request)
- "This function is called by PROCESS-CONNECTION after the incoming
-headers have been read. It selects and calls a handler and sends the
-output of this handler to the client using START-OUTPUT. It also sets
-up simple error handling for the actual request handler.
-
-The return value of this function is ignored."
- (let (*tmp-files* *headers-sent*)
- (unwind-protect
- (let* ((*request* request))
- (multiple-value-bind (body error)
- (catch 'handler-done
- (handler-bind ((error
- (lambda (cond)
- (when *log-lisp-errors-p*
- (log-message *lisp-errors-log-level* "~A" cond))
- ;; if the headers were already sent
- ;; the error happens within the body
- ;; and we have to close the stream
- (when *headers-sent*
- (setq *close-hunchentoot-stream* t))
- (throw 'handler-done
- (values nil cond))))
- (warning
- (lambda (cond)
- (when *log-lisp-warnings-p*
- (log-message *lisp-warnings-log-level* "~A" cond)))))
- ;; skip dispatch if bad request
- (when (eql (return-code *reply*) +http-ok+)
- ;; now do the work
- (funcall (acceptor-handler-selector *acceptor*) *request*))))
- (when error
- (setf (return-code *reply*)
- +http-internal-server-error+))
- (start-output :content (cond ((and error *show-lisp-errors-p*)
- (format nil "<pre>~A</pre>"
- (escape-for-html (format nil "~A" error))))
- (error
- "An error has occured.")
- (t body)))))
- (dolist (path *tmp-files*)
- (when (and (pathnamep path) (probe-file path))
- ;; the handler may have chosen to (re)move the uploaded
- ;; file, so ignore errors that happen during deletion
- (ignore-errors
- (delete-file path)))))))
(defmethod acceptor-ssl-p ((acceptor t))
;; the default is to always answer "no"
@@ -454,7 +401,7 @@
(mp:process-unstop (acceptor-process acceptor))
nil)
-(defun list-handler-selector (request)
+(defun list-request-dispatcher (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."
Modified: trunk/thirdparty/hunchentoot/packages.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/packages.lisp 2009-02-18 00:32:16 UTC (rev 4278)
+++ trunk/thirdparty/hunchentoot/packages.lisp 2009-02-18 14:57:40 UTC (rev 4279)
@@ -121,7 +121,7 @@
"ACCEPTOR-ACCESS-LOGGER"
"ACCEPTOR-ADDRESS"
"ACCEPT-CONNECTIONS"
- "ACCEPTOR-HANDLER-SELECTOR"
+ "ACCEPTOR-REQUEST-DISPATCHER"
"ACCEPTOR-INPUT-CHUNKING-P"
"ACCEPTOR-MESSAGE-LOGGER"
"ACCEPTOR-NAME"
@@ -194,6 +194,7 @@
"POST-PARAMETERS"
"POST-PARAMETERS*"
"PROCESS-CONNECTION"
+ "PROCESS-REQUEST"
"QUERY-STRING"
"QUERY-STRING*"
"RAW-POST-DATA"
Modified: trunk/thirdparty/hunchentoot/request.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/request.lisp 2009-02-18 00:32:16 UTC (rev 4278)
+++ trunk/thirdparty/hunchentoot/request.lisp 2009-02-18 14:57:40 UTC (rev 4279)
@@ -95,6 +95,14 @@
can subclass REQUEST in order to implement your own behaviour. See
the REQUEST-CLASS slot of the ACCEPTOR class."))
+(defgeneric process-request (request)
+ (:documentation "This function is called by PROCESS-CONNECTION after the incoming
+headers have been read. It selects and calls a handler and sends the
+output of this handler to the client using START-OUTPUT. It also sets
+up simple error handling for the actual request handler.
+
+The return value of this function is ignored."))
+
(defun convert-hack (string external-format)
"The rfc2388 package is buggy in that it operates on a character
stream and thus only accepts encodings which are 8 bit transparent.
@@ -195,6 +203,50 @@
;; we assume it's not our fault...
(setf (return-code*) +http-bad-request+)))))
+(defmethod process-request (request)
+
+ "Standard implementation for processing a request."
+
+ (let (*tmp-files* *headers-sent*)
+ (unwind-protect
+ (let* ((*request* request))
+ (multiple-value-bind (body error)
+ (catch 'handler-done
+ (handler-bind ((error
+ (lambda (cond)
+ (when *log-lisp-errors-p*
+ (log-message *lisp-errors-log-level* "~A" cond))
+ ;; if the headers were already sent
+ ;; the error happens within the body
+ ;; and we have to close the stream
+ (when *headers-sent*
+ (setq *close-hunchentoot-stream* t))
+ (throw 'handler-done
+ (values nil cond))))
+ (warning
+ (lambda (cond)
+ (when *log-lisp-warnings-p*
+ (log-message *lisp-warnings-log-level* "~A" cond)))))
+ ;; skip dispatch if bad request
+ (when (eql (return-code *reply*) +http-ok+)
+ ;; now do the work
+ (funcall (acceptor-request-dispatcher *acceptor*) *request*))))
+ (when error
+ (setf (return-code *reply*)
+ +http-internal-server-error+))
+ (start-output :content (cond ((and error *show-lisp-errors-p*)
+ (format nil "<pre>~A</pre>"
+ (escape-for-html (format nil "~A" error))))
+ (error
+ "An error has occured.")
+ (t body)))))
+ (dolist (path *tmp-files*)
+ (when (and (pathnamep path) (probe-file path))
+ ;; the handler may have chosen to (re)move the uploaded
+ ;; file, so ignore errors that happen during deletion
+ (ignore-errors
+ (delete-file path)))))))
+
(defun parse-multipart-form-data (request external-format)
"Parse the REQUEST body as multipart/form-data, assuming that its
content type has already been verified. Returns the form data as
Modified: trunk/thirdparty/hunchentoot/session.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/session.lisp 2009-02-18 00:32:16 UTC (rev 4278)
+++ trunk/thirdparty/hunchentoot/session.lisp 2009-02-18 14:57:40 UTC (rev 4279)
@@ -129,6 +129,9 @@
USER-AGENT, REMOTE-ADDR, and START"
;; *SESSION-SECRET* is used twice due to known theoretical
;; vulnerabilities of MD5 encoding
+ (unless (boundp '*session-secret*)
+ (hunchentoot-warn "Session secret is unbound. Using Lisp's RANDOM function to initialize it.")
+ (reset-session-secret))
(md5-hex (concatenate 'string
*session-secret*
(md5-hex (format nil "~A~A~@[~A~]~@[~A~]~A"
More information about the Bknr-cvs
mailing list