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

;;; 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))))