Change from MK-DEFSYSTEM to ASDF, rename .cl to .lisp files.

src/main/session.lisp

@@ -0,0 +1,108 @@
+;;;; 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))