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

11 years ago
;;; 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)
11 years ago
(defparameter *pg-session-max-time* 3600) ; 1 hour
11 years ago
(defvar *pg-session-secret* "thisisasecret")
11 years ago
(defparameter *database-connection-spec* nil)
11 years ago
(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
11 years ago
:initform *pg-session-max-time*
11 years ago
: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."))
11 years ago
(defparameter *session-type* 'pg-session)
11 years ago
(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)
11 years ago
;; *PG-SESSION-SECRET* is used twice due to known theoretical
;; vulnerabilities of MD5 encoding
11 years ago
(md5-hex (concatenate 'string
11 years ago
*pg-session-secret*
(md5-hex (format nil "~A~A~@[~A~]~@[~A~]~A"
*pg-session-secret*
id
11 years ago
start)))))
11 years ago
(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)))
11 years ago
(defun pg-remove-session (&optional (session hunchentoot:*session*))
11 years ago
"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."
11 years ago
(loop for session in (select-dao *session-type*)
11 years ago
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))))
11 years ago
(defun save-pg-session (&optional (session hunchentoot:*session*))
11 years ago
(upsert-dao session))
11 years ago
(defun pg-start-session (&rest args)
11 years ago
"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))
11 years ago
(setf session
(apply #'make-dao
(append `(,*session-type*)
11 years ago
args)))
11 years ago
(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."
11 years ago
(let ((session (get-dao *session-type* id)))
11 years ago
(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
11 years ago
*database-connection-spec*
11 years ago
(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))
11 years ago
(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)))
11 years ago
(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
11 years ago
(pg-remove-session session)
11 years ago
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))))))))
11 years ago
(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))))