diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,55 @@ +-- copied from https://github.com/singpolyma/wai-session/blob/master/example/Main.hs and modified +module Main where + +import Data.Default (def) +import Data.String (fromString) +import Database.PostgreSQL.Simple +import Numeric (showHex) +import Network.Wai +import Network.Wai.Session (withSession, Session) +import Network.Wai.Session.PostgreSQL +import Network.Wai.Handler.Warp (run) +import Network.HTTP.Types (ok200) +import System.Entropy (getEntropy) + +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vault.Lazy as Vault + +app :: Vault.Key (Session IO String String) -> Application +app session env = (>>=) $ do + u <- sessionLookup "u" + sessionInsert "u" insertThis + return $ responseLBS ok200 [] $ maybe (fromString "Nothing") fromString u + where + insertThis = show $ pathInfo env + Just (sessionLookup, sessionInsert) = Vault.lookup session (vault env) + +main :: IO () +main = do + conn <- dbconnect + session <- Vault.newKey + store <- dbStore conn settings + purger conn settings + run 3000 $ withSession store (fromString "SESSION") def session $ app session + +settings :: StoreSettings +settings = defaultSettings + +genSessionKey :: IO B.ByteString +genSessionKey = + TE.encodeUtf8 . prettyPrint <$> getEntropy 24 + +dbconnect :: IO Connection +dbconnect = do + let connectInfo = ConnectInfo { + connectHost = "localhost" + , connectPort = 5432 + , connectUser = "demo" + , connectPassword = "omed" + , connectDatabase = "demodb" } + connectPostgreSQL $ postgreSQLConnectionString connectInfo + +prettyPrint :: B.ByteString -> T.Text +prettyPrint = T.pack . concat . map (flip showHex "") . B.unpack 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 @@ -1,9 +1,14 @@ module Network.Wai.Session.PostgreSQL ( dbStore + , defaultSettings + , purgeOldSessions + , purger + , ratherSecureGen , WithPostgreSQLConn (..) , StoreSettings (..) ) where +import Control.Concurrent import Control.Exception.Base import Control.Exception import Control.Monad @@ -13,15 +18,45 @@ import Data.Time.Clock.POSIX (getPOSIXTime) import Database.PostgreSQL.Simple import Network.Wai.Session +import Numeric (showHex) +import System.Entropy (getEntropy) import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE -data StoreSettings = StoreSettings - { storeSettingsSessionTimeout :: Int64 +-- |These settings control how the session store is behaving +data StoreSettings = StoreSettings { + -- |The number of seconds a session is valid + -- Seconds are counted since the session is last accessed (read or written), + -- not since it was created. + storeSettingsSessionTimeout :: Int64 + -- |A random session key generator. The session ID should provide + -- sufficient entropy, and must not be predictable. It is recommended + -- to use a cryptographically secure random number generator. , storeSettingsKeyGen :: IO B.ByteString + -- |Whether to create the database table if it does not exist upon + -- creating the session store. If set to false, the database table + -- must exist or be created by some other means. + , storeSettingsCreateTable :: Bool + -- |A function that is called by to log events such as session + -- purges or the table creation. + , storeSettingsLog :: String -> IO () + -- |The number of microseconds to sleep between two runs of the + -- old session purge worker. + , storeSettingsPurgeInterval :: Int } +-- |By default, you pass a postgresql connection to the session store +-- when creating it. The passed connection will have to stay open +-- for the (possibly very long) existence of the session and it should +-- not be used for any other purpose during that time. +-- You can implement an instance of this class for a connection pool +-- instead, so that the session manager will not require a permanent +-- open PostgreSQL connection. class WithPostgreSQLConn a where + -- |Call the function (Connection -> IO b) with a valid and open + -- PostgreSQL connection. withPostgreSQLConn :: a -> (Connection -> IO b) -> IO b instance WithPostgreSQLConn Connection where @@ -33,12 +68,51 @@ 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 a -> StoreSettings -> IO (SessionStore m k v) dbStore pool stos = do - withPostgreSQLConn pool $ \ conn -> - unerror $ execute_ conn qryCreateTable + when (storeSettingsCreateTable stos) $ + withPostgreSQLConn pool $ \ conn -> + unerror $ execute_ conn qryCreateTable return $ dbStore' pool stos + +-- |Delete expired sessions from the database. +purgeOldSessions :: WithPostgreSQLConn a => a -> StoreSettings -> IO Int64 +purgeOldSessions pool stos = do + curtime <- round <$> liftIO getPOSIXTime + count <- withPostgreSQLConn pool $ \ conn -> + execute conn qryPurgeOldSessions (Only (curtime - storeSettingsSessionTimeout stos)) + storeSettingsLog stos $ "Purged " ++ show count ++ " session(s)." + return count + +-- |Run a thread using forkIO that runs periodically to +-- purge old sessions. +purger :: WithPostgreSQLConn a => a -> StoreSettings -> IO ThreadId +purger pool stos = forkIO . forever . unerror $ do + purgeOldSessions pool stos + threadDelay $ storeSettingsPurgeInterval stos + +-- |Create default settings using a session timeout of +-- one hour, a cryptographically secure session id generator +-- using 24 bytes of entropy and putStrLn to log events +-- to stdout. +defaultSettings :: StoreSettings +defaultSettings = StoreSettings + { storeSettingsSessionTimeout=3600 + , storeSettingsKeyGen=ratherSecureGen 24 + , storeSettingsCreateTable=True + , storeSettingsLog=putStrLn + , storeSettingsPurgeInterval=600000000 + } + +-- |Generate a session ID with n bytes of entropy +ratherSecureGen :: Int -> IO B.ByteString +ratherSecureGen n = TE.encodeUtf8 . prettyPrint <$> getEntropy n + +prettyPrint :: B.ByteString -> T.Text +prettyPrint = T.pack . concatMap (`showHex` "") . B.unpack dbStore' :: (WithPostgreSQLConn a, Serialize k, Eq k, Serialize v, MonadIO m) => a -> StoreSettings -> SessionStore m k v dbStore' pool stos Nothing = do diff --git a/wai-session-postgresql.cabal b/wai-session-postgresql.cabal --- a/wai-session-postgresql.cabal +++ b/wai-session-postgresql.cabal @@ -1,8 +1,8 @@ name: wai-session-postgresql -version: 0.1.0.0 +version: 0.1.0.1 synopsis: PostgreSQL backed Wai session store -description: Please see README.md -homepage: http://github.com/githubuser/postgresql-session#readme +description: Provides a PostgreSQL backed session store for the Network.Wai.Session interface. +homepage: http://github.com/hce/postgresql-session#readme license: BSD3 license-file: LICENSE author: Hans-Christian Esperer hc@hcesperer.org @@ -19,14 +19,35 @@ hs-source-dirs: src exposed-modules: Network.Wai.Session.PostgreSQL build-depends: base >= 4.7 && < 5 + , bytestring >= 0.10.6 && < 0.11 + , cereal >= 0.4.1 && < 0.5 + , entropy >= 0.3.7 && < 0.4 + , postgresql-simple >= 0.4.10 && < 0.5 + , text >= 1.2.1 && < 1.3 + , time >= 1.5.0 && < 1.6 + , transformers >= 0.4.2 && < 0.5 + , wai-session >= 0.3.2 && < 0.4 + default-language: Haskell2010 + default-extensions: OverloadedStrings + +executable postgresql-session-exe + hs-source-dirs: example + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base , bytestring - , cereal + , data-default + , entropy + , http-types + , wai-session-postgresql , postgresql-simple - , time - , transformers + , text + , vault + , wai , wai-session + , warp default-language: Haskell2010 - default-extensions: OverloadedStrings + test-suite postgresql-session-test type: exitcode-stdio-1.0