;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: src/session-manager.lisp $

;;; Copyright (c) 2008, Andrea Chiumenti.  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 :claw-as)


(defgeneric session-manager-start-session (session-manager &key path max-time domain)
  (:documentation "Creates a new session if none exists"))

(defgeneric session-manager-session-value (session-manager symbol)
  (:documentation "Returns the value bound to the given session symbol.
It returns nil if no symbol is defined for the current session."))

(defgeneric (setf session-manager-session-value) (value session-manager symbol)
  (:documentation "Sets the session symbol with the given value."))

(defgeneric session-manager-delete-session-value (session-manager symbol)
  (:documentation "Completely removes any data associated with the symbol symbol from the session.
Note that this is different from using SESSION-VALUE to set the data to NIL"))

(defgeneric session-manager-remove-session (session-manager &optional session)  (:documentation "Removes the user session."))

(defgeneric session-manager-reset-sessions (session-manager)
  (:documentation "Invalidates and destroy all sessions"))

(defgeneric session-manager-session-cookie-value (session-manager)
  (:documentation "Returns a unique string that's associated with the user session"))

(defgeneric session-manager-session-max-time (session-manager)
  (:documentation "This gets or sets the maximum time (in seconds) the session should be valid before it's invalidated. 
If a request associated with this session comes in and the last request for the same session was more than seconds seconds ago than the session is deleted and a new one is started for this client"))

(defgeneric session-manager-session-remote-addr (session-manager)
  (:documentation "Returns the 'real' remote address (see CONNECTOR-REAL-REMOTE-ADDR) of the client for which the session was initiated."))

(defgeneric session-manager-session-user-agent (session-manager)
  (:documentation "Returns the 'User-Agent' http header (see USER-AGENT) of the client for which the session was initiated."))

(defgeneric session-manager-session-gc (session-manager)
  (:documentation "Deletes sessions which are too old - see SESSION-MANAGER-SESSION-TOO-OLD-P. Usually, you don't call this function directly"))

(defgeneric session-manager-session-too-old-p (session-manager)
  (:documentation "Returns a true value if the session is too old and would be deleted during the next session GC."))

(defgeneric session-manager-start (session-manager)
  (:documentation "Starts the session manager."))

(defgeneric session-manager-stop (session-manager)
  (:documentation "Stops the session manager."))

(let ((session-id-counter 0))
  (defun get-next-session-id ()
    "Returns the next sequential session id."
    (incf session-id-counter)))

;;-------------------------------------------------------------------------
(defvar *session-default-max-time* (* 30 60)
  "The default time \(in seconds) after which this
session expires if it's not used.")

(defclass session ()
  ((session-id :initform (get-next-session-id)
               :reader session-id
               :type integer
               :documentation "The unique ID \(an INTEGER) of the session.")
   (realm :initarg :realm
          :accessor session-realm
          :documentation "The realm under which the request has been sent.
A realm is used to group resources under a common 'place', and is used for registered web applications
to have different or common sessions for a give user")
   (session-string :accessor session-string
                   :documentation "The session strings encodes enough
data to safely retrieve this session. It is sent to the browser as a
cookie value or as a GET parameter.")
   (user-agent :initform (connector-user-agent (claw-server-connector *claw-server*))
               :reader session-user-agent
               :documentation "The incoming 'User-Agent' header that
was sent when this session was created.")
   (remote-addr :initform (connector-remote-addr (claw-server-connector *claw-server*));(connector-real-remote-addr (claw-server-connector *claw-server*))
                :reader session-remote-addr
                :documentation "The remote IP address of the client when
this sessions was started as returned by REAL-REMOTE-ADDR.")
   (session-start :initform (get-universal-time)
                  :reader session-start
                  :documentation "The time this session was started.")
   (last-click :initform (get-universal-time)
               :reader session-last-click
               :documentation "The last time this session was used.")
   (session-data :initarg :session-data
                 :initform (make-hash-table)
                 :reader session-data
                 :documentation "Data associated with this session -
see SESSION-VALUE.")
   (session-counter :initform 0
                    :reader session-counter
                    :documentation "The number of times this session
has been used.")
   (max-time :initarg :max-time
             :initform *session-default-max-time*
             :accessor session-max-time
             :type fixnum
             :documentation "The time \(in seconds) after which this
session expires if it's not used."))
  (:default-initargs :realm *claw-current-realm*)
  (:documentation "SESSION objects are automatically maintained
by Hunchentoot. They should not be created explicitly with
MAKE-INSTANCE but implicitly with START-SESSION. Note that
SESSION objects can only be created when the special variable
*REQUEST* is bound to a REQUEST object."))

;;-------------------------------------------------------------------------
(defvar *session-manager* nil
  "The session manager used during the request cycle.")

(defclass session-manager (claw-service)
  ((max-time :initarg :max-time
             :accessor session-manager-max-time
             :type fixnum
             :documentation "The time \(in seconds) after which this session expires if it's not used."))
  (:default-initargs :name 'session-manager :max-time 1800)
  (:documentation "SESSION-MANAGER is an interface, so you cannot directly use it.
A SESSION-MANAGER subclass is a class that helps to decouple CLAW from the web server on which claw-server resides.
To properly work a claw-server instance must be provided with a SESSION-MANAGER implementation.
A SESSION-MANAGER implementation to properly work, must implement all the CONNECTOR- methods.
As the name suggests this is a server that handles user sessions."))


(defgeneric default-session-manager-session-verify (session-manager)
  (:documentation "Tries to get a session identifier from the cookies \(oralternatively from the GET parameters) sent by the client. 
This identifier is then checked for validity against the REQUEST. 
On success the corresponding session object \(if not too old) is returned \(and updated). Otherwise NIL is returned."))

;;-------------------------------------------------------------------------
(defgeneric default-session-manager-session-too-old-p (default-session-manager session)
  (:documentation "Returns true if the SESSION has not been active in the last \(SESSION-MANAGER-MAX-TIME SESSION-MANAGER) seconds."))

(defgeneric default-session-manager-encode-session-string (default-session-manager id user-agent remote-addr start realm)
  (:documentation "Create a uniquely encoded session string based on the values ID, USER-AGENT, REMOTE-ADDR, START and REALM"))

(defgeneric default-session-manager-current-session (default-session-manager)
  (:documentation "Returns the session bouded to the current request"))

(defclass default-session-manager (session-manager)
  ((gc-timeout :initarg :gc-timeout
               :accessor default-session-manager-gc-timeout
               :documentation "The period the service waits before calling the session garbage collector")
   (sessions :initform (make-hash-table)
             :accessor default-session-manager-sessions
             :documentation "A hash table containing all sessions identified by their id")
   (service-lock :accessor default-session-manager-service-lock
                 :documentation "This is a thread lock that is used when adding or removing sessions, or when calling the session garbage collector.")
   (session-cookie-name :initarg :session-cookie-name
                        :accessor default-session-manager-session-cookie-name
                        :documentation "The name of the cookie that stores the session id.")
   (use-user-agent-for-sessions-p :initarg :use-user-agent-for-sessions-p
                                  :reader use-user-agent-for-sessions-p
                                  :documentation "")
   (use-remote-addr-for-sessions-p :initarg :use-remote-addr-for-sessions-p
                                   :reader use-remote-addr-for-sessions-p
                                   :documentation "")
   (session-secret :initarg :session-secret
                   :accessor default-session-manager-random-secret
                   :documentation "A random letter used to encode sessin into a string in a random way."))
  (:default-initargs :gc-timeout 1 :session-cookie-name "CLAWSID" 
                     :use-user-agent-for-sessions-p t
                     :use-remote-addr-for-sessions-p t
                     :session-secret (format nil "~VR" 36 (random 36 (make-random-state t))))
  (:documentation "This is the CLAW default session manager."))

(defmethod initialize-instance :after ((session-manager default-session-manager) &rest keys)
  (declare (ignore keys))
  (setf (default-session-manager-service-lock session-manager)
        (bt:make-lock (symbol-name 'session-manager))))

(defmethod default-session-manager-current-session ((session-manager default-session-manager))
  (or *claw-session*
      (let* ((connector (claw-server-connector *claw-server*))
             (cookie-name (default-session-manager-session-cookie-name session-manager))
             (sessions (default-session-manager-sessions session-manager))
             (session-identifier (or (connector-cookie-in connector cookie-name)
                                     (connector-get-parameter connector cookie-name))))
        (when session-identifier
          (destructuring-bind (id-string session-string)
              (split ":" session-identifier :limit 2)
            (declare (ignore session-string))
            (let ((id (and (scan "^\\d+$" id-string)
                           (parse-integer id-string :junk-allowed t))))
              (and id (gethash id sessions))))))))

(defmethod claw-service-start :after ((session-manager default-session-manager))
  (unless (claw-service-running-p session-manager)
    (bt:make-thread #'(lambda ()
                        (do ((continue (claw-service-running-p session-manager) (funcall #'claw-service-running-p session-manager)))
                            ((null continue))
                          (session-manager-session-gc session-manager))))))

(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-sequence string)
       do (format s "~2,'0x" code))))

(defmethod default-session-manager-encode-session-string ((session-manager default-session-manager) id user-agent remote-addr start realm)
  ;; *SESSION-SECRET* is used twice due to known theoretical
  ;; vulnerabilities of MD5 encoding
  (let ((session-secret (default-session-manager-random-secret session-manager)))
    (md5-hex (concatenate 'string
                          session-secret
                          (md5-hex (format nil "~A~A~@[~A~]~@[~A~]~A~@[~A~]"
                                           session-secret
                                           id
                                           user-agent
                                           remote-addr
                                           start
                                           realm))))))

(defmethod default-session-manager-session-verify ((session-manager default-session-manager))
  (let* ((connector (claw-server-connector *claw-server*))
         (sessions (default-session-manager-sessions session-manager))
         (cookie-name (default-session-manager-session-cookie-name session-manager)) 
         (session-identifier (or (connector-cookie-in connector cookie-name)
                                 (connector-get-parameter connector cookie-name))))
    (unless (and session-identifier
                 (stringp session-identifier)
                 (plusp (length session-identifier)))
      (return-from default-session-manager-session-verify nil))
    (destructuring-bind (id-string session-string)
        (split ":" session-identifier :limit 2)
      (let* ((id (and (scan "^\\d+$" id-string)
                      (parse-integer id-string
                                     :junk-allowed t)))
             (session (and id
                           (gethash id sessions)))
             (user-agent (connector-user-agent connector))
             (remote-addr (connector-remote-addr connector))
	     (realm (when session (session-realm session))))
        (unless (and session
                     session-string
                     (string= session-string
                              (session-string session))
                     (string= session-string
                              (default-session-manager-encode-session-string session-manager
                                  id
                                (and (use-user-agent-for-sessions-p session-manager)
                                     user-agent)
                                (and (use-remote-addr-for-sessions-p session-manager)
                                     remote-addr)
                                (session-start session)
                                realm)))
          (cond ((null session)
                 (log-message :notice "No session for session identifier '~A' \(User-Agent: '~A', IP: '~A', REALM: '~A')"
                              session-identifier user-agent remote-addr realm))
                (t
                 (log-message :warning "Fake session identifier '~A' \(User-Agent: '~A', IP: '~A', REALM: '~A')"
                              session-identifier user-agent remote-addr realm)))
          (when (and session-identifier  *claw-current-lisplet*)
            (let ((cookie (make-instance 'claw-cookie
                                         :name cookie-name
                                         :expires (get-universal-time)
                                         :path (format nil "~a/" *root-path*)
                                         :domain nil
                                         :value "")))
              (setf (connector-cookie-out connector cookie-name) cookie)))
          (when session
            (session-manager-remove-session session-manager session))
          (setf *claw-session* nil)
          (return-from default-session-manager-session-verify *claw-session*))
        (incf (slot-value session 'session-counter))
        (setf (slot-value session 'last-click) (get-universal-time)
              *claw-session* session)))))


(defmethod default-session-manager-session-too-old-p ((session-manager default-session-manager) (session session))
  (< (+ (session-last-click session) (or (session-max-time session) (session-manager-max-time session-manager)))
     (get-universal-time)))

(defmethod session-manager-start-session ((session-manager default-session-manager) &key (path "/") max-time domain)
  (let* ((connector (claw-server-connector *claw-server*))
         (sessions (default-session-manager-sessions session-manager))
         (cookie-name (default-session-manager-session-cookie-name session-manager))
         (session-identifier (or (connector-cookie-in connector cookie-name)
                                 (connector-get-parameter connector cookie-name))))
    (if (and session-identifier (gethash (parse-integer session-identifier :junk-allowed t) sessions))
        (destructuring-bind (id-string session-string)
            (split ":" session-identifier :limit 2)
          (declare (ignore session-string))
          (let* ((id (and (scan "^\\d+$" id-string)
                          (parse-integer id-string :junk-allowed t)))
                 (session (and id (gethash id sessions))))
            (unless (and session (default-session-manager-session-too-old-p session-manager session))
              (return-from session-manager-start-session session))))
        (bt:with-lock-held ((default-session-manager-service-lock session-manager))
          (let* ((session (make-instance 'session 
                                         :max-time (or max-time (session-manager-max-time session-manager))))
                 (cookie-name (default-session-manager-session-cookie-name session-manager))
                 (cookie))
            (setf (session-string session) (default-session-manager-encode-session-string session-manager
                                               (session-id session)
                                             (session-user-agent session)
                                             (session-remote-addr session)
                                             (session-start session) 
                                             (session-realm session))
                  cookie (make-instance 'claw-cookie
                                        :name cookie-name
                                        :expires nil
                                        :path path
                                        :domain domain
                                        :value (format nil "~a:~a" (session-id session) (session-string session))))
            (setf (connector-cookie-out connector cookie-name) cookie)
            (setf (gethash (session-id session) (default-session-manager-sessions session-manager)) session
                  *claw-session* session))))))

(defmethod session-manager-remove-session ((session-manager default-session-manager) &optional session)
  (let ((connector (claw-server-connector *claw-server*))
        (cookie-name (default-session-manager-session-cookie-name session-manager))
        (current-session (or session (default-session-manager-current-session session-manager))))
    (when current-session
      (bt:with-lock-held ((default-session-manager-service-lock session-manager))
        (remhash (session-id current-session) (default-session-manager-sessions session-manager))
        (let ((cookie (make-instance 'claw-cookie
                                     :name cookie-name
                                     :expires (get-universal-time)
                                     :path (format nil "~a/" *root-path*)
                                     :domain nil
                                     :value "")))
          (setf (connector-cookie-out connector cookie-name) cookie))))))

(defmethod session-manager-session-value ((session-manager default-session-manager) symbol)
  (let ((session (default-session-manager-current-session session-manager)))
    (when session
      (gethash symbol (session-data session)))))

(defmethod (setf session-manager-session-value) (value (session-manager default-session-manager) symbol)
  (let ((session (default-session-manager-current-session session-manager)))
    (when session
      (bt:with-lock-held ((default-session-manager-service-lock session-manager))
        (setf (gethash symbol (session-data session)) value)))))


(defmethod session-manager-delete-session-value ((session-manager default-session-manager) symbol)
  (let ((session (default-session-manager-current-session session-manager)))
    (when session
      (bt:with-lock-held ((default-session-manager-service-lock session-manager))
        (remhash symbol (session-data session))))))

(defmethod session-manager-reset-sessions ((session-manager default-session-manager))
  (bt:with-lock-held ((default-session-manager-service-lock session-manager))
    (setf (default-session-manager-sessions session-manager) (make-hash-table))))

(defmethod session-manager-session-gc ((session-manager default-session-manager))
  (let ((sessions (default-session-manager-sessions session-manager)))
    (loop for session-id being the hash-key of sessions using (hash-value session)
         do (when (default-session-manager-session-too-old-p session-manager session)
              (bt:with-lock-held ((default-session-manager-service-lock session-manager))
                (remhash session-id sessions))))))