{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Rank2Types #-}
module Snap.Snaplet.RedisDB
(RedisDB(..)
, runRedisDB
, redisConnection
, redisDBInit
, redisDBInitConf)
where
import Control.Lens
import Control.Monad.State
import Database.Redis hiding (String)
import Data.Configurator as C
import Data.Configurator.Types (Configured(..), Value(..))
import Data.Maybe
import Data.Ratio (numerator, denominator)
import qualified Data.Text as T
import Snap.Snaplet
newtype RedisDB = RedisDB
{ _connection :: Connection
}
makeLenses ''RedisDB
newtype ConfiguredPortID = ConfiguredPortID { unConfiguredPortID :: PortID }
instance Configured ConfiguredPortID where
convert (Number r) | denominator r == 1 = Just $ ConfiguredPortID $ PortNumber $ fromInteger $ numerator r
convert (String s) = Just $ ConfiguredPortID $ UnixSocket $ T.unpack s
convert _ = Nothing
redisConnection :: Simple Lens RedisDB Connection
redisConnection = connection
runRedisDB :: (MonadIO m, MonadState app m) =>
Simple Lens app (Snaplet RedisDB) -> Redis a -> m a
runRedisDB snaplet action = do
c <- gets $ view (snaplet . snapletValue . connection)
liftIO $ runRedis c action
redisDBInitConf :: SnapletInit b RedisDB
redisDBInitConf = makeSnaplet "redis" "Redis snaplet." Nothing $ do
config <- getSnapletUserConfig
connInfo <- liftIO $ do
cHost <- C.lookup config "host"
cPort <- C.lookup config "port"
cAuth <- C.lookup config "auth"
cCons <- C.lookup config "max_connections"
cIdle <- C.lookup config "max_idle_time"
let def = defaultConnectInfo
return $ def { connectHost = fromMaybe (connectHost def) cHost
, connectPort = maybe (connectPort def)
unConfiguredPortID cPort
, connectAuth = cAuth
, connectMaxConnections =
fromMaybe (connectMaxConnections def) cCons
, connectMaxIdleTime =
maybe (connectMaxIdleTime def) fromRational cIdle
}
conn <- liftIO $ connect connInfo
return $ RedisDB conn
redisDBInit :: ConnectInfo
-> SnapletInit b RedisDB
redisDBInit connInfo =
makeSnaplet "snaplet-redis" "Redis snaplet." Nothing $ do
conn <- liftIO $ connect connInfo
return $ RedisDB conn