Initial version.
This commit is contained in:
@@ -3,6 +3,11 @@
|
||||
(:export #:pg-session
|
||||
#:pg-session-id
|
||||
#:pg-session-gc
|
||||
#:pg-remove-session
|
||||
#:*session-type*
|
||||
#:*database-connection-spec*
|
||||
#:pg-session-value
|
||||
#:pg-session-max-time
|
||||
#:pg-start-session
|
||||
#:save-pg-session))
|
||||
|
||||
|
||||
@@ -27,8 +27,9 @@
|
||||
|
||||
(in-package #:pg-sessions)
|
||||
|
||||
(defparameter *hunchentoot-postmodern-session-max-time* 3600) ; 1 hour
|
||||
(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)
|
||||
@@ -44,7 +45,7 @@ cookie value or as a GET parameter.")
|
||||
(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*
|
||||
: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."))
|
||||
@@ -53,6 +54,8 @@ session expires if it's not used."))
|
||||
(: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)
|
||||
@@ -64,11 +67,7 @@ stored in the postmodern database."))
|
||||
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
|
||||
(md5-hex (concatenate 'string
|
||||
*pg-session-secret*
|
||||
(md5-hex (format nil "~A~A~@[~A~]~@[~A~]~A"
|
||||
*pg-session-secret*
|
||||
@@ -77,16 +76,11 @@ USER-AGENT, and START"
|
||||
user-agent)
|
||||
(and hunchentoot:*use-remote-addr-for-sessions*
|
||||
remote-addr)
|
||||
start))))))
|
||||
(hunchentoot:log-message* :info "encoding: ~A" r)
|
||||
r))
|
||||
start)))))
|
||||
|
||||
(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)
|
||||
@@ -96,7 +90,7 @@ ENCODE-SESSION-STRING."
|
||||
(< (+ (pg-session-last-click session) (pg-session-max-time session))
|
||||
(get-universal-time)))
|
||||
|
||||
(defun pg-remove-session (session)
|
||||
(defun pg-remove-session (&optional (session hunchentoot:*session*))
|
||||
"Completely removes the SESSION object SESSION from Hunchentoot's
|
||||
internal session database."
|
||||
(delete-dao session)
|
||||
@@ -105,35 +99,36 @@ internal session database."
|
||||
(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)
|
||||
(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))
|
||||
(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)
|
||||
(defun save-pg-session (&optional (session hunchentoot:*session*))
|
||||
(upsert-dao session))
|
||||
|
||||
(defun pg-start-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."
|
||||
(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 session
|
||||
(apply #'make-dao
|
||||
(append `(,*session-type*
|
||||
:user-agent ,(hunchentoot:user-agent hunchentoot:*request*)
|
||||
:remote-addr ,(hunchentoot:real-remote-addr hunchentoot:*request*))
|
||||
args)))
|
||||
;; (setf session (make-dao *session-type*
|
||||
;; :user-agent (hunchentoot:user-agent hunchentoot:*request*)
|
||||
;; :remote-addr (hunchentoot:real-remote-addr hunchentoot:*request*)))
|
||||
(setf (hunchentoot:session hunchentoot:*request*) session)
|
||||
(setf (pg-session-string session) (stringify-session session))
|
||||
(save-pg-session session)
|
||||
@@ -146,11 +141,7 @@ case the function will also send a session cookie to the browser."
|
||||
"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)
|
||||
(let ((session (get-dao *session-type* id)))
|
||||
(when (and session
|
||||
(session-too-old-p session))
|
||||
(when hunchentoot:*reply*
|
||||
@@ -158,16 +149,13 @@ will not create a new one."
|
||||
(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)
|
||||
*database-connection-spec*
|
||||
(with-transaction (transaction)
|
||||
(let ((session-identifier
|
||||
(or (when-let (session-cookie (hunchentoot:cookie-in
|
||||
@@ -208,7 +196,7 @@ will not create a new one."
|
||||
;; 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)
|
||||
(pg-remove-session session)
|
||||
nil)
|
||||
(t
|
||||
;; no session was found under the ID given, presumably
|
||||
@@ -218,6 +206,19 @@ will not create a new one."
|
||||
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))))
|
||||
|
||||
;; (defun reset-sessions (&optional (acceptor *acceptor*))
|
||||
;; "Removes ALL stored sessions of ACCEPTOR."
|
||||
;; (with-session-lock-held ((session-db-lock acceptor))
|
||||
|
||||
Reference in New Issue
Block a user