diff --git a/src/main/session.cl b/src/main/session.cl new file mode 100644 index 0000000..bea9498 --- /dev/null +++ b/src/main/session.cl @@ -0,0 +1,103 @@ +;;;; 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 (resource) + ((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)) + +(defgeneric session-leader-process-login (leader request) + (:documentation + "Process the :post request to handle a login.")) + +(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)) + +(defmethod access-resource-using-method + ((resource session-leader) request (method (eql :POST))) + (session-leader-process-login resource request)) + +(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 ((resource session-leader) request) + (when (header-exists-p request 'cookie) + (let* ((session-name (session-leader-session-name resource)) + (cookie (assoc session-name (header-value request 'cookie) + :test #'string-equal))) + (when cookie + (gethash (cdr cookie) + (session-leader-sessions resource) + 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)))))