Initial version.

package.lisp

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

pg-sessions.lisp

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