[bknr-cvs] edi changed trunk/thirdparty/hunchentoot/
BKNR Commits
bknr at bknr.net
Wed Feb 11 23:10:20 UTC 2009
Revision: 4241
Author: edi
URL: http://bknr.net/trac/changeset/4241
Checkpoint session changes
U trunk/thirdparty/hunchentoot/misc.lisp
U trunk/thirdparty/hunchentoot/packages.lisp
U trunk/thirdparty/hunchentoot/session.lisp
U trunk/thirdparty/hunchentoot/specials.lisp
U trunk/thirdparty/hunchentoot/test/test-handlers.lisp
Modified: trunk/thirdparty/hunchentoot/misc.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/misc.lisp 2009-02-11 21:44:43 UTC (rev 4240)
+++ trunk/thirdparty/hunchentoot/misc.lisp 2009-02-11 23:10:20 UTC (rev 4241)
@@ -51,8 +51,8 @@
#\=
(:greedy-repetition 0 nil (:inverted-char-class #\&))
#\&))))))
- (defun add-cookie-value-to-url (url &key (cookie-name *session-cookie-name*)
- (value (session-cookie-value))
+ (defun add-cookie-value-to-url (url &key (cookie-name (session-cookie-name *acceptor*))
+ (value (session-cookie-value (session *request*)))
(replace-ampersands-p t))
"Removes all GET parameters named COOKIE-NAME from URL and then
adds a new GET parameter with the name COOKIE-NAME and the value
@@ -72,8 +72,8 @@
(setq url (regex-replace-all "&" url "&")))
url))
-(defun maybe-rewrite-urls-for-session (html &key (cookie-name *session-cookie-name*)
- (value (session-cookie-value)))
+(defun maybe-rewrite-urls-for-session (html &key (cookie-name (session-cookie-name *acceptor*))
+ (value (session-cookie-value (session *request*))))
"Rewrites the HTML page HTML such that the name/value pair
COOKIE-NAME/COOKIE-VALUE is inserted if the client hasn't sent a
cookie of the same name but only if *REWRITE-FOR-SESSION-URLS* is
@@ -220,7 +220,7 @@
(protocol (if (ssl-p) :https :http))
(add-session-id (not (or host-provided-p
(starts-with-scheme-p target)
- (cookie-in *session-cookie-name*))))
+ (cookie-in (session-cookie-name *acceptor*)))))
(code +http-moved-temporarily+))
"Redirects the browser to TARGET which should be a string. If
TARGET is a full URL starting with a scheme, HOST, PORT and PROTOCOL
Modified: trunk/thirdparty/hunchentoot/packages.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/packages.lisp 2009-02-11 21:44:43 UTC (rev 4240)
+++ trunk/thirdparty/hunchentoot/packages.lisp 2009-02-11 23:10:20 UTC (rev 4241)
@@ -64,7 +64,6 @@
"*REQUEST*"
"*REWRITE-FOR-SESSION-URLS*"
"*SESSION*"
- "*SESSION-COOKIE-NAME*"
"*SESSION-GC-FREQUENCY*"
"*SESSION-MAX-TIME*"
"*SESSION-REMOVAL-HOOK*"
@@ -157,7 +156,6 @@
"DELETE-SESSION-VALUE"
"DISPATCH-EASY-HANDLERS"
"DISPATCH-REQUEST"
- "DO-SESSIONS"
"ESCAPE-FOR-HTML"
"EXECUTE-ACCEPTOR"
"GET-PARAMETER"
@@ -216,14 +214,17 @@
"SEND-HEADERS"
"SERVER-PROTOCOL"
"SERVER-PROTOCOL*"
+ "SESSION-COOKIE-NAME"
"SESSION-COOKIE-VALUE"
- "SESSION-COUNTER"
+ "SESSION-DB"
+ "SESSION-DB-LOCK"
"SESSION-GC"
"SESSION-MAX-TIME"
"SESSION-REMOTE-ADDR"
"SESSION-TOO-OLD-P"
"SESSION-USER-AGENT"
"SESSION-VALUE"
+ "SESSION-VERIFY"
"SET-COOKIE"
"SET-COOKIE*"
"SHUTDOWN"
Modified: trunk/thirdparty/hunchentoot/session.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/session.lisp 2009-02-11 21:44:43 UTC (rev 4240)
+++ trunk/thirdparty/hunchentoot/session.lisp 2009-02-11 23:10:20 UTC (rev 4241)
@@ -29,10 +29,46 @@
(in-package :hunchentoot)
-(defvar *session-data-lock* (make-lock "session-data-lock")
- "A lock to prevent two threads from modifying *SESSION-DATA* at the
-same time.")
+(defgeneric session-db-lock (acceptor &key (whole-db-p t))
+ (:documentation "A function which returns a lock that will be used
+to prevent concurrent access to sessions. The first argument will be
+the acceptor that handles the current request, the second argument is
+true if the whole \(current) session database is modified. If it is
+NIL, only one existing session in the database is modified.
+This function can return NIL which means that sessions or session
+databases will be modified without a lock held. The default is to
+always return a global lock for Lisps that support threads and NIL
+otherwise."))
+
+(defmethod session-db-lock ((acceptor t) &key (whole-db-p t))
+ (declare (ignore whole-db-p))
+ *global-session-db-lock*)
+
+(defmacro with-session-lock-held ((lock) &body body)
+ "This is like WITH-LOCK-HELD except that it will accept NIL as a
+\"lock\" and just execute BODY in this case."
+ (with-unique-names (thunk)
+ (with-rebinding (lock)
+ `(flet ((,thunk () , at body))
+ (cond (,lock (with-lock-held (,lock) (,thunk)))
+ (t (,thunk)))))))
+
+(defgeneric session-db (acceptor)
+ (:documentation "Returns the current session database which is an
+alist where each car is a session's ID and the cdr is the
+corresponding SESSION object itself. The default is to use a global
+list for all acceptors."))
+
+(defmethod session-db ((acceptor t))
+ *session-db*)
+
+(defgeneric (setf session-db) (new-value acceptor)
+ (:documentation "Modifies the current session database. See SESSION-DB."))
+
+(defmethod (setf session-db) (new-value (acceptor t))
+ (setq *session-db* new-value))
+
(let ((session-id-counter 0))
(defun get-next-session-id ()
"Returns the next sequential session id."
@@ -46,7 +82,6 @@
*session-gc-frequency*)))
(session-gc))))
-
(defclass session ()
((session-id :initform (get-next-session-id)
:reader session-id
@@ -75,21 +110,17 @@
:reader session-data
:documentation "Data associated with this session -
see SESSION-VALUE.")
- (session-counter :initform 0
- :reader session-counter
- :documentation "The number of times this session
-has been used.")
(max-time :initarg :max-time
:initform *session-max-time*
:accessor session-max-time
:type fixnum
:documentation "The time \(in seconds) after which this
session expires if it's not used."))
- (:documentation "SESSION objects are automatically maintained
-by Hunchentoot. They should not be created explicitly with
-MAKE-INSTANCE but implicitly with START-SESSION. Note that
-SESSION objects can only be created when the special variable
-*REQUEST* is bound to a REQUEST object."))
+ (:documentation "SESSION objects are automatically maintained by
+Hunchentoot. They should not be created explicitly with MAKE-INSTANCE
+but implicitly with START-SESSION. Note that SESSION objects can only
+be created when the special variable *REQUEST* is bound to a REQUEST
+object."))
(defun encode-session-string (id user-agent remote-addr start)
"Create a uniquely encoded session string based on the values ID,
@@ -121,16 +152,16 @@
(setf (slot-value session 'session-string) (stringify-session session)))
(defun session-gc ()
- "Removes sessions from *session-data* which are too old - see
-SESSION-TOO-OLD-P."
- (with-lock-held (*session-data-lock*)
- (setq *session-data*
- (loop for id-session-pair in *session-data*
- for (nil . session) = id-session-pair
- when (session-too-old-p session)
- do (funcall *session-removal-hook* session)
- else
- collect id-session-pair)))
+ "Removes sessions from the current session database which are too
+old - see SESSION-TOO-OLD-P."
+ (with-session-lock-held ((session-db-lock *acceptor*))
+ (setf (session-db *acceptor*)
+ (loop for id-session-pair in (session-db *acceptor*)
+ for (nil . session) = id-session-pair
+ when (session-too-old-p session)
+ do (funcall *session-removal-hook* session)
+ else
+ collect id-session-pair)))
(values))
(defun session-value (symbol &optional (session *session*))
@@ -149,7 +180,7 @@
(with-rebinding (symbol)
(with-unique-names (place %session)
`(let ((,%session (or ,session (start-session))))
- (with-lock-held (*session-data-lock*)
+ (with-session-lock-held ((session-db-lock *acceptor* :whole-db-p nil))
(let* ((,place (assoc ,symbol (session-data ,%session) :test #'eq)))
(cond
(,place
@@ -168,17 +199,30 @@
:key #'car :test #'eq)))
(values))
-(defun session-cookie-value (&optional (session (session *request*)))
- "Returns a string which can be used to safely restore the
-session if as session has already been established. This is used
-as the value stored in the session cookie or in the corresponding
-GET parameter."
+(defgeneric session-cookie-value (session)
+ (:documentation "Returns a string which can be used to safely
+restore the session SESSION if as session has already been
+established. This is used as the value stored in the session cookie
+or in the corresponding GET parameter. A default method is provided
+and there's no reason to change it unless you want to use your own
+session objects."))
+
+(defmethod session-cookie-value ((session session))
(and session
(format nil
"~A:~A"
(session-id session)
(session-string session))))
+(defgeneric session-cookie-name (acceptor)
+ (:documentation "Returns the name \(a string) of the cookie \(or the
+GET parameter) which is used to store a session on the client side.
+The default is to use the string \"hunchentoot-session\", but you can
+specialize this function if you want another name."))
+
+(defmethod session-cookie-name ((acceptor t))
+ "hunchentoot-session")
+
(defun start-session ()
"Returns the current SESSION object. If there is no current session,
creates one and updates the corresponding data structures. In this
@@ -189,9 +233,10 @@
(return-from start-session session))
(setf session (make-instance 'session)
(session *request*) session)
- (with-lock-held (*session-data-lock*)
- (setq *session-data* (acons (session-id session) session *session-data*)))
- (set-cookie *session-cookie-name*
+ (with-session-lock-held ((session-db-lock *acceptor*))
+ (setf (session-db *acceptor*)
+ (acons (session-id session) session (session-db *acceptor*))))
+ (set-cookie (session-cookie-name *acceptor*)
:value (session-cookie-value session)
:path "/")
(setq *session* session)))
@@ -199,11 +244,11 @@
(defun remove-session (session)
"Completely removes the SESSION object SESSION from Hunchentoot's
internal session database."
- (with-lock-held (*session-data-lock*)
+ (with-session-lock-held ((session-db-lock *acceptor*))
(funcall *session-removal-hook* session)
- (setq *session-data*
- (delete (session-id session) *session-data*
- :key #'car :test #'=)))
+ (setf (session-db *acceptor*)
+ (delete (session-id session) (session-db *acceptor*)
+ :key #'car :test #'=)))
(values))
(defun session-too-old-p (session)
@@ -217,7 +262,7 @@
session has not expired. Will remove the session if it has expired but
will not create a new one."
(let ((session
- (cdr (assoc id *session-data* :test #'=))))
+ (cdr (assoc id (session-db *acceptor*) :test #'=))))
(when (and session
(session-too-old-p session))
(when *reply*
@@ -226,14 +271,19 @@
(setq session nil))
session))
-(defun session-verify (request)
- "Tries to get a session identifier from the cookies \(or
-alternatively from the GET parameters) sent by the client. This
+(defgeneric session-verify (request)
+ (:documentation "Tries to get a session identifier from the cookies
+\(or alternatively from the GET parameters) sent by the client. This
identifier is then checked for validity against the REQUEST object
-REQUEST. On success the corresponding session object \(if not too old)
-is returned \(and updated). Otherwise NIL is returned."
- (let ((session-identifier (or (cookie-in *session-cookie-name* request)
- (get-parameter *session-cookie-name* request))))
+REQUEST. On success the corresponding session object \(if not too
+old) is returned \(and updated). Otherwise NIL is returned.
+
+A default method is provided and you only need to write your own one
+if you want to maintain your own sessions."))
+
+(defmethod session-verify ((request request))
+ (let ((session-identifier (or (cookie-in (session-cookie-name *acceptor*) request)
+ (get-parameter (session-cookie-name *acceptor*) request))))
(unless (and session-identifier
(stringp session-identifier)
(plusp (length session-identifier)))
@@ -245,36 +295,35 @@
(user-agent (user-agent request))
(remote-addr (remote-addr request)))
(cond
- ((and session
- (string= session-string
- (session-string session))
- (string= session-string
- (encode-session-string id
- user-agent
- (real-remote-addr request)
- (session-start session))))
- ;; The session key presented by the client is valid.
- (incf (slot-value session 'session-counter))
- (setf (slot-value session 'last-click) (get-universal-time))
- session)
- (session
- ;; The session ID pointed to an existing session, but the
- ;; session string did not match the expected session
- ;; string. Report to the log file, remove the session to
- ;; make sure that it can't be used again. The original
- ;; legitimate user will be required to log in again.
- (log-message* :warning
- "Fake session identifier '~A' (User-Agent: '~A', IP: '~A')"
- session-identifier user-agent remote-addr)
- (remove-session session)
- nil)
- (t
- ;; No session was found under the ID given, presumably
- ;; because it has expired.
- (log-message* :info
- "No session for session identifier '~A' (User-Agent: '~A', IP: '~A')"
- session-identifier user-agent remote-addr)
- nil))))))
+ ((and session
+ (string= session-string
+ (session-string session))
+ (string= session-string
+ (encode-session-string id
+ user-agent
+ (real-remote-addr request)
+ (session-start session))))
+ ;; The session key presented by the client is valid.
+ (setf (slot-value session 'last-click) (get-universal-time))
+ session)
+ (session
+ ;; The session ID pointed to an existing session, but the
+ ;; session string did not match the expected session
+ ;; string. Report to the log file, remove the session to
+ ;; make sure that it can't be used again. The original
+ ;; legitimate user will be required to log in again.
+ (log-message* :warning
+ "Fake session identifier '~A' (User-Agent: '~A', IP: '~A')"
+ session-identifier user-agent remote-addr)
+ (remove-session session)
+ nil)
+ (t
+ ;; No session was found under the ID given, presumably
+ ;; because it has expired.
+ (log-message* :info
+ "No session for session identifier '~A' (User-Agent: '~A', IP: '~A')"
+ session-identifier user-agent remote-addr)
+ nil))))))
(defun reset-session-secret ()
"Sets *SESSION-SECRET* to a new random value. All old sessions will
@@ -283,18 +332,8 @@
(defun reset-sessions ()
"Removes ALL stored sessions."
- (with-lock-held (*session-data-lock*)
- (loop for (nil . session) in *session-data*
+ (with-session-lock-held ((session-db-lock *acceptor*))
+ (loop for (nil . session) in (session-db *acceptor*)
do (funcall *session-removal-hook* session))
- (setq *session-data* nil))
- (values))
-
-(defmacro do-sessions ((var &optional result-form) &body body)
- "Executes BODY with VAR bound to each existing SESSION object
-consecutively. Returns the values returned by RESULT-FORM unless
-RETURN is executed. The scope of the binding of VAR does not include
-RESULT-FORM."
- (let ((=temp= (gensym)))
- `(dolist (,=temp= *session-data* ,result-form)
- (let ((,var (cdr ,=temp=)))
- , at body))))
\ No newline at end of file
+ (setq *session-db* nil))
+ (values))
\ No newline at end of file
Modified: trunk/thirdparty/hunchentoot/specials.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/specials.lisp 2009-02-11 21:44:43 UTC (rev 4240)
+++ trunk/thirdparty/hunchentoot/specials.lisp 2009-02-11 23:10:20 UTC (rev 4241)
@@ -120,10 +120,6 @@
"The three-character names of the twelve months - needed for cookie
date format.")
-(defvar *session-cookie-name* "hunchentoot-session"
- "The name of the cookie \(or the GET parameter) which is used to
-store the session on the client side.")
-
(defvar *rewrite-for-session-urls* t
"Whether HTML pages should possibly be rewritten for cookie-less
session-management.")
@@ -161,10 +157,8 @@
the uploaded file is written. The hook is called directly before
the file is created.")
-(defvar *session-data* nil
- "All sessions of all users currently using Hunchentoot. An
-alist where the car is the session's ID and the cdr is the
-SESSION object itself.")
+(defvar *session-db* nil
+ "The default \(global) session database.")
(defvar *session-max-time* #.(* 30 60)
"The default time \(in seconds) after which a session times out.")
@@ -313,6 +307,11 @@
#+:lispworks t
#-:lispworks bt:*supports-threads-p*)
+(defvar *global-session-db-lock*
+ (load-time-value (and *supports-threads-p* (make-lock "global-session-db-lock")))
+ "A global lock to prevent two threads from modifying *session-db* at
+the same time \(or NIL for Lisps which don't have threads).")
+
(defconstant +new-connection-wait-time+ 2
"Time in seconds to wait for a new connection to arrive before
performing a cleanup run.")
Modified: trunk/thirdparty/hunchentoot/test/test-handlers.lisp
===================================================================
--- trunk/thirdparty/hunchentoot/test/test-handlers.lisp 2009-02-11 21:44:43 UTC (rev 4240)
+++ trunk/thirdparty/hunchentoot/test/test-handlers.lisp 2009-02-11 23:10:20 UTC (rev 4241)
@@ -198,8 +198,8 @@
(:input :type :text
:name "new-bar-value"
:value (or (session-value 'bar) ""))))
- (info-table *session-cookie-name*
- (cookie-in *session-cookie-name*)
+ (info-table (session-cookie-name *acceptor*)
+ (cookie-in (session-cookie-name *acceptor*))
(mapcar #'car (cookies-in*))
(session-value 'foo)
(session-value 'bar))))))
More information about the Bknr-cvs
mailing list