wai-session-mysql (empty) → 0.2.1.0
raw patch · 6 files changed
+467/−0 lines, 6 filesdep +basedep +bytestringdep +cerealsetup-changed
Dependencies added: base, bytestring, cereal, cookie, data-default, entropy, mysql-simple, resource-pool, text, time, transformers, wai, wai-session, wai-session-mysql
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- changelog.md +4/−0
- src/Network/Wai/Session/MySQL.hs +306/−0
- test/Spec.hs +71/−0
- wai-session-mysql.cabal +54/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Li Meng Jun <lmjubuntu@gmail.com> (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ changelog.md view
@@ -0,0 +1,4 @@+0.1.1.0 / 2016-07-03+--------------------++Initial Commit
+ src/Network/Wai/Session/MySQL.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE FlexibleInstances #-}+-- copied from https://github.com/hce/postgresql-session/blob/master/src/Network/Wai/Session/PostgreSQL.hs and modified++-- |+-- Module: Network.Wai.Session.MySQL+-- Copyright: (C) 2016, Li Meng Jun+-- License: BSD3+-- Maintainer: Li Meng Jun <lmjubuntu@gmail.com>+-- Stability: experimental+-- Portability: portable+--+-- Simple MySQL backed wai-session backend. This module allows you to store+-- session data of wai-sessions in a MySQL 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 mysql 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.MySQL+ ( dbStore+ , clearSession+ , defaultSettings+ , fromSimpleConnection+ , purgeOldSessions+ , purger+ , ratherSecureGen+ , SimpleConnection+ , StoreSettings (..)+ , WithMySQLConn (..)+ ) where++import Control.Applicative ((<$>))+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)+import Database.MySQL.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+import qualified Data.Text.Encoding as TE++-- |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+ }++instance Default StoreSettings where+ def = defaultSettings++-- |By default, you pass a mysql 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 MySQL connection.+class WithMySQLConn a where+ -- |Call the function (Connection -> IO b) with a valid and open+ -- MySQL connection.+ withMySQLConn :: a -> (Connection -> IO b) -> IO b+++-- |Prepare a simple mysql connection for use by the mysql+-- 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 WithMySQLConn type class.+fromSimpleConnection :: Connection -> IO SimpleConnection+fromSimpleConnection connection = do+ mvar <- newMVar ()+ return $ SimpleConnection (mvar, connection)++-- |A simple MySQL connection stored together with a mutex that+-- prevents from running more than one mysql transaction at+-- the same time. It is recommended to use a connection pool+-- instead for larger sites.+newtype SimpleConnection = SimpleConnection (MVar (), Connection)++instance WithMySQLConn SimpleConnection where+ withMySQLConn (SimpleConnection (mvar, conn)) =+ bracket (takeMVar mvar >> return conn) (\_ -> putMVar mvar ())++instance WithMySQLConn (Pool Connection) where+ withMySQLConn = withResource++qryCreateTable1 :: Query+qryCreateTable1 = fromString $ unlines [+ "CREATE TABLE IF NOT EXISTS `wai_sessions` (",+ " `id` int(10) unsigned NOT NULL AUTO_INCREMENT,",+ " `session_key` varchar(128) NOT NULL,",+ " `session_created_at` bigint NOT NULL,",+ " `session_last_access` bigint NOT NULL,",+ " `session_invalidate_key` boolean NOT NULL DEFAULT false,",+ " PRIMARY KEY (`id`),",+ " UNIQUE KEY `wai_sessions_session_key` (`session_key`)",+ ") ENGINE=InnoDB DEFAULT CHARSET=utf8"]++qryCreateTable2 :: Query+qryCreateTable2 = fromString $ unlines [+ "CREATE TABLE IF NOT EXISTS `wai_session_data` (",+ " `id` int(10) unsigned NOT NULL AUTO_INCREMENT,",+ " `wai_session` bigint,",+ " `key` varchar(128),",+ " `value` varchar(1500),",+ " PRIMARY KEY (`id`),",+ " UNIQUE KEY `wai_session_data_wai_session_key_key` (`wai_session`, `key`)",+ ") ENGINE=InnoDB DEFAULT CHARSET=utf8"]++qryCreateSession :: Query+qryCreateSession = "INSERT INTO `wai_sessions` (`session_key`, `session_created_at`, `session_last_access`) VALUES (?,?,?)"++qryCreateSessionEntry :: Query+qryCreateSessionEntry = "INSERT INTO `wai_session_data` (`wai_session`,`key`,`value`) VALUES (?,?,?)"++qryUpdateSession :: Query+qryUpdateSession = "UPDATE `wai_sessions` SET `session_last_access`=? WHERE `id`=?"++qryUpdateSessionEntry :: Query+qryUpdateSessionEntry = "UPDATE `wai_session_data` SET `value`=? WHERE `wai_session`=? AND `key`=?"++qryLookupSession :: Query+qryLookupSession = "SELECT `id` FROM `wai_sessions` WHERE `session_key`=? AND `session_last_access`>=?"++qryLookupSession' :: Query+qryLookupSession' = "UPDATE `wai_sessions` SET `session_last_access`=? WHERE `id`=?"++qryLookupSession'' :: Query+qryLookupSession'' = "SELECT `value` FROM `wai_session_data` WHERE `wai_session`=? AND `key`=?"++qryLookupSession''' :: Query+qryLookupSession''' = "SELECT `id` FROM `wai_session_data` WHERE `wai_session`=? AND `key`=?"++qryPurgeOldSessions :: Query+qryPurgeOldSessions = "DELETE FROM `wai_sessions` WHERE `session_last_access`<?"++qryCheckNewKey :: Query+qryCheckNewKey = "SELECT `session_invalidate_key` FROM `wai_sessions` WHERE `session_key`=?"++qryInvalidateSess1 :: Query+qryInvalidateSess1 = "UPDATE `wai_sessions` SET `session_invalidate_key`=TRUE WHERE `session_key`=?"++qryInvalidateSess2 :: Query+qryInvalidateSess2 = "DELETE FROM `wai_session_data` WHERE `wai_session`=(SELECT `id` FROM `wai_sessions` WHERE `session_key`=?)"++qryUpdateKey :: Query+qryUpdateKey = "UPDATE `wai_sessions` SET `session_key`=?,`session_invalidate_key`=FALSE WHERE `session_key`=?"++-- |Create a new mysql backed wai session store.+dbStore :: (WithMySQLConn a, Serialize k, Eq k, Serialize v, MonadIO m) => a -> StoreSettings -> IO (SessionStore m k v)+dbStore pool stos = do+ when (storeSettingsCreateTable stos) $+ withMySQLConn pool $ \ conn ->+ unerror $ do+ void $ execute_ conn qryCreateTable1+ void $ execute_ conn qryCreateTable2+ storeSettingsLog stos "Created tables."+ return $ dbStore' pool stos++-- |Delete expired sessions from the database.+purgeOldSessions :: WithMySQLConn a => a -> StoreSettings -> IO Int64+purgeOldSessions pool stos = do+ curtime <- round <$> liftIO getPOSIXTime+ count <- withMySQLConn 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 :: WithMySQLConn 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' :: (WithMySQLConn a, Serialize k, Eq k, Serialize v, MonadIO m) => a -> StoreSettings -> SessionStore m k v+dbStore' pool stos Nothing = do+ newKey <- storeSettingsKeyGen stos+ curtime <- liftIO getPOSIXTime+ sessionId <- withMySQLConn pool $ \ conn -> do+ execute conn qryCreateSession (newKey, round curtime :: Int64, round curtime :: Int64)+ fromIntegral <$> insertID conn+ backend pool stos newKey sessionId+dbStore' pool stos (Just key) = do+ curtime <- round <$> liftIO getPOSIXTime+ res <- withMySQLConn pool $ \ conn ->+ query conn qryLookupSession (key, curtime - storeSettingsSessionTimeout stos) :: IO [Only Int64]+ case res of+ [Only sessionId] -> backend pool stos key sessionId+ _ -> 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+-- 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 :: (WithMySQLConn a) => a -> B.ByteString -> Request -> IO ()+clearSession pool cookieName req = do+ let map = [] :: [(k, v)]+ map' = "" -- encode map+ cookies = parseCookies <$> lookup (fromString "Cookie") (requestHeaders req)+ Just key = lookup cookieName =<< cookies+ withMySQLConn pool $ \ conn ->+ withTransaction conn $ do+ void $ execute conn qryInvalidateSess1 (Only key)+ void $ execute conn qryInvalidateSess2 (Only key)++backend :: (WithMySQLConn 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 sessionId =+ return ( (+ reader pool key sessionId+ , writer pool key sessionId ), withMySQLConn pool $ \conn -> do+ -- Update session access time+ curtime <- liftIO getPOSIXTime+ void $ execute conn qryLookupSession' (round curtime :: Int64, sessionId)++ [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 :: (WithMySQLConn a, Serialize k, Eq k, Serialize v, MonadIO m) => a -> B.ByteString -> Int64 -> k -> m (Maybe v)+reader pool key sessionId k = do+ res <- liftIO $ withMySQLConn pool $ \conn ->+ query conn qryLookupSession'' (sessionId, encode k)+ case res of+ [Only value] -> case decode value of+ Right value' -> return $ Just value'+ Left error -> return Nothing+ [] -> return Nothing++writer :: (WithMySQLConn a, Serialize k, Eq k, Serialize v, MonadIO m) => a -> B.ByteString -> Int64 -> k -> v -> m ()+writer pool key sessionId k v = do+ let k' = encode k+ v' = encode v+ liftIO $ withMySQLConn pool $ \conn ->+ withTransaction conn $ do+ res <- query conn qryLookupSession''' (sessionId, k') :: IO [Only Int64]+ case res of+ [Only id] -> void $ execute conn qryUpdateSessionEntry (v', sessionId, k')+ _ -> void $ execute conn qryCreateSessionEntry (sessionId, k', v')++ignoreSqlError :: ResultError -> IO ()+ignoreSqlError _ = return ()++unerror :: IO a -> IO ()+unerror action = void action `catch` ignoreSqlError
+ test/Spec.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++import Control.Concurrent (threadDelay)+import Control.Exception.Base (assert)+import Control.Monad+import Data.Default (def)+import Data.String (fromString)+import Data.Maybe (isNothing)+import Database.MySQL.Simple+import Network.Wai.Session (withSession, Session)+import Network.Wai.Session.MySQL++import qualified Data.ByteString as B+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE++main :: IO ()+main = do+ conn <- dbconnect+ conn' <- fromSimpleConnection conn+ store <- dbStore conn' testSettings+ purger conn' testSettings++ ((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 (isNothing l2) 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++ l4 <- lookupSess3 "foo"+ assert (isNothing l4) it++ ((lookupSess4, insertSess4), mknewsessid) <- store $ Just sessid+ l5 <- lookupSess4 "foo"+ assert (l5 == Just "bar") it++ threadDelay 6000000++ ((lookupSess5, insertSess5), mknewsessid) <- store $ Just sessid+ l6 <- lookupSess5 "foo"+ assert (isNothing l6) it++it :: IO ()+it = return ()++dbconnect :: IO Connection+dbconnect = connect defaultConnectInfo { connectDatabase = "test" }++testSettings :: StoreSettings+testSettings = def { storeSettingsSessionTimeout=5 }
+ wai-session-mysql.cabal view
@@ -0,0 +1,54 @@+name: wai-session-mysql+version: 0.2.1.0+synopsis: MySQL backed Wai session store+description: Provides a MySQL backed session store for the Network.Wai.Session interface.+homepage: https://github.com/Lupino/mysql-session#readme+bug-reports: https://github.com/Lupino/mysql-session/issues+license: BSD3+license-file: LICENSE+author: Li Meng Jun <lmjubuntu@gmail.com>+maintainer: Li Meng Jun <lmjubuntu@gmail.com>+copyright: 2016 Li Meng Jun+stability: experimental+tested-with: GHC == 8.1+category: Web+build-type: Simple+cabal-version: >=1.10+extra-source-files: changelog.md++library+ hs-source-dirs: src+ exposed-modules: Network.Wai.Session.MySQL+ 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.1 && < 0.8+ , entropy >= 0.3 && < 0.4+ , mysql-simple+ , resource-pool >= 0.2.3 && < 0.3+ , text >= 0.11.3.1 && < 1.3+ , time >= 1.4.0.1 && < 1.7+ , transformers >= 0.3.0 && < 0.6+ , wai >= 3.0.2.3 && < 3.3+ , wai-session >= 0.3.2 && < 0.4+ default-language: Haskell2010+ default-extensions: OverloadedStrings++test-suite mysql-session-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , bytestring >= 0.10.0.2 && < 0.11+ , data-default >= 0.5.1 && < 0.8+ , mysql-simple+ , text >= 0.11.3.1 && < 1.3+ , wai-session >= 0.3.2 && < 0.4+ , wai-session-mysql+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -O0+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/Lupino/mysql-session