diff --git a/src/Network/Wai/Session/PostgreSQL.hs b/src/Network/Wai/Session/PostgreSQL.hs --- a/src/Network/Wai/Session/PostgreSQL.hs +++ b/src/Network/Wai/Session/PostgreSQL.hs @@ -29,6 +29,7 @@ , WithPostgreSQLConn (..) ) where +import Control.Applicative ((<$>)) import Control.Concurrent import Control.Concurrent.MVar import Control.Exception.Base @@ -126,37 +127,37 @@ qryCreateSessionEntry :: Query qryCreateSessionEntry = "INSERT INTO wai_pg_session_data (wai_pg_session,key,value) VALUES (?,?,?)" -qryUpdateSession :: Query +qryUpdateSession :: Query qryUpdateSession = "UPDATE wai_pg_sessions SET session_last_access=? WHERE id=?" -qryUpdateSessionEntry :: Query +qryUpdateSessionEntry :: Query qryUpdateSessionEntry = "UPDATE wai_pg_session_data SET value=? WHERE wai_pg_session=? AND key=?" -qryLookupSession :: Query +qryLookupSession :: Query qryLookupSession = "SELECT id FROM wai_pg_sessions WHERE session_key=? AND session_last_access>=?" -qryLookupSession' :: Query +qryLookupSession' :: Query qryLookupSession' = "UPDATE wai_pg_sessions SET session_last_access=? WHERE id=?" -qryLookupSession'' :: Query +qryLookupSession'' :: Query qryLookupSession'' = "SELECT value FROM wai_pg_session_data WHERE wai_pg_session=? AND key=?" -qryLookupSession''' :: Query +qryLookupSession''' :: Query qryLookupSession''' = "SELECT id FROM wai_pg_session_data WHERE wai_pg_session=? AND key=?" -qryPurgeOldSessions :: Query +qryPurgeOldSessions :: Query qryPurgeOldSessions = "DELETE FROM wai_pg_sessions WHERE session_last_access a -> StoreSettings -> SessionStore m k v dbStore' pool stos Nothing = do newKey <- storeSettingsKeyGen stos - curtime <- round <$> liftIO getPOSIXTime + curtime <- liftIO getPOSIXTime sessionPgId <- withPostgreSQLConn pool $ \ conn -> do - [Only res] <- query conn qryCreateSession (newKey, curtime :: Int64, curtime) :: IO [Only Int64] + [Only res] <- query conn qryCreateSession (newKey, round curtime :: Int64, round curtime :: Int64) :: IO [Only Int64] return (res :: Int64) backend pool stos newKey sessionPgId dbStore' pool stos (Just key) = do @@ -245,6 +246,10 @@ return ( ( reader pool key sessionPgId , writer pool key sessionPgId ), withPostgreSQLConn pool $ \conn -> do + -- Update session access time + curtime <- liftIO getPOSIXTime + void $ execute conn qryLookupSession' (round curtime :: Int64, sessionPgId) + [Only shouldNewKey] <- query conn qryCheckNewKey (Only key) if shouldNewKey then do newKey' <- storeSettingsKeyGen stos @@ -257,9 +262,7 @@ reader :: (WithPostgreSQLConn a, Serialize k, Eq k, Serialize v, MonadIO m) => a -> B.ByteString -> Int64 -> k -> m (Maybe v) reader pool key sessionPgId k = do - curtime <- round <$> liftIO getPOSIXTime res <- liftIO $ withPostgreSQLConn pool $ \conn -> do - void $ execute conn qryLookupSession' (curtime :: Int64, sessionPgId) query conn qryLookupSession'' (sessionPgId, Binary $ encode k) case res of [Only value] -> case decode (fromBinary value) of @@ -269,7 +272,6 @@ writer :: (WithPostgreSQLConn a, Serialize k, Eq k, Serialize v, MonadIO m) => a -> B.ByteString -> Int64 -> k -> v -> m () writer pool key sessionPgId k v = do - curtime <- round <$> liftIO getPOSIXTime let k' = Binary $ encode k v' = Binary $ encode v liftIO $ withPostgreSQLConn pool $ \conn -> @@ -278,10 +280,9 @@ case res of [Only id] -> void $ execute conn qryUpdateSessionEntry (v', sessionPgId, k') _ -> void $ execute conn qryCreateSessionEntry (sessionPgId, k', v') - void $ execute conn qryUpdateSession (curtime :: Int64, sessionPgId) ignoreSqlError :: SqlError -> IO () -ignoreSqlError _ = pure () +ignoreSqlError _ = return () unerror :: IO a -> IO () unerror action = void action `catch` ignoreSqlError diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Exception.Base (assert) +import Control.Monad +import Data.Default (def) +import Data.String (fromString) +import Database.PostgreSQL.Simple +import Network.Wai.Session (withSession, Session) +import Network.Wai.Session.PostgreSQL + +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + main :: IO () -main = putStrLn "Test suite not yet implemented" +main = do + conn <- dbconnect + conn' <- fromSimpleConnection conn + store <- dbStore conn' def + purger conn' def + + ((lookupSess1, insertSess1), mknewsessid) <- store Nothing + sessid <- mknewsessid + + insertSess1 ("foo" :: B.ByteString) ("bar" :: B.ByteString) + + l1 <- lookupSess1 "foo" + assert (l1 == (Just "bar")) it + + l2 <- lookupSess1 "bar" + assert (l2 == Nothing) it + + ((lookupSess2, insertSess2), mknewsessid) <- store $ Just sessid + newsessid <- mknewsessid + + l3 <- lookupSess2 "foo" + assert (l3 == (Just "bar")) it + + assert (newsessid == sessid) it + + let invalidsessid = "foobar" + ((lookupSess3, insertSess3), mknewsessid) <- store $ Just invalidsessid + newsessid2 <- mknewsessid + + assert (newsessid2 /= newsessid) it + assert (newsessid2 /= invalidsessid) it + + l3 <- lookupSess3 "foo" + assert (l3 == Nothing) it + + +it :: IO () +it = return () + +dbconnect :: IO Connection +dbconnect = do + let connectInfo = ConnectInfo { + connectHost = "localhost" + , connectPort = 5432 + , connectUser = "demo" + , connectPassword = "omed" + , connectDatabase = "demodb" } + connectPostgreSQL $ postgreSQLConnectionString connectInfo diff --git a/wai-session-postgresql.cabal b/wai-session-postgresql.cabal --- a/wai-session-postgresql.cabal +++ b/wai-session-postgresql.cabal @@ -1,5 +1,5 @@ name: wai-session-postgresql -version: 0.2.0.2 +version: 0.2.0.3 synopsis: PostgreSQL backed Wai session store description: Provides a PostgreSQL backed session store for the Network.Wai.Session interface. homepage: https://github.com/hce/postgresql-session#readme @@ -19,18 +19,18 @@ library hs-source-dirs: src exposed-modules: Network.Wai.Session.PostgreSQL - build-depends: base >= 4.7 && < 5 - , bytestring >= 0.10.6 && < 0.11 + build-depends: base >= 4.5 && < 5 + , bytestring >= 0.10.0.2 && < 0.11 , cereal >= 0.4.1 && < 0.6 , cookie >= 0.4.1 && < 0.5 - , data-default >= 0.5.3 && < 0.6 - , entropy >= 0.3.7 && < 0.4 - , postgresql-simple >= 0.4.10 && < 0.6 + , data-default >= 0.5.1 && < 0.6 + , entropy >= 0.3 && < 0.4 + , postgresql-simple >= 0.4.0 && < 0.6 , resource-pool >= 0.2.3 && < 0.3 - , text >= 1.2.1 && < 1.3 - , time >= 1.5.0 && < 1.6 - , transformers >= 0.4.2 && < 0.5 - , wai >= 3.0.3 && < 3.1 + , text >= 0.11.3.1 && < 1.3 + , time >= 1.4.0.1 && < 1.6 + , transformers >= 0.3.0 && < 0.5 + , wai >= 3.0.2.3 && < 3.1 , wai-session >= 0.3.2 && < 0.4 default-language: Haskell2010 default-extensions: OverloadedStrings @@ -40,8 +40,13 @@ hs-source-dirs: test main-is: Spec.hs build-depends: base + , bytestring >= 0.10.0.2 && < 0.11 + , data-default >= 0.5.1 && < 0.6 + , postgresql-simple >= 0.4.0 && < 0.6 + , text >= 0.11.3.1 && < 1.3 + , wai-session >= 0.3.2 && < 0.4 , wai-session-postgresql - ghc-options: -threaded -rtsopts -with-rtsopts=-N + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O0 default-language: Haskell2010 source-repository head