Changes that bring CLASH up to extended HTTP/1.0 support:
Code to implement session management for resources. The current version supports transient cookie based session management, but other forms of management could be added without undue hassle.
This commit is contained in:
103
src/main/session.cl
Normal file
103
src/main/session.cl
Normal file
@ -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)))))
|
||||
Reference in New Issue
Block a user