pg-sessions/pg-sessions.lisp

;;; Copyright (c) 2004-2010, Dr. Edmund Weitz.  All rights reserved.
;;; Copyright (c) 2014, Thomas Hintz. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package #:pg-sessions)

(defparameter *pg-session-max-time* 3600) ; 1 hour
(defvar *pg-session-secret* "thisisasecret")
(defparameter *database-connection-spec* nil)

(defclass pg-session ()
  ((session-id :col-type serial :initarg :session-id :reader pg-session-id)
   (session-string :col-type string :initform "" :accessor pg-session-string
                   :documentation "The session string encodes enough
data to safely retrieve this session.  It is sent to the browser as a
cookie value or as a GET parameter.")
   (session-start :col-type bigint :initform (get-universal-time) :accessor pg-session-start)
   (last-click :col-type bigint :initform (get-universal-time) :accessor pg-session-last-click
               :documentation "The last time this session was used.")
   (max-time :col-type bigint :initarg :max-time
             :initform *pg-session-max-time*
             :accessor pg-session-max-time
             :documentation "The time \(in seconds) after which this
session expires if it's not used."))
  (:metaclass dao-class)
  (:keys session-id)
  (:documentation "An extensions of hunchentoot's sessions so that sessions can be
stored in the postmodern database."))

(defparameter *session-type* 'pg-session)

(defun md5-hex (string)
  "Calculates the md5 sum of the string STRING and returns it as a hex string."
  (with-output-to-string (s)
    (loop for code across (md5:md5sum-string string)
	  do (format s "~2,'0x" code))))

(defun encode-session-string (id start)
  ;; *PG-SESSION-SECRET* is used twice due to known theoretical
  ;; vulnerabilities of MD5 encoding
  (md5-hex (concatenate 'string
			*pg-session-secret*
			(md5-hex (format nil "~A~A~@[~A~]~@[~A~]~A"
                                         *pg-session-secret*
                                         id
                                         start)))))

(defun stringify-session (session)
  "Creates a string representing of the SESSION object SESSION. See
ENCODE-SESSION-STRING."
  (encode-session-string (pg-session-id session)
                         (pg-session-start session)))

(defun session-too-old-p (session)
  (< (+ (pg-session-last-click session) (pg-session-max-time session))
     (get-universal-time)))

(defun pg-remove-session (&optional (session hunchentoot:*session*))
  "Completely removes the SESSION object SESSION from Hunchentoot's
internal session database."
  (delete-dao session)
  (values))

(defun pg-session-gc ()
  "Removes sessions from the current session database which are too
old - see SESSION-TOO-OLD-P."
  (loop for session in (select-dao *session-type*)
        when (session-too-old-p session)
        do (remove-session session)))

(defmethod hunchentoot:session-cookie-value ((pg-session pg-session))
  (and pg-session
       (format nil
               "~D:~A"
               (pg-session-id pg-session)
               (pg-session-string pg-session))))

(defun save-pg-session (&optional (session hunchentoot:*session*))
  (upsert-dao session))

(defun pg-start-session (&rest args)
  "Returns the current SESSION object. If there is no current session,
creates one and updates the corresponding data structures. In this
case the function will also send a session cookie to the browser."
  (let ((session (hunchentoot:session hunchentoot:*request*)))
    (when session
      (return-from pg-start-session session))
    (setf session
          (apply #'make-dao
                 (append `(,*session-type*)
                         args)))
    (setf (hunchentoot:session hunchentoot:*request*) session)
    (setf (pg-session-string session) (stringify-session session))
    (save-pg-session session)
    (hunchentoot:set-cookie (hunchentoot:session-cookie-name hunchentoot:*acceptor*)
                :value (hunchentoot:session-cookie-value session)
                :path "/")
    (setq hunchentoot:*session* session)))

(defun get-stored-session (id request)
  "Returns the SESSION object corresponding to the number ID if the
session has not expired. Will remove the session if it has expired but
will not create a new one."
  (let ((session (get-dao *session-type* id)))
    (when (and session
               (session-too-old-p session))
      (when hunchentoot:*reply*
        (hunchentoot:log-message* :info "Session with ID ~A too old" id))
      (pg-remove-session session)
      (setq session nil))
    session))

(defmethod hunchentoot:session-verify ((request hunchentoot:request))
  (with-connection
      *database-connection-spec*
    (with-transaction (transaction)
      (let ((session-identifier
             (or (when-let (session-cookie (hunchentoot:cookie-in
                                            (hunchentoot:session-cookie-name
                                             hunchentoot:*acceptor*) request))
                   (hunchentoot:url-decode session-cookie))
                 (hunchentoot:get-parameter (hunchentoot:session-cookie-name
                                             hunchentoot:*acceptor*) request))))
        (unless (and session-identifier
                     (stringp session-identifier)
                     (plusp (length session-identifier)))
          (return-from hunchentoot:session-verify nil))
        (destructuring-bind (id-string session-string)
            (cl-ppcre:split ":" session-identifier :limit 2)
          (let* ((id (parse-integer id-string))
                 (session (get-stored-session id request)))
            (cond
              ((and session
                    (string= session-string
                             (pg-session-string session))
                    (string= session-string
                             (encode-session-string id
                                                    (pg-session-start session))))
               ;; the session key presented by the client is valid
               (setf (pg-session-last-click session) (get-universal-time))
               (save-pg-session session)
               session)
              (session
               ;; the session ID pointed to an existing session, but the
               ;; session string did not match the expected session string
               (hunchentoot:log-message*
                :warning "Fake session identifier '~A' (User-Agent: '~A', IP: '~A')"
                session-identifier user-agent remote-addr)
               ;; remove the session to make sure that it can't be used
               ;; again; the original legitimate user will be required to
               ;; log in again
               (pg-remove-session session)
               nil)
              (t
               ;; no session was found under the ID given, presumably
               ;; because it has expired.
               (hunchentoot:log-message*
                :info "No session for session identifier '~A' (User-Agent: '~A', IP: '~A')"
                session-identifier user-agent remote-addr)
               nil))))))))

(defun pg-session-value (symbol &optional (session hunchentoot:*session*))
  "Returns the value associated with SYMBOL from the session object
SESSION \(the default is the current session) if it exists."
  (when session
    (slot-value session symbol)))

(defsetf pg-session-value (symbol &optional session) (new-value)
  (with-gensyms (%session %symbol)
    `(let ((,%session (or ,session (pg-start-session)))
           (,%symbol ,symbol))
       (setf (slot-value ,%session ,%symbol) ,new-value)
       (save-pg-session ,%session))))