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                "~A:~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     (session-created *acceptor* session)
 263     (setq *session* session)))
 264
 265 (defun remove-session (session)
 266   "Completely removes the SESSION object SESSION from Hunchentoot's
 267 internal session database."
 268   (with-session-lock-held ((session-db-lock *acceptor*))
 269     (acceptor-remove-session *acceptor* session)
 270     (setf (session-db *acceptor*)
 271           (delete (session-id session) (session-db *acceptor*)
 272                   :key #'car :test #'=)))
 273   (values))
 274
 275 (defun session-too-old-p (session)
 276   "Returns true if the SESSION object SESSION has not been active in
 277 the last \(SESSION-MAX-TIME SESSION) seconds."
 278   (< (+ (session-last-click session) (session-max-time session))
 279      (get-universal-time)))
 280
 281 (defun get-stored-session (id)
 282   "Returns the SESSION object corresponding to the number ID if the
 283 session has not expired. Will remove the session if it has expired but
 284 will not create a new one."
 285   (let ((session
 286          (cdr (assoc id (session-db *acceptor*) :test #'=))))
 287     (when (and session
 288                (session-too-old-p session))
 289       (when *reply*
 290         (log-message* :info "Session with ID ~A too old" id))
 291       (remove-session session)
 292       (setq session nil))
 293     session))
 294
 295 (defgeneric session-verify (request)
 296   (:documentation "Tries to get a session identifier from the cookies
 297 \(or alternatively from the GET parameters) sent by the client (see
 298 SESSION-COOKIE-NAME and SESSION-COOKIE-VALUE).  This identifier is
 299 then checked for validity against the REQUEST object REQUEST.  On
 300 success the corresponding session object \(if not too old) is returned
 301 \(and updated).  Otherwise NIL is returned.
 302
 303 A default method is provided and you only need to write your own one
 304 if you want to maintain your own sessions."))
 305
 306 (defmethod session-verify ((request request))
 307   (let ((session-identifier (or (when-let (session-cookie (cookie-in (session-cookie-name *acceptor*) request))
 308                                   (url-decode session-cookie))
 309                                 (get-parameter (session-cookie-name *acceptor*) request))))
 310     (unless (and session-identifier
 311                  (stringp session-identifier)
 312                  (plusp (length session-identifier)))
 313       (return-from session-verify nil))
 314     (destructuring-bind (id-string session-string)
 315         (split ":" session-identifier :limit 2)
 316       (let* ((id (parse-integer id-string))
 317              (session (get-stored-session id))
 318              (user-agent (user-agent request))
 319              (remote-addr (remote-addr request)))
 320         (cond
 321          ((and session
 322                (string= session-string
 323                         (session-string session))
 324                (string= session-string
 325                         (encode-session-string id
 326                                                user-agent
 327                                                (real-remote-addr request)
 328                                                (session-start session))))
 329           ;; the session key presented by the client is valid
 330           (setf (slot-value session 'last-click) (get-universal-time))
 331           session)
 332          (session
 333           ;; the session ID pointed to an existing session, but the
 334           ;; session string did not match the expected session string
 335           (log-message* :warning
 336                         "Fake session identifier '~A' (User-Agent: '~A', IP: '~A')"
 337                         session-identifier user-agent remote-addr)
 338           ;; remove the session to make sure that it can't be used
 339           ;; again; the original legitimate user will be required to
 340           ;; log in again
 341           (remove-session session)
 342           nil)
 343          (t
 344           ;; no session was found under the ID given, presumably
 345           ;; because it has expired.
 346           (log-message* :info
 347                         "No session for session identifier '~A' (User-Agent: '~A', IP: '~A')"
 348                         session-identifier user-agent remote-addr)
 349           nil))))))
 350
 351 (defun reset-session-secret ()
 352   "Sets *SESSION-SECRET* to a new random value. All old sessions will
 353 cease to be valid."
 354   (setq *session-secret* (create-random-string 10 36)))
 355
 356 (defun reset-sessions (&optional (acceptor *acceptor*))
 357   "Removes ALL stored sessions of ACCEPTOR."
 358   (with-session-lock-held ((session-db-lock acceptor))
 359     (loop for (nil . session) in (session-db acceptor)
 360           do (acceptor-remove-session acceptor session))
 361     (setq *session-db* nil))
 362   (values))