;;;; CLASH --- The Common Lisp Adaptable Simple HTTP server
;;;; This is copyrighted software.  See documentation for terms.
;;;; 
;;;; session.cl --- Session management resources
;;;; 
;;;; Checkout Tag: $Name$
;;;; $Id$

(in-package :CLASH)

;;;; %File Description:
;;;; 
;;;; The Resources in this file implement various session management
;;;; mechanisms for HTTP.
;;;; 

;;; Ephemeral cookie-based session management

(defclass session-leader ()
  ((sessions :initform (make-hash-table :test #'equal)
	     :reader session-leader-sessions)
   (session-name :initform "SESSIONID" :initarg :session-name
		 :reader session-leader-session-name)
   (session-path :initform "/" :initarg :session-path
		 :reader session-leader-session-path)))

(defgeneric session-leader-new-id (leader)
  (:documentation "Allocate and return a new transient session id."))

(defmethod session-leader-new-id ((leader session-leader))
  (format nil "~D-~D" (get-universal-time) (get-internal-real-time)))

(defgeneric session-leader-new-session (leader session-data)
  (:documentation
   "Register a new session binding `session-data' to a newly allocated
session id, which is then returned."))

(defmethod session-leader-new-session ((leader session-leader) data)
  (let ((new-id (session-leader-new-id leader)))
    (setf (gethash new-id (session-leader-sessions leader)) data)
    new-id))

(defmacro with-new-session ((leader data) &body body)
  `(let ((leader ,leader)
	 (data ,data)
	 (result (progn ,@body)))
     (setf (slot-value result 'set-cookie)
           (list (list (session-leader-session-name leader)
		       (session-leader-new-session leader data))
	         (list "path"
		       (session-leader-session-path leader))))
     result))

(defgeneric get-session-data (leader request)
  (:documentation
   "Lookup a possible session-data item bound to the session id that
is included in a Cookie header in the given request.  Returns nil of
no corresponding session-data item can be found."))

(defmethod get-session-data ((leader session-leader) request)
  (when (header-exists-p request 'cookie)
    (let* ((session-name (session-leader-session-name leader))
	   (cookie (assoc session-name (header-value request 'cookie)
			  :test #'string-equal)))
      (when cookie
	(gethash (cdr cookie)
		 (session-leader-sessions leader)
		 nil)))))

(defclass sessioned-resource (resource)
  ())

(defgeneric sessioned-resource-session-leader (resource)
  (:documentation
   "Determine the session-leader that is responsible for the
sessioned-resource."))

(defgeneric handle-missing-session (resource request)
  (:documentation
   "Handle a missing session in a `with-session-data' block."))

(defmacro with-session-data ((var resource request) &body body)
  "Bind `var' to the session-data object for the session the request
belongs to.  If no session-data object exists `handle-missing-session'
is invoked to handle the request."
  (let ((res-var (gensym))
	(req-var (gensym)))
    `(let* ((,res-var ,resource)
	    (,req-var ,request)
	    (,var (get-session-data
		   (sessioned-resource-session-leader ,res-var)
		   ,req-var)))
       (if ,var
	   (progn ,@body)
	   (handle-missing-session ,res-var ,req-var)))))

;;; Hack for limited backwards compatability

(defclass session-leader-resource (resource session-leader)
  ())

(defgeneric session-leader-process-login (leader request)
  (:documentation
   "Process the :post request to handle a login."))

(defmethod access-resource-using-method
    ((resource session-leader-resource) request (method (eql :POST)))
  (session-leader-process-login resource request))