1.3.1
[hunchentoot.git] / session.lisp
blobaa19656e737260c87b75079c759441d175b81276
1 ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: HUNCHENTOOT; Base: 10 -*-
3 ;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
7 ;;; are met:
9 ;;; * Redistributions of source code must retain the above copyright
10 ;;; notice, this list of conditions and the following disclaimer.
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.
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.
29 (in-package :hunchentoot)
31 (defgeneric session-db-lock (acceptor &key whole-db-p)
32 (:documentation "A function which returns a lock that will be used
33 to prevent concurrent access to sessions. The first argument will be
34 the acceptor that handles the current request, the second argument is
35 true if the whole \(current) session database is modified. If it is
36 NIL, only one existing session in the database is modified.
38 This function can return NIL which means that sessions or session
39 databases will be modified without a lock held \(for example for
40 single-threaded environments). The default is to always return a
41 global lock \(ignoring the ACCEPTOR argument) for Lisps that support
42 threads and NIL otherwise."))
44 (defmethod session-db-lock ((acceptor t) &key (whole-db-p t))
45 (declare (ignore whole-db-p))
46 *global-session-db-lock*)
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)))))))
57 (defgeneric session-db (acceptor)
58 (:documentation "Returns the current session database which is an
59 alist where each car is a session's ID and the cdr is the
60 corresponding SESSION object itself. The default is to use a global
61 list for all acceptors."))
63 (defmethod session-db ((acceptor t))
64 *session-db*)
66 (defgeneric (setf session-db) (new-value acceptor)
67 (:documentation "Modifies the current session database. See SESSION-DB."))
69 (defmethod (setf session-db) (new-value (acceptor t))
70 (setq *session-db* new-value))
72 (defgeneric next-session-id (acceptor)
73 (:documentation "Returns the next sequential session ID, an integer,
74 which should be unique per session. The default method uses a simple
75 global counter and isn't guarded by a lock. For a high-performance
76 production environment you might consider using a more robust
77 implementation."))
79 (let ((session-id-counter 0))
80 (defmethod next-session-id ((acceptor t))
81 (incf session-id-counter)))
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
90 data to safely retrieve this session. It is sent to the browser as a
91 cookie 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
95 was 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
99 when 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 -
110 see 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
116 session expires if it's not used."))
117 (:documentation "SESSION objects are automatically maintained by
118 Hunchentoot. They should not be created explicitly with MAKE-INSTANCE
119 but implicitly with START-SESSION and they should be treated as opaque
120 objects.
122 You can ignore Hunchentoot's SESSION objects altogether and implement
123 your own sessions if you provide corresponding methods for
124 SESSION-COOKIE-VALUE and SESSION-VERIFY."))
126 (defun encode-session-string (id user-agent remote-addr start)
127 "Creates a uniquely encoded session string based on the values ID,
128 USER-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*
139 (and *use-user-agent-for-sessions*
140 user-agent)
141 (and *use-remote-addr-for-sessions*
142 remote-addr)
143 start)))))
145 (defun stringify-session (session)
146 "Creates a string representing the SESSION object SESSION. See
147 ENCODE-SESSION-STRING."
148 (encode-session-string (session-id session)
149 (session-user-agent session)
150 (session-remote-addr session)
151 (session-start session)))
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)))
158 (defun session-gc ()
159 "Removes sessions from the current session database which are too
160 old - 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))
171 (defun session-value (symbol &optional (session *session*))
172 "Returns the value associated with SYMBOL from the session object
173 SESSION \(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))))
178 (defsetf session-value (symbol &optional session)
179 (new-value)
180 "Sets the value associated with SYMBOL from the session object
181 SESSION. If there is already a value associated with SYMBOL it will be
182 replaced. Will automatically start a session if none was supplied and
183 there'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))
193 (push (cons ,symbol ,new-value)
194 (slot-value ,%session 'session-data))
195 ,new-value))))))))
197 (defun delete-session-value (symbol &optional (session *session*))
198 "Removes the value associated with SYMBOL from SESSION if there is
199 one."
200 (when session
201 (setf (slot-value session 'session-data)
202 (delete symbol (session-data session)
203 :key #'car :test #'eq)))
204 (values))
206 (defgeneric session-cookie-value (session)
207 (:documentation "Returns a string which can be used to safely
208 restore the session SESSION if as session has already been
209 established. This is used as the value stored in the session cookie
210 or in the corresponding GET parameter and verified by SESSION-VERIFY.
212 A default method is provided and there's no reason to change it unless
213 you want to use your own session objects."))
215 (defmethod session-cookie-value ((session session))
216 (and session
217 (format nil
218 "~D:~A"
219 (session-id session)
220 (session-string session))))
222 (defgeneric session-cookie-name (acceptor)
223 (:documentation "Returns the name \(a string) of the cookie \(or the
224 GET parameter) which is used to store a session on the client side.
225 The default is to use the string \"hunchentoot-session\", but you can
226 specialize this function if you want another name."))
228 (defmethod session-cookie-name ((acceptor t))
229 "hunchentoot-session")
231 (defgeneric session-created (acceptor new-session)
232 (:documentation "This function is called whenever a new session has
233 been created. There's a default method which might trigger a session
234 GC based on the value of *SESSION-GC-FREQUENCY*.
236 The return value is ignored."))
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
241 necessary."
242 (when (and *session-gc-frequency*
243 (zerop (mod (incf global-session-usage-counter)
244 *session-gc-frequency*)))
245 (session-gc))))
247 (defun start-session ()
248 "Returns the current SESSION object. If there is no current session,
249 creates one and updates the corresponding data structures. In this
250 case 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 (with-session-lock-held ((session-db-lock *acceptor*))
255 ;; Must be under a lock because creating a new session increments a global counter
256 (setf session (make-instance 'session))
257 (setf (session *request*) session
258 (session-db *acceptor*)
259 (acons (session-id session) session (session-db *acceptor*))))
260 (set-cookie (session-cookie-name *acceptor*)
261 :value (session-cookie-value session)
262 :path "/"
263 :http-only t)
264 (session-created *acceptor* session)
265 (setq *session* session)))
267 (defun remove-session (session)
268 "Completely removes the SESSION object SESSION from Hunchentoot's
269 internal session database."
270 (set-cookie (session-cookie-name *acceptor*)
271 :value "deleted"
272 :path "/"
273 :expires 0)
274 (with-session-lock-held ((session-db-lock *acceptor*))
275 (acceptor-remove-session *acceptor* session)
276 (setf (session-db *acceptor*)
277 (delete (session-id session) (session-db *acceptor*)
278 :key #'car :test #'=)))
279 (values))
281 (defun session-too-old-p (session)
282 "Returns true if the SESSION object SESSION has not been active in
283 the last \(SESSION-MAX-TIME SESSION) seconds."
284 (< (+ (session-last-click session) (session-max-time session))
285 (get-universal-time)))
287 (defun get-stored-session (id)
288 "Returns the SESSION object corresponding to the number ID if the
289 session has not expired. Will remove the session if it has expired but
290 will not create a new one."
291 (let ((session
292 (cdr (assoc id (session-db *acceptor*) :test #'=))))
293 (when (and session
294 (session-too-old-p session))
295 (when *reply*
296 (log-message* :info "Session with ID ~A too old" id))
297 (remove-session session)
298 (setq session nil))
299 session))
301 (defun regenerate-session-cookie-value (session)
302 "Regenerates the cookie value. This should be used
303 when a user logs in according to the application to prevent against
304 session fixation attacks. The cookie value being dependent on ID,
305 USER-AGENT, REMOTE-ADDR, START, and *SESSION-SECRET*, the only value
306 we can change is START to regenerate a new value. Since we're
307 generating a new cookie, it makes sense to have the session being
308 restarted, in time. That said, because of this fact, calling this
309 function twice in the same second will regenerate twice the same value."
310 (setf (slot-value session 'session-start) (get-universal-time)
311 (slot-value session 'session-string) (stringify-session session))
312 (set-cookie (session-cookie-name *acceptor*)
313 :value (session-cookie-value session)
314 :path "/"
315 :http-only t))
317 (defgeneric session-verify (request)
318 (:documentation "Tries to get a session identifier from the cookies
319 \(or alternatively from the GET parameters) sent by the client (see
320 SESSION-COOKIE-NAME and SESSION-COOKIE-VALUE). This identifier is
321 then checked for validity against the REQUEST object REQUEST. On
322 success the corresponding session object \(if not too old) is returned
323 \(and updated). Otherwise NIL is returned.
325 A default method is provided and you only need to write your own one
326 if you want to maintain your own sessions."))
328 (defmethod session-verify ((request request))
329 (let ((session-identifier (or (when-let (session-cookie (cookie-in (session-cookie-name *acceptor*) request))
330 (url-decode session-cookie))
331 (get-parameter (session-cookie-name *acceptor*) request))))
332 (when (and (stringp session-identifier)
333 (scan "^\\d+:.+" session-identifier))
334 (destructuring-bind (id-string session-string)
335 (split ":" session-identifier :limit 2)
336 (let* ((id (parse-integer id-string))
337 (session (get-stored-session id))
338 (user-agent (user-agent request))
339 (remote-addr (remote-addr request)))
340 (cond
341 ((and session
342 (string= session-string
343 (session-string session))
344 (string= session-string
345 (encode-session-string id
346 user-agent
347 (real-remote-addr request)
348 (session-start session))))
349 ;; the session key presented by the client is valid
350 (setf (slot-value session 'last-click) (get-universal-time))
351 session)
352 (session
353 ;; the session ID pointed to an existing session, but the
354 ;; session string did not match the expected session string
355 (log-message* :warning
356 "Fake session identifier '~A' (User-Agent: '~A', IP: '~A')"
357 session-identifier user-agent remote-addr)
358 ;; remove the session to make sure that it can't be used
359 ;; again; the original legitimate user will be required to
360 ;; log in again
361 (remove-session session)
362 nil)
364 ;; no session was found under the ID given, presumably
365 ;; because it has expired.
366 (log-message* :info
367 "No session for session identifier '~A' (User-Agent: '~A', IP: '~A')"
368 session-identifier user-agent remote-addr)
369 nil)))))))
371 (defun reset-session-secret ()
372 "Sets *SESSION-SECRET* to a new random value. All old sessions will
373 cease to be valid."
374 (setq *session-secret* (create-random-string 10 36)))
376 (defun reset-sessions (&optional (acceptor *acceptor*))
377 "Removes ALL stored sessions of ACCEPTOR."
378 (with-session-lock-held ((session-db-lock acceptor))
379 (loop for (nil . session) in (session-db acceptor)
380 do (acceptor-remove-session acceptor session))
381 (setq *session-db* nil))
382 (values))