PageRenderTime 33ms CodeModel.GetById 16ms app.highlight 12ms RepoModel.GetById 1ms app.codeStats 1ms

/session.lisp

http://github.com/edicl/hunchentoot
Lisp | 381 lines | 306 code | 43 blank | 32 comment | 20 complexity | ee718d56d160de0429ad0eab4a7149df MD5 | raw file
  1;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
  2
  3;;; Copyright (c) 2004-2010, Dr. Edmund Weitz.  All rights reserved.
  4
  5;;; Redistribution and use in source and binary forms, with or without
  6;;; modification, are permitted provided that the following conditions
  7;;; are met:
  8
  9;;;   * Redistributions of source code must retain the above copyright
 10;;;     notice, this list of conditions and the following disclaimer.
 11
 12;;;   * Redistributions in binary form must reproduce the above
 13;;;     copyright notice, this list of conditions and the following
 14;;;     disclaimer in the documentation and/or other materials
 15;;;     provided with the distribution.
 16
 17;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
 18;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 19;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 20;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
 21;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
 22;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
 23;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 24;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 25;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
 26;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 27;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 28
 29(in-package :hunchentoot)
 30
 31(defgeneric session-db-lock (acceptor &key whole-db-p)
 32  (:documentation "A function which returns a lock that will be used
 33to prevent concurrent access to sessions.  The first argument will be
 34the acceptor that handles the current request, the second argument is
 35true if the whole \(current) session database is modified.  If it is
 36NIL, only one existing session in the database is modified.
 37
 38This function can return NIL which means that sessions or session
 39databases will be modified without a lock held \(for example for
 40single-threaded environments).  The default is to always return a
 41global lock \(ignoring the ACCEPTOR argument) for Lisps that support
 42threads and NIL otherwise."))
 43
 44(defmethod session-db-lock ((acceptor t) &key (whole-db-p t))
 45  (declare (ignore whole-db-p))
 46  *global-session-db-lock*)
 47
 48(defmacro with-session-lock-held ((lock) &body body)
 49  "This is like WITH-LOCK-HELD except that it will accept NIL as a
 50\"lock\" and just execute BODY in this case."
 51  (with-gensyms (thunk)
 52    (once-only (lock)
 53      `(flet ((,thunk () ,@body))
 54         (cond (,lock (with-lock-held (,lock) (,thunk)))
 55               (t (,thunk)))))))
 56
 57(defgeneric session-db (acceptor)
 58  (:documentation "Returns the current session database which is an
 59alist where each car is a session's ID and the cdr is the
 60corresponding SESSION object itself.  The default is to use a global
 61list for all acceptors."))
 62
 63(defmethod session-db ((acceptor t))
 64  *session-db*)
 65
 66(defgeneric (setf session-db) (new-value acceptor)
 67  (:documentation "Modifies the current session database.  See SESSION-DB."))
 68
 69(defmethod (setf session-db) (new-value (acceptor t))
 70  (setq *session-db* new-value))
 71
 72(defgeneric next-session-id (acceptor)
 73  (:documentation "Returns the next sequential session ID, an integer,
 74which should be unique per session.  The default method uses a simple
 75global counter and isn't guarded by a lock.  For a high-performance
 76production environment you might consider using a more robust
 77implementation."))
 78
 79(let ((session-id-counter 0))
 80  (defmethod next-session-id ((acceptor t))
 81    (incf session-id-counter)))
 82
 83(defclass session ()
 84  ((session-id :initform (next-session-id (request-acceptor *request*))
 85               :reader session-id
 86               :type integer
 87               :documentation "The unique ID \(an INTEGER) of the session.")
 88   (session-string :reader session-string
 89                   :documentation "The session string encodes enough
 90data to safely retrieve this session.  It is sent to the browser as a
 91cookie value or as a GET parameter.")
 92   (user-agent :initform (user-agent *request*)
 93               :reader session-user-agent
 94               :documentation "The incoming 'User-Agent' header that
 95was sent when this session was created.")
 96   (remote-addr :initform (real-remote-addr *request*)
 97                :reader session-remote-addr
 98                :documentation "The remote IP address of the client
 99when this session was started as returned by REAL-REMOTE-ADDR.")
100   (session-start :initform (get-universal-time)
101                  :reader session-start
102                  :documentation "The time this session was started.")
103   (last-click :initform (get-universal-time)
104               :reader session-last-click
105               :documentation "The last time this session was used.")
106   (session-data :initarg :session-data
107                 :initform nil
108                 :reader session-data
109                 :documentation "Data associated with this session -
110see SESSION-VALUE.")
111   (max-time :initarg :max-time
112             :initform *session-max-time*
113             :accessor session-max-time
114             :type fixnum
115             :documentation "The time \(in seconds) after which this
116session expires if it's not used."))
117  (:documentation "SESSION objects are automatically maintained by
118Hunchentoot.  They should not be created explicitly with MAKE-INSTANCE
119but implicitly with START-SESSION and they should be treated as opaque
120objects.
121
122You can ignore Hunchentoot's SESSION objects altogether and implement
123your own sessions if you provide corresponding methods for
124SESSION-COOKIE-VALUE and SESSION-VERIFY."))
125
126(defun encode-session-string (id user-agent remote-addr start)
127  "Creates a uniquely encoded session string based on the values ID,
128USER-AGENT, REMOTE-ADDR, and START"
129  (unless (boundp '*session-secret*)
130    (hunchentoot-warn "Session secret is unbound.  Using Lisp's RANDOM function to initialize it.")
131    (reset-session-secret))
132  ;; *SESSION-SECRET* is used twice due to known theoretical
133  ;; vulnerabilities of MD5 encoding
134  (md5-hex (concatenate 'string
135			*session-secret*
136			(md5-hex (format nil "~A~A~@[~A~]~@[~A~]~A"
137                                         *session-secret*
138                                         id
139                                         (and *use-user-agent-for-sessions*
140                                              user-agent)
141                                         (and *use-remote-addr-for-sessions*
142                                              remote-addr)
143                                         start)))))
144
145(defun stringify-session (session)
146  "Creates a string representing the SESSION object SESSION. See
147ENCODE-SESSION-STRING."
148  (encode-session-string (session-id session)
149                         (session-user-agent session)
150                         (session-remote-addr session)
151                         (session-start session)))
152
153(defmethod initialize-instance :after ((session session) &rest init-args)
154  "Set SESSION-STRING slot after the session has been initialized."
155  (declare (ignore init-args))
156  (setf (slot-value session 'session-string) (stringify-session session)))
157
158(defun session-gc ()
159  "Removes sessions from the current session database which are too
160old - see SESSION-TOO-OLD-P."
161  (with-session-lock-held ((session-db-lock *acceptor*))
162    (setf (session-db *acceptor*)
163          (loop for id-session-pair in (session-db *acceptor*)
164                for (nil . session) = id-session-pair
165                when (session-too-old-p session)
166                do (acceptor-remove-session *acceptor* session)
167                else
168                collect id-session-pair)))
169  (values))
170
171(defun session-value (symbol &optional (session *session*))
172  "Returns the value associated with SYMBOL from the session object
173SESSION \(the default is the current session) if it exists."
174  (when session
175    (let ((found (assoc symbol (session-data session) :test #'eq)))
176      (values (cdr found) found))))
177
178(defsetf session-value (symbol &optional session)
179    (new-value)
180  "Sets the value associated with SYMBOL from the session object
181SESSION. If there is already a value associated with SYMBOL it will be
182replaced. Will automatically start a session if none was supplied and
183there's no session for the current request."
184  (once-only (symbol)
185    (with-gensyms (place %session)
186      `(let ((,%session (or ,session (start-session))))
187         (with-session-lock-held ((session-db-lock *acceptor* :whole-db-p nil))
188           (let* ((,place (assoc ,symbol (session-data ,%session) :test #'eq)))
189             (cond
190               (,place
191                (setf (cdr ,place) ,new-value))
192               (t
193                (push (cons ,symbol ,new-value)
194                      (slot-value ,%session 'session-data))
195                ,new-value))))))))
196
197(defun delete-session-value (symbol &optional (session *session*))
198  "Removes the value associated with SYMBOL from SESSION if there is
199one."
200  (when session
201    (setf (slot-value session 'session-data)
202            (delete symbol (session-data session)
203                    :key #'car :test #'eq)))
204  (values))
205
206(defgeneric session-cookie-value (session)
207  (:documentation "Returns a string which can be used to safely
208restore the session SESSION if as session has already been
209established.  This is used as the value stored in the session cookie
210or in the corresponding GET parameter and verified by SESSION-VERIFY.
211
212A default method is provided and there's no reason to change it unless
213you want to use your own session objects."))
214
215(defmethod session-cookie-value ((session session))
216  (and session
217       (format nil
218               "~D:~A"
219               (session-id session)
220               (session-string session))))
221
222(defgeneric session-cookie-name (acceptor)
223  (:documentation "Returns the name \(a string) of the cookie \(or the
224GET parameter) which is used to store a session on the client side.
225The default is to use the string \"hunchentoot-session\", but you can
226specialize this function if you want another name."))
227
228(defmethod session-cookie-name ((acceptor t))
229  "hunchentoot-session")
230
231(defgeneric session-created (acceptor new-session)
232  (:documentation "This function is called whenever a new session has
233been created.  There's a default method which might trigger a session
234GC based on the value of *SESSION-GC-FREQUENCY*.
235
236The return value is ignored."))
237
238(let ((global-session-usage-counter 0))
239  (defmethod session-created ((acceptor t) (session t))
240    "Counts session usage globally and triggers session GC if
241necessary."
242    (when (and *session-gc-frequency*
243               (zerop (mod (incf global-session-usage-counter)
244                           *session-gc-frequency*)))
245      (session-gc))))
246
247(defun start-session ()
248  "Returns the current SESSION object. If there is no current session,
249creates one and updates the corresponding data structures. In this
250case the function will also send a session cookie to the browser."
251  (let ((session (session *request*)))
252    (when session
253      (return-from start-session session))
254    (setf session (make-instance 'session)
255          (session *request*) session)
256    (with-session-lock-held ((session-db-lock *acceptor*))
257      (setf (session-db *acceptor*)
258            (acons (session-id session) session (session-db *acceptor*))))
259    (set-cookie (session-cookie-name *acceptor*)
260                :value (session-cookie-value session)
261                :path "/"
262                :http-only t)
263    (session-created *acceptor* session)
264    (setq *session* session)))
265
266(defun remove-session (session)
267  "Completely removes the SESSION object SESSION from Hunchentoot's
268internal session database."
269  (set-cookie (session-cookie-name *acceptor*)
270              :value "deleted"
271              :path "/"
272              :expires 0)
273  (with-session-lock-held ((session-db-lock *acceptor*))
274    (acceptor-remove-session *acceptor* session)
275    (setf (session-db *acceptor*)
276          (delete (session-id session) (session-db *acceptor*)
277                  :key #'car :test #'=)))
278  (values))
279
280(defun session-too-old-p (session)
281  "Returns true if the SESSION object SESSION has not been active in
282the last \(SESSION-MAX-TIME SESSION) seconds."
283  (< (+ (session-last-click session) (session-max-time session))
284     (get-universal-time)))
285
286(defun get-stored-session (id)
287  "Returns the SESSION object corresponding to the number ID if the
288session has not expired. Will remove the session if it has expired but
289will not create a new one."
290  (let ((session
291         (cdr (assoc id (session-db *acceptor*) :test #'=))))
292    (when (and session
293               (session-too-old-p session))
294      (when *reply*
295        (log-message* :info "Session with ID ~A too old" id))
296      (remove-session session)
297      (setq session nil))
298    session))
299
300(defun regenerate-session-cookie-value (session)
301  "Regenerates the cookie value. This should be used
302when a user logs in according to the application to prevent against
303session fixation attacks. The cookie value being dependent on ID,
304USER-AGENT, REMOTE-ADDR, START, and *SESSION-SECRET*, the only value
305we can change is START to regenerate a new value. Since we're
306generating a new cookie, it makes sense to have the session being
307restarted, in time. That said, because of this fact, calling this
308function twice in the same second will regenerate twice the same value."
309  (setf (slot-value session 'session-start) (get-universal-time)
310        (slot-value session 'session-string) (stringify-session session))
311  (set-cookie (session-cookie-name *acceptor*)
312              :value (session-cookie-value session)
313              :path "/"
314              :http-only t))
315
316(defgeneric session-verify (request)
317  (:documentation "Tries to get a session identifier from the cookies
318\(or alternatively from the GET parameters) sent by the client (see
319SESSION-COOKIE-NAME and SESSION-COOKIE-VALUE).  This identifier is
320then checked for validity against the REQUEST object REQUEST.  On
321success the corresponding session object \(if not too old) is returned
322\(and updated).  Otherwise NIL is returned.
323
324A default method is provided and you only need to write your own one
325if you want to maintain your own sessions."))
326
327(defmethod session-verify ((request request))
328  (let ((session-identifier (or (when-let (session-cookie (cookie-in (session-cookie-name *acceptor*) request))
329                                  (url-decode session-cookie))
330                                (get-parameter (session-cookie-name *acceptor*) request))))
331    (when (and (stringp session-identifier)
332               (scan "^\\d+:.+" session-identifier))
333      (destructuring-bind (id-string session-string)
334          (split ":" session-identifier :limit 2)
335        (let* ((id (parse-integer id-string))
336               (session (get-stored-session id))
337               (user-agent (user-agent request))
338               (remote-addr (remote-addr request)))
339          (cond
340            ((and session
341                  (string= session-string
342                           (session-string session))
343                  (string= session-string
344                           (encode-session-string id
345                                                  user-agent
346                                                  (real-remote-addr request)
347                                                  (session-start session))))
348             ;; the session key presented by the client is valid
349             (setf (slot-value session 'last-click) (get-universal-time))
350             session)
351            (session
352             ;; the session ID pointed to an existing session, but the
353             ;; session string did not match the expected session string
354             (log-message* :warning
355                           "Fake session identifier '~A' (User-Agent: '~A', IP: '~A')"
356                           session-identifier user-agent remote-addr)
357             ;; remove the session to make sure that it can't be used
358             ;; again; the original legitimate user will be required to
359             ;; log in again
360             (remove-session session)
361             nil)
362            (t
363             ;; no session was found under the ID given, presumably
364             ;; because it has expired.
365             (log-message* :info
366                           "No session for session identifier '~A' (User-Agent: '~A', IP: '~A')"
367                           session-identifier user-agent remote-addr)
368             nil)))))))
369
370(defun reset-session-secret ()
371  "Sets *SESSION-SECRET* to a new random value. All old sessions will
372cease to be valid."
373  (setq *session-secret* (create-random-string 10 36)))
374
375(defun reset-sessions (&optional (acceptor *acceptor*))
376  "Removes ALL stored sessions of ACCEPTOR."
377  (with-session-lock-held ((session-db-lock acceptor))
378    (loop for (nil . session) in (session-db acceptor)
379          do (acceptor-remove-session acceptor session))
380    (setq *session-db* nil))
381  (values))