You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
197 lines
8.7 KiB
Common Lisp
197 lines
8.7 KiB
Common Lisp
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
|
|
;;; Copyright (c) 2014, Thomas Hintz. All rights reserved.
|
|
|
|
;;; Redistribution and use in source and binary forms, with or without
|
|
;;; modification, are permitted provided that the following conditions
|
|
;;; are met:
|
|
|
|
;;; * Redistributions of source code must retain the above copyright
|
|
;;; notice, this list of conditions and the following disclaimer.
|
|
|
|
;;; * Redistributions in binary form must reproduce the above
|
|
;;; copyright notice, this list of conditions and the following
|
|
;;; disclaimer in the documentation and/or other materials
|
|
;;; provided with the distribution.
|
|
|
|
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
|
|
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
|
|
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
|
;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
|
|
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
|
|
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
|
|
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
|
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
|
|
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
|
|
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
|
|
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
|
|
|
(in-package #:pg-sessions)
|
|
|
|
(defparameter *pg-session-max-time* 3600) ; 1 hour
|
|
(defvar *pg-session-secret* "thisisasecret")
|
|
(defparameter *database-connection-spec* nil)
|
|
|
|
(defclass pg-session ()
|
|
((session-id :col-type serial :initarg :session-id :reader pg-session-id)
|
|
(session-string :col-type string :initform "" :accessor pg-session-string
|
|
:documentation "The session string encodes enough
|
|
data to safely retrieve this session. It is sent to the browser as a
|
|
cookie value or as a GET parameter.")
|
|
(session-start :col-type bigint :initform (get-universal-time) :accessor pg-session-start)
|
|
(last-click :col-type bigint :initform (get-universal-time) :accessor pg-session-last-click
|
|
:documentation "The last time this session was used.")
|
|
(max-time :col-type bigint :initarg :max-time
|
|
:initform *pg-session-max-time*
|
|
:accessor pg-session-max-time
|
|
:documentation "The time \(in seconds) after which this
|
|
session expires if it's not used."))
|
|
(:metaclass dao-class)
|
|
(:keys session-id)
|
|
(:documentation "An extensions of hunchentoot's sessions so that sessions can be
|
|
stored in the postmodern database."))
|
|
|
|
(defparameter *session-type* 'pg-session)
|
|
|
|
(defun md5-hex (string)
|
|
"Calculates the md5 sum of the string STRING and returns it as a hex string."
|
|
(with-output-to-string (s)
|
|
(loop for code across (md5:md5sum-string string)
|
|
do (format s "~2,'0x" code))))
|
|
|
|
(defun encode-session-string (id start)
|
|
;; *PG-SESSION-SECRET* is used twice due to known theoretical
|
|
;; vulnerabilities of MD5 encoding
|
|
(md5-hex (concatenate 'string
|
|
*pg-session-secret*
|
|
(md5-hex (format nil "~A~A~@[~A~]~@[~A~]~A"
|
|
*pg-session-secret*
|
|
id
|
|
start)))))
|
|
|
|
(defun stringify-session (session)
|
|
"Creates a string representing of the SESSION object SESSION. See
|
|
ENCODE-SESSION-STRING."
|
|
(encode-session-string (pg-session-id session)
|
|
(pg-session-start session)))
|
|
|
|
(defun session-too-old-p (session)
|
|
(< (+ (pg-session-last-click session) (pg-session-max-time session))
|
|
(get-universal-time)))
|
|
|
|
(defun pg-remove-session (&optional (session hunchentoot:*session*))
|
|
"Completely removes the SESSION object SESSION from Hunchentoot's
|
|
internal session database."
|
|
(delete-dao session)
|
|
(values))
|
|
|
|
(defun pg-session-gc ()
|
|
"Removes sessions from the current session database which are too
|
|
old - see SESSION-TOO-OLD-P."
|
|
(loop for session in (select-dao *session-type*)
|
|
when (session-too-old-p session)
|
|
do (remove-session session)))
|
|
|
|
(defmethod hunchentoot:session-cookie-value ((pg-session pg-session))
|
|
(and pg-session
|
|
(format nil
|
|
"~D:~A"
|
|
(pg-session-id pg-session)
|
|
(pg-session-string pg-session))))
|
|
|
|
(defun save-pg-session (&optional (session hunchentoot:*session*))
|
|
(upsert-dao session))
|
|
|
|
(defun pg-start-session (&rest args)
|
|
"Returns the current SESSION object. If there is no current session,
|
|
creates one and updates the corresponding data structures. In this
|
|
case the function will also send a session cookie to the browser."
|
|
(let ((session (hunchentoot:session hunchentoot:*request*)))
|
|
(when session
|
|
(return-from pg-start-session session))
|
|
(setf session
|
|
(apply #'make-dao
|
|
(append `(,*session-type*)
|
|
args)))
|
|
(setf (hunchentoot:session hunchentoot:*request*) session)
|
|
(setf (pg-session-string session) (stringify-session session))
|
|
(save-pg-session session)
|
|
(hunchentoot:set-cookie (hunchentoot:session-cookie-name hunchentoot:*acceptor*)
|
|
:value (hunchentoot:session-cookie-value session)
|
|
:path "/")
|
|
(setq hunchentoot:*session* session)))
|
|
|
|
(defun get-stored-session (id request)
|
|
"Returns the SESSION object corresponding to the number ID if the
|
|
session has not expired. Will remove the session if it has expired but
|
|
will not create a new one."
|
|
(let ((session (get-dao *session-type* id)))
|
|
(when (and session
|
|
(session-too-old-p session))
|
|
(when hunchentoot:*reply*
|
|
(hunchentoot:log-message* :info "Session with ID ~A too old" id))
|
|
(pg-remove-session session)
|
|
(setq session nil))
|
|
session))
|
|
|
|
(defmethod hunchentoot:session-verify ((request hunchentoot:request))
|
|
(with-connection
|
|
*database-connection-spec*
|
|
(with-transaction (transaction)
|
|
(let ((session-identifier
|
|
(or (when-let (session-cookie (hunchentoot:cookie-in
|
|
(hunchentoot:session-cookie-name
|
|
hunchentoot:*acceptor*) request))
|
|
(hunchentoot:url-decode session-cookie))
|
|
(hunchentoot:get-parameter (hunchentoot:session-cookie-name
|
|
hunchentoot:*acceptor*) request))))
|
|
(unless (and session-identifier
|
|
(stringp session-identifier)
|
|
(plusp (length session-identifier)))
|
|
(return-from hunchentoot:session-verify nil))
|
|
(destructuring-bind (id-string session-string)
|
|
(cl-ppcre:split ":" session-identifier :limit 2)
|
|
(let* ((id (parse-integer id-string))
|
|
(session (get-stored-session id request)))
|
|
(cond
|
|
((and session
|
|
(string= session-string
|
|
(pg-session-string session))
|
|
(string= session-string
|
|
(encode-session-string id
|
|
(pg-session-start session))))
|
|
;; the session key presented by the client is valid
|
|
(setf (pg-session-last-click session) (get-universal-time))
|
|
(save-pg-session session)
|
|
session)
|
|
(session
|
|
;; the session ID pointed to an existing session, but the
|
|
;; session string did not match the expected session string
|
|
(hunchentoot:log-message*
|
|
:warning "Fake session identifier '~A' (User-Agent: '~A', IP: '~A')"
|
|
session-identifier user-agent remote-addr)
|
|
;; remove the session to make sure that it can't be used
|
|
;; again; the original legitimate user will be required to
|
|
;; log in again
|
|
(pg-remove-session session)
|
|
nil)
|
|
(t
|
|
;; no session was found under the ID given, presumably
|
|
;; because it has expired.
|
|
(hunchentoot:log-message*
|
|
:info "No session for session identifier '~A' (User-Agent: '~A', IP: '~A')"
|
|
session-identifier user-agent remote-addr)
|
|
nil))))))))
|
|
|
|
(defun pg-session-value (symbol &optional (session hunchentoot:*session*))
|
|
"Returns the value associated with SYMBOL from the session object
|
|
SESSION \(the default is the current session) if it exists."
|
|
(when session
|
|
(slot-value session symbol)))
|
|
|
|
(defsetf pg-session-value (symbol &optional session) (new-value)
|
|
(with-gensyms (%session %symbol)
|
|
`(let ((,%session (or ,session (pg-start-session)))
|
|
(,%symbol ,symbol))
|
|
(setf (slot-value ,%session ,%symbol) ,new-value)
|
|
(save-pg-session ,%session))))
|