/src/session.lisp

  1(in-package :wu)
  2
  3;;; +=========================================================================+
  4;;; | Copyright (c) 2009, 2010  Mike Travers and CollabRx, Inc                |
  5;;; |                                                                         |
  6;;; | Released under the MIT Open Source License                              |
  7;;; |   http://www.opensource.org/licenses/mit-license.php                    |
  8;;; |                                                                         |
  9;;; | Permission is hereby granted, free of charge, to any person obtaining   |
 10;;; | a copy of this software and associated documentation files (the         |
 11;;; | "Software"), to deal in the Software without restriction, including     |
 12;;; | without limitation the rights to use, copy, modify, merge, publish,     |
 13;;; | distribute, sublicense, and/or sell copies of the Software, and to      |
 14;;; | permit persons to whom the Software is furnished to do so, subject to   |
 15;;; | the following conditions:                                               |
 16;;; |                                                                         |
 17;;; | The above copyright notice and this permission notice shall be included |
 18;;; | in all copies or substantial portions of the Software.                  |
 19;;; |                                                                         |
 20;;; | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,         |
 21;;; | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF      |
 22;;; | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.  |
 23;;; | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY    |
 24;;; | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,    |
 25;;; | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE       |
 26;;; | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.                  |
 27;;; +=========================================================================+
 28
 29;;; Author:  Mike Travers
 30
 31;;; Session management
 32
 33(export '(cookie-value
 34	  with-session with-session-response def-session-variable delete-session new-session-hook
 35	  *aserve-request*))
 36
 37;;: Variables and parameters 
 38
 39;;; Bound by session handler to the session name (a keyword)
 40(defvar *session* nil)
 41;;; Dynamic bound to current request, makes life much easier
 42;;; Bound in with-session, but should be universal
 43;;; There is an aserve variable, but not exported so not a good idea to use: net.aserve::*worker-request*
 44(defvar *aserve-request* nil)
 45;;; +++ document...and hook up or delete
 46;;; (defparameter *default-login-handler* nil)
 47
 48
 49;;; Session store
 50#|
 51Theory:
 52- there are multiple session stores, each represented by a session store object
 53- each handles a certain set of variables,
 54- each is indexed by the same session id
 55
 56- variables are CLOS objects that point to a symbol and have additional info about reading/writing
 57
 58|#
 59
 60;;;; :::::::::::::::::::::::::::::::: Utilities
 61
 62;;; Signatures
 63
 64(defun string-signature (string &optional (secret *session-secret*))
 65  #+ALLEGRO (let ((*print-base* 36)) (princ-to-string (excl:hmac-sha1-string secret string)))
 66  #-ALLEGRO (hmac-sha1-string string secret))
 67
 68#-ALLEGRO
 69(defun hmac-sha1-string (string &optional (secret *session-secret*) (return :hex))
 70  (let ((hmac (ironclad:make-hmac (ironclad:ascii-string-to-byte-array secret) :sha1)))
 71    (ironclad:update-hmac hmac (ironclad:ascii-string-to-byte-array string))
 72    (ecase return
 73      (:hex (ironclad:byte-array-to-hex-string (ironclad:hmac-digest hmac)))
 74      (:bytes (ironclad:hmac-digest hmac)))))
 75
 76;;; Value is a list, gets written out as | separated values with the signature added
 77(defun signed-value (v &optional (secret *session-secret*))
 78  (let* ((base-string (format nil "~{~A|~}" v))
 79	 (sig (string-signature (string+ base-string secret))))
 80    (format nil "~A~A" base-string sig)))
 81  
 82;; Return value is a list of strings, or NIL if it doesn't verify
 83(defun verify-signed-value (rv &optional (secret *session-secret*))
 84  (when rv
 85    (ignore-errors			;if error, just don't verify
 86      (let* ((split-pos (1+ (position  #\| rv :from-end t)))
 87	     (content (subseq rv 0 split-pos))
 88	     (sig (subseq rv split-pos)))
 89	(when (equal sig
 90		     (string-signature (string+ content secret)))
 91	  (butlast #+ALLEGRO (excl:split-re "\\|" content)
 92		   #-ALLEGRO (mt:string-split content #\|)
 93		   ))))))
 94
 95;;;; :::::::::::::::::::::::::::::::: Session Stores
 96
 97(defvar *session-stores* nil)
 98
 99(defclass session-store ()
100  ((variables :initform nil :reader session-variables)
101   ))
102
103(defmethod initialize-instance :after ((store session-store) &rest ignore)
104  (declare (ignore ignore))
105  (push store *session-stores*))
106
107;;; dev only
108(defun reset-session-stores ()
109  (setf *session-stores* nil))
110
111
112;;; Assumes there will be at most one of each, seems safe
113(defun find-or-make-session-store (class)
114  (or (find class *session-stores* :key #'type-of)
115      (make-instance class)))
116
117(defun cookie-value (req name)
118  (assocdr name (get-cookie-values req) :test #'equal))
119
120
121;;;; :::::::::::::::::::::::::::::::: Session Variables
122
123(defmacro def-session-variable (name &optional initform &key (store-type :memory) reader writer)
124  `(progn
125     (defvar ,name ,initform)
126     (let ((var (make-instance 'session-variable
127		  :symbol ',name
128		  :reader ',reader
129		  :writer ',writer
130		  :initform ',initform)))
131       (add-session-variable ,store-type var)
132       )))
133
134;;; +++ these ought to delete var from other stores, for development purposes
135(defmethod add-session-variable ((type (eql :memory)) var)
136  (add-session-variable (find-or-make-session-store 'in-memory-session-store) var))
137
138(defmethod add-session-variable ((type (eql :cookie)) var)
139  (add-session-variable (find-or-make-session-store 'cookie-session-store) var))
140
141;;; These stores don't exist yet +++
142
143(defmethod add-session-variable ((type (eql :file)) var)
144  (add-session-variable (find-or-make-session-store 'file-session-store) var))
145
146(defmethod add-session-variable ((type (eql :sql)) var)
147  (add-session-variable (find-or-make-session-store 'sql-session-store) var))
148
149;;; This is constant once all session vars are defined, so kind of wasteful(+++)
150(defun all-session-variables ()
151  (mapappend #'session-variables *session-stores*))
152
153(defun all-session-variable-symbols ()
154  (mapappend #'session-variable-symbols *session-stores*))
155
156;;; +++ extend so nil arg returns default values
157(defun all-session-variable-values (session)
158  (mapappend #'(lambda (store) (session-values store session)) *session-stores*))
159
160(defun save-session-variables (&optional (session *session*))
161  (dolist (store *session-stores*)
162    (session-save-session-variables store session)))
163
164(defclass session-variable ()
165  ((symbol :initarg :symbol :reader session-variable-symbol)
166   (reader :initarg :reader :initform nil)
167   (writer :initarg :writer :initform nil)
168   (store :initarg :store)
169   (initform :initarg :initform :initform nil :reader session-variable-initform)))
170
171(defmethod print-object ((object session-variable) stream)
172  (with-slots (symbol) object
173    (print-unreadable-object (object stream :type t :identity t)
174      (princ symbol stream))))
175
176(defmethod session-variable-value ((ssv session-variable))
177  (symbol-value (session-variable-symbol ssv)))
178
179;;; temp theory -- all writing is in lisp syntax, reader/writer just transforms into readable if necessary
180
181(defmethod write-session-variable-value ((ssv session-variable) stream)
182  (with-slots (writer) ssv
183    (let ((raw (session-variable-value ssv)))
184      (if (and writer raw)
185	  (write (funcall writer raw) :stream stream)
186	  (write raw :stream stream))
187      (write-char #\space stream))))
188
189(defmethod read-session-variable-value ((ssv session-variable) stream)
190  (with-slots (reader) ssv
191    (let ((raw (read stream)))
192      (if (and reader raw)
193	  (funcall reader raw)
194	  raw))))
195
196
197;;;; :::::::::::::::::::::::::::::::: Response Generation
198
199
200
201(defmethod session-variable-symbols ((store session-store))
202  (with-slots (variables) store
203    (mapcar #'session-variable-symbol variables)))
204
205
206(defmethod add-session-variable ((store session-store) var)
207  (with-slots (variables) store
208    ;; +++ no, we want to update if its the same as existing
209    (replacef var variables :key #'session-variable-symbol)))
210
211
212;;;; :::::::::::::::::::::::::::::::: Memory Session Store
213
214(defclass in-memory-session-store (session-store)
215  ((sessions :initform (make-hash-table :test #'eq))))
216
217(defmethod session-values ((store in-memory-session-store) session)
218  (with-slots (sessions variables) store
219    (or (gethash session sessions)
220	(setf (gethash session sessions)
221	      (mapcar #'(lambda (var) (eval (session-variable-initform var))) variables))
222	)))
223
224;; +++ rename these methods, they are on session-store not session
225(defmethod session-save-session-variables ((store in-memory-session-store) session)
226  (with-slots (sessions variables) store
227    (setf (gethash session sessions)
228	  (mapcar #'session-variable-value variables))))
229
230(defmethod session-delete-session ((store in-memory-session-store) session)
231  (with-slots (sessions variables) store
232    (remhash session sessions)))
233
234(defmethod reset-session-store ((store in-memory-session-store))
235  (with-slots (sessions) store
236    (clrhash sessions)))
237  
238
239;;;; :::::::::::::::::::::::::::::::: Cookie Session Store
240
241;;; +++ warning overdesign, may throw some of this out in the interests of simplifying other things
242
243;;; +++ needs a timer and sweeper...could just make last-use-time a session variable
244
245;;; +++ I don't quite understand how cookie store can work, since cookie sets have to be done before
246;;; generating the body of a response.  Possibly through some javascript, but then that will affect
247;;; the page content (maybe breaking caching, argh).  Of course if we are buffering responses, like
248;;; we do on most cwest methods, then it could work.
249(defclass serialized-session-store (session-store)
250  ((package :initform (find-package :wuwei)))) ;+++ temp
251
252(defclass cookie-session-store (serialized-session-store) 
253  ((secret)
254   (cookie-name :initform (string+ *system-name* "-session"))
255   ))
256
257(defmethod initialize-instance :after ((store cookie-session-store) &rest ignore)
258  (declare (ignore ignore))
259  (recompute-secret store))
260
261;;; Incorporate the variables into the secret.  That way, if they change, existing cookies
262;;; will be invalidated, otherwise they will be mismatched.
263(defmethod recompute-secret ((store cookie-session-store))
264  (with-slots (variables secret) store
265    (setf secret
266	  (with-output-to-string (s)
267	    (write-string *session-secret* s)
268	    (dolist (v variables)
269	      (write (session-variable-symbol v) :stream s))))))
270
271(defmethod add-session-variable :after ((store cookie-session-store) var)
272  (recompute-secret store))
273
274;;; Encryption option would be good (see ironclad package)
275
276(defmethod session-values ((store cookie-session-store) session)
277  (unless *aserve-request*
278    (error "attempt to get cookie session vars without binding *aserve-request*"))
279  (with-slots (cookie-name variables package secret) store
280    (let ((value (verify-signed-value (cookie-value *aserve-request* cookie-name) secret))
281	  (*package* package))
282      (if value
283	  (with-input-from-string (s (cadr value))
284	    (collecting
285	      (dolist (var variables)
286		(collect (report-and-ignore-errors
287			      (read-session-variable-value var s))))))
288	  (mapcar #'(lambda (var) (eval (session-variable-initform var))) variables)
289	  ))))
290
291(defmethod set-cookie-session-cookie ((store cookie-session-store) req)
292  (with-slots (cookie-name) store
293    (set-cookie-header req :name cookie-name :value (session-state-cookie-value store) :expires :never)))
294
295(defmethod session-state-cookie-value ((store cookie-session-store))
296  (with-slots (variables package secret) store
297    (signed-value
298     (list *session*
299	   (with-output-to-string (s)
300	     (let ((*print-readably* t)
301		   (*print-pretty* nil)
302		   (*package* package))
303;	 (unless compact?
304;	   (format s "~S " (mapcar #'session-variable-symbol variables)))
305	 (dolist (var variables)
306	   (write-session-variable-value var s)))))
307     secret)))
308
309;;; No-op (should make sure vars have not changed since header was written +++)
310(defmethod session-save-session-variables ((store cookie-session-store) session)
311  (set-cookie-session-cookie store *aserve-request*))
312
313;;; +++ these need to get timed out, otherwise they will accumulate ad infinitum
314
315(defmethod session-delete-session ((store cookie-session-store) session)
316  (with-slots (cookie-name) store
317    (set-cookie-header *aserve-request* :name cookie-name :value ""))) 
318
319;;;; :::::::::::::::::::::::::::::::: Login, Session Creation, Etc
320
321(defun gensym-session-id ()
322  (keywordize (format nil "~A-~A" (machine-instance) (get-universal-time))))
323
324(defmacro with-session-variables (&body body)
325  `(let ((%val nil))
326     (progv (all-session-variable-symbols) (all-session-variable-values *session*)
327       (unwind-protect
328	    (setq %val (progn ,@body))
329	 (save-session-variables *session*)))
330     %val))
331
332;;; Note: has to be OUTSIDE with-http-response-and-body or equiv
333;;; +++ login-handler is ignored?
334;;; Assumes *session* set by with-session-vars, nil if invalid.
335;;; no longer implemented, but maybe should be brought back  (login-handler '*default-login-handler*)
336(defmacro with-session ((req ent &key) &body body)
337  `(let* ((*aserve-request* ,req)
338	 (*session* (get-session-id (find-or-make-session-store 'cookie-session-store) ,req)) ;+++ assume this validates
339	 (new-session nil))
340     (unless *session*
341       (setq *session* (gensym-session-id)
342	     new-session t))
343     (with-session-variables
344       (when new-session (new-session-hook ,req ,ent))
345       (save-session-variables)		;save cookie variables, especially *session*
346       ,@body
347       (save-session-variables)		;we also save the session variables here; let's memory state vars work more easily
348       )))
349
350(defmethod get-session-id ((store cookie-session-store) req)
351  (with-slots (cookie-name secret) store
352    (let ((value (verify-signed-value (cookie-value *aserve-request* cookie-name) secret)))
353      (when value
354	(keywordize (first value))))))
355
356;;; must be run inside with-session
357(defmacro with-session-response ((req ent &key content-type no-save?) &body body)
358  `(progn
359     (assert *session* nil "With-session-response in bad context")
360     (unless ,no-save? (save-session-variables *session*))
361     (with-http-response (,req ,ent ,@(if content-type `(:content-type ,content-type)))
362       (with-http-body (,req ,ent)
363	 ,@body))))
364
365(defun logout (req ent)
366  (with-session (req ent)
367    (delete-session)))
368
369(defun delete-session (&optional (key *session*) store-class)
370  (if store-class
371      (session-delete-session (find-or-make-session-store store-class) key)
372      (dolist (store *session-stores*) (session-delete-session store key))))
373
374
375
376;;; applications can redefine this to do special actions to initialize a session
377(defun new-session-hook (req ent)
378  (declare (ignore req ent))
379  )
380
381;;; See session-debug page in eval-server.lisp
382
383
384
385