session.lisp 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
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.
37
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."))
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-unique-names (thunk)
52 (with-rebinding (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
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."))
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,
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."))
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
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.
121
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."))
125
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*
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
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)))
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
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))
170
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))))
177
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 (with-rebinding (symbol)
185 (with-unique-names (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
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))
205
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.
211
212 A default method is provided and there's no reason to change it unless
213 you 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
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."))
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
233 been created. There's a default method which might trigger a session
234 GC based on the value of *SESSION-GC-FREQUENCY*.
235
236 The 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
241 necessary."
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,
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 (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
268 internal 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
282 the 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
288 session has not expired. Will remove the session if it has expired but
289 will 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
302 when a user logs in according to the application to prevent against
303 session fixation attacks. The cookie value being dependent on ID,
304 USER-AGENT, REMOTE-ADDR, START, and *SESSION-SECRET*, the only value
305 we can change is START to regenerate a new value. Since we're
306 generating a new cookie, it makes sense to have the session being
307 restarted, in time. That said, because of this fact, calling this
308 function 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
319 SESSION-COOKIE-NAME and SESSION-COOKIE-VALUE). This identifier is
320 then checked for validity against the REQUEST object REQUEST. On
321 success the corresponding session object \(if not too old) is returned
322 \(and updated). Otherwise NIL is returned.
323
324 A default method is provided and you only need to write your own one
325 if 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
372 cease 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))