diff --git a/example/Main.hs b/example/Main.hs deleted file mode 100644 --- a/example/Main.hs +++ /dev/null @@ -1,55 +0,0 @@ --- 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,6 +1,7 @@ module Network.Wai.Session.PostgreSQL ( dbStore , defaultSettings + , clearSession , purgeOldSessions , purger , ratherSecureGen @@ -15,11 +16,14 @@ import Control.Monad.IO.Class import Data.Int (Int64) import Data.Serialize (encode, decode, Serialize) +import Data.String (fromString) import Data.Time.Clock.POSIX (getPOSIXTime) import Database.PostgreSQL.Simple +import Network.Wai (Request, requestHeaders) import Network.Wai.Session import Numeric (showHex) import System.Entropy (getEntropy) +import Web.Cookie (parseCookies) import qualified Data.ByteString as B import qualified Data.Text as T @@ -62,13 +66,16 @@ 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, CONSTRAINT session_pkey PRIMARY KEY (id), CONSTRAINT session_session_key_key UNIQUE (session_key)) WITH (OIDS=FALSE);" +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 a -> StoreSettings -> IO (SessionStore m k v) @@ -121,8 +128,8 @@ map' = "" -- encode map curtime <- round <$> liftIO getPOSIXTime withPostgreSQLConn pool $ \ conn -> - void $ execute conn qryCreateSession (newKey, curtime :: Int64, curtime, map' :: B.ByteString) - backend pool newKey map + void $ execute conn qryCreateSession (newKey, curtime :: Int64, curtime, Binary (map' :: B.ByteString)) + backend pool stos newKey map dbStore' pool stos (Just key) = do let map = [] :: [(k, v)] map' = "\"\"" -- encode map @@ -130,15 +137,40 @@ res <- withPostgreSQLConn pool $ \ conn -> query conn qryLookupSession (key, curtime - storeSettingsSessionTimeout stos) :: IO [Only B.ByteString] case res of - [Only _] -> backend pool key map + [Only _] -> backend pool stos key map _ -> dbStore' pool stos Nothing -backend :: (WithPostgreSQLConn a, Serialize k, Eq k, Serialize v, MonadIO m) => a -> B.ByteString -> [(k, v)] -> IO (Session m k v, IO B.ByteString) -backend pool key mappe = +-- |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* and calls +-- to sessionStore are made. It needs to be passed a request and the cookie +-- name explicitly due to the limited nature of the Network.Wai.Session +-- interface. +-- Sessions should be cleared when a login is performed, to prevent certain +-- kinds of session hijacking attacks. +clearSession :: (WithPostgreSQLConn a) => a -> B.ByteString -> Request -> IO () +clearSession pool cookieName req = do + let map = [] :: [(k, v)] + map' = "" -- encode map + cookies = fmap 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 + return ( ( (reader pool key mappe) - , (writer pool key mappe) ) - , return key ) + , (writer pool key mappe) ), withPostgreSQLConn pool $ \conn -> do + [Only shouldNewKey] <- query conn qryCheckNewKey (Only key) + if shouldNewKey then do + newKey' <- storeSettingsKeyGen stos + execute conn qryUpdateKey (newKey', key) + return newKey' + else + return key + ) + 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 diff --git a/wai-session-postgresql.cabal b/wai-session-postgresql.cabal --- a/wai-session-postgresql.cabal +++ b/wai-session-postgresql.cabal @@ -1,13 +1,13 @@ name: wai-session-postgresql -version: 0.1.0.1 +version: 0.1.0.2 synopsis: PostgreSQL backed Wai session store description: Provides a PostgreSQL backed session store for the Network.Wai.Session interface. -homepage: http://github.com/hce/postgresql-session#readme +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 -homepage: https://github.com/hce/postgresql-session copyright: 2015 Hans-Christian Esperer stability: experimental tested-with: GHC == 7.10.2 @@ -30,25 +30,6 @@ 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 - , data-default - , entropy - , http-types - , wai-session-postgresql - , postgresql-simple - , text - , vault - , wai - , wai-session - , warp - default-language: Haskell2010 - - test-suite postgresql-session-test type: exitcode-stdio-1.0 hs-source-dirs: test @@ -60,4 +41,4 @@ source-repository head type: git - location: https://github.com/githubuser/postgresql-session + location: https://github.com/hce/postgresql-session