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.
228 lines
11 KiB
Common Lisp
228 lines
11 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 *hunchentoot-postmodern-session-max-time* 3600) ; 1 hour
|
|
(defvar *pg-session-secret* "thisisasecret")
|
|
|
|
(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.")
|
|
(user-agent :initarg :user-agent
|
|
:accessor pg-session-user-agent)
|
|
(remote-addr :initarg :remote-addr
|
|
:accessor pg-session-remote-addr)
|
|
(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 *hunchentoot-postmodern-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."))
|
|
|
|
(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 user-agent remote-addr start)
|
|
"Creates a uniquely encoded session string based on the values ID,
|
|
USER-AGENT, and START"
|
|
;; *PG-SESSION-SECRET* is used twice due to known theoretical
|
|
;; vulnerabilities of MD5 encoding
|
|
(hunchentoot:log-message* :info "UA: ~A" user-agent)
|
|
(hunchentoot:log-message* :info "addr: ~A" remote-addr)
|
|
(hunchentoot:log-message* :info "start: ~A" start)
|
|
(hunchentoot:log-message* :info "id: ~A" id)
|
|
(let ((r (md5-hex (concatenate 'string
|
|
*pg-session-secret*
|
|
(md5-hex (format nil "~A~A~@[~A~]~@[~A~]~A"
|
|
*pg-session-secret*
|
|
id
|
|
(and hunchentoot:*use-user-agent-for-sessions*
|
|
user-agent)
|
|
(and hunchentoot:*use-remote-addr-for-sessions*
|
|
remote-addr)
|
|
start))))))
|
|
(hunchentoot:log-message* :info "encoding: ~A" r)
|
|
r))
|
|
|
|
(defun stringify-session (session)
|
|
"Creates a string representing of the SESSION object SESSION. See
|
|
ENCODE-SESSION-STRING."
|
|
(hunchentoot:log-message* :info "UA: ~A" (pg-session-user-agent session))
|
|
(hunchentoot:log-message* :info "addr: ~A" (pg-session-remote-addr session))
|
|
(hunchentoot:log-message* :info "start: ~A" (pg-session-start session))
|
|
(encode-session-string (pg-session-id session)
|
|
(pg-session-user-agent session)
|
|
(pg-session-remote-addr 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 (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 'pg-session)
|
|
when (session-too-old-p session)
|
|
do (remove-session session)))
|
|
|
|
(defmethod hunchentoot:session-cookie-value ((pg-session pg-session))
|
|
(hunchentoot:log-message* :warning "session verify")
|
|
(and pg-session
|
|
(format nil
|
|
"~D:~A"
|
|
(pg-session-id pg-session)
|
|
(pg-session-string pg-session))))
|
|
|
|
(defun save-pg-session (session)
|
|
(upsert-dao session))
|
|
|
|
(defun pg-start-session ()
|
|
"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."
|
|
(hunchentoot:log-message* :info "in pg-start-session")
|
|
(let ((session (hunchentoot:session hunchentoot:*request*)))
|
|
(when session
|
|
(return-from pg-start-session session))
|
|
(hunchentoot:log-message* :info "session before")
|
|
(setf session (make-dao 'pg-session
|
|
:user-agent (hunchentoot:user-agent hunchentoot:*request*)
|
|
:remote-addr (hunchentoot:real-remote-addr hunchentoot:*request*)))
|
|
(hunchentoot:log-message* :info "session ~S" session)
|
|
(hunchentoot:log-message* :info "session-id: ~A" (pg-session-id session))
|
|
(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."
|
|
(hunchentoot:log-message* :info "get-stored-session ~A" id)
|
|
(hunchentoot:log-message* :info "request ~S" request)
|
|
(let ((session (get-dao 'pg-session id)))
|
|
(hunchentoot:log-message* :info "get-stored-session ~A recieved" id)
|
|
(hunchentoot:log-message* :info "session: ~A" session)
|
|
(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))
|
|
(when session
|
|
(hunchentoot:log-message* :info "setting stuff")
|
|
(setf (pg-session-user-agent session) (hunchentoot:user-agent request)
|
|
(pg-session-remote-addr session) (hunchentoot:real-remote-addr request)))
|
|
session))
|
|
|
|
(defmethod hunchentoot:session-verify ((request hunchentoot:request))
|
|
(hunchentoot:log-message* :info "session verify")
|
|
(hunchentoot:log-message* :warning "UNCOMMENT remove session in faked")
|
|
(with-connection
|
|
'("foods" "tjhintz" "" "localhost" :pooled-p t)
|
|
(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 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))
|
|
(user-agent (hunchentoot:user-agent request))
|
|
(remote-addr (hunchentoot:remote-addr request)))
|
|
(cond
|
|
((and session
|
|
(string= session-string
|
|
(pg-session-string session))
|
|
(string= session-string
|
|
(encode-session-string id
|
|
user-agent
|
|
(hunchentoot:real-remote-addr request)
|
|
(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 reset-sessions (&optional (acceptor *acceptor*))
|
|
;; "Removes ALL stored sessions of ACCEPTOR."
|
|
;; (with-session-lock-held ((session-db-lock acceptor))
|
|
;; (loop for (nil . session) in (session-db acceptor)
|
|
;; do (acceptor-remove-session acceptor session))
|
|
;; (setq *session-db* nil))
|
|
;; (values))
|