(in-package :araneida)

#|
How all this works:

Each session is stored in *session-table* - a vector of (or null session).
Each session has a session id (the slot of the vector); this session id is encoded
using the function assigned to *session-id->cookie-value*, and stored in
the cookie "<*session-cookie-name*><session-name>".

When (request-send-headers) is called, it checks to see if the client
has all of the cookies that are associated with the request. If not, it sends them.

|#

; These are internal to clean up code
(defun request-authorized-for-session-p (request session)
  (funcall *request-authorized-for-session-p* request session))

(defun session-id->cookie-value (session-id)
  (funcall *session-id->cookie-value* session-id))

(defun cookie-value->session-id (cookie-value)
  (funcall *cookie-value->session-id* cookie-value))

(defun unused-session-id ()
  "Finds an unused session slot in the *session-table* vector."
  (flet ((twenty-tries (limit)
	   (loop repeat (min limit 20)
		 do (let ((i (random limit)))
		      (when (null (aref *session-table* i))
			(return i)))
		 finally (return nil))))
    (let ((size (array-dimension *session-table* 0)))
      (let ((free-random-element (twenty-tries size)))
	(if free-random-element
	    free-random-element
	    (progn
	      (adjust-array *session-table* (expt (max 2 size) 2) :element-type '(or null session) :initial-element nil)
	      (+ 2 size)))))))
    
; note: this doesn't attach the session to the request
; That's done elsewhere
(defun create-session (this-request &key (session-name :default) (lifetime *default-session-lifetime*))
  "Creates a new session object and places it in the session-table"
  (let* ((unused-id (unused-session-id))
	 (new-session (make-instance 'session
				     :name session-name
				     :lifetime lifetime
				     :session-id unused-id
				     :last-access-time (get-universal-time)
				     :creation-request (copy-request this-request))))
    (setf (aref *session-table* unused-id) new-session)
    new-session))
    
(let ((last-scan 0))
  (defun reap-sessions (&key force-scan)
    "Goes through the sessions and removes those which have expired.
Every access of a session (through with-session-slots or session-slot-value) refreshes
a session.
By default, reap-sessions will only perform a scan if *default-session-lifetime*/4 has
passed. Setting force-scan to true will force it to perform the scan."
    (let ((current-time (get-universal-time)))
      (when (or force-scan
		(> (- current-time last-scan)
		   (/ *default-session-lifetime* 4)))
	(dotimes (i (array-dimension *session-table* 0))
	  (let ((session (aref *session-table* i)))
	    (when session
	      (with-slots (last-access-time lifetime) session
		(when (> current-time
			 (+ last-access-time lifetime))
		  (setf (aref *session-table* i) nil))))))
	(setf last-scan current-time)))))

(defun delete-sessions ()
  "Deletes all sessions."
  (setf *session-table* (make-array 1 :element-type '(or null session) :initial-element nil :adjustable t)))

(defun session-slot-value (session slot)
  "Accessor for session slots.
This is used exactly like (slot-value obj slot). Just pretend
that the session has whatever slot you want."
  (setf (last-access-time session) (get-universal-time))
  (gethash slot (slot-value session 'slots)))

(defun update-session-slot-value (new-value session slot)
  (setf (last-access-time session) (get-universal-time))
  (setf (gethash slot (slot-value session 'slots)) new-value))

(defsetf session-slot-value (session slot) (store)
  `(update-session-slot-value ,store ,session ,slot))

(defmacro with-session-slots (slots session &body body)
  "Just like with-slots, but for sessions!"
  (once-only (session)
    `(symbol-macrolet ,(mapcar (lambda (slot)
				 `(,slot (araneida:session-slot-value ,session ',slot)))
			       slots)
      ,@body)))

(defgeneric session-slots (session)
  (:documentation "Returns all of the slots in the session"))
(defmethod session-slots ((session session))
  (let ((hash (slot-value session 'slots)))
    (loop for key being each hash-key of hash
	  collect key)))

(defun refresh-session (session)
  "Freshens the session (sets its access time to now)
Use this when you wish to refresh a session but don't need any values from it."
  (setf (last-access-time session) (get-universal-time)))

(defun session-name->cookie-name (session-name)
  "Returns the cookie name for a session name"
  (concatenate 'string *session-cookie-name* (symbol-name session-name)))
(defun cookie-name->session-name (cookie-name)
  "Returns the intern'd session name or nil if it is not a session-name cookie"
  (if (equal *session-cookie-name*
	     (subseq cookie-name
		     0
		     (min (length cookie-name) (length *session-cookie-name*))))
      (intern (subseq cookie-name (length *session-cookie-name*))
	      :keyword)
      nil))

(defun parse-sessions-from-cookies (request)
  (let* ((cookies (mapcar (lambda (cookie)
			    (cons (cookie-name->session-name (rfc2109:cookie-name cookie))
				  (rfc2109:cookie-value cookie)))
			  (request-cookies request)))
	 (scookies (remove-if #'null cookies :key #'car)))
    (let ((sessions
	   (mapcar (lambda (scookie)
		     (let ((session-id (cookie-value->session-id (cdr scookie))))
		       (if (and (> (length *session-table*) session-id)
				(not (null (aref *session-table* session-id))))
			   (progn (setf (cdr scookie)
					(aref *session-table* session-id))
				  scookie)
			   nil)))
		   scookies)))
      (setf (slot-value request 'sessions)
	    (remove-if #'null sessions :key #'cdr)))))
      

(defgeneric request-session (request &key create-if-null session-name minimum-lifetime)
  (:documentation "Gets the session named SESSION-NAME associated with the request.
Normally, if there is no session, the session has expired, or the request is not
authorized for the request (see *request-authorized-for-session*), a new session
will be returned. You can turn this behavior off by setting :create-if-null to nil.
nil will then be returned upon no session."))

; FIXME: allow session to be from GET parameters, not just cookies
(defmethod request-session ((request request) &key (create-if-null t) (session-name :default) minimum-lifetime)
  (with-slots (sessions) request
    (flet ((create-new-session ()
	     (if create-if-null
		 (new-session request :session-name session-name :lifetime (if minimum-lifetime
									       (max minimum-lifetime *default-session-lifetime*)
									       *default-session-lifetime*))
		 nil))
	   (authorized (s)
	     "check to make sure you're supposed to be able to access the session AND the session isn't expired"
	     (and (< (get-universal-time)
		     (+ (last-access-time s) (lifetime s)))
		  (request-authorized-for-session-p request s))))
      (let ((the-valid-session (let ((session-pair (assoc session-name sessions)))
				 (if (null session-pair)
				     (let ((the-session-pair (assoc session-name (parse-sessions-from-cookies request))))
				       (if (null the-session-pair)
					   (create-new-session)
					   (if (not (authorized (cdr the-session-pair)))
					       (progn (warn "not authorized") (create-new-session))
					       (cdr the-session-pair))))
				     (if (not (authorized (cdr session-pair)))
					 (create-new-session)
					 (cdr session-pair))))))
	(when (and minimum-lifetime
		   (> minimum-lifetime (lifetime the-valid-session)))
	  (setf (lifetime the-valid-session) minimum-lifetime))
	the-valid-session))))

(defgeneric new-session (request &key session-name lifetime)
  (:documentation "Creates a new session, overriding any old session"))
(defmethod new-session ((request request) &key (session-name :default) (lifetime *default-session-lifetime*))
  (with-slots (sessions) request
    (let ((session-pair (assoc session-name sessions))
	  (new-session (create-session request :session-name session-name :lifetime lifetime)))
      (if session-pair
	  (setf (cdr session-pair) new-session)
	  (setf sessions (acons session-name new-session sessions)))
      new-session)))

(defgeneric delete-session (request &key session-name)
  (:documentation "Removes the current session from association with the request.
NB: accessing (request-session request) will create a new session!"))
(defmethod delete-session ((request request) &key (session-name :default))
  (let ((session (request-session request :create-if-null nil :session-name session-name)))
    (when session
      (when (session-id session)
	(setf (aref *session-table* (session-id session)) nil)
	(setf (session-id session) nil))
      (with-slots (sessions) request
	(setf sessions (remove session-name sessions :key #'car))))))