{-# 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