{-# 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() -- we require only RealFrac instance of 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)

-- | Information required to connect to a Redis server
data RedisConf = RedisConf {
    RedisConf -> Text
rdHost    :: Text,  -- ^ Host
    RedisConf -> PortID
rdPort    :: R.PortID, -- ^ Port
    RedisConf -> Maybe RedisAuth
rdAuth    :: Maybe RedisAuth, -- ^ Auth info
    RedisConf -> Int
rdMaxConn :: Int -- ^ Maximum number of connections
} 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"

-- | Monad reader transformer keeping Redis connection through out the work
type RedisT = ReaderT R.Connection

-- | Extracts connection from RedisT monad transformer
thisConnection :: Monad m => RedisT m R.Connection
thisConnection :: RedisT m Connection
thisConnection = RedisT m Connection
forall r (m :: * -> *). MonadReader r m => m r
ask

-- | Run a connection reader function against a Redis configuration
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