{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Database.Persist.Redis.Config
( RedisAuth (..)
, RedisConf (..)
, R.RedisCtx
, R.Redis
, R.Connection
, R.PortID (..)
, RedisT
, runRedisPool
, withRedisConn
, thisConnection
, module Database.Persist
) where
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Reader(ReaderT(..))
import Control.Monad.Reader.Class
import Data.Aeson (Value (Object, Number, String), (.:?), (.!=), FromJSON(..))
import qualified Data.ByteString.Char8 as B
import Control.Monad (mzero, MonadPlus(..))
import Data.Scientific()
import Data.Text (Text, unpack, pack)
import qualified Database.Redis as R
import Database.Persist
newtype RedisAuth = RedisAuth Text deriving (RedisAuth -> RedisAuth -> Bool
(RedisAuth -> RedisAuth -> Bool)
-> (RedisAuth -> RedisAuth -> Bool) -> Eq RedisAuth
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RedisAuth -> RedisAuth -> Bool
$c/= :: RedisAuth -> RedisAuth -> Bool
== :: RedisAuth -> RedisAuth -> Bool
$c== :: RedisAuth -> RedisAuth -> Bool
Eq, Int -> RedisAuth -> ShowS
[RedisAuth] -> ShowS
RedisAuth -> String
(Int -> RedisAuth -> ShowS)
-> (RedisAuth -> String)
-> ([RedisAuth] -> ShowS)
-> Show RedisAuth
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RedisAuth] -> ShowS
$cshowList :: [RedisAuth] -> ShowS
show :: RedisAuth -> String
$cshow :: RedisAuth -> String
showsPrec :: Int -> RedisAuth -> ShowS
$cshowsPrec :: Int -> RedisAuth -> ShowS
Show)
data RedisConf = RedisConf {
RedisConf -> Text
rdHost :: Text,
RedisConf -> PortID
rdPort :: R.PortID,
RedisConf -> Maybe RedisAuth
rdAuth :: Maybe RedisAuth,
RedisConf -> Int
rdMaxConn :: Int
} deriving (Int -> RedisConf -> ShowS
[RedisConf] -> ShowS
RedisConf -> String
(Int -> RedisConf -> ShowS)
-> (RedisConf -> String)
-> ([RedisConf] -> ShowS)
-> Show RedisConf
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RedisConf] -> ShowS
$cshowList :: [RedisConf] -> ShowS
show :: RedisConf -> String
$cshow :: RedisConf -> String
showsPrec :: Int -> RedisConf -> ShowS
$cshowsPrec :: Int -> RedisConf -> ShowS
Show)
instance FromJSON R.PortID where
parseJSON :: Value -> Parser PortID
parseJSON (Number Scientific
x) = (PortID -> Parser PortID
forall (m :: * -> *) a. Monad m => a -> m a
return (PortID -> Parser PortID)
-> (Scientific -> PortID) -> Scientific -> Parser PortID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortNumber -> PortID
R.PortNumber (PortNumber -> PortID)
-> (Scientific -> PortNumber) -> Scientific -> PortID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> PortNumber
forall a. Num a => Integer -> a
fromInteger (Integer -> PortNumber)
-> (Scientific -> Integer) -> Scientific -> PortNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
truncate) Scientific
x
parseJSON Value
_ = String -> Parser PortID
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"persistent Redis: couldn't parse port number"
instance FromJSON RedisAuth where
parseJSON :: Value -> Parser RedisAuth
parseJSON (String Text
t) = (RedisAuth -> Parser RedisAuth
forall (m :: * -> *) a. Monad m => a -> m a
return (RedisAuth -> Parser RedisAuth)
-> (Text -> RedisAuth) -> Text -> Parser RedisAuth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> RedisAuth
RedisAuth) Text
t
parseJSON Value
_ = String -> Parser RedisAuth
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"persistent ResisAuth: couldn't parse auth"
type RedisT = ReaderT R.Connection
thisConnection :: Monad m => RedisT m R.Connection
thisConnection :: RedisT m Connection
thisConnection = RedisT m Connection
forall r (m :: * -> *). MonadReader r m => m r
ask
withRedisConn :: (MonadIO m) => RedisConf -> (R.Connection -> m a) -> m a
withRedisConn :: RedisConf -> (Connection -> m a) -> m a
withRedisConn RedisConf
conf Connection -> m a
connectionReader = do
Connection
conn <- IO Connection -> m Connection
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Connection -> m Connection) -> IO Connection -> m Connection
forall a b. (a -> b) -> a -> b
$ RedisConf -> IO (PersistConfigPool RedisConf)
forall c. PersistConfig c => c -> IO (PersistConfigPool c)
createPoolConfig RedisConf
conf
Connection -> m a
connectionReader Connection
conn
runRedisPool :: RedisT m a -> R.Connection -> m a
runRedisPool :: RedisT m a -> Connection -> m a
runRedisPool RedisT m a
r = RedisT m a -> Connection -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT RedisT m a
r
instance PersistConfig RedisConf where
type PersistConfigBackend RedisConf = RedisT
type PersistConfigPool RedisConf = R.Connection
loadConfig :: Value -> Parser RedisConf
loadConfig (Object Object
o) = do
String
host <- Object
o Object -> Key -> Parser (Maybe String)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"host" Parser (Maybe String) -> String -> Parser String
forall a. Parser (Maybe a) -> a -> Parser a
.!= ConnectInfo -> String
R.connectHost ConnectInfo
R.defaultConnectInfo
PortID
port <- Object
o Object -> Key -> Parser (Maybe PortID)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"port" Parser (Maybe PortID) -> PortID -> Parser PortID
forall a. Parser (Maybe a) -> a -> Parser a
.!= ConnectInfo -> PortID
R.connectPort ConnectInfo
R.defaultConnectInfo
Maybe RedisAuth
mPass <- Object
o Object -> Key -> Parser (Maybe RedisAuth)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"password"
Int
maxConn <- Object
o Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"maxConn" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= ConnectInfo -> Int
R.connectMaxConnections ConnectInfo
R.defaultConnectInfo
RedisConf -> Parser RedisConf
forall (m :: * -> *) a. Monad m => a -> m a
return RedisConf :: Text -> PortID -> Maybe RedisAuth -> Int -> RedisConf
RedisConf {
rdHost :: Text
rdHost = String -> Text
pack String
host,
rdPort :: PortID
rdPort = PortID
port,
rdAuth :: Maybe RedisAuth
rdAuth = Maybe RedisAuth
mPass,
rdMaxConn :: Int
rdMaxConn = Int
maxConn
}
loadConfig Value
_ = Parser RedisConf
forall (m :: * -> *) a. MonadPlus m => m a
mzero
createPoolConfig :: RedisConf -> IO (PersistConfigPool RedisConf)
createPoolConfig (RedisConf Text
h PortID
p Maybe RedisAuth
Nothing Int
m) =
ConnectInfo -> IO Connection
R.connect (ConnectInfo -> IO Connection) -> ConnectInfo -> IO Connection
forall a b. (a -> b) -> a -> b
$
ConnectInfo
R.defaultConnectInfo {
connectHost :: String
R.connectHost = Text -> String
unpack Text
h,
connectPort :: PortID
R.connectPort = PortID
p,
connectMaxConnections :: Int
R.connectMaxConnections = Int
m
}
createPoolConfig (RedisConf Text
h PortID
p (Just (RedisAuth Text
pwd)) Int
m) =
ConnectInfo -> IO Connection
R.connect (ConnectInfo -> IO Connection) -> ConnectInfo -> IO Connection
forall a b. (a -> b) -> a -> b
$
ConnectInfo
R.defaultConnectInfo {
connectHost :: String
R.connectHost = Text -> String
unpack Text
h,
connectPort :: PortID
R.connectPort = PortID
p,
connectAuth :: Maybe ByteString
R.connectAuth = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
pwd,
connectMaxConnections :: Int
R.connectMaxConnections = Int
m
}
runPool :: RedisConf
-> PersistConfigBackend RedisConf m a
-> PersistConfigPool RedisConf
-> m a
runPool RedisConf
_ = PersistConfigBackend RedisConf m a
-> PersistConfigPool RedisConf -> m a
forall (m :: * -> *) a. RedisT m a -> Connection -> m a
runRedisPool