wai-session-postgresql 0.1.1.1 → 0.2.0.1

raw patch · 3 files changed

+141/−52 lines, 3 filesdep +resource-poolPVP ok

version bump matches the API change (PVP)

Dependencies added: resource-pool

API changes (from Hackage documentation)

Files

• changelog.md +10/−0
• src/Network/Wai/Session/PostgreSQL.hs +127/−49
• wai-session-postgresql.cabal +4/−3

@@ -1,3 +1,13 @@+0.2.0.1 / 2016-01-03+--------------------++- Add an instance declaration for Data.Pool connection pools, so they can be used directly with wai-postgresql-session++0.2.0.0 / 2016-01-02+--------------------++- Use two PostgreSQL tables, store each session id/key pair in its own db row+ 0.1.1.1 / 2016-01-01 -------------------- 

@@ -1,21 +1,43 @@+{-# LANGUAGE FlexibleInstances #-}++-- |+-- Module: Network.Wai.Session.PostgreSQL+-- Copyright: (C) 2015, Hans-Christian Esperer+-- License: BSD3+-- Maintainer: Hans-Christian Esperer <hc@hcesperer.org>+-- Stability: experimental+-- Portability: portable+--+-- Simple PostgreSQL backed wai-session backend. This module allows you to store+-- session data of wai-sessions in a PostgreSQL database. Two tables are kept, one+-- to store the session's metadata and one to store key,value pairs for each session.+-- All keys and values are stored as bytea values in the postgresql database using+-- haskell's cereal module to serialize and deserialize them.+--+-- Please note that the module does not let you configure the names of the database+-- tables. It is recommended to use this module with its own database schema. module Network.Wai.Session.PostgreSQL     ( dbStore-    , defaultSettings     , clearSession+    , defaultSettings+    , fromSimpleConnection     , purgeOldSessions     , purger     , ratherSecureGen-    , WithPostgreSQLConn (..)+    , SimpleConnection     , StoreSettings (..)+    , WithPostgreSQLConn (..)     ) where  import Control.Concurrent+import Control.Concurrent.MVar import Control.Exception.Base import Control.Exception import Control.Monad import Control.Monad.IO.Class import Data.Default import Data.Int (Int64)+import Data.Pool (Pool, withResource) import Data.Serialize (encode, decode, Serialize) import Data.String (fromString) import Data.Time.Clock.POSIX (getPOSIXTime)@@ -67,26 +89,85 @@     -- PostgreSQL connection.     withPostgreSQLConn :: a -> (Connection -> IO b) -> IO b -instance WithPostgreSQLConn Connection where-    withPostgreSQLConn conn = bracket (return conn) (\_ -> return ()) -qryCreateTable      = "CREATE TABLE session (id bigserial NOT NULL, session_key character varying NOT NULL, session_created_at bigint NOT NULL, session_last_access bigint NOT NULL, session_value bytea NOT NULL, session_invalidate_key bool NOT NULL DEFAULT FALSE, CONSTRAINT session_pkey PRIMARY KEY (id), CONSTRAINT session_session_key_key UNIQUE (session_key)) WITH (OIDS=FALSE);"-qryCreateSession    = "INSERT INTO session (session_key, session_created_at, session_last_access, session_value) VALUES (?,?,?,?)"-qryUpdateSession    = "UPDATE session SET session_value=?,session_last_access=? WHERE session_key=?"-qryLookupSession    = "SELECT session_value FROM session WHERE session_key=? AND session_last_access>=?"-qryLookupSession'   = "UPDATE session SET session_last_access=? WHERE session_key=?"-qryLookupSession''  = "SELECT session_value FROM session WHERE session_key=?"-qryPurgeOldSessions = "DELETE FROM session WHERE session_last_access<?"-qryCheckNewKey      = "SELECT session_invalidate_key FROM session WHERE session_key=?"-qryInvalidateSess   = "UPDATE session SET session_value=?,session_invalidate_key=TRUE WHERE session_key=?"-qryUpdateKey        = "UPDATE session SET session_key=?,session_invalidate_key=FALSE WHERE session_key=?"+-- |Prepare a simple postgresql connection for use by the postgresql+-- session store. This basically wraps the connection along with a mutex+-- to ensure transactions work correctly. Connections used this way must+-- not be used anywhere else for the duration of the session store!+-- It is recommended to use a connection pool instead. To use a connection+-- pool, you simply need to implement the WithPostgreSQLConn type class.+fromSimpleConnection :: Connection -> IO SimpleConnection+fromSimpleConnection connection = do+    mvar <- newMVar ()+    return $ SimpleConnection (mvar, connection) +-- |A simple PostgreSQL connection stored together with a mutex that+-- prevents from running more than one postgresql transaction at+-- the same time. It is recommended to use a connection pool+-- instead for larger sites.+newtype SimpleConnection = SimpleConnection (MVar (), Connection)++instance WithPostgreSQLConn SimpleConnection where+    withPostgreSQLConn (SimpleConnection (mvar, conn)) =+        bracket (takeMVar mvar >> return conn) (\_ -> putMVar mvar ())++instance WithPostgreSQLConn (Pool Connection) where+    withPostgreSQLConn = withResource++qryCreateTable1 :: Query+qryCreateTable1         = "CREATE TABLE wai_pg_sessions (id bigserial NOT NULL, session_key character varying NOT NULL, session_created_at bigint NOT NULL, session_last_access bigint NOT NULL, session_invalidate_key boolean NOT NULL DEFAULT false, CONSTRAINT session_pkey PRIMARY KEY (id), CONSTRAINT session_session_key_key UNIQUE (session_key)) WITH ( OIDS=FALSE );"++qryCreateTable2 :: Query+qryCreateTable2         = "CREATE TABLE wai_pg_session_data ( id bigserial NOT NULL, wai_pg_session bigint, key bytea, value bytea, CONSTRAINT wai_pg_session_data_pkey PRIMARY KEY (id), CONSTRAINT wai_pg_session_data_wai_pg_session_fkey FOREIGN KEY (wai_pg_session) REFERENCES wai_pg_sessions (id) MATCH SIMPLE ON UPDATE RESTRICT ON DELETE CASCADE, CONSTRAINT wai_pg_session_data_wai_pg_session_key_key UNIQUE (wai_pg_session, key) ) WITH (OIDS=FALSE);"++qryCreateSession :: Query+qryCreateSession        = "INSERT INTO wai_pg_sessions (session_key, session_created_at, session_last_access) VALUES (?,?,?) RETURNING id"++qryCreateSessionEntry :: Query+qryCreateSessionEntry   = "INSERT INTO wai_pg_session_data (wai_pg_session,key,value) VALUES (?,?,?)"++qryUpdateSession :: Query+qryUpdateSession        = "UPDATE wai_pg_sessions SET session_last_access=? WHERE id=?"++qryUpdateSessionEntry :: Query+qryUpdateSessionEntry   = "UPDATE wai_pg_session_data SET value=? WHERE wai_pg_session=? AND key=?"++qryLookupSession :: Query+qryLookupSession        = "SELECT id FROM wai_pg_sessions WHERE session_key=? AND session_last_access>=?"++qryLookupSession' :: Query+qryLookupSession'       = "UPDATE wai_pg_sessions SET session_last_access=? WHERE id=?"++qryLookupSession'' :: Query+qryLookupSession''      = "SELECT value FROM wai_pg_session_data WHERE wai_pg_session=? AND key=?"++qryLookupSession''' :: Query+qryLookupSession'''     = "SELECT id FROM wai_pg_session_data WHERE wai_pg_session=? AND key=?"++qryPurgeOldSessions :: Query+qryPurgeOldSessions     = "DELETE FROM wai_pg_sessions WHERE session_last_access<?"++qryCheckNewKey :: Query+qryCheckNewKey          = "SELECT session_invalidate_key FROM wai_pg_sessions WHERE session_key=?"++qryInvalidateSess1 :: Query+qryInvalidateSess1      = "UPDATE wai_pg_sessions SET session_invalidate_key=TRUE WHERE session_key=?"++qryInvalidateSess2 :: Query+qryInvalidateSess2      = "DELETE FROM wai_pg_session_data WHERE wai_pg_session=(SELECT id FROM wai_pg_sessions WHERE session_key=?)"++qryUpdateKey :: Query+qryUpdateKey            = "UPDATE wai_pg_sessions SET session_key=?,session_invalidate_key=FALSE WHERE session_key=?"+ -- |Create a new postgresql backed wai session store. dbStore :: (WithPostgreSQLConn a, Serialize k, Eq k, Serialize v, MonadIO m) => a -> StoreSettings -> IO (SessionStore m k v) dbStore pool stos = do     when (storeSettingsCreateTable stos) $         withPostgreSQLConn pool $ \ conn ->-            unerror $ execute_ conn qryCreateTable+            unerror $ do+                void $ execute_ conn qryCreateTable1+                void $ execute_ conn qryCreateTable2+                storeSettingsLog stos "Created tables."     return $ dbStore' pool stos  -- |Delete expired sessions from the database.@@ -128,21 +209,18 @@ dbStore' :: (WithPostgreSQLConn a, Serialize k, Eq k, Serialize v, MonadIO m) => a -> StoreSettings -> SessionStore m k v dbStore' pool stos Nothing = do     newKey <- storeSettingsKeyGen stos-    let map     = [] :: [(k, v)]-        map'    = "" -- encode map     curtime <- round <$> liftIO getPOSIXTime-    withPostgreSQLConn pool $ \ conn ->-        void $ execute conn qryCreateSession (newKey, curtime :: Int64, curtime, Binary (map' :: B.ByteString))-    backend pool stos newKey map+    sessionPgId <- withPostgreSQLConn pool $ \ conn -> do+        [Only res] <- query conn qryCreateSession (newKey, curtime :: Int64, curtime) :: IO [Only Int64]+        return (res :: Int64)+    backend pool stos newKey sessionPgId dbStore' pool stos (Just key) = do-    let map     = [] :: [(k, v)]-        map'    = "\"\"" -- encode map     curtime <- round <$> liftIO getPOSIXTime     res <- withPostgreSQLConn pool $ \ conn ->-        query conn qryLookupSession (key, curtime - storeSettingsSessionTimeout stos) :: IO [Only B.ByteString]+        query conn qryLookupSession (key, curtime - storeSettingsSessionTimeout stos) :: IO [Only Int64]     case res of-        [Only _]    -> backend pool stos key map-        _           -> dbStore' pool stos Nothing+        [Only sessionPgId]  -> backend pool stos key sessionPgId+        _                   -> dbStore' pool stos Nothing  -- |This function can be called to invalidate a session and enforce creating -- a new one with a new session ID. It should be called *before* any calls@@ -155,17 +233,18 @@ clearSession pool cookieName req = do     let map         = [] :: [(k, v)]         map'        = "" -- encode map-        cookies     = fmap parseCookies $ lookup (fromString "Cookie") (requestHeaders req)+        cookies     = parseCookies <$> lookup (fromString "Cookie") (requestHeaders req)         Just key    = lookup cookieName =<< cookies     withPostgreSQLConn pool $ \ conn ->-        void $ execute conn qryInvalidateSess (Binary (map' :: B.ByteString), key)--backend :: (WithPostgreSQLConn a, Serialize k, Eq k, Serialize v, MonadIO m) => a -> StoreSettings -> B.ByteString -> [(k, v)] -> IO (Session m k v, IO B.ByteString)-backend pool stos key mappe = do+        withTransaction conn $ do+            void $ execute conn qryInvalidateSess1 (Only key)+            void $ execute conn qryInvalidateSess2 (Only key) +backend :: (WithPostgreSQLConn a, Serialize k, Eq k, Serialize v, MonadIO m) => a -> StoreSettings -> B.ByteString -> Int64 -> IO (Session m k v, IO B.ByteString)+backend pool stos key sessionPgId =     return ( (-        (reader pool key mappe)-      , (writer pool key mappe) ), withPostgreSQLConn pool $ \conn -> do+        reader pool key sessionPgId+      , writer pool key sessionPgId ), withPostgreSQLConn pool $ \conn -> do         [Only shouldNewKey] <- query conn qryCheckNewKey (Only key)         if shouldNewKey then do             newKey' <- storeSettingsKeyGen stos@@ -176,31 +255,30 @@       )  -reader :: (WithPostgreSQLConn a, Serialize k, Eq k, Serialize v, MonadIO m) => a -> B.ByteString -> [(k, v)] -> k -> m (Maybe v)-reader pool key mappe k = do+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, key)-        query conn qryLookupSession'' (Only key)+        void $ execute conn qryLookupSession' (curtime :: Int64, sessionPgId)+        query conn qryLookupSession'' (sessionPgId, Binary $ encode k)     case res of-        [Only store']    -> case decode (fromBinary store') of-            Right store     -> return $ k `lookup` store+        [Only value]    -> case decode (fromBinary value) of+            Right value'    -> return $ Just value'             Left error      -> return Nothing         []              -> return Nothing -writer :: (WithPostgreSQLConn a, Serialize k, Eq k, Serialize v, MonadIO m) => a -> B.ByteString -> [(k, v)] -> k -> v -> m ()-writer pool key mappe k v = do+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-    [Only store] <- liftIO $ withPostgreSQLConn pool $ \conn ->-        query conn qryLookupSession'' (Only key)-    let store'      = case decode (fromBinary store) of-            Right s             -> s-            _                   -> []-        store''     = ((k,v):) . filter ((/=k) . fst) $ store'-        store'''    = encode store''+    let k' = Binary $ encode k+        v' = Binary $ encode v     liftIO $ withPostgreSQLConn pool $ \conn ->-        void $ execute conn qryUpdateSession (Binary store''', curtime :: Int64, key)-+        withTransaction conn $ do+            res <- query conn qryLookupSession''' (sessionPgId, k') :: IO [Only Int64]+            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 ()

@@ -1,13 +1,13 @@ name:                wai-session-postgresql-version:             0.1.1.1+version:             0.2.0.1 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 bug-reports:         https://github.com/hce/postgresql-session/issues license:             BSD3 license-file:        LICENSE-author:              Hans-Christian Esperer hc@hcesperer.org-maintainer:          Hans-Christian Esperer hc@hcesperer.org+author:              Hans-Christian Esperer <hc@hcesperer.org>+maintainer:          Hans-Christian Esperer <hc@hcesperer.org> copyright:           2015 Hans-Christian Esperer stability:           experimental tested-with:         GHC == 7.10.2@@ -26,6 +26,7 @@                      , data-default >= 0.5.3 && < 0.6                      , entropy >= 0.3.7 && < 0.4                      , postgresql-simple >= 0.4.10 && < 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