{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE StandaloneDeriving #-}
module Database.Redis.Sentinel
(
SentinelConnectInfo(..)
, SentinelConnection
, connect
, runRedis
, RedisSentinelException(..)
, module Database.Redis
) where
import Control.Concurrent
import Control.Exception (Exception, IOException, evaluate, throwIO)
import Control.Monad
import Control.Monad.Catch (Handler (..), MonadCatch, catches, throwM)
import Control.Monad.Except
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Data.Foldable (toList)
import Data.List (delete)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Typeable (Typeable)
import Data.Unique
import Network.Socket (HostName)
import Database.Redis hiding (Connection, connect, runRedis)
import qualified Database.Redis as Redis
runRedis :: SentinelConnection
-> Redis (Either Reply a)
-> IO (Either Reply a)
runRedis :: SentinelConnection -> Redis (Either Reply a) -> IO (Either Reply a)
runRedis (SentinelConnection MVar SentinelConnection'
connMVar) Redis (Either Reply a)
action = do
(Connection
baseConn, Unique
preToken) <- MVar SentinelConnection'
-> (SentinelConnection'
-> IO (SentinelConnection', (Connection, Unique)))
-> IO (Connection, Unique)
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar SentinelConnection'
connMVar ((SentinelConnection'
-> IO (SentinelConnection', (Connection, Unique)))
-> IO (Connection, Unique))
-> (SentinelConnection'
-> IO (SentinelConnection', (Connection, Unique)))
-> IO (Connection, Unique)
forall a b. (a -> b) -> a -> b
$ \oldConnection :: SentinelConnection'
oldConnection@SentinelConnection'
{ Bool
rcCheckFailover :: SentinelConnection' -> Bool
rcCheckFailover :: Bool
rcCheckFailover
, rcToken :: SentinelConnection' -> Unique
rcToken = Unique
oldToken
, rcSentinelConnectInfo :: SentinelConnection' -> SentinelConnectInfo
rcSentinelConnectInfo = SentinelConnectInfo
oldConnectInfo
, rcMasterConnectInfo :: SentinelConnection' -> ConnectInfo
rcMasterConnectInfo = ConnectInfo
oldMasterConnectInfo
, rcBaseConnection :: SentinelConnection' -> Connection
rcBaseConnection = Connection
oldBaseConnection } ->
if Bool
rcCheckFailover
then do
(SentinelConnectInfo
newConnectInfo, ConnectInfo
newMasterConnectInfo) <- SentinelConnectInfo -> IO (SentinelConnectInfo, ConnectInfo)
updateMaster SentinelConnectInfo
oldConnectInfo
Unique
newToken <- IO Unique
newUnique
(ConnectInfo
connInfo, Connection
conn) <-
if ConnectInfo -> ConnectInfo -> Bool
sameHost ConnectInfo
newMasterConnectInfo ConnectInfo
oldMasterConnectInfo
then (ConnectInfo, Connection) -> IO (ConnectInfo, Connection)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnectInfo
oldMasterConnectInfo, Connection
oldBaseConnection)
else do
Connection
newConn <- ConnectInfo -> IO Connection
Redis.connect ConnectInfo
newMasterConnectInfo
(ConnectInfo, Connection) -> IO (ConnectInfo, Connection)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnectInfo
newMasterConnectInfo, Connection
newConn)
(SentinelConnection', (Connection, Unique))
-> IO (SentinelConnection', (Connection, Unique))
forall (m :: * -> *) a. Monad m => a -> m a
return
( SentinelConnection' :: Bool
-> Unique
-> SentinelConnectInfo
-> ConnectInfo
-> Connection
-> SentinelConnection'
SentinelConnection'
{ rcCheckFailover :: Bool
rcCheckFailover = Bool
False
, rcToken :: Unique
rcToken = Unique
newToken
, rcSentinelConnectInfo :: SentinelConnectInfo
rcSentinelConnectInfo = SentinelConnectInfo
newConnectInfo
, rcMasterConnectInfo :: ConnectInfo
rcMasterConnectInfo = ConnectInfo
connInfo
, rcBaseConnection :: Connection
rcBaseConnection = Connection
conn
}
, (Connection
conn, Unique
newToken)
)
else (SentinelConnection', (Connection, Unique))
-> IO (SentinelConnection', (Connection, Unique))
forall (m :: * -> *) a. Monad m => a -> m a
return (SentinelConnection'
oldConnection, (Connection
oldBaseConnection, Unique
oldToken))
Either Reply a
reply <- (Connection -> Redis (Either Reply a) -> IO (Either Reply a)
forall a. Connection -> Redis a -> IO a
Redis.runRedis Connection
baseConn Redis (Either Reply a)
action IO (Either Reply a)
-> (Either Reply a -> IO (Either Reply a)) -> IO (Either Reply a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either Reply a -> IO (Either Reply a)
forall a. a -> IO a
evaluate)
IO (Either Reply a) -> (String -> IO ()) -> IO (Either Reply a)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (String -> m ()) -> m a
`catchRedisRethrow` (\String
_ -> Unique -> IO ()
setCheckSentinel Unique
preToken)
case Either Reply a
reply of
Left (Error ByteString
e) | ByteString
"READONLY " ByteString -> ByteString -> Bool
`BS.isPrefixOf` ByteString
e ->
Unique -> IO ()
setCheckSentinel Unique
preToken
Either Reply a
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Either Reply a -> IO (Either Reply a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either Reply a
reply
where
sameHost :: Redis.ConnectInfo -> Redis.ConnectInfo -> Bool
sameHost :: ConnectInfo -> ConnectInfo -> Bool
sameHost ConnectInfo
l ConnectInfo
r = ConnectInfo -> String
connectHost ConnectInfo
l String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectInfo -> String
connectHost ConnectInfo
r Bool -> Bool -> Bool
&& ConnectInfo -> PortID
connectPort ConnectInfo
l PortID -> PortID -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectInfo -> PortID
connectPort ConnectInfo
r
setCheckSentinel :: Unique -> IO ()
setCheckSentinel Unique
preToken = MVar SentinelConnection'
-> (SentinelConnection' -> IO SentinelConnection') -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar SentinelConnection'
connMVar ((SentinelConnection' -> IO SentinelConnection') -> IO ())
-> (SentinelConnection' -> IO SentinelConnection') -> IO ()
forall a b. (a -> b) -> a -> b
$ \conn :: SentinelConnection'
conn@SentinelConnection'{Unique
rcToken :: Unique
rcToken :: SentinelConnection' -> Unique
rcToken} ->
if Unique
preToken Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
rcToken
then do
Unique
newToken <- IO Unique
newUnique
SentinelConnection' -> IO SentinelConnection'
forall (m :: * -> *) a. Monad m => a -> m a
return (SentinelConnection'
conn{rcToken :: Unique
rcToken = Unique
newToken, rcCheckFailover :: Bool
rcCheckFailover = Bool
True})
else SentinelConnection' -> IO SentinelConnection'
forall (m :: * -> *) a. Monad m => a -> m a
return SentinelConnection'
conn
connect :: SentinelConnectInfo -> IO SentinelConnection
connect :: SentinelConnectInfo -> IO SentinelConnection
connect SentinelConnectInfo
origConnectInfo = do
(SentinelConnectInfo
connectInfo, ConnectInfo
masterConnectInfo) <- SentinelConnectInfo -> IO (SentinelConnectInfo, ConnectInfo)
updateMaster SentinelConnectInfo
origConnectInfo
Connection
conn <- ConnectInfo -> IO Connection
Redis.connect ConnectInfo
masterConnectInfo
Unique
token <- IO Unique
newUnique
MVar SentinelConnection' -> SentinelConnection
SentinelConnection (MVar SentinelConnection' -> SentinelConnection)
-> IO (MVar SentinelConnection') -> IO SentinelConnection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SentinelConnection' -> IO (MVar SentinelConnection')
forall a. a -> IO (MVar a)
newMVar SentinelConnection' :: Bool
-> Unique
-> SentinelConnectInfo
-> ConnectInfo
-> Connection
-> SentinelConnection'
SentinelConnection'
{ rcCheckFailover :: Bool
rcCheckFailover = Bool
False
, rcToken :: Unique
rcToken = Unique
token
, rcSentinelConnectInfo :: SentinelConnectInfo
rcSentinelConnectInfo = SentinelConnectInfo
connectInfo
, rcMasterConnectInfo :: ConnectInfo
rcMasterConnectInfo = ConnectInfo
masterConnectInfo
, rcBaseConnection :: Connection
rcBaseConnection = Connection
conn
}
updateMaster :: SentinelConnectInfo
-> IO (SentinelConnectInfo, Redis.ConnectInfo)
updateMaster :: SentinelConnectInfo -> IO (SentinelConnectInfo, ConnectInfo)
updateMaster sci :: SentinelConnectInfo
sci@SentinelConnectInfo{ByteString
NonEmpty (String, PortID)
ConnectInfo
connectBaseInfo :: SentinelConnectInfo -> ConnectInfo
connectMasterName :: SentinelConnectInfo -> ByteString
connectSentinels :: SentinelConnectInfo -> NonEmpty (String, PortID)
connectBaseInfo :: ConnectInfo
connectMasterName :: ByteString
connectSentinels :: NonEmpty (String, PortID)
..} = do
Either (ConnectInfo, (String, PortID)) ()
resultEither <- ExceptT (ConnectInfo, (String, PortID)) IO ()
-> IO (Either (ConnectInfo, (String, PortID)) ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (ConnectInfo, (String, PortID)) IO ()
-> IO (Either (ConnectInfo, (String, PortID)) ()))
-> ExceptT (ConnectInfo, (String, PortID)) IO ()
-> IO (Either (ConnectInfo, (String, PortID)) ())
forall a b. (a -> b) -> a -> b
$ NonEmpty (String, PortID)
-> ((String, PortID)
-> ExceptT (ConnectInfo, (String, PortID)) IO ())
-> ExceptT (ConnectInfo, (String, PortID)) IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (String, PortID)
connectSentinels (((String, PortID)
-> ExceptT (ConnectInfo, (String, PortID)) IO ())
-> ExceptT (ConnectInfo, (String, PortID)) IO ())
-> ((String, PortID)
-> ExceptT (ConnectInfo, (String, PortID)) IO ())
-> ExceptT (ConnectInfo, (String, PortID)) IO ()
forall a b. (a -> b) -> a -> b
$ \(String
host, PortID
port) -> do
String -> PortID -> ExceptT (ConnectInfo, (String, PortID)) IO ()
trySentinel String
host PortID
port ExceptT (ConnectInfo, (String, PortID)) IO ()
-> (String -> ExceptT (ConnectInfo, (String, PortID)) IO ())
-> ExceptT (ConnectInfo, (String, PortID)) IO ()
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (String -> m a) -> m a
`catchRedis` (\String
_ -> () -> ExceptT (ConnectInfo, (String, PortID)) IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
case Either (ConnectInfo, (String, PortID)) ()
resultEither of
Left (ConnectInfo
conn, (String, PortID)
sentinelPair) -> (SentinelConnectInfo, ConnectInfo)
-> IO (SentinelConnectInfo, ConnectInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return
( SentinelConnectInfo
sci
{ connectSentinels :: NonEmpty (String, PortID)
connectSentinels = (String, PortID)
sentinelPair (String, PortID) -> [(String, PortID)] -> NonEmpty (String, PortID)
forall a. a -> [a] -> NonEmpty a
:| (String, PortID) -> [(String, PortID)] -> [(String, PortID)]
forall a. Eq a => a -> [a] -> [a]
delete (String, PortID)
sentinelPair (NonEmpty (String, PortID) -> [(String, PortID)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty (String, PortID)
connectSentinels)
}
, ConnectInfo
conn
)
Right () -> RedisSentinelException -> IO (SentinelConnectInfo, ConnectInfo)
forall e a. Exception e => e -> IO a
throwIO (RedisSentinelException -> IO (SentinelConnectInfo, ConnectInfo))
-> RedisSentinelException -> IO (SentinelConnectInfo, ConnectInfo)
forall a b. (a -> b) -> a -> b
$ NonEmpty (String, PortID) -> RedisSentinelException
NoSentinels NonEmpty (String, PortID)
connectSentinels
where
trySentinel :: HostName -> PortID -> ExceptT (Redis.ConnectInfo, (HostName, PortID)) IO ()
trySentinel :: String -> PortID -> ExceptT (ConnectInfo, (String, PortID)) IO ()
trySentinel String
sentinelHost PortID
sentinelPort = do
!Either Reply [ByteString]
replyE <- IO (Either Reply [ByteString])
-> ExceptT
(ConnectInfo, (String, PortID)) IO (Either Reply [ByteString])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Reply [ByteString])
-> ExceptT
(ConnectInfo, (String, PortID)) IO (Either Reply [ByteString]))
-> IO (Either Reply [ByteString])
-> ExceptT
(ConnectInfo, (String, PortID)) IO (Either Reply [ByteString])
forall a b. (a -> b) -> a -> b
$ do
!Connection
sentinelConn <- ConnectInfo -> IO Connection
Redis.connect (ConnectInfo -> IO Connection) -> ConnectInfo -> IO Connection
forall a b. (a -> b) -> a -> b
$ ConnectInfo
Redis.defaultConnectInfo
{ connectHost :: String
connectHost = String
sentinelHost
, connectPort :: PortID
connectPort = PortID
sentinelPort
, connectMaxConnections :: Int
connectMaxConnections = Int
1
}
Connection
-> Redis (Either Reply [ByteString])
-> IO (Either Reply [ByteString])
forall a. Connection -> Redis a -> IO a
Redis.runRedis Connection
sentinelConn (Redis (Either Reply [ByteString])
-> IO (Either Reply [ByteString]))
-> Redis (Either Reply [ByteString])
-> IO (Either Reply [ByteString])
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Redis (Either Reply [ByteString])
forall (m :: * -> *) (f :: * -> *) a.
(RedisCtx m f, RedisResult a) =>
[ByteString] -> m (f a)
sendRequest
[ByteString
"SENTINEL", ByteString
"get-master-addr-by-name", ByteString
connectMasterName]
case Either Reply [ByteString]
replyE of
Right [ByteString
host, ByteString
port] ->
(ConnectInfo, (String, PortID))
-> ExceptT (ConnectInfo, (String, PortID)) IO ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
( ConnectInfo
connectBaseInfo
{ connectHost :: String
connectHost = ByteString -> String
BS8.unpack ByteString
host
, connectPort :: PortID
connectPort =
PortID
-> ((Int, ByteString) -> PortID)
-> Maybe (Int, ByteString)
-> PortID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(PortNumber -> PortID
PortNumber PortNumber
26379)
(PortNumber -> PortID
PortNumber (PortNumber -> PortID)
-> ((Int, ByteString) -> PortNumber) -> (Int, ByteString) -> PortID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> PortNumber)
-> ((Int, ByteString) -> Int) -> (Int, ByteString) -> PortNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, ByteString) -> Int
forall a b. (a, b) -> a
fst)
(Maybe (Int, ByteString) -> PortID)
-> Maybe (Int, ByteString) -> PortID
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe (Int, ByteString)
BS8.readInt ByteString
port
}
, (String
sentinelHost, PortID
sentinelPort)
)
Either Reply [ByteString]
_ -> () -> ExceptT (ConnectInfo, (String, PortID)) IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
catchRedisRethrow :: MonadCatch m => m a -> (String -> m ()) -> m a
catchRedisRethrow :: m a -> (String -> m ()) -> m a
catchRedisRethrow m a
action String -> m ()
handler =
m a
action m a -> [Handler m a] -> m a
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadCatch m) =>
m a -> f (Handler m a) -> m a
`catches`
[ (IOException -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((IOException -> m a) -> Handler m a)
-> (IOException -> m a) -> Handler m a
forall a b. (a -> b) -> a -> b
$ \IOException
ex -> String -> m ()
handler (IOException -> String
forall a. Show a => a -> String
show @IOException IOException
ex) m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IOException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM IOException
ex
, (ConnectionLostException -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((ConnectionLostException -> m a) -> Handler m a)
-> (ConnectionLostException -> m a) -> Handler m a
forall a b. (a -> b) -> a -> b
$ \ConnectionLostException
ex -> String -> m ()
handler (ConnectionLostException -> String
forall a. Show a => a -> String
show @ConnectionLostException ConnectionLostException
ex) m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConnectionLostException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ConnectionLostException
ex
]
catchRedis :: MonadCatch m => m a -> (String -> m a) -> m a
catchRedis :: m a -> (String -> m a) -> m a
catchRedis m a
action String -> m a
handler =
m a
action m a -> [Handler m a] -> m a
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadCatch m) =>
m a -> f (Handler m a) -> m a
`catches`
[ (IOException -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((IOException -> m a) -> Handler m a)
-> (IOException -> m a) -> Handler m a
forall a b. (a -> b) -> a -> b
$ \IOException
ex -> String -> m a
handler (IOException -> String
forall a. Show a => a -> String
show @IOException IOException
ex)
, (ConnectionLostException -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((ConnectionLostException -> m a) -> Handler m a)
-> (ConnectionLostException -> m a) -> Handler m a
forall a b. (a -> b) -> a -> b
$ \ConnectionLostException
ex -> String -> m a
handler (ConnectionLostException -> String
forall a. Show a => a -> String
show @ConnectionLostException ConnectionLostException
ex)
]
newtype SentinelConnection = SentinelConnection (MVar SentinelConnection')
data SentinelConnection'
= SentinelConnection'
{ SentinelConnection' -> Bool
rcCheckFailover :: Bool
, SentinelConnection' -> Unique
rcToken :: Unique
, SentinelConnection' -> SentinelConnectInfo
rcSentinelConnectInfo :: SentinelConnectInfo
, SentinelConnection' -> ConnectInfo
rcMasterConnectInfo :: Redis.ConnectInfo
, SentinelConnection' -> Connection
rcBaseConnection :: Redis.Connection
}
data SentinelConnectInfo
= SentinelConnectInfo
{ SentinelConnectInfo -> NonEmpty (String, PortID)
connectSentinels :: NonEmpty (HostName, PortID)
, SentinelConnectInfo -> ByteString
connectMasterName :: ByteString
, SentinelConnectInfo -> ConnectInfo
connectBaseInfo :: Redis.ConnectInfo
}
deriving (Int -> SentinelConnectInfo -> ShowS
[SentinelConnectInfo] -> ShowS
SentinelConnectInfo -> String
(Int -> SentinelConnectInfo -> ShowS)
-> (SentinelConnectInfo -> String)
-> ([SentinelConnectInfo] -> ShowS)
-> Show SentinelConnectInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SentinelConnectInfo] -> ShowS
$cshowList :: [SentinelConnectInfo] -> ShowS
show :: SentinelConnectInfo -> String
$cshow :: SentinelConnectInfo -> String
showsPrec :: Int -> SentinelConnectInfo -> ShowS
$cshowsPrec :: Int -> SentinelConnectInfo -> ShowS
Show)
data RedisSentinelException
= NoSentinels (NonEmpty (HostName, PortID))
deriving (Int -> RedisSentinelException -> ShowS
[RedisSentinelException] -> ShowS
RedisSentinelException -> String
(Int -> RedisSentinelException -> ShowS)
-> (RedisSentinelException -> String)
-> ([RedisSentinelException] -> ShowS)
-> Show RedisSentinelException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RedisSentinelException] -> ShowS
$cshowList :: [RedisSentinelException] -> ShowS
show :: RedisSentinelException -> String
$cshow :: RedisSentinelException -> String
showsPrec :: Int -> RedisSentinelException -> ShowS
$cshowsPrec :: Int -> RedisSentinelException -> ShowS
Show, Typeable)
deriving instance Exception RedisSentinelException