From 75750e7ffdd6ab23991bea9bccd5421f77e21aa3 Mon Sep 17 00:00:00 2001 From: Alex Good Date: Thu, 26 Sep 2019 12:55:32 +0200 Subject: [PATCH 001/103] First working implementation of MOVE and ASK redirection --- hedis.cabal | 11 +- src/Database/Redis.hs | 17 +- src/Database/Redis/Cluster.hs | 128 +++++++++++++ src/Database/Redis/Cluster/HashSlot.hs | 30 ++++ src/Database/Redis/Commands.hs | 17 +- src/Database/Redis/Connection.hs | 220 +++++++++++++++++++++++ src/Database/Redis/ConnectionContext.hs | 162 +++++++++++++++++ src/Database/Redis/Core.hs | 209 +++------------------ src/Database/Redis/ManualCommands.hs | 179 +++++++++++++++++- src/Database/Redis/ProtocolPipelining.hs | 142 ++------------- src/Database/Redis/PubSub.hs | 6 +- src/Database/Redis/URL.hs | 6 +- stack.yaml | 1 + 13 files changed, 801 insertions(+), 327 deletions(-) create mode 100644 src/Database/Redis/Cluster.hs create mode 100644 src/Database/Redis/Cluster/HashSlot.hs create mode 100644 src/Database/Redis/Connection.hs create mode 100644 src/Database/Redis/ConnectionContext.hs diff --git a/hedis.cabal b/hedis.cabal index 752e0297..52f5e1c5 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -69,10 +69,12 @@ library exposed-modules: Database.Redis build-depends: scanner >= 0.2, async >= 2.1, + array >= 0.5.3, base >= 4.8 && < 5, bytestring >= 0.9, bytestring-lexing >= 0.5, unordered-containers, + containers, text, deepseq, mtl >= 2, @@ -84,12 +86,16 @@ library vector >= 0.9, HTTP, errors, - network-uri + network-uri, + crc16 == 0.1.0 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.11 && < 0.19 other-modules: Database.Redis.Core, + Database.Redis.Connection, + Database.Redis.Cluster, + Database.Redis.Cluster.HashSlot, Database.Redis.ProtocolPipelining, Database.Redis.Protocol, Database.Redis.PubSub, @@ -97,7 +103,8 @@ library Database.Redis.Types Database.Redis.Commands, Database.Redis.ManualCommands, - Database.Redis.URL + Database.Redis.URL, + Database.Redis.ConnectionContext benchmark hedis-benchmark type: exitcode-stdio-1.0 diff --git a/src/Database/Redis.hs b/src/Database/Redis.hs index 1ebc211f..7cda84f5 100644 --- a/src/Database/Redis.hs +++ b/src/Database/Redis.hs @@ -163,7 +163,7 @@ module Database.Redis ( -- * Connection Connection, ConnectError(..), connect, checkedConnect, disconnect, - ConnectInfo(..), defaultConnectInfo, parseConnectInfo, + ConnectInfo(..), defaultConnectInfo, parseConnectInfo, connectCluster, PortID(..), -- * Commands @@ -189,15 +189,26 @@ module Database.Redis ( -- -- > lindex :: ByteString -> Integer -> Redis (Either Reply ByteString) -- + HashSlot, keyToSlot ) where import Database.Redis.Core +import Database.Redis.Connection + ( runRedis + , connectCluster + , defaultConnectInfo + , ConnectInfo(..) + , disconnect + , checkedConnect + , connect + , ConnectError(..) + , Connection(..)) +import Database.Redis.ConnectionContext(PortID(..), ConnectionLostException(..)) import Database.Redis.PubSub import Database.Redis.Protocol -import Database.Redis.ProtocolPipelining - (PortID(..), ConnectionLostException(..)) import Database.Redis.Transactions import Database.Redis.Types import Database.Redis.URL import Database.Redis.Commands +import Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs new file mode 100644 index 00000000..f9a93718 --- /dev/null +++ b/src/Database/Redis/Cluster.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} +module Database.Redis.Cluster + ( Connection(..) + , NodeRole(..) + , Node(..) + , ShardMap(..) + , HashSlot + , Shard(..) + , connect + , request + , nodes +) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.IORef as IOR +import Data.Maybe(listToMaybe) +import Control.Exception(Exception, throwIO) +import Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot) +import qualified Database.Redis.ConnectionContext as CC +import qualified Data.IntMap.Strict as IntMap +import Data.Typeable +import qualified Network.Socket as NS +import qualified Scanner + +import Database.Redis.Protocol(Reply(Error), renderRequest, reply) + + +data Connection = Connection + { ctx :: CC.ConnectionContext + , lastRecvRef :: IOR.IORef (Maybe B.ByteString) } + +instance Show Connection where + show Connection{..} = "Connection{ ctx = " <> show ctx <> ", lastRecvRef = IORef}" + +data NodeRole = Master | Slave deriving (Show) + +type Host = String +type Port = Int +type NodeID = B.ByteString +data Node = Node NodeID NodeRole Connection Host Port deriving (Show) + +type MasterNode = Node +type SlaveNode = Node +data Shard = Shard MasterNode [SlaveNode] deriving Show + +newtype ShardMap = ShardMap (IntMap.IntMap Shard) deriving (Show) + +newtype MissingNodeException = MissingNodeException [B.ByteString] deriving (Show, Typeable) + +instance Exception MissingNodeException + +connect :: NS.HostName -> NS.PortNumber -> Maybe Int -> IO Connection +connect hostName portNumber timeoutOpt = do + ctx <- CC.connect hostName (CC.PortNumber portNumber) timeoutOpt + lastRecvRef <- IOR.newIORef Nothing + return Connection{..} + + +request :: IOR.IORef ShardMap -> (() -> IO ShardMap) -> [B.ByteString] -> IO Reply +request shardMapRef refreshShardMap requestData = do + shardMap <- IOR.readIORef shardMapRef + let maybeNode = nodeForCommand shardMap requestData + case maybeNode of + Nothing -> throwIO $ MissingNodeException requestData + Just node -> do + resp <- requestNode node (renderRequest requestData) + case resp of + (Error errString) | B.isPrefixOf "MOVED" errString -> do + newShardMap <- refreshShardMap () + IOR.writeIORef shardMapRef newShardMap + request shardMapRef refreshShardMap requestData + (askingRedirection -> Just (host, port)) -> do + let maybeAskNode = nodeWithHostAndPort shardMap host port + case maybeAskNode of + Just askNode -> do + _ <- requestNode askNode (renderRequest ["ASKING"]) + requestNode askNode (renderRequest requestData) + Nothing -> do + newShardMap <- refreshShardMap () + IOR.writeIORef shardMapRef newShardMap + request shardMapRef refreshShardMap requestData + _ -> return resp + +askingRedirection :: Reply -> Maybe (Host, Port) +askingRedirection (Error errString) = case Char8.words errString of + ["ASK", _, hostport] -> case Char8.split ':' hostport of + [host, portString] -> case Char8.readInt portString of + Just (port,"") -> Just (Char8.unpack host, port) + _ -> Nothing + _ -> Nothing + _ -> Nothing +askingRedirection _ = Nothing + + +nodeForCommand :: ShardMap -> [B.ByteString] -> Maybe Node +nodeForCommand (ShardMap shards) (_:key:_) = do + (Shard master _) <- IntMap.lookup (fromEnum $ keyToSlot key) shards + Just master +nodeForCommand _ _ = Nothing + +requestNode :: Node -> B.ByteString -> IO Reply +requestNode (Node _ _ Connection{..} _ _) requestData = do + _ <- CC.send ctx requestData >> CC.flush ctx + maybeLastRecv <- IOR.readIORef lastRecvRef + scanResult <- case maybeLastRecv of + Just lastRecv -> Scanner.scanWith (CC.recv ctx) reply lastRecv + Nothing -> Scanner.scanWith (CC.recv ctx) reply B.empty + + + case scanResult of + Scanner.Fail{} -> CC.errConnClosed + Scanner.More{} -> error "Hedis: parseWith returned Partial" + Scanner.Done rest' r -> do + IOR.writeIORef lastRecvRef (Just rest') + return r + +nodes :: ShardMap -> [Node] +nodes (ShardMap shardMap) = concatMap snd $ IntMap.toList $ fmap shardNodes shardMap where + shardNodes :: Shard -> [Node] + shardNodes (Shard master slaves) = master:slaves + + +nodeWithHostAndPort :: ShardMap -> Host -> Port -> Maybe Node +nodeWithHostAndPort shardMap host port = listToMaybe $ filter (\(Node _ _ _ nodeHost nodePort) -> port == nodePort && host == nodeHost) $ nodes shardMap diff --git a/src/Database/Redis/Cluster/HashSlot.hs b/src/Database/Redis/Cluster/HashSlot.hs new file mode 100644 index 00000000..3a502902 --- /dev/null +++ b/src/Database/Redis/Cluster/HashSlot.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +module Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot) where + +import Data.Bits((.&.)) +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteString as BS +import Data.Word(Word16) +import qualified Data.Digest.CRC16 as CRC16 + +newtype HashSlot = HashSlot Word16 deriving (Num, Eq, Ord, Real, Enum, Integral, Show) + +numHashSlots :: Word16 +numHashSlots = 16384 + +-- | Compute the hashslot associated with a key +keyToSlot :: BS.ByteString -> HashSlot +keyToSlot = HashSlot . (.&.) (numHashSlots - 1) . crc16 . findSubKey + +-- | Find the section of a key to compute the slot for. +findSubKey :: BS.ByteString -> BS.ByteString +findSubKey key = case Char8.break (=='{') key of + (whole, "") -> whole + (_, xs) -> case Char8.break (=='}') (Char8.tail xs) of + ("", _) -> key + (subKey, _) -> subKey + +crc16 :: BS.ByteString -> Word16 +crc16 = BS.foldl (CRC16.crc16_update 0x1021 False) 0 + diff --git a/src/Database/Redis/Commands.hs b/src/Database/Redis/Commands.hs index e26129b8..b1dacf49 100644 --- a/src/Database/Redis/Commands.hs +++ b/src/Database/Redis/Commands.hs @@ -261,7 +261,19 @@ xinfoStream, -- |Get info about a stream. The Redis command @XINFO@ is split int xdel, -- |Delete messages from a stream. Since Redis 5.0.0 xtrim, -- |Set the upper bound for number of messages in a stream. Since Redis 5.0.0 inf, -- |Constructor for `inf` Redis argument values - +ClusterNodesResponse(..), +ClusterNodesResponseEntry(..), +ClusterNodesResponseSlotSpec(..), +clusterNodes, +ClusterSlotsResponse(..), +ClusterSlotsResponseEntry(..), +ClusterSlotsNode(..), +clusterSlots, +clusterSetSlotNode, +clusterSetSlotStable, +clusterSetSlotImporting, +clusterSetSlotMigrating, +clusterGetKeysInSlot -- * Unimplemented Commands -- |These commands are not implemented, as of now. Library -- users can implement these or other commands from @@ -306,7 +318,7 @@ import Prelude hiding (min,max) import Data.ByteString (ByteString) import Database.Redis.ManualCommands import Database.Redis.Types -import Database.Redis.Core +import Database.Redis.Core(sendRequest, RedisCtx) ttl :: (RedisCtx m f) @@ -1080,4 +1092,3 @@ sismember -> ByteString -- ^ member -> m (f Bool) sismember key member = sendRequest (["SISMEMBER"] ++ [encode key] ++ [encode member] ) - diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs new file mode 100644 index 00000000..6074e5ee --- /dev/null +++ b/src/Database/Redis/Connection.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +module Database.Redis.Connection where + +import Control.Exception +import Control.Monad.IO.Class(liftIO) +import Control.Monad(when) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as Char8 +import Data.Functor(void) +import qualified Data.IntMap.Strict as IntMap +import Data.Pool(Pool, withResource, createPool, destroyAllResources) +import Data.Typeable +import qualified Data.IORef as IOR +import qualified Data.Time as Time +import Network.TLS (ClientParams) +import qualified Network.Socket as NS + +import qualified Database.Redis.ProtocolPipelining as PP +import Database.Redis.Core(Redis, runRedisInternal, runRedisClusteredInternal) +import Database.Redis.Protocol(Reply(..)) +import Database.Redis.Cluster(ShardMap(..), Node, Shard(..)) +import qualified Database.Redis.Cluster as Cluster +import qualified Database.Redis.ConnectionContext as CC +import Database.Redis.Commands + ( ping + , select + , auth + , clusterSlots + , ClusterSlotsResponse(..) + , ClusterSlotsResponseEntry(..) + , ClusterSlotsNode(..)) + +-------------------------------------------------------------------------------- +-- Connection +-- + +-- |A threadsafe pool of network connections to a Redis server. Use the +-- 'connect' function to create one. +data Connection + = NonClusteredConnection (Pool PP.Connection) + | ClusteredConnection (IOR.IORef ShardMap) + +-- |Information for connnecting to a Redis server. +-- +-- It is recommended to not use the 'ConnInfo' data constructor directly. +-- Instead use 'defaultConnectInfo' and update it with record syntax. For +-- example to connect to a password protected Redis server running on localhost +-- and listening to the default port: +-- +-- @ +-- myConnectInfo :: ConnectInfo +-- myConnectInfo = defaultConnectInfo {connectAuth = Just \"secret\"} +-- @ +-- +data ConnectInfo = ConnInfo + { connectHost :: NS.HostName + , connectPort :: CC.PortID + , connectAuth :: Maybe B.ByteString + -- ^ When the server is protected by a password, set 'connectAuth' to 'Just' + -- the password. Each connection will then authenticate by the 'auth' + -- command. + , connectDatabase :: Integer + -- ^ Each connection will 'select' the database with the given index. + , connectMaxConnections :: Int + -- ^ Maximum number of connections to keep open. The smallest acceptable + -- value is 1. + , connectMaxIdleTime :: Time.NominalDiffTime + -- ^ Amount of time for which an unused connection is kept open. The + -- smallest acceptable value is 0.5 seconds. If the @timeout@ value in + -- your redis.conf file is non-zero, it should be larger than + -- 'connectMaxIdleTime'. + , connectTimeout :: Maybe Time.NominalDiffTime + -- ^ Optional timeout until connection to Redis gets + -- established. 'ConnectTimeoutException' gets thrown if no socket + -- get connected in this interval of time. + , connectTLSParams :: Maybe ClientParams + -- ^ Optional TLS parameters. TLS will be enabled if this is provided. + } deriving Show + +data ConnectError = ConnectAuthError Reply + | ConnectSelectError Reply + deriving (Eq, Show, Typeable) + +instance Exception ConnectError + +-- |Default information for connecting: +-- +-- @ +-- connectHost = \"localhost\" +-- connectPort = PortNumber 6379 -- Redis default port +-- connectAuth = Nothing -- No password +-- connectDatabase = 0 -- SELECT database 0 +-- connectMaxConnections = 50 -- Up to 50 connections +-- connectMaxIdleTime = 30 -- Keep open for 30 seconds +-- connectTimeout = Nothing -- Don't add timeout logic +-- connectTLSParams = Nothing -- Do not use TLS +-- @ +-- +defaultConnectInfo :: ConnectInfo +defaultConnectInfo = ConnInfo + { connectHost = "localhost" + , connectPort = CC.PortNumber 6379 + , connectAuth = Nothing + , connectDatabase = 0 + , connectMaxConnections = 50 + , connectMaxIdleTime = 30 + , connectTimeout = Nothing + , connectTLSParams = Nothing + } + +createConnection :: ConnectInfo -> IO PP.Connection +createConnection ConnInfo{..} = do + let timeoutOptUs = + round . (1000000 *) <$> connectTimeout + conn <- PP.connect connectHost connectPort timeoutOptUs + conn' <- case connectTLSParams of + Nothing -> return conn + Just tlsParams -> PP.enableTLS tlsParams conn + PP.beginReceiving conn' + + runRedisInternal conn' $ do + -- AUTH + case connectAuth of + Nothing -> return () + Just pass -> do + resp <- auth pass + case resp of + Left r -> liftIO $ throwIO $ ConnectAuthError r + _ -> return () + -- SELECT + when (connectDatabase /= 0) $ do + resp <- select connectDatabase + case resp of + Left r -> liftIO $ throwIO $ ConnectSelectError r + _ -> return () + return conn' + +-- |Constructs a 'Connection' pool to a Redis server designated by the +-- given 'ConnectInfo'. The first connection is not actually established +-- until the first call to the server. +connect :: ConnectInfo -> IO Connection +connect cInfo@ConnInfo{..} = NonClusteredConnection <$> + createPool (createConnection cInfo) PP.disconnect 1 connectMaxIdleTime connectMaxConnections + +-- |Constructs a 'Connection' pool to a Redis server designated by the +-- given 'ConnectInfo', then tests if the server is actually there. +-- Throws an exception if the connection to the Redis server can't be +-- established. +checkedConnect :: ConnectInfo -> IO Connection +checkedConnect connInfo = do + conn <- connect connInfo + runRedis conn $ void ping + return conn + +-- |Destroy all idle resources in the pool. +disconnect :: Connection -> IO () +disconnect (NonClusteredConnection pool) = destroyAllResources pool +disconnect (ClusteredConnection _) = return () + +-- | Memory bracket around 'connect' and 'disconnect'. +withConnect :: ConnectInfo -> (Connection -> IO c) -> IO c +withConnect connInfo = bracket (connect connInfo) disconnect + +-- | Memory bracket around 'checkedConnect' and 'disconnect' +withCheckedConnect :: ConnectInfo -> (Connection -> IO c) -> IO c +withCheckedConnect connInfo = bracket (checkedConnect connInfo) disconnect + +-- |Interact with a Redis datastore specified by the given 'Connection'. +-- +-- Each call of 'runRedis' takes a network connection from the 'Connection' +-- pool and runs the given 'Redis' action. Calls to 'runRedis' may thus block +-- while all connections from the pool are in use. +runRedis :: Connection -> Redis a -> IO a +runRedis (NonClusteredConnection pool) redis = + withResource pool $ \conn -> runRedisInternal conn redis +runRedis c@(ClusteredConnection shardMapRef) redis = runRedisClusteredInternal shardMapRef (\() -> refreshShardMap c) redis + +newtype ClusterConnectError = ClusterConnectError Reply + deriving (Eq, Show, Typeable) + +instance Exception ClusterConnectError + +-- |Constructs a 'ShardMap' of connections to clustered nodes. The argument is +-- a 'ConnectInfo' for any node in the cluster +connectCluster :: ConnectInfo -> IO Connection +connectCluster bootstrapConnInfo = do + conn <- createConnection bootstrapConnInfo + slotsResponse <- runRedisInternal conn clusterSlots + case slotsResponse of + Left e -> throwIO $ ClusterConnectError e + Right slots -> do + shardMap <- shardMapFromClusterSlotsResponse slots + shardMapRef <- IOR.newIORef shardMap + return $ ClusteredConnection shardMapRef + +shardMapFromClusterSlotsResponse :: ClusterSlotsResponse -> IO ShardMap +shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr mkShardMap (pure IntMap.empty) clusterSlotsResponseEntries where + mkShardMap :: ClusterSlotsResponseEntry -> IO (IntMap.IntMap Shard) -> IO (IntMap.IntMap Shard) + mkShardMap ClusterSlotsResponseEntry{..} accumulator = do + accumulated <- accumulator + master <- nodeFromClusterSlotNode True clusterSlotsResponseEntryMaster + replicas <- mapM (nodeFromClusterSlotNode False) clusterSlotsResponseEntryReplicas + let shard = Shard master replicas + let slotMap = IntMap.fromList $ map (, shard) [clusterSlotsResponseEntryStartSlot..clusterSlotsResponseEntryEndSlot] + return $ IntMap.union slotMap accumulated + nodeFromClusterSlotNode :: Bool -> ClusterSlotsNode -> IO Node + nodeFromClusterSlotNode isMaster ClusterSlotsNode{..} = do + let hostname = Char8.unpack clusterSlotsNodeIP + conn <- Cluster.connect hostname (toEnum clusterSlotsNodePort) Nothing + let role = if isMaster then Cluster.Master else Cluster.Slave + return $ Cluster.Node clusterSlotsNodeID role conn hostname (toEnum clusterSlotsNodePort) + +refreshShardMap :: Connection -> IO ShardMap +refreshShardMap conn = do + slotsResponse <- runRedis conn clusterSlots + case slotsResponse of + Left e -> throwIO $ ClusterConnectError e + Right slots -> shardMapFromClusterSlotsResponse slots diff --git a/src/Database/Redis/ConnectionContext.hs b/src/Database/Redis/ConnectionContext.hs new file mode 100644 index 00000000..6ed88124 --- /dev/null +++ b/src/Database/Redis/ConnectionContext.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Database.Redis.ConnectionContext ( + ConnectionContext(..) + , ConnectTimeout(..) + , ConnectionLostException(..) + , PortID(..) + , connect + , disconnect + , send + , recv + , errConnClosed + , enableTLS + , flush + , ioErrorToConnLost +) where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (race) +import Control.Monad(when) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import qualified Data.IORef as IOR +import Control.Concurrent.MVar(newMVar, readMVar, swapMVar) +import Control.Exception(bracketOnError, Exception, throwIO, try) +import Data.Typeable +import Data.Functor(void) +import qualified Network.Socket as NS +import qualified Network.TLS as TLS +import System.IO(Handle, hSetBinaryMode, hClose, IOMode(..), hFlush, hIsOpen) +import System.IO.Error(catchIOError) + +data ConnectionContext = NormalHandle Handle | TLSContext TLS.Context + +instance Show ConnectionContext where + show (NormalHandle _) = "NormalHandle" + show (TLSContext _) = "TLSContext" + +data Connection = Connection + { ctx :: ConnectionContext + , lastRecvRef :: IOR.IORef (Maybe B.ByteString) } + +instance Show Connection where + show Connection{..} = "Connection{ ctx = " <> show ctx <> ", lastRecvRef = IORef}" + +data ConnectPhase + = PhaseUnknown + | PhaseResolve + | PhaseOpenSocket + deriving (Show) + +newtype ConnectTimeout = ConnectTimeout ConnectPhase + deriving (Show, Typeable) + +instance Exception ConnectTimeout + +data ConnectionLostException = ConnectionLost deriving Show +instance Exception ConnectionLostException + +data PortID = PortNumber NS.PortNumber + | UnixSocket String + deriving Show + +connect :: NS.HostName -> PortID -> Maybe Int -> IO ConnectionContext +connect hostName portId timeoutOpt = + bracketOnError hConnect hClose $ \h -> do + hSetBinaryMode h True + return $ NormalHandle h + where + hConnect = do + phaseMVar <- newMVar PhaseUnknown + let doConnect = hConnect' phaseMVar + case timeoutOpt of + Nothing -> doConnect + Just micros -> do + result <- race doConnect (threadDelay micros) + case result of + Left h -> return h + Right () -> do + phase <- readMVar phaseMVar + errConnectTimeout phase + hConnect' mvar = bracketOnError createSock NS.close $ \sock -> do + NS.setSocketOption sock NS.KeepAlive 1 + void $ swapMVar mvar PhaseResolve + void $ swapMVar mvar PhaseOpenSocket + NS.socketToHandle sock ReadWriteMode + where + createSock = case portId of + PortNumber portNumber -> do + addrInfo <- getHostAddrInfo hostName portNumber + connectSocket addrInfo + UnixSocket addr -> bracketOnError + (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol) + NS.close + (\sock -> NS.connect sock (NS.SockAddrUnix addr) >> return sock) + +getHostAddrInfo :: NS.HostName -> NS.PortNumber -> IO [NS.AddrInfo] +getHostAddrInfo hostname port = + NS.getAddrInfo (Just hints) (Just hostname) (Just $ show port) + where + hints = NS.defaultHints + { NS.addrSocketType = NS.Stream } + +errConnectTimeout :: ConnectPhase -> IO a +errConnectTimeout phase = throwIO $ ConnectTimeout phase + +connectSocket :: [NS.AddrInfo] -> IO NS.Socket +connectSocket [] = error "connectSocket: unexpected empty list" +connectSocket (addr:rest) = tryConnect >>= \case + Right sock -> return sock + Left err -> if null rest + then throwIO err + else connectSocket rest + where + tryConnect :: IO (Either IOError NS.Socket) + tryConnect = bracketOnError createSock NS.close $ \sock -> + try (NS.connect sock $ NS.addrAddress addr) >>= \case + Right () -> return (Right sock) + Left err -> return (Left err) + where + createSock = NS.socket (NS.addrFamily addr) + (NS.addrSocketType addr) + (NS.addrProtocol addr) + +send :: ConnectionContext -> B.ByteString -> IO () +send (NormalHandle h) requestData = + ioErrorToConnLost (B.hPut h requestData) +send (TLSContext ctx) requestData = + ioErrorToConnLost (TLS.sendData ctx (LB.fromStrict requestData)) + +recv :: ConnectionContext -> IO B.ByteString +recv (NormalHandle h) = ioErrorToConnLost $ B.hGetSome h 4096 +recv (TLSContext ctx) = TLS.recvData ctx + + +ioErrorToConnLost :: IO a -> IO a +ioErrorToConnLost a = a `catchIOError` const errConnClosed + +errConnClosed :: IO a +errConnClosed = throwIO ConnectionLost + + +enableTLS :: TLS.ClientParams -> ConnectionContext -> IO ConnectionContext +enableTLS tlsParams (NormalHandle h) = do + ctx <- TLS.contextNew h tlsParams + TLS.handshake ctx + return $ TLSContext ctx +enableTLS _ c@(TLSContext _) = return c + +disconnect :: ConnectionContext -> IO () +disconnect (NormalHandle h) = do + open <- hIsOpen h + when open $ hClose h +disconnect (TLSContext ctx) = do + TLS.bye ctx + TLS.contextClose ctx + +flush :: ConnectionContext -> IO () +flush (NormalHandle h) = hFlush h +flush (TLSContext c) = TLS.contextFlush c diff --git a/src/Database/Redis/Core.hs b/src/Database/Redis/Core.hs index e0034ad5..e780080e 100644 --- a/src/Database/Redis/Core.hs +++ b/src/Database/Redis/Core.hs @@ -3,36 +3,30 @@ DeriveDataTypeable, StandaloneDeriving #-} module Database.Redis.Core ( - Connection(..), ConnectError(..), connect, checkedConnect, disconnect, - withConnect, withCheckedConnect, - ConnectInfo(..), defaultConnectInfo, - Redis(), runRedis, unRedis, reRedis, + Redis(), unRedis, reRedis, RedisCtx(..), MonadRedis(..), send, recv, sendRequest, - auth, select, ping + runRedisInternal, + runRedisClusteredInternal, + RedisEnv(..), ) where import Prelude #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif -import Control.Exception #if __GLASGOW_HASKELL__ > 711 -import Control.Monad.Fail (MonadFail) #endif import Control.Monad.Reader +import Control.Monad.Fail(MonadFail) import qualified Data.ByteString as B import Data.IORef -import Data.Pool -import Data.Time -import Data.Typeable -import qualified Network.Socket as NS -import Network.TLS (ClientParams) import Database.Redis.Protocol import qualified Database.Redis.ProtocolPipelining as PP import Database.Redis.Types - +import Database.Redis.Cluster(ShardMap) +import qualified Database.Redis.Cluster as Cluster -------------------------------------------------------------------------------- -- The Redis Monad @@ -50,7 +44,9 @@ newtype Redis a = Redis (ReaderT RedisEnv IO a) deriving instance MonadFail Redis #endif -data RedisEnv = Env { envConn :: PP.Connection, envLastReply :: IORef Reply } +data RedisEnv + = NonClusteredEnv { envConn :: PP.Connection, envLastReply :: IORef Reply } + | ClusteredEnv { currentShardMap :: IORef ShardMap, refreshAction :: () -> IO ShardMap } -- |This class captures the following behaviour: In a context @m@, a command -- will return its result wrapped in a \"container\" of type @f@. @@ -60,24 +56,16 @@ data RedisEnv = Env { envConn :: PP.Connection, envLastReply :: IORef Reply } class (MonadRedis m) => RedisCtx m f | m -> f where returnDecode :: RedisResult a => Reply -> m (f a) -instance RedisCtx Redis (Either Reply) where - returnDecode = return . decode - class (Monad m) => MonadRedis m where liftRedis :: Redis a -> m a + +instance RedisCtx Redis (Either Reply) where + returnDecode = return . decode + instance MonadRedis Redis where liftRedis = id --- |Interact with a Redis datastore specified by the given 'Connection'. --- --- Each call of 'runRedis' takes a network connection from the 'Connection' --- pool and runs the given 'Redis' action. Calls to 'runRedis' may thus block --- while all connections from the pool are in use. -runRedis :: Connection -> Redis a -> IO a -runRedis (Conn pool) redis = - withResource pool $ \conn -> runRedisInternal conn redis - -- |Deconstruct Redis constructor. -- -- 'unRedis' and 'reRedis' can be used to define instances for @@ -98,11 +86,14 @@ runRedisInternal :: PP.Connection -> Redis a -> IO a runRedisInternal conn (Redis redis) = do -- Dummy reply in case no request is sent. ref <- newIORef (SingleLine "nobody will ever see this") - r <- runReaderT redis (Env conn ref) + r <- runReaderT redis (NonClusteredEnv conn ref) -- Evaluate last reply to keep lazy IO inside runRedis. readIORef ref >>= (`seq` return ()) return r +runRedisClusteredInternal :: IORef ShardMap -> (() -> IO ShardMap) -> Redis a -> IO a +runRedisClusteredInternal shardMapRef refreshShardmapAction (Redis redis) = runReaderT redis (ClusteredEnv shardMapRef refreshShardmapAction) + setLastReply :: Reply -> ReaderT RedisEnv IO () setLastReply r = do ref <- asks envLastReply @@ -134,161 +125,11 @@ sendRequest :: (RedisCtx m f, RedisResult a) => [B.ByteString] -> m (f a) sendRequest req = do r' <- liftRedis $ Redis $ do - conn <- asks envConn - r <- liftIO $ PP.request conn (renderRequest req) - setLastReply r - return r + env <- ask + case env of + NonClusteredEnv{..} -> do + r <- liftIO $ PP.request envConn (renderRequest req) + setLastReply r + return r + ClusteredEnv{..} -> liftIO $ Cluster.request currentShardMap refreshAction req returnDecode r' - - --------------------------------------------------------------------------------- --- Connection --- - --- |A threadsafe pool of network connections to a Redis server. Use the --- 'connect' function to create one. -newtype Connection = Conn (Pool PP.Connection) - --- |Information for connnecting to a Redis server. --- --- It is recommended to not use the 'ConnInfo' data constructor directly. --- Instead use 'defaultConnectInfo' and update it with record syntax. For --- example to connect to a password protected Redis server running on localhost --- and listening to the default port: --- --- @ --- myConnectInfo :: ConnectInfo --- myConnectInfo = defaultConnectInfo {connectAuth = Just \"secret\"} --- @ --- -data ConnectInfo = ConnInfo - { connectHost :: NS.HostName - , connectPort :: PP.PortID - , connectAuth :: Maybe B.ByteString - -- ^ When the server is protected by a password, set 'connectAuth' to 'Just' - -- the password. Each connection will then authenticate by the 'auth' - -- command. - , connectDatabase :: Integer - -- ^ Each connection will 'select' the database with the given index. - , connectMaxConnections :: Int - -- ^ Maximum number of connections to keep open. The smallest acceptable - -- value is 1. - , connectMaxIdleTime :: NominalDiffTime - -- ^ Amount of time for which an unused connection is kept open. The - -- smallest acceptable value is 0.5 seconds. If the @timeout@ value in - -- your redis.conf file is non-zero, it should be larger than - -- 'connectMaxIdleTime'. - , connectTimeout :: Maybe NominalDiffTime - -- ^ Optional timeout until connection to Redis gets - -- established. 'ConnectTimeoutException' gets thrown if no socket - -- get connected in this interval of time. - , connectTLSParams :: Maybe ClientParams - -- ^ Optional TLS parameters. TLS will be enabled if this is provided. - } deriving Show - -data ConnectError = ConnectAuthError Reply - | ConnectSelectError Reply - deriving (Eq, Show, Typeable) - -instance Exception ConnectError - --- |Default information for connecting: --- --- @ --- connectHost = \"localhost\" --- connectPort = PortNumber 6379 -- Redis default port --- connectAuth = Nothing -- No password --- connectDatabase = 0 -- SELECT database 0 --- connectMaxConnections = 50 -- Up to 50 connections --- connectMaxIdleTime = 30 -- Keep open for 30 seconds --- connectTimeout = Nothing -- Don't add timeout logic --- connectTLSParams = Nothing -- Do not use TLS --- @ --- -defaultConnectInfo :: ConnectInfo -defaultConnectInfo = ConnInfo - { connectHost = "localhost" - , connectPort = PP.PortNumber 6379 - , connectAuth = Nothing - , connectDatabase = 0 - , connectMaxConnections = 50 - , connectMaxIdleTime = 30 - , connectTimeout = Nothing - , connectTLSParams = Nothing - } - --- |Constructs a 'Connection' pool to a Redis server designated by the --- given 'ConnectInfo'. The first connection is not actually established --- until the first call to the server. -connect :: ConnectInfo -> IO Connection -connect ConnInfo{..} = Conn <$> - createPool create destroy 1 connectMaxIdleTime connectMaxConnections - where - create = do - let timeoutOptUs = - round . (1000000 *) <$> connectTimeout - conn <- PP.connect connectHost connectPort timeoutOptUs - conn' <- case connectTLSParams of - Nothing -> return conn - Just tlsParams -> PP.enableTLS tlsParams conn - PP.beginReceiving conn' - - runRedisInternal conn' $ do - -- AUTH - case connectAuth of - Nothing -> return () - Just pass -> do - resp <- auth pass - case resp of - Left r -> liftIO $ throwIO $ ConnectAuthError r - _ -> return () - -- SELECT - when (connectDatabase /= 0) $ do - resp <- select connectDatabase - case resp of - Left r -> liftIO $ throwIO $ ConnectSelectError r - _ -> return () - return conn' - - destroy = PP.disconnect - --- |Constructs a 'Connection' pool to a Redis server designated by the --- given 'ConnectInfo', then tests if the server is actually there. --- Throws an exception if the connection to the Redis server can't be --- established. -checkedConnect :: ConnectInfo -> IO Connection -checkedConnect connInfo = do - conn <- connect connInfo - runRedis conn $ void ping - return conn - --- |Destroy all idle resources in the pool. -disconnect :: Connection -> IO () -disconnect (Conn pool) = destroyAllResources pool - --- | Memory bracket around 'connect' and 'disconnect'. -withConnect :: ConnectInfo -> (Connection -> IO c) -> IO c -withConnect connInfo = bracket (connect connInfo) disconnect - --- | Memory bracket around 'checkedConnect' and 'disconnect' -withCheckedConnect :: ConnectInfo -> (Connection -> IO c) -> IO c -withCheckedConnect connInfo = bracket (checkedConnect connInfo) disconnect - --- The AUTH command. It has to be here because it is used in 'connect'. -auth - :: B.ByteString -- ^ password - -> Redis (Either Reply Status) -auth password = sendRequest ["AUTH", password] - --- The SELECT command. Used in 'connect'. -select - :: RedisCtx m f - => Integer -- ^ index - -> m (f Status) -select ix = sendRequest ["SELECT", encode ix] - --- The PING command. Used in 'checkedConnect'. -ping - :: (RedisCtx m f) - => m (f Status) -ping = sendRequest (["PING"] ) diff --git a/src/Database/Redis/ManualCommands.hs b/src/Database/Redis/ManualCommands.hs index d4aaeb89..c4f67ea7 100644 --- a/src/Database/Redis/ManualCommands.hs +++ b/src/Database/Redis/ManualCommands.hs @@ -4,7 +4,9 @@ module Database.Redis.ManualCommands where import Prelude hiding (min, max) import Data.ByteString (ByteString, empty, append) -import Data.Maybe (maybeToList) +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteString as BS +import Data.Maybe (maybeToList, catMaybes) import Database.Redis.Core import Database.Redis.Protocol import Database.Redis.Types @@ -1197,3 +1199,178 @@ xtrim stream opts = sendRequest $ ["XTRIM", stream] ++ optArgs inf :: RealFloat a => a inf = 1 / 0 + +auth + :: RedisCtx m f + => ByteString -- ^ password + -> m (f Status) +auth password = sendRequest ["AUTH", password] + +-- the select command. used in 'connect'. +select + :: RedisCtx m f + => Integer -- ^ index + -> m (f Status) +select ix = sendRequest ["SELECT", encode ix] + +-- the ping command. used in 'checkedconnect'. +ping + :: (RedisCtx m f) + => m (f Status) +ping = sendRequest (["PING"] ) + +data ClusterNodesResponse = ClusterNodesResponse + { clusterNodesResponseEntries :: [ClusterNodesResponseEntry] + } deriving (Show, Eq) + +data ClusterNodesResponseEntry = ClusterNodesResponseEntry { clusterNodesResponseNodeId :: ByteString + , clusterNodesResponseNodeIp :: ByteString + , clusterNodesResponseNodePort :: Integer + , clusterNodesResponseNodeFlags :: [ByteString] + , clusterNodesResponseMasterId :: Maybe ByteString + , clusterNodesResponsePingSent :: Integer + , clusterNodesResponsePongReceived :: Integer + , clusterNodesResponseConfigEpoch :: Integer + , clusterNodesResponseLinkState :: ByteString + , clusterNodesResponseSlots :: [ClusterNodesResponseSlotSpec] + } deriving (Show, Eq) + +data ClusterNodesResponseSlotSpec + = ClusterNodesResponseSingleSlot Integer + | ClusterNodesResponseSlotRange Integer Integer + | ClusterNodesResponseSlotImporting Integer ByteString + | ClusterNodesResponseSlotMigrating Integer ByteString deriving (Show, Eq) + + +instance RedisResult ClusterNodesResponse where + decode r@(Bulk (Just bulkData)) = maybe (Left r) Right $ do + infos <- mapM parseNodeInfo $ Char8.lines bulkData + return $ ClusterNodesResponse infos where + parseNodeInfo :: ByteString -> Maybe ClusterNodesResponseEntry + parseNodeInfo line = case Char8.words line of + (nodeId : hostNamePort : flags : masterNodeId : pingSent : pongRecv : epoch : linkState : slots) -> + case Char8.split ':' hostNamePort of + [hostName, port] -> ClusterNodesResponseEntry <$> pure nodeId + <*> pure hostName + <*> readInteger port + <*> pure (Char8.split ',' flags) + <*> pure (readMasterNodeId masterNodeId) + <*> readInteger pingSent + <*> readInteger pongRecv + <*> readInteger epoch + <*> pure linkState + <*> (pure . catMaybes $ map readNodeSlot slots) + _ -> Nothing + _ -> Nothing + readInteger :: ByteString -> Maybe Integer + readInteger = fmap fst . Char8.readInteger + + readMasterNodeId :: ByteString -> Maybe ByteString + readMasterNodeId "-" = Nothing + readMasterNodeId nodeId = Just nodeId + + readNodeSlot :: ByteString -> Maybe ClusterNodesResponseSlotSpec + readNodeSlot slotSpec = case '[' `Char8.elem` slotSpec of + True -> readSlotImportMigrate slotSpec + False -> case '-' `Char8.elem` slotSpec of + True -> readSlotRange slotSpec + False -> ClusterNodesResponseSingleSlot <$> readInteger slotSpec + readSlotImportMigrate :: ByteString -> Maybe ClusterNodesResponseSlotSpec + readSlotImportMigrate slotSpec = case BS.breakSubstring "->-" slotSpec of + (_, "") -> case BS.breakSubstring "-<-" slotSpec of + (_, "") -> Nothing + (leftPart, rightPart) -> ClusterNodesResponseSlotImporting + <$> (readInteger $ Char8.drop 1 leftPart) + <*> (pure $ BS.take (BS.length rightPart - 1) rightPart) + (leftPart, rightPart) -> ClusterNodesResponseSlotMigrating + <$> (readInteger $ Char8.drop 1 leftPart) + <*> (pure $ BS.take (BS.length rightPart - 1) rightPart) + readSlotRange :: ByteString -> Maybe ClusterNodesResponseSlotSpec + readSlotRange slotSpec = case BS.breakSubstring "-" slotSpec of + (_, "") -> Nothing + (leftPart, rightPart) -> ClusterNodesResponseSlotRange + <$> readInteger leftPart + <*> (readInteger $ BS.drop 1 rightPart) + + decode r = Left r + +clusterNodes + :: (RedisCtx m f) + => m (f ClusterNodesResponse) +clusterNodes = sendRequest $ ["CLUSTER", "NODES"] + +data ClusterSlotsResponse = ClusterSlotsResponse { clusterSlotsResponseEntries :: [ClusterSlotsResponseEntry] } deriving (Show) + +data ClusterSlotsNode = ClusterSlotsNode + { clusterSlotsNodeIP :: ByteString + , clusterSlotsNodePort :: Int + , clusterSlotsNodeID :: ByteString + } deriving (Show) + +data ClusterSlotsResponseEntry = ClusterSlotsResponseEntry + { clusterSlotsResponseEntryStartSlot :: Int + , clusterSlotsResponseEntryEndSlot :: Int + , clusterSlotsResponseEntryMaster :: ClusterSlotsNode + , clusterSlotsResponseEntryReplicas :: [ClusterSlotsNode] + } deriving (Show) + +instance RedisResult ClusterSlotsResponse where + decode (MultiBulk (Just bulkData)) = do + clusterSlotsResponseEntries <- mapM decode bulkData + return ClusterSlotsResponse{..} + decode a = Left a + +instance RedisResult ClusterSlotsResponseEntry where + decode (MultiBulk (Just + ((Integer startSlot):(Integer endSlot):masterData:replicas))) = do + clusterSlotsResponseEntryMaster <- decode masterData + clusterSlotsResponseEntryReplicas <- mapM decode replicas + let clusterSlotsResponseEntryStartSlot = fromInteger startSlot + let clusterSlotsResponseEntryEndSlot = fromInteger endSlot + return ClusterSlotsResponseEntry{..} + decode a = Left a + +instance RedisResult ClusterSlotsNode where + decode (MultiBulk (Just ((Bulk (Just clusterSlotsNodeIP)):(Integer port):(Bulk (Just clusterSlotsNodeID)):_))) = Right ClusterSlotsNode{..} + where clusterSlotsNodePort = fromInteger port + decode a = Left a + + +clusterSlots + :: (RedisCtx m f) + => m (f ClusterSlotsResponse) +clusterSlots = sendRequest $ ["CLUSTER", "SLOTS"] + +clusterSetSlotImporting + :: (RedisCtx m f) + => Integer + -> ByteString + -> m (f Status) +clusterSetSlotImporting slot sourceNodeId = sendRequest $ ["CLUSTER", "SETSLOT", (encode slot), "IMPORTING", sourceNodeId] + +clusterSetSlotMigrating + :: (RedisCtx m f) + => Integer + -> ByteString + -> m (f Status) +clusterSetSlotMigrating slot destinationNodeId = sendRequest $ ["CLUSTER", "SETSLOT", (encode slot), "MIGRATING", destinationNodeId] + +clusterSetSlotStable + :: (RedisCtx m f) + => Integer + -> m (f Status) +clusterSetSlotStable slot = sendRequest $ ["CLUSTER", "SETSLOT", "STABLE", (encode slot)] + +clusterSetSlotNode + :: (RedisCtx m f) + => Integer + -> ByteString + -> m (f Status) +clusterSetSlotNode slot node = sendRequest ["CLUSTER", "SETSLOT", (encode slot), "NODE", node] + +clusterGetKeysInSlot + :: (RedisCtx m f) + => Integer + -> Integer + -> m (f [ByteString]) +clusterGetKeysInSlot slot count = sendRequest ["CLUSTER", "GETKEYSINSLOT", (encode slot), (encode count)] diff --git a/src/Database/Redis/ProtocolPipelining.hs b/src/Database/Redis/ProtocolPipelining.hs index 134aa796..1e0ea83e 100644 --- a/src/Database/Redis/ProtocolPipelining.hs +++ b/src/Database/Redis/ProtocolPipelining.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -19,37 +17,22 @@ module Database.Redis.ProtocolPipelining ( Connection, connect, enableTLS, beginReceiving, disconnect, request, send, recv, flush, - ConnectionLostException(..), - PortID(..) ) where import Prelude -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (race) -import Control.Concurrent.MVar -import Control.Exception import Control.Monad import qualified Scanner import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L import Data.IORef -import Data.Typeable import qualified Network.Socket as NS import qualified Network.TLS as TLS -import System.IO -import System.IO.Error import System.IO.Unsafe import Database.Redis.Protocol - -data PortID = PortNumber NS.PortNumber - | UnixSocket String - deriving Show - -data ConnectionContext = NormalHandle Handle | TLSContext TLS.Context +import qualified Database.Redis.ConnectionContext as CC data Connection = Conn - { connCtx :: ConnectionContext -- ^ Connection socket-handle. + { connCtx :: CC.ConnectionContext -- ^ Connection socket-handle. , connReplies :: IORef [Reply] -- ^ Reply thunks for unsent requests. , connPending :: IORef [Reply] -- ^ Reply thunks for requests "in the pipeline". Refers to the same list as @@ -60,92 +43,19 @@ data Connection = Conn -- length connPending - pendingCount = length connReplies } -data ConnectionLostException = ConnectionLost - deriving (Show, Typeable) - -instance Exception ConnectionLostException - -data ConnectPhase - = PhaseUnknown - | PhaseResolve - | PhaseOpenSocket - deriving (Show) -data ConnectTimeout = ConnectTimeout ConnectPhase - deriving (Show, Typeable) - -instance Exception ConnectTimeout - -getHostAddrInfo :: NS.HostName -> NS.PortNumber -> IO [NS.AddrInfo] -getHostAddrInfo hostname port = do - NS.getAddrInfo (Just hints) (Just hostname) (Just $ show port) - where - hints = NS.defaultHints - { NS.addrSocketType = NS.Stream } - -connectSocket :: [NS.AddrInfo] -> IO NS.Socket -connectSocket [] = error "connectSocket: unexpected empty list" -connectSocket (addr:rest) = tryConnect >>= \case - Right sock -> return sock - Left err -> if null rest - then throwIO err - else connectSocket rest - where - tryConnect :: IO (Either IOError NS.Socket) - tryConnect = bracketOnError createSock NS.close $ \sock -> do - try (NS.connect sock $ NS.addrAddress addr) >>= \case - Right () -> return (Right sock) - Left err -> return (Left err) - where - createSock = NS.socket (NS.addrFamily addr) - (NS.addrSocketType addr) - (NS.addrProtocol addr) - -connect :: NS.HostName -> PortID -> Maybe Int -> IO Connection -connect hostName portId timeoutOpt = - bracketOnError hConnect hClose $ \h -> do - hSetBinaryMode h True +connect :: NS.HostName -> CC.PortID -> Maybe Int -> IO Connection +connect hostName portId timeoutOpt = do + connCtx <- CC.connect hostName portId timeoutOpt connReplies <- newIORef [] connPending <- newIORef [] connPendingCnt <- newIORef 0 - let connCtx = NormalHandle h return Conn{..} - where - hConnect = do - phaseMVar <- newMVar PhaseUnknown - let doConnect = hConnect' phaseMVar - case timeoutOpt of - Nothing -> doConnect - Just micros -> do - result <- race doConnect (threadDelay micros) - case result of - Left h -> return h - Right () -> do - phase <- readMVar phaseMVar - errConnectTimeout phase - hConnect' mvar = bracketOnError createSock NS.close $ \sock -> do - NS.setSocketOption sock NS.KeepAlive 1 - void $ swapMVar mvar PhaseResolve - void $ swapMVar mvar PhaseOpenSocket - NS.socketToHandle sock ReadWriteMode - where - createSock = case portId of - PortNumber portNumber -> do - addrInfo <- getHostAddrInfo hostName portNumber - connectSocket addrInfo - UnixSocket addr -> bracketOnError - (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol) - NS.close - (\sock -> NS.connect sock (NS.SockAddrUnix addr) >> return sock) enableTLS :: TLS.ClientParams -> Connection -> IO Connection enableTLS tlsParams conn@Conn{..} = do - case connCtx of - NormalHandle h -> do - ctx <- TLS.contextNew h tlsParams - TLS.handshake ctx - return $ conn { connCtx = TLSContext ctx } - TLSContext _ -> return conn + newCtx <- CC.enableTLS tlsParams connCtx + return conn{connCtx = newCtx} beginReceiving :: Connection -> IO () beginReceiving conn = do @@ -154,25 +64,13 @@ beginReceiving conn = do writeIORef (connPending conn) rs disconnect :: Connection -> IO () -disconnect Conn{..} = do - case connCtx of - NormalHandle h -> do - open <- hIsOpen h - when open $ hClose h - TLSContext ctx -> do - TLS.bye ctx - TLS.contextClose ctx +disconnect Conn{..} = CC.disconnect connCtx -- |Write the request to the socket output buffer, without actually sending. -- The 'Handle' is 'hFlush'ed when reading replies from the 'connCtx'. send :: Connection -> S.ByteString -> IO () send Conn{..} s = do - case connCtx of - NormalHandle h -> - ioErrorToConnLost $ S.hPut h s - - TLSContext ctx -> - ioErrorToConnLost $ TLS.sendData ctx (L.fromStrict s) + CC.send connCtx s -- Signal that we expect one more reply from Redis. n <- atomicModifyIORef' connPendingCnt $ \n -> let n' = n+1 in (n', n') @@ -195,10 +93,7 @@ recv Conn{..} = do -- for the multithreaded pub/sub code, the sending thread needs to explicitly flush the subscription -- change requests. flush :: Connection -> IO () -flush Conn{..} = - case connCtx of - NormalHandle h -> hFlush h - TLSContext ctx -> TLS.contextFlush ctx +flush Conn{..} = CC.flush connCtx -- |Send a request and receive the corresponding reply request :: Connection -> S.ByteString -> IO Reply @@ -226,7 +121,7 @@ connGetReplies conn@Conn{..} = go S.empty (SingleLine "previous of first") previous `seq` return () scanResult <- Scanner.scanWith readMore reply rest case scanResult of - Scanner.Fail{} -> errConnClosed + Scanner.Fail{} -> CC.errConnClosed Scanner.More{} -> error "Hedis: parseWith returned Partial" Scanner.Done rest' r -> do -- r is the same as 'head' of 'connPending'. Since we just @@ -239,17 +134,6 @@ connGetReplies conn@Conn{..} = go S.empty (SingleLine "previous of first") rs <- unsafeInterleaveIO (go rest' r) return (r:rs) - readMore = ioErrorToConnLost $ do + readMore = CC.ioErrorToConnLost $ do flush conn - case connCtx of - NormalHandle h -> S.hGetSome h 4096 - TLSContext ctx -> TLS.recvData ctx - -ioErrorToConnLost :: IO a -> IO a -ioErrorToConnLost a = a `catchIOError` const errConnClosed - -errConnClosed :: IO a -errConnClosed = throwIO ConnectionLost - -errConnectTimeout :: ConnectPhase -> IO a -errConnectTimeout phase = throwIO $ ConnectTimeout phase + CC.recv connCtx diff --git a/src/Database/Redis/PubSub.hs b/src/Database/Redis/PubSub.hs index 489e2506..1c5783fc 100644 --- a/src/Database/Redis/PubSub.hs +++ b/src/Database/Redis/PubSub.hs @@ -36,6 +36,7 @@ import Data.Pool import Data.Semigroup (Semigroup(..)) import qualified Data.HashMap.Strict as HM import qualified Database.Redis.Core as Core +import qualified Database.Redis.Connection as Connection import qualified Database.Redis.ProtocolPipelining as PP import Database.Redis.Protocol (Reply(..), renderRequest) import Database.Redis.Types @@ -558,13 +559,13 @@ sendThread ctrl rawConn = forever $ do -- and then create a Haskell thread bound to each capability each calling 'pubSubForever' in a loop. -- This will create one network connection per controller/capability and allow you to -- register separate channels and callbacks for each controller, spreading the load across the capabilities. -pubSubForever :: Core.Connection -- ^ The connection pool +pubSubForever :: Connection.Connection -- ^ The connection pool -> PubSubController -- ^ The controller which keeps track of all subscriptions and handlers -> IO () -- ^ This action is executed once Redis acknowledges that all the subscriptions in -- the controller are now subscribed. You can use this after an exception (such as -- 'ConnectionLost') to signal that all subscriptions are now reactivated. -> IO () -pubSubForever (Core.Conn pool) ctrl onInitialLoad = withResource pool $ \rawConn -> do +pubSubForever (Connection.NonClusteredConnection pool) ctrl onInitialLoad = withResource pool $ \rawConn -> do -- get initial subscriptions and write them into the queue. atomically $ do let loop = tryReadTBQueue (sendChanges ctrl) >>= @@ -595,6 +596,7 @@ pubSubForever (Core.Conn pool) ctrl onInitialLoad = withResource pool $ \rawConn (Right (Left err)) -> throwIO err (Left (Left err)) -> throwIO err _ -> return () -- should never happen, since threads exit only with an error +pubSubForever (Connection.ClusteredConnection _) _ _ = undefined ------------------------------------------------------------------------------ diff --git a/src/Database/Redis/URL.hs b/src/Database/Redis/URL.hs index 4e5627dd..6541ce7f 100644 --- a/src/Database/Redis/URL.hs +++ b/src/Database/Redis/URL.hs @@ -9,8 +9,8 @@ import Control.Applicative ((<$>)) import Control.Error.Util (note) import Control.Monad (guard) import Data.Monoid ((<>)) -import Database.Redis.Core (ConnectInfo(..), defaultConnectInfo) -import Database.Redis.ProtocolPipelining +import Database.Redis.Connection (ConnectInfo(..), defaultConnectInfo) +import qualified Database.Redis.ConnectionContext as CC import Network.HTTP.Base import Network.URI (parseURI, uriPath, uriScheme) import Text.Read (readMaybe) @@ -57,7 +57,7 @@ parseConnectInfo url = do { connectHost = if null h then connectHost defaultConnectInfo else h - , connectPort = maybe (connectPort defaultConnectInfo) (PortNumber . fromIntegral) (port uriAuth) + , connectPort = maybe (connectPort defaultConnectInfo) (CC.PortNumber . fromIntegral) (port uriAuth) , connectAuth = C8.pack <$> password uriAuth , connectDatabase = db } diff --git a/stack.yaml b/stack.yaml index 265cfa11..bfa11f28 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,6 +2,7 @@ resolver: lts-13.21 packages: - '.' extra-deps: + - crc16-0.1.0 flags: hedis: dev: true From c3c67fb2d3b8dda68957efa2a46acd7e95dad0cc Mon Sep 17 00:00:00 2001 From: Alex Good Date: Sat, 14 Dec 2019 18:58:06 +0000 Subject: [PATCH 002/103] Add messy clustered pipelining implementation --- hedis.cabal | 3 +- src/Database/Redis/Cluster.hs | 226 +++++++++++++++++------ src/Database/Redis/Connection.hs | 41 ++-- src/Database/Redis/Core.hs | 16 +- src/Database/Redis/ProtocolPipelining.hs | 6 +- src/Database/Redis/PubSub.hs | 2 +- 6 files changed, 214 insertions(+), 80 deletions(-) diff --git a/hedis.cabal b/hedis.cabal index 52f5e1c5..5d31e201 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -87,7 +87,8 @@ library HTTP, errors, network-uri, - crc16 == 0.1.0 + crc16 == 0.1.0, + say if !impl(ghc >= 8.0) build-depends: semigroups >= 0.11 && < 0.19 diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index f9a93718..3ad2139e 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -1,16 +1,19 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} module Database.Redis.Cluster ( Connection(..) , NodeRole(..) + , NodeConnection(..) , Node(..) , ShardMap(..) , HashSlot , Shard(..) , connect - , request + , disconnect + --, request + , requestPipelined , nodes ) where @@ -18,30 +21,42 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as Char8 import qualified Data.IORef as IOR import Data.Maybe(listToMaybe) -import Control.Exception(Exception, throwIO) +import Data.List(nub, sortBy) +import Data.Map(fromListWith, assocs) +import Data.Function(on) +import Control.Exception(Exception, throwIO, BlockedIndefinitelyOnMVar(..), catches, Handler(..)) +import Control.Concurrent.MVar(MVar, newMVar, readMVar, modifyMVar, modifyMVar_) +import Control.Monad(zipWithM, when) import Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot) import qualified Database.Redis.ConnectionContext as CC +import qualified Data.HashMap.Strict as HM import qualified Data.IntMap.Strict as IntMap import Data.Typeable -import qualified Network.Socket as NS import qualified Scanner +import System.IO.Unsafe(unsafeInterleaveIO) +import Say(sayString) import Database.Redis.Protocol(Reply(Error), renderRequest, reply) -data Connection = Connection - { ctx :: CC.ConnectionContext - , lastRecvRef :: IOR.IORef (Maybe B.ByteString) } +data NodeConnection = NodeConnection CC.ConnectionContext (IOR.IORef (Maybe B.ByteString)) NodeID -instance Show Connection where - show Connection{..} = "Connection{ ctx = " <> show ctx <> ", lastRecvRef = IORef}" +instance Eq NodeConnection where + (NodeConnection _ _ id1) == (NodeConnection _ _ id2) = id1 == id2 -data NodeRole = Master | Slave deriving (Show) +instance Ord NodeConnection where + compare (NodeConnection _ _ id1) (NodeConnection _ _ id2) = compare id1 id2 + +data PipelineState = Pending [[B.ByteString]] | Evaluated [Reply] +newtype Pipeline = Pipeline (MVar PipelineState) +data Connection = Connection (HM.HashMap NodeID NodeConnection) (MVar Pipeline) + +data NodeRole = Master | Slave deriving (Show, Eq, Ord) type Host = String type Port = Int type NodeID = B.ByteString -data Node = Node NodeID NodeRole Connection Host Port deriving (Show) +data Node = Node NodeID NodeRole Host Port deriving (Show, Eq, Ord) type MasterNode = Node type SlaveNode = Node @@ -53,37 +68,101 @@ newtype MissingNodeException = MissingNodeException [B.ByteString] deriving (Sho instance Exception MissingNodeException -connect :: NS.HostName -> NS.PortNumber -> Maybe Int -> IO Connection -connect hostName portNumber timeoutOpt = do - ctx <- CC.connect hostName (CC.PortNumber portNumber) timeoutOpt - lastRecvRef <- IOR.newIORef Nothing - return Connection{..} - - -request :: IOR.IORef ShardMap -> (() -> IO ShardMap) -> [B.ByteString] -> IO Reply -request shardMapRef refreshShardMap requestData = do - shardMap <- IOR.readIORef shardMapRef - let maybeNode = nodeForCommand shardMap requestData - case maybeNode of - Nothing -> throwIO $ MissingNodeException requestData - Just node -> do - resp <- requestNode node (renderRequest requestData) - case resp of - (Error errString) | B.isPrefixOf "MOVED" errString -> do - newShardMap <- refreshShardMap () - IOR.writeIORef shardMapRef newShardMap - request shardMapRef refreshShardMap requestData - (askingRedirection -> Just (host, port)) -> do - let maybeAskNode = nodeWithHostAndPort shardMap host port - case maybeAskNode of - Just askNode -> do - _ <- requestNode askNode (renderRequest ["ASKING"]) - requestNode askNode (renderRequest requestData) - Nothing -> do - newShardMap <- refreshShardMap () - IOR.writeIORef shardMapRef newShardMap - request shardMapRef refreshShardMap requestData - _ -> return resp + +connect :: ShardMap -> Maybe Int -> IO Connection +connect shardMap timeoutOpt = do + stateVar <- newMVar $ Pending [] + pipelineVar <- newMVar $ Pipeline stateVar + nodeConns <- nodeConnections + return $ Connection nodeConns pipelineVar where + nodeConnections :: IO (HM.HashMap NodeID NodeConnection) + nodeConnections = HM.fromList <$> mapM connectNode (nub $ nodes shardMap) + connectNode :: Node -> IO (NodeID, NodeConnection) + connectNode (Node n _ host port) = do + ctx <- CC.connect host (CC.PortNumber $ toEnum port) timeoutOpt + ref <- IOR.newIORef Nothing + return (n, NodeConnection ctx ref n) + +disconnect :: Connection -> IO () +disconnect (Connection nodeConnMap _) = mapM_ disconnectNode (HM.elems nodeConnMap) where + disconnectNode (NodeConnection nodeCtx _ _) = CC.disconnect nodeCtx + + +requestPipelined :: MVar ShardMap -> IO ShardMap -> Connection -> [B.ByteString] -> IO Reply +requestPipelined shardMapVar refreshAction conn@(Connection _ pipelineVar) nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do + (newStateVar, repliesIndex) <- hasLocked "locked adding to pipeline" $ modifyMVar stateVar $ \case + Pending requests -> return (Pending (nextRequest:requests), (stateVar, length requests)) + e@(Evaluated _) -> do + s' <- newMVar $ Pending [nextRequest] + return (e, (s', 0)) + evaluateAction <- unsafeInterleaveIO $ do + replies <- hasLocked "locked evaluating replies" $ modifyMVar newStateVar $ \case + Evaluated replies -> return (Evaluated replies, replies) + Pending requests-> do + replies <- evaluatePipeline shardMapVar refreshAction conn requests + return (Evaluated replies, replies) + return $ replies !! repliesIndex + return (Pipeline newStateVar, evaluateAction) + + + +data PendingRequest = PendingRequest Int [B.ByteString] +data CompletedRequest = CompletedRequest Int [B.ByteString] Reply + +rawRequest :: PendingRequest -> [B.ByteString] +rawRequest (PendingRequest _ r) = r + +responseIndex :: CompletedRequest -> Int +responseIndex (CompletedRequest i _ _) = i + +rawResponse :: CompletedRequest -> Reply +rawResponse (CompletedRequest _ _ r) = r + +requestForResponse :: CompletedRequest -> [B.ByteString] +requestForResponse (CompletedRequest _ r _) = r + +evaluatePipeline :: MVar ShardMap -> IO ShardMap -> Connection -> [[B.ByteString]] -> IO [Reply] +evaluatePipeline shardMapVar refreshShardmapAction conn requests = do + shardMap <- hasLocked "reading shardmap in evaluatePipeline" $ readMVar shardMapVar + requestsByNode <- getRequestsByNode shardMap + resps <- concat <$> mapM (uncurry executeRequests) requestsByNode + _ <- when (any (moved . rawResponse) resps) (refreshShardMapVar "locked refreshing due to moved responses") + retriedResps <- mapM (retry 0) resps + return $ map rawResponse $ sortBy (on compare responseIndex) retriedResps where + getRequestsByNode :: ShardMap -> IO [(NodeConnection, [PendingRequest])] + getRequestsByNode shardMap = do + commandsWithNodes <- zipWithM (requestWithNode shardMap) [0..] (reverse requests) + return $ assocs $ fromListWith (++) commandsWithNodes + requestWithNode :: ShardMap -> Int -> [B.ByteString] -> IO (NodeConnection, [PendingRequest]) + requestWithNode shardMap index request = do + nodeConn <- nodeConnectionForCommandOrThrow shardMap conn request + return (nodeConn, [PendingRequest index request]) + executeRequests :: NodeConnection -> [PendingRequest] -> IO [CompletedRequest] + executeRequests nodeConn nodeRequests = do + replies <- requestNode nodeConn $ map rawRequest nodeRequests + return $ map (\(PendingRequest i r, rep) -> CompletedRequest i r rep) (zip nodeRequests replies) + retry :: Int -> CompletedRequest -> IO CompletedRequest + retry retryCount resp@(CompletedRequest index request thisReply) = do + retryReply <- case thisReply of + (Error errString) | B.isPrefixOf "MOVED" errString -> do + shardMap <- hasLocked "reading shard map in retry MOVED" $ readMVar shardMapVar + nodeConn <- nodeConnectionForCommandOrThrow shardMap conn (requestForResponse resp) + head <$> requestNode nodeConn [request] + (askingRedirection -> Just (host, port)) -> do + shardMap <- hasLocked "reading shardmap in retry ASK" $ readMVar shardMapVar + let maybeAskNode = nodeConnWithHostAndPort shardMap conn host port + case maybeAskNode of + Just askNode -> last <$> requestNode askNode [["ASKING"], requestForResponse resp] + Nothing -> case retryCount of + 0 -> do + _ <- refreshShardMapVar "missing node in first retry of ASK" + rawResponse <$> retry (retryCount + 1) resp + _ -> throwIO $ MissingNodeException (requestForResponse resp) + _ -> return thisReply + return (CompletedRequest index request retryReply) + refreshShardMapVar :: String -> IO () + refreshShardMapVar msg = hasLocked msg $ modifyMVar_ shardMapVar (const refreshShardmapAction) + askingRedirection :: Reply -> Maybe (Host, Port) askingRedirection (Error errString) = case Char8.words errString of @@ -95,6 +174,23 @@ askingRedirection (Error errString) = case Char8.words errString of _ -> Nothing askingRedirection _ = Nothing +moved :: Reply -> Bool +moved (Error errString) = case Char8.words errString of + "MOVED":_ -> True + _ -> False +moved _ = False + + +nodeConnWithHostAndPort :: ShardMap -> Connection -> Host -> Port -> Maybe NodeConnection +nodeConnWithHostAndPort shardMap (Connection nodeConns _) host port = do + node <- nodeWithHostAndPort shardMap host port + HM.lookup (nodeId node) nodeConns + +nodeConnectionForCommandOrThrow :: ShardMap -> Connection -> [B.ByteString] -> IO NodeConnection +nodeConnectionForCommandOrThrow shardMap (Connection nodeConns _) command = maybe (throwIO $ MissingNodeException command) return maybeNode where + maybeNode = do + node <- nodeForCommand shardMap command + HM.lookup (nodeId node) nodeConns nodeForCommand :: ShardMap -> [B.ByteString] -> Maybe Node nodeForCommand (ShardMap shards) (_:key:_) = do @@ -102,21 +198,30 @@ nodeForCommand (ShardMap shards) (_:key:_) = do Just master nodeForCommand _ _ = Nothing -requestNode :: Node -> B.ByteString -> IO Reply -requestNode (Node _ _ Connection{..} _ _) requestData = do - _ <- CC.send ctx requestData >> CC.flush ctx - maybeLastRecv <- IOR.readIORef lastRecvRef - scanResult <- case maybeLastRecv of - Just lastRecv -> Scanner.scanWith (CC.recv ctx) reply lastRecv - Nothing -> Scanner.scanWith (CC.recv ctx) reply B.empty +requestNode :: NodeConnection -> [[B.ByteString]] -> IO [Reply] +requestNode (NodeConnection ctx lastRecvRef _) requests = do + _ <- mapM_ (sendNode . renderRequest) requests + _ <- CC.flush ctx + sequence $ take (length requests) (repeat recvNode) + + where + + sendNode :: B.ByteString -> IO () + sendNode = CC.send ctx + recvNode :: IO Reply + recvNode = do + maybeLastRecv <- IOR.readIORef lastRecvRef + scanResult <- case maybeLastRecv of + Just lastRecv -> Scanner.scanWith (CC.recv ctx) reply lastRecv + Nothing -> Scanner.scanWith (CC.recv ctx) reply B.empty - case scanResult of - Scanner.Fail{} -> CC.errConnClosed - Scanner.More{} -> error "Hedis: parseWith returned Partial" - Scanner.Done rest' r -> do - IOR.writeIORef lastRecvRef (Just rest') - return r + case scanResult of + Scanner.Fail{} -> CC.errConnClosed + Scanner.More{} -> error "Hedis: parseWith returned Partial" + Scanner.Done rest' r -> do + IOR.writeIORef lastRecvRef (Just rest') + return r nodes :: ShardMap -> [Node] nodes (ShardMap shardMap) = concatMap snd $ IntMap.toList $ fmap shardNodes shardMap where @@ -125,4 +230,13 @@ nodes (ShardMap shardMap) = concatMap snd $ IntMap.toList $ fmap shardNodes shar nodeWithHostAndPort :: ShardMap -> Host -> Port -> Maybe Node -nodeWithHostAndPort shardMap host port = listToMaybe $ filter (\(Node _ _ _ nodeHost nodePort) -> port == nodePort && host == nodeHost) $ nodes shardMap +nodeWithHostAndPort shardMap host port = listToMaybe $ filter (\(Node _ _ nodeHost nodePort) -> port == nodePort && host == nodeHost) $ nodes shardMap + +nodeId :: Node -> NodeID +nodeId (Node theId _ _ _) = theId + +hasLocked :: String -> IO a -> IO a +hasLocked msg action = + action `catches` + [ Handler $ \exc@BlockedIndefinitelyOnMVar -> sayString ("[MVar]: " ++ msg) >> throwIO exc + ] diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs index 6074e5ee..a278f3fa 100644 --- a/src/Database/Redis/Connection.hs +++ b/src/Database/Redis/Connection.hs @@ -6,16 +6,17 @@ module Database.Redis.Connection where import Control.Exception import Control.Monad.IO.Class(liftIO) import Control.Monad(when) +import Control.Concurrent.MVar(MVar, newMVar) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as Char8 import Data.Functor(void) import qualified Data.IntMap.Strict as IntMap import Data.Pool(Pool, withResource, createPool, destroyAllResources) import Data.Typeable -import qualified Data.IORef as IOR import qualified Data.Time as Time import Network.TLS (ClientParams) import qualified Network.Socket as NS +import qualified Data.HashMap.Strict as HM import qualified Database.Redis.ProtocolPipelining as PP import Database.Redis.Core(Redis, runRedisInternal, runRedisClusteredInternal) @@ -23,6 +24,7 @@ import Database.Redis.Protocol(Reply(..)) import Database.Redis.Cluster(ShardMap(..), Node, Shard(..)) import qualified Database.Redis.Cluster as Cluster import qualified Database.Redis.ConnectionContext as CC +--import qualified Database.Redis.Cluster.Pipeline as ClusterPipeline import Database.Redis.Commands ( ping , select @@ -40,7 +42,7 @@ import Database.Redis.Commands -- 'connect' function to create one. data Connection = NonClusteredConnection (Pool PP.Connection) - | ClusteredConnection (IOR.IORef ShardMap) + | ClusteredConnection (MVar ShardMap) (Pool Cluster.Connection) -- |Information for connnecting to a Redis server. -- @@ -157,7 +159,7 @@ checkedConnect connInfo = do -- |Destroy all idle resources in the pool. disconnect :: Connection -> IO () disconnect (NonClusteredConnection pool) = destroyAllResources pool -disconnect (ClusteredConnection _) = return () +disconnect (ClusteredConnection _ pool) = destroyAllResources pool -- | Memory bracket around 'connect' and 'disconnect'. withConnect :: ConnectInfo -> (Connection -> IO c) -> IO c @@ -175,7 +177,8 @@ withCheckedConnect connInfo = bracket (checkedConnect connInfo) disconnect runRedis :: Connection -> Redis a -> IO a runRedis (NonClusteredConnection pool) redis = withResource pool $ \conn -> runRedisInternal conn redis -runRedis c@(ClusteredConnection shardMapRef) redis = runRedisClusteredInternal shardMapRef (\() -> refreshShardMap c) redis +runRedis (ClusteredConnection shardMapRef pool) redis = + withResource pool $ \conn -> runRedisClusteredInternal conn shardMapRef (refreshShardMap conn) redis newtype ClusterConnectError = ClusterConnectError Reply deriving (Eq, Show, Typeable) @@ -192,29 +195,33 @@ connectCluster bootstrapConnInfo = do Left e -> throwIO $ ClusterConnectError e Right slots -> do shardMap <- shardMapFromClusterSlotsResponse slots - shardMapRef <- IOR.newIORef shardMap - return $ ClusteredConnection shardMapRef + shardMapRef <- newMVar shardMap + pool <- createPool (Cluster.connect shardMap Nothing) Cluster.disconnect 1 (connectMaxIdleTime bootstrapConnInfo) (connectMaxConnections bootstrapConnInfo) + return $ ClusteredConnection shardMapRef pool shardMapFromClusterSlotsResponse :: ClusterSlotsResponse -> IO ShardMap shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr mkShardMap (pure IntMap.empty) clusterSlotsResponseEntries where mkShardMap :: ClusterSlotsResponseEntry -> IO (IntMap.IntMap Shard) -> IO (IntMap.IntMap Shard) mkShardMap ClusterSlotsResponseEntry{..} accumulator = do accumulated <- accumulator - master <- nodeFromClusterSlotNode True clusterSlotsResponseEntryMaster - replicas <- mapM (nodeFromClusterSlotNode False) clusterSlotsResponseEntryReplicas + let master = nodeFromClusterSlotNode True clusterSlotsResponseEntryMaster + let replicas = map (nodeFromClusterSlotNode False) clusterSlotsResponseEntryReplicas let shard = Shard master replicas let slotMap = IntMap.fromList $ map (, shard) [clusterSlotsResponseEntryStartSlot..clusterSlotsResponseEntryEndSlot] return $ IntMap.union slotMap accumulated - nodeFromClusterSlotNode :: Bool -> ClusterSlotsNode -> IO Node - nodeFromClusterSlotNode isMaster ClusterSlotsNode{..} = do + nodeFromClusterSlotNode :: Bool -> ClusterSlotsNode -> Node + nodeFromClusterSlotNode isMaster ClusterSlotsNode{..} = let hostname = Char8.unpack clusterSlotsNodeIP - conn <- Cluster.connect hostname (toEnum clusterSlotsNodePort) Nothing - let role = if isMaster then Cluster.Master else Cluster.Slave - return $ Cluster.Node clusterSlotsNodeID role conn hostname (toEnum clusterSlotsNodePort) - -refreshShardMap :: Connection -> IO ShardMap -refreshShardMap conn = do - slotsResponse <- runRedis conn clusterSlots + role = if isMaster then Cluster.Master else Cluster.Slave + in + Cluster.Node clusterSlotsNodeID role hostname (toEnum clusterSlotsNodePort) + +refreshShardMap :: Cluster.Connection -> IO ShardMap +refreshShardMap (Cluster.Connection nodeConns _) = do + let (Cluster.NodeConnection ctx _ _) = head $ HM.elems nodeConns + pipelineConn <- PP.fromCtx ctx + _ <- PP.beginReceiving pipelineConn + slotsResponse <- runRedisInternal pipelineConn clusterSlots case slotsResponse of Left e -> throwIO $ ClusterConnectError e Right slots -> shardMapFromClusterSlotsResponse slots diff --git a/src/Database/Redis/Core.hs b/src/Database/Redis/Core.hs index e780080e..041aaf1b 100644 --- a/src/Database/Redis/Core.hs +++ b/src/Database/Redis/Core.hs @@ -19,6 +19,7 @@ import Control.Applicative #endif import Control.Monad.Reader import Control.Monad.Fail(MonadFail) +import Control.Concurrent.MVar(MVar) import qualified Data.ByteString as B import Data.IORef @@ -46,7 +47,11 @@ deriving instance MonadFail Redis data RedisEnv = NonClusteredEnv { envConn :: PP.Connection, envLastReply :: IORef Reply } - | ClusteredEnv { currentShardMap :: IORef ShardMap, refreshAction :: () -> IO ShardMap } + | ClusteredEnv + { currentShardMap :: MVar ShardMap + , refreshAction :: IO ShardMap + , connection :: Cluster.Connection + } -- |This class captures the following behaviour: In a context @m@, a command -- will return its result wrapped in a \"container\" of type @f@. @@ -91,8 +96,11 @@ runRedisInternal conn (Redis redis) = do readIORef ref >>= (`seq` return ()) return r -runRedisClusteredInternal :: IORef ShardMap -> (() -> IO ShardMap) -> Redis a -> IO a -runRedisClusteredInternal shardMapRef refreshShardmapAction (Redis redis) = runReaderT redis (ClusteredEnv shardMapRef refreshShardmapAction) +runRedisClusteredInternal :: Cluster.Connection -> MVar ShardMap -> IO ShardMap -> Redis a -> IO a +runRedisClusteredInternal connection shardMapRef refreshShardmapAction (Redis redis) = do + r <- runReaderT redis (ClusteredEnv shardMapRef refreshShardmapAction connection) + r `seq` return () + return r setLastReply :: Reply -> ReaderT RedisEnv IO () setLastReply r = do @@ -131,5 +139,5 @@ sendRequest req = do r <- liftIO $ PP.request envConn (renderRequest req) setLastReply r return r - ClusteredEnv{..} -> liftIO $ Cluster.request currentShardMap refreshAction req + ClusteredEnv{..} -> liftIO $ Cluster.requestPipelined currentShardMap refreshAction connection req returnDecode r' diff --git a/src/Database/Redis/ProtocolPipelining.hs b/src/Database/Redis/ProtocolPipelining.hs index 1e0ea83e..2989b4f2 100644 --- a/src/Database/Redis/ProtocolPipelining.hs +++ b/src/Database/Redis/ProtocolPipelining.hs @@ -16,7 +16,7 @@ -- module Database.Redis.ProtocolPipelining ( Connection, - connect, enableTLS, beginReceiving, disconnect, request, send, recv, flush, + connect, enableTLS, beginReceiving, disconnect, request, send, recv, flush, fromCtx ) where import Prelude @@ -44,6 +44,10 @@ data Connection = Conn } +fromCtx :: CC.ConnectionContext -> IO Connection +fromCtx ctx = Conn ctx <$> newIORef [] <*> newIORef [] <*> newIORef 0 + + connect :: NS.HostName -> CC.PortID -> Maybe Int -> IO Connection connect hostName portId timeoutOpt = do connCtx <- CC.connect hostName portId timeoutOpt diff --git a/src/Database/Redis/PubSub.hs b/src/Database/Redis/PubSub.hs index 1c5783fc..5c2d3da3 100644 --- a/src/Database/Redis/PubSub.hs +++ b/src/Database/Redis/PubSub.hs @@ -596,7 +596,7 @@ pubSubForever (Connection.NonClusteredConnection pool) ctrl onInitialLoad = with (Right (Left err)) -> throwIO err (Left (Left err)) -> throwIO err _ -> return () -- should never happen, since threads exit only with an error -pubSubForever (Connection.ClusteredConnection _) _ _ = undefined +pubSubForever (Connection.ClusteredConnection _ _) _ _ = undefined ------------------------------------------------------------------------------ From f36caaedae38db6d83632c9f17c498fa86f8f888 Mon Sep 17 00:00:00 2001 From: Alex Good Date: Sat, 14 Dec 2019 19:29:19 +0000 Subject: [PATCH 003/103] Slight cleanup and documentation --- src/Database/Redis/Cluster.hs | 51 +++++++++++++++++++++----------- src/Database/Redis/Connection.hs | 12 ++++---- src/Database/Redis/Core.hs | 12 ++++---- 3 files changed, 44 insertions(+), 31 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 3ad2139e..b1c3fca1 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -38,7 +38,20 @@ import Say(sayString) import Database.Redis.Protocol(Reply(Error), renderRequest, reply) - +-- This modules implements a clustered connection whilst maintaining +-- compatibility with the original Hedis codebase. In particular it still +-- performs implicit pipelining using `unsafeInterleaveIO` as the single node +-- codebase does. To achieve this each connection carries around with it a +-- pipeline of commands. Every time `sendRequest` is called the command is +-- added to the pipeline and an IO action is returned which will, upon being +-- evaluated, execute the entire pipeline. If the pipeline is already executed +-- then it just looks up it's response in the executed pipeline. + +-- | A connection to a redis cluster, it is compoesed of a map from Node IDs to +-- | 'NodeConnection's, a 'Pipeline', and a 'ShardMap' +data Connection = Connection (HM.HashMap NodeID NodeConnection) (MVar Pipeline) (MVar ShardMap) + +-- | A connection to a single node in the cluster, similar to 'ProtocolPipelining.Connection' data NodeConnection = NodeConnection CC.ConnectionContext (IOR.IORef (Maybe B.ByteString)) NodeID instance Eq NodeConnection where @@ -47,9 +60,8 @@ instance Eq NodeConnection where instance Ord NodeConnection where compare (NodeConnection _ _ id1) (NodeConnection _ _ id2) = compare id1 id2 -data PipelineState = Pending [[B.ByteString]] | Evaluated [Reply] +data PipelineState = Pending [[B.ByteString]] | Executed [Reply] newtype Pipeline = Pipeline (MVar PipelineState) -data Connection = Connection (HM.HashMap NodeID NodeConnection) (MVar Pipeline) data NodeRole = Master | Slave deriving (Show, Eq, Ord) @@ -69,14 +81,15 @@ newtype MissingNodeException = MissingNodeException [B.ByteString] deriving (Sho instance Exception MissingNodeException -connect :: ShardMap -> Maybe Int -> IO Connection -connect shardMap timeoutOpt = do +connect :: MVar ShardMap -> Maybe Int -> IO Connection +connect shardMapVar timeoutOpt = do + shardMap <- readMVar shardMapVar stateVar <- newMVar $ Pending [] pipelineVar <- newMVar $ Pipeline stateVar - nodeConns <- nodeConnections - return $ Connection nodeConns pipelineVar where - nodeConnections :: IO (HM.HashMap NodeID NodeConnection) - nodeConnections = HM.fromList <$> mapM connectNode (nub $ nodes shardMap) + nodeConns <- nodeConnections shardMap + return $ Connection nodeConns pipelineVar shardMapVar where + nodeConnections :: ShardMap -> IO (HM.HashMap NodeID NodeConnection) + nodeConnections shardMap = HM.fromList <$> mapM connectNode (nub $ nodes shardMap) connectNode :: Node -> IO (NodeID, NodeConnection) connectNode (Node n _ host port) = do ctx <- CC.connect host (CC.PortNumber $ toEnum port) timeoutOpt @@ -84,23 +97,25 @@ connect shardMap timeoutOpt = do return (n, NodeConnection ctx ref n) disconnect :: Connection -> IO () -disconnect (Connection nodeConnMap _) = mapM_ disconnectNode (HM.elems nodeConnMap) where +disconnect (Connection nodeConnMap _ _) = mapM_ disconnectNode (HM.elems nodeConnMap) where disconnectNode (NodeConnection nodeCtx _ _) = CC.disconnect nodeCtx - -requestPipelined :: MVar ShardMap -> IO ShardMap -> Connection -> [B.ByteString] -> IO Reply -requestPipelined shardMapVar refreshAction conn@(Connection _ pipelineVar) nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do +-- Add a request to the current pipeline for this connection. The pipeline will +-- be executed implicitly as soon as any result returned from this function is +-- evaluated. +requestPipelined :: IO ShardMap -> Connection -> [B.ByteString] -> IO Reply +requestPipelined refreshAction conn@(Connection _ pipelineVar shardMapVar) nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do (newStateVar, repliesIndex) <- hasLocked "locked adding to pipeline" $ modifyMVar stateVar $ \case Pending requests -> return (Pending (nextRequest:requests), (stateVar, length requests)) - e@(Evaluated _) -> do + e@(Executed _) -> do s' <- newMVar $ Pending [nextRequest] return (e, (s', 0)) evaluateAction <- unsafeInterleaveIO $ do replies <- hasLocked "locked evaluating replies" $ modifyMVar newStateVar $ \case - Evaluated replies -> return (Evaluated replies, replies) + Executed replies -> return (Executed replies, replies) Pending requests-> do replies <- evaluatePipeline shardMapVar refreshAction conn requests - return (Evaluated replies, replies) + return (Executed replies, replies) return $ replies !! repliesIndex return (Pipeline newStateVar, evaluateAction) @@ -182,12 +197,12 @@ moved _ = False nodeConnWithHostAndPort :: ShardMap -> Connection -> Host -> Port -> Maybe NodeConnection -nodeConnWithHostAndPort shardMap (Connection nodeConns _) host port = do +nodeConnWithHostAndPort shardMap (Connection nodeConns _ _) host port = do node <- nodeWithHostAndPort shardMap host port HM.lookup (nodeId node) nodeConns nodeConnectionForCommandOrThrow :: ShardMap -> Connection -> [B.ByteString] -> IO NodeConnection -nodeConnectionForCommandOrThrow shardMap (Connection nodeConns _) command = maybe (throwIO $ MissingNodeException command) return maybeNode where +nodeConnectionForCommandOrThrow shardMap (Connection nodeConns _ _) command = maybe (throwIO $ MissingNodeException command) return maybeNode where maybeNode = do node <- nodeForCommand shardMap command HM.lookup (nodeId node) nodeConns diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs index a278f3fa..a3040331 100644 --- a/src/Database/Redis/Connection.hs +++ b/src/Database/Redis/Connection.hs @@ -177,8 +177,8 @@ withCheckedConnect connInfo = bracket (checkedConnect connInfo) disconnect runRedis :: Connection -> Redis a -> IO a runRedis (NonClusteredConnection pool) redis = withResource pool $ \conn -> runRedisInternal conn redis -runRedis (ClusteredConnection shardMapRef pool) redis = - withResource pool $ \conn -> runRedisClusteredInternal conn shardMapRef (refreshShardMap conn) redis +runRedis (ClusteredConnection _ pool) redis = + withResource pool $ \conn -> runRedisClusteredInternal conn (refreshShardMap conn) redis newtype ClusterConnectError = ClusterConnectError Reply deriving (Eq, Show, Typeable) @@ -195,9 +195,9 @@ connectCluster bootstrapConnInfo = do Left e -> throwIO $ ClusterConnectError e Right slots -> do shardMap <- shardMapFromClusterSlotsResponse slots - shardMapRef <- newMVar shardMap - pool <- createPool (Cluster.connect shardMap Nothing) Cluster.disconnect 1 (connectMaxIdleTime bootstrapConnInfo) (connectMaxConnections bootstrapConnInfo) - return $ ClusteredConnection shardMapRef pool + shardMapVar <- newMVar shardMap + pool <- createPool (Cluster.connect shardMapVar Nothing) Cluster.disconnect 1 (connectMaxIdleTime bootstrapConnInfo) (connectMaxConnections bootstrapConnInfo) + return $ ClusteredConnection shardMapVar pool shardMapFromClusterSlotsResponse :: ClusterSlotsResponse -> IO ShardMap shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr mkShardMap (pure IntMap.empty) clusterSlotsResponseEntries where @@ -217,7 +217,7 @@ shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr m Cluster.Node clusterSlotsNodeID role hostname (toEnum clusterSlotsNodePort) refreshShardMap :: Cluster.Connection -> IO ShardMap -refreshShardMap (Cluster.Connection nodeConns _) = do +refreshShardMap (Cluster.Connection nodeConns _ _) = do let (Cluster.NodeConnection ctx _ _) = head $ HM.elems nodeConns pipelineConn <- PP.fromCtx ctx _ <- PP.beginReceiving pipelineConn diff --git a/src/Database/Redis/Core.hs b/src/Database/Redis/Core.hs index 041aaf1b..6281533b 100644 --- a/src/Database/Redis/Core.hs +++ b/src/Database/Redis/Core.hs @@ -19,7 +19,6 @@ import Control.Applicative #endif import Control.Monad.Reader import Control.Monad.Fail(MonadFail) -import Control.Concurrent.MVar(MVar) import qualified Data.ByteString as B import Data.IORef @@ -48,8 +47,7 @@ deriving instance MonadFail Redis data RedisEnv = NonClusteredEnv { envConn :: PP.Connection, envLastReply :: IORef Reply } | ClusteredEnv - { currentShardMap :: MVar ShardMap - , refreshAction :: IO ShardMap + { refreshAction :: IO ShardMap , connection :: Cluster.Connection } @@ -96,9 +94,9 @@ runRedisInternal conn (Redis redis) = do readIORef ref >>= (`seq` return ()) return r -runRedisClusteredInternal :: Cluster.Connection -> MVar ShardMap -> IO ShardMap -> Redis a -> IO a -runRedisClusteredInternal connection shardMapRef refreshShardmapAction (Redis redis) = do - r <- runReaderT redis (ClusteredEnv shardMapRef refreshShardmapAction connection) +runRedisClusteredInternal :: Cluster.Connection -> IO ShardMap -> Redis a -> IO a +runRedisClusteredInternal connection refreshShardmapAction (Redis redis) = do + r <- runReaderT redis (ClusteredEnv refreshShardmapAction connection) r `seq` return () return r @@ -139,5 +137,5 @@ sendRequest req = do r <- liftIO $ PP.request envConn (renderRequest req) setLastReply r return r - ClusteredEnv{..} -> liftIO $ Cluster.requestPipelined currentShardMap refreshAction connection req + ClusteredEnv{..} -> liftIO $ Cluster.requestPipelined refreshAction connection req returnDecode r' From 92dc3df0502c027013bcdd426c503e0d58243595 Mon Sep 17 00:00:00 2001 From: Alex Good Date: Tue, 17 Dec 2019 22:56:19 +0000 Subject: [PATCH 004/103] Add command dispatch logic --- hedis.cabal | 1 + src/Database/Redis/Cluster.hs | 67 ++++++++----- src/Database/Redis/Cluster/Command.hs | 131 ++++++++++++++++++++++++++ src/Database/Redis/Commands.hs | 3 +- src/Database/Redis/Connection.hs | 13 ++- src/Database/Redis/ManualCommands.hs | 4 + 6 files changed, 189 insertions(+), 30 deletions(-) create mode 100644 src/Database/Redis/Cluster/Command.hs diff --git a/hedis.cabal b/hedis.cabal index 5d31e201..465bf2d9 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -97,6 +97,7 @@ library Database.Redis.Connection, Database.Redis.Cluster, Database.Redis.Cluster.HashSlot, + Database.Redis.Cluster.Command, Database.Redis.ProtocolPipelining, Database.Redis.Protocol, Database.Redis.PubSub, diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index b1c3fca1..c4a6e3b3 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -12,7 +12,6 @@ module Database.Redis.Cluster , Shard(..) , connect , disconnect - --, request , requestPipelined , nodes ) where @@ -20,7 +19,7 @@ module Database.Redis.Cluster import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as Char8 import qualified Data.IORef as IOR -import Data.Maybe(listToMaybe) +import Data.Maybe(listToMaybe, mapMaybe) import Data.List(nub, sortBy) import Data.Map(fromListWith, assocs) import Data.Function(on) @@ -37,8 +36,9 @@ import System.IO.Unsafe(unsafeInterleaveIO) import Say(sayString) import Database.Redis.Protocol(Reply(Error), renderRequest, reply) +import qualified Database.Redis.Cluster.Command as CMD --- This modules implements a clustered connection whilst maintaining +-- This module implements a clustered connection whilst maintaining -- compatibility with the original Hedis codebase. In particular it still -- performs implicit pipelining using `unsafeInterleaveIO` as the single node -- codebase does. To achieve this each connection carries around with it a @@ -49,7 +49,7 @@ import Database.Redis.Protocol(Reply(Error), renderRequest, reply) -- | A connection to a redis cluster, it is compoesed of a map from Node IDs to -- | 'NodeConnection's, a 'Pipeline', and a 'ShardMap' -data Connection = Connection (HM.HashMap NodeID NodeConnection) (MVar Pipeline) (MVar ShardMap) +data Connection = Connection (HM.HashMap NodeID NodeConnection) (MVar Pipeline) (MVar ShardMap) CMD.InfoMap -- | A connection to a single node in the cluster, similar to 'ProtocolPipelining.Connection' data NodeConnection = NodeConnection CC.ConnectionContext (IOR.IORef (Maybe B.ByteString)) NodeID @@ -72,22 +72,27 @@ data Node = Node NodeID NodeRole Host Port deriving (Show, Eq, Ord) type MasterNode = Node type SlaveNode = Node -data Shard = Shard MasterNode [SlaveNode] deriving Show +data Shard = Shard MasterNode [SlaveNode] deriving (Show, Eq, Ord) newtype ShardMap = ShardMap (IntMap.IntMap Shard) deriving (Show) newtype MissingNodeException = MissingNodeException [B.ByteString] deriving (Show, Typeable) - instance Exception MissingNodeException +newtype UnsupportedClusterCommandException = UnsupportedClusterCommandException [B.ByteString] deriving (Show, Typeable) +instance Exception UnsupportedClusterCommandException + +newtype CrossSlotException = CrossSlotException [B.ByteString] deriving (Show, Typeable) +instance Exception CrossSlotException -connect :: MVar ShardMap -> Maybe Int -> IO Connection -connect shardMapVar timeoutOpt = do + +connect :: [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> IO Connection +connect commandInfos shardMapVar timeoutOpt = do shardMap <- readMVar shardMapVar stateVar <- newMVar $ Pending [] pipelineVar <- newMVar $ Pipeline stateVar nodeConns <- nodeConnections shardMap - return $ Connection nodeConns pipelineVar shardMapVar where + return $ Connection nodeConns pipelineVar shardMapVar (CMD.newInfoMap commandInfos) where nodeConnections :: ShardMap -> IO (HM.HashMap NodeID NodeConnection) nodeConnections shardMap = HM.fromList <$> mapM connectNode (nub $ nodes shardMap) connectNode :: Node -> IO (NodeID, NodeConnection) @@ -97,14 +102,14 @@ connect shardMapVar timeoutOpt = do return (n, NodeConnection ctx ref n) disconnect :: Connection -> IO () -disconnect (Connection nodeConnMap _ _) = mapM_ disconnectNode (HM.elems nodeConnMap) where +disconnect (Connection nodeConnMap _ _ _) = mapM_ disconnectNode (HM.elems nodeConnMap) where disconnectNode (NodeConnection nodeCtx _ _) = CC.disconnect nodeCtx -- Add a request to the current pipeline for this connection. The pipeline will -- be executed implicitly as soon as any result returned from this function is -- evaluated. requestPipelined :: IO ShardMap -> Connection -> [B.ByteString] -> IO Reply -requestPipelined refreshAction conn@(Connection _ pipelineVar shardMapVar) nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do +requestPipelined refreshAction conn@(Connection _ pipelineVar shardMapVar _) nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do (newStateVar, repliesIndex) <- hasLocked "locked adding to pipeline" $ modifyMVar stateVar $ \case Pending requests -> return (Pending (nextRequest:requests), (stateVar, length requests)) e@(Executed _) -> do @@ -136,6 +141,17 @@ rawResponse (CompletedRequest _ _ r) = r requestForResponse :: CompletedRequest -> [B.ByteString] requestForResponse (CompletedRequest _ r _) = r +-- The approach we take here is similar to that taken by the redis-py-cluster +-- library, which is described at https://redis-py-cluster.readthedocs.io/en/master/pipelines.html +-- +-- Essentially we group all the commands by node (based on the current shardmap) +-- and then execute a pipeline for each node (maintaining the order of commands +-- on a per node basis but not between nodes). Once we've done this, if any of +-- the commands have resulted in a MOVED error we refresh the shard map, then +-- we run through all the responses and retry any MOVED or ASK errors. This retry +-- step is not pipelined, there is a request per error. This is probably +-- acceptable in most cases as these errors should only occur in the case of +-- cluster reconfiguration events, which should be rare. evaluatePipeline :: MVar ShardMap -> IO ShardMap -> Connection -> [[B.ByteString]] -> IO [Reply] evaluatePipeline shardMapVar refreshShardmapAction conn requests = do shardMap <- hasLocked "reading shardmap in evaluatePipeline" $ readMVar shardMapVar @@ -150,7 +166,7 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do return $ assocs $ fromListWith (++) commandsWithNodes requestWithNode :: ShardMap -> Int -> [B.ByteString] -> IO (NodeConnection, [PendingRequest]) requestWithNode shardMap index request = do - nodeConn <- nodeConnectionForCommandOrThrow shardMap conn request + nodeConn <- nodeConnectionForCommand conn shardMap request return (nodeConn, [PendingRequest index request]) executeRequests :: NodeConnection -> [PendingRequest] -> IO [CompletedRequest] executeRequests nodeConn nodeRequests = do @@ -161,7 +177,7 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do retryReply <- case thisReply of (Error errString) | B.isPrefixOf "MOVED" errString -> do shardMap <- hasLocked "reading shard map in retry MOVED" $ readMVar shardMapVar - nodeConn <- nodeConnectionForCommandOrThrow shardMap conn (requestForResponse resp) + nodeConn <- nodeConnectionForCommand conn shardMap (requestForResponse resp) head <$> requestNode nodeConn [request] (askingRedirection -> Just (host, port)) -> do shardMap <- hasLocked "reading shardmap in retry ASK" $ readMVar shardMapVar @@ -197,21 +213,22 @@ moved _ = False nodeConnWithHostAndPort :: ShardMap -> Connection -> Host -> Port -> Maybe NodeConnection -nodeConnWithHostAndPort shardMap (Connection nodeConns _ _) host port = do +nodeConnWithHostAndPort shardMap (Connection nodeConns _ _ _) host port = do node <- nodeWithHostAndPort shardMap host port HM.lookup (nodeId node) nodeConns -nodeConnectionForCommandOrThrow :: ShardMap -> Connection -> [B.ByteString] -> IO NodeConnection -nodeConnectionForCommandOrThrow shardMap (Connection nodeConns _ _) command = maybe (throwIO $ MissingNodeException command) return maybeNode where - maybeNode = do - node <- nodeForCommand shardMap command - HM.lookup (nodeId node) nodeConns - -nodeForCommand :: ShardMap -> [B.ByteString] -> Maybe Node -nodeForCommand (ShardMap shards) (_:key:_) = do - (Shard master _) <- IntMap.lookup (fromEnum $ keyToSlot key) shards - Just master -nodeForCommand _ _ = Nothing +nodeConnectionForCommand :: Connection -> ShardMap -> [B.ByteString] -> IO NodeConnection +nodeConnectionForCommand (Connection nodeConns _ _ infoMap) (ShardMap shardMap) request = do + keys <- case CMD.keysForRequest infoMap request of + Nothing -> throwIO $ UnsupportedClusterCommandException request + Just k -> return k + let shards = nub $ mapMaybe ((flip IntMap.lookup shardMap) . fromEnum . keyToSlot) keys + node <- case shards of + [] -> throwIO $ MissingNodeException request + [Shard master _] -> return master + _ -> throwIO $ CrossSlotException request + maybe (throwIO $ MissingNodeException request) return (HM.lookup (nodeId node) nodeConns) + requestNode :: NodeConnection -> [[B.ByteString]] -> IO [Reply] diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs new file mode 100644 index 00000000..4ec0e03f --- /dev/null +++ b/src/Database/Redis/Cluster/Command.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +module Database.Redis.Cluster.Command where + +import Data.Char(toLower) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.HashMap.Strict as HM +import Database.Redis.Types(RedisResult(decode)) +import Database.Redis.Protocol(Reply(..)) + +data Flag + = Write + | ReadOnly + | DenyOOM + | Admin + | PubSub + | NoScript + | Random + | SortForScript + | Loading + | Stale + | SkipMonitor + | Asking + | Fast + | MovableKeys + | Other BS.ByteString deriving (Show, Eq) + + +data AritySpec = Required Integer | MinimumRequired Integer deriving (Show) + +data LastKeyPositionSpec = LastKeyPosition Integer | UnlimitedKeys deriving (Show) + +newtype InfoMap = InfoMap (HM.HashMap String CommandInfo) + +-- Represents the result of the COMMAND command, which returns information +-- about the position of keys in a request +data CommandInfo = CommandInfo + { name :: BS.ByteString + , arity :: AritySpec + , flags :: [Flag] + , firstKeyPosition :: Integer + , lastKeyPosition :: LastKeyPositionSpec + , stepCount :: Integer + } deriving (Show) + +instance RedisResult CommandInfo where + decode (MultiBulk (Just + [ Bulk (Just commandName) + , Integer aritySpec + , MultiBulk (Just replyFlags) + , Integer firstKeyPos + , Integer lastKeyPos + , Integer replyStepCount])) = do + parsedFlags <- mapM parseFlag replyFlags + lastKey <- parseLastKeyPos + return $ CommandInfo + { name = commandName + , arity = parseArity aritySpec + , flags = parsedFlags + , firstKeyPosition = firstKeyPos + , lastKeyPosition = lastKey + , stepCount = replyStepCount + } where + parseArity int = case int of + i | i >= 0 -> Required i + i -> MinimumRequired $ abs i + parseFlag :: Reply -> Either Reply Flag + parseFlag (SingleLine flag) = return $ case flag of + "write" -> Write + "readonly" -> ReadOnly + "denyoom" -> DenyOOM + "admin" -> Admin + "pubsub" -> PubSub + "noscript" -> NoScript + "random" -> Random + "sort_for_script" -> SortForScript + "loading" -> Loading + "stale" -> Stale + "skip_monitor" -> SkipMonitor + "asking" -> Asking + "fast" -> Fast + "movablekeys" -> MovableKeys + other -> Other other + parseFlag bad = Left bad + parseLastKeyPos :: Either Reply LastKeyPositionSpec + parseLastKeyPos = return $ case lastKeyPos of + i | i == -1 -> UnlimitedKeys + i -> LastKeyPosition i + + decode e = Left e + +newInfoMap :: [CommandInfo] -> InfoMap +newInfoMap = InfoMap . HM.fromList . map (\c -> (Char8.unpack $ name c, c)) + +keysForRequest :: InfoMap -> [BS.ByteString] -> Maybe [BS.ByteString] +keysForRequest (InfoMap infoMap) request@(command:_) = do + info <- HM.lookup (map toLower $ Char8.unpack command) infoMap + if isMovable info then return $ parseMovable request else do + let possibleKeys = case lastKeyPosition info of + LastKeyPosition end -> take (fromEnum $ 1 + end - firstKeyPosition info) $ drop (fromEnum $ firstKeyPosition info) request + UnlimitedKeys -> drop (fromEnum $ firstKeyPosition info) request + return $ takeEvery (fromEnum $ stepCount info) possibleKeys +keysForRequest _ [] = Nothing + +isMovable :: CommandInfo -> Bool +isMovable CommandInfo{..} = MovableKeys `elem` flags + +parseMovable :: [BS.ByteString] -> [BS.ByteString] +parseMovable ("SORT":key:_) = [key] +parseMovable ("EVAL":_:rest) = readNumKeys rest +parseMovable ("EVALSH":_:rest) = readNumKeys rest +parseMovable ("ZUNIONSTORE":_:rest) = readNumKeys rest +parseMovable ("ZINTERSTORE":_:rest) = readNumKeys rest +parseMovable _ = [] + + +readNumKeys :: [BS.ByteString] -> [BS.ByteString] +readNumKeys (rawNumKeys:rest) = case readMaybe (Char8.unpack rawNumKeys) of + Just numKeys -> take numKeys rest + Nothing -> [] +readNumKeys _ = [] + +takeEvery :: Int -> [a] -> [a] +takeEvery n xs = case drop (n-1) xs of + (y:ys) -> y : takeEvery n ys + [] -> [] + +readMaybe :: Read a => String -> Maybe a +readMaybe s = case reads s of + [(val, "")] -> Just val + _ -> Nothing diff --git a/src/Database/Redis/Commands.hs b/src/Database/Redis/Commands.hs index b1dacf49..69f9859e 100644 --- a/src/Database/Redis/Commands.hs +++ b/src/Database/Redis/Commands.hs @@ -273,7 +273,8 @@ clusterSetSlotNode, clusterSetSlotStable, clusterSetSlotImporting, clusterSetSlotMigrating, -clusterGetKeysInSlot +clusterGetKeysInSlot, +command -- * Unimplemented Commands -- |These commands are not implemented, as of now. Library -- users can implement these or other commands from diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs index a3040331..80b2d697 100644 --- a/src/Database/Redis/Connection.hs +++ b/src/Database/Redis/Connection.hs @@ -30,6 +30,7 @@ import Database.Redis.Commands , select , auth , clusterSlots + , command , ClusterSlotsResponse(..) , ClusterSlotsResponseEntry(..) , ClusterSlotsNode(..)) @@ -191,12 +192,16 @@ connectCluster :: ConnectInfo -> IO Connection connectCluster bootstrapConnInfo = do conn <- createConnection bootstrapConnInfo slotsResponse <- runRedisInternal conn clusterSlots - case slotsResponse of + shardMapVar <- case slotsResponse of Left e -> throwIO $ ClusterConnectError e Right slots -> do shardMap <- shardMapFromClusterSlotsResponse slots - shardMapVar <- newMVar shardMap - pool <- createPool (Cluster.connect shardMapVar Nothing) Cluster.disconnect 1 (connectMaxIdleTime bootstrapConnInfo) (connectMaxConnections bootstrapConnInfo) + newMVar shardMap + commandInfos <- runRedisInternal conn command + case commandInfos of + Left e -> throwIO $ ClusterConnectError e + Right infos -> do + pool <- createPool (Cluster.connect infos shardMapVar Nothing) Cluster.disconnect 1 (connectMaxIdleTime bootstrapConnInfo) (connectMaxConnections bootstrapConnInfo) return $ ClusteredConnection shardMapVar pool shardMapFromClusterSlotsResponse :: ClusterSlotsResponse -> IO ShardMap @@ -217,7 +222,7 @@ shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr m Cluster.Node clusterSlotsNodeID role hostname (toEnum clusterSlotsNodePort) refreshShardMap :: Cluster.Connection -> IO ShardMap -refreshShardMap (Cluster.Connection nodeConns _ _) = do +refreshShardMap (Cluster.Connection nodeConns _ _ _) = do let (Cluster.NodeConnection ctx _ _) = head $ HM.elems nodeConns pipelineConn <- PP.fromCtx ctx _ <- PP.beginReceiving pipelineConn diff --git a/src/Database/Redis/ManualCommands.hs b/src/Database/Redis/ManualCommands.hs index c4f67ea7..d7c01d2c 100644 --- a/src/Database/Redis/ManualCommands.hs +++ b/src/Database/Redis/ManualCommands.hs @@ -10,6 +10,7 @@ import Data.Maybe (maybeToList, catMaybes) import Database.Redis.Core import Database.Redis.Protocol import Database.Redis.Types +import qualified Database.Redis.Cluster.Command as CMD objectRefcount @@ -1374,3 +1375,6 @@ clusterGetKeysInSlot -> Integer -> m (f [ByteString]) clusterGetKeysInSlot slot count = sendRequest ["CLUSTER", "GETKEYSINSLOT", (encode slot), (encode count)] + +command :: (RedisCtx m f) => m (f [CMD.CommandInfo]) +command = sendRequest ["COMMAND"] From ce6de8f158e87414cf11bcba4e95d54a9c3185f3 Mon Sep 17 00:00:00 2001 From: Alex Good Date: Wed, 18 Dec 2019 11:34:54 +0000 Subject: [PATCH 005/103] Slightly better handling of missing commands from the COMMAND response --- src/Database/Redis/Cluster/Command.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index 4ec0e03f..1bde0cdf 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -95,7 +95,7 @@ newInfoMap = InfoMap . HM.fromList . map (\c -> (Char8.unpack $ name c, c)) keysForRequest :: InfoMap -> [BS.ByteString] -> Maybe [BS.ByteString] keysForRequest (InfoMap infoMap) request@(command:_) = do info <- HM.lookup (map toLower $ Char8.unpack command) infoMap - if isMovable info then return $ parseMovable request else do + if isMovable info then parseMovable request else do let possibleKeys = case lastKeyPosition info of LastKeyPosition end -> take (fromEnum $ 1 + end - firstKeyPosition info) $ drop (fromEnum $ firstKeyPosition info) request UnlimitedKeys -> drop (fromEnum $ firstKeyPosition info) request @@ -105,20 +105,20 @@ keysForRequest _ [] = Nothing isMovable :: CommandInfo -> Bool isMovable CommandInfo{..} = MovableKeys `elem` flags -parseMovable :: [BS.ByteString] -> [BS.ByteString] -parseMovable ("SORT":key:_) = [key] +parseMovable :: [BS.ByteString] -> Maybe [BS.ByteString] +parseMovable ("SORT":key:_) = Just [key] parseMovable ("EVAL":_:rest) = readNumKeys rest parseMovable ("EVALSH":_:rest) = readNumKeys rest parseMovable ("ZUNIONSTORE":_:rest) = readNumKeys rest parseMovable ("ZINTERSTORE":_:rest) = readNumKeys rest -parseMovable _ = [] +parseMovable _ = Nothing -readNumKeys :: [BS.ByteString] -> [BS.ByteString] -readNumKeys (rawNumKeys:rest) = case readMaybe (Char8.unpack rawNumKeys) of - Just numKeys -> take numKeys rest - Nothing -> [] -readNumKeys _ = [] +readNumKeys :: [BS.ByteString] -> Maybe [BS.ByteString] +readNumKeys (rawNumKeys:rest) = do + numKeys <- readMaybe (Char8.unpack rawNumKeys) + return $ take numKeys rest +readNumKeys _ = Nothing takeEvery :: Int -> [a] -> [a] takeEvery n xs = case drop (n-1) xs of From bec48d343d1bb3e5ebe9554f5876750b5fb01123 Mon Sep 17 00:00:00 2001 From: Alex Good Date: Wed, 26 Feb 2020 11:26:45 +0000 Subject: [PATCH 006/103] WIP --- hedis.cabal | 2 +- src/Database/Redis.hs | 1 + src/Database/Redis/Cluster.hs | 59 +++++++++++++++++--- src/Database/Redis/Cluster/Command.hs | 3 +- src/Database/Redis/Connection.hs | 6 +-- src/Database/Redis/Core.hs | 35 ++++++++++-- test/Test.hs | 78 +++++++++++++++++++-------- 7 files changed, 147 insertions(+), 37 deletions(-) diff --git a/hedis.cabal b/hedis.cabal index 465bf2d9..3db82d75 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -88,7 +88,7 @@ library errors, network-uri, crc16 == 0.1.0, - say + say if !impl(ghc >= 8.0) build-depends: semigroups >= 0.11 && < 0.19 diff --git a/src/Database/Redis.hs b/src/Database/Redis.hs index 7cda84f5..557c2d6b 100644 --- a/src/Database/Redis.hs +++ b/src/Database/Redis.hs @@ -177,6 +177,7 @@ module Database.Redis ( -- * Low-Level Command API sendRequest, + sendToAllMasterNodes, Reply(..),Status(..),RedisResult(..),ConnectionLostException(..), -- |[Solution to Exercise] diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index c4a6e3b3..9805d06b 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -13,6 +13,7 @@ module Database.Redis.Cluster , connect , disconnect , requestPipelined + , requestMasterNodes , nodes ) where @@ -25,6 +26,7 @@ import Data.Map(fromListWith, assocs) import Data.Function(on) import Control.Exception(Exception, throwIO, BlockedIndefinitelyOnMVar(..), catches, Handler(..)) import Control.Concurrent.MVar(MVar, newMVar, readMVar, modifyMVar, modifyMVar_) +import Control.DeepSeq(deepseq) import Control.Monad(zipWithM, when) import Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot) import qualified Database.Redis.ConnectionContext as CC @@ -47,7 +49,7 @@ import qualified Database.Redis.Cluster.Command as CMD -- evaluated, execute the entire pipeline. If the pipeline is already executed -- then it just looks up it's response in the executed pipeline. --- | A connection to a redis cluster, it is compoesed of a map from Node IDs to +-- | A connection to a redis cluster, it is composed of a map from Node IDs to -- | 'NodeConnection's, a 'Pipeline', and a 'ShardMap' data Connection = Connection (HM.HashMap NodeID NodeConnection) (MVar Pipeline) (MVar ShardMap) CMD.InfoMap @@ -60,7 +62,17 @@ instance Eq NodeConnection where instance Ord NodeConnection where compare (NodeConnection _ _ id1) (NodeConnection _ _ id2) = compare id1 id2 -data PipelineState = Pending [[B.ByteString]] | Executed [Reply] +data PipelineState = + -- Nothing in the pipeline has been evaluated yet so nothing has been + -- sent + Pending [[B.ByteString]] + -- This pipeline has been executed, the replies are contained within it + | Executed [Reply] +-- A pipeline has an MVar for the current state, this state is actually always +-- `Pending` because the first thing the implementation does when executing a +-- pipeline is to take the current pipeline state out of the MVar and replace +-- it with a new `Pending` state. The executed state is held on to by the +-- replies within it. newtype Pipeline = Pipeline (MVar PipelineState) data NodeRole = Master | Slave deriving (Show, Eq, Ord) @@ -68,12 +80,20 @@ data NodeRole = Master | Slave deriving (Show, Eq, Ord) type Host = String type Port = Int type NodeID = B.ByteString +-- Represents a single node, note that this type does not include the +-- connection to the node because the shard map can be shared amongst multiple +-- connections data Node = Node NodeID NodeRole Host Port deriving (Show, Eq, Ord) type MasterNode = Node type SlaveNode = Node + +-- A 'shard' is a master node and 0 or more slaves, (the 'master', 'slave' +-- terminology is unfortunate but I felt it better to follow the documentation +-- until it changes). data Shard = Shard MasterNode [SlaveNode] deriving (Show, Eq, Ord) +-- A map from hashslot to shards newtype ShardMap = ShardMap (IntMap.IntMap Shard) deriving (Show) newtype MissingNodeException = MissingNodeException [B.ByteString] deriving (Show, Typeable) @@ -110,17 +130,29 @@ disconnect (Connection nodeConnMap _ _ _) = mapM_ disconnectNode (HM.elems nodeC -- evaluated. requestPipelined :: IO ShardMap -> Connection -> [B.ByteString] -> IO Reply requestPipelined refreshAction conn@(Connection _ pipelineVar shardMapVar _) nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do + putStrLn $ "requestPipeline: " ++ show nextRequest (newStateVar, repliesIndex) <- hasLocked "locked adding to pipeline" $ modifyMVar stateVar $ \case - Pending requests -> return (Pending (nextRequest:requests), (stateVar, length requests)) + Pending requests | length requests > 1000 -> do + putStrLn "Forcing pipeline as there are over 1000 requests pending" + replies <- evaluatePipeline shardMapVar refreshAction conn (nextRequest:requests) + return (Executed replies, (stateVar, length requests)) + Pending requests -> do + putStrLn $ "Adding to pending requests, pipeline is now: " ++ show (nextRequest:requests) + return (Pending (nextRequest:requests), (stateVar, length requests)) e@(Executed _) -> do + putStrLn $ "Pipeline already executed, creating new pipeline, new pipeline is " ++ show [nextRequest] s' <- newMVar $ Pending [nextRequest] return (e, (s', 0)) evaluateAction <- unsafeInterleaveIO $ do + putStrLn $ "Executing request: " ++ show nextRequest replies <- hasLocked "locked evaluating replies" $ modifyMVar newStateVar $ \case - Executed replies -> return (Executed replies, replies) + Executed replies -> do + putStrLn $ "Pipeline already executed, responses are: " ++ show replies + return (Executed replies, replies) Pending requests-> do + putStrLn $ "Total pipeline is: " ++ show requests replies <- evaluatePipeline shardMapVar refreshAction conn requests - return (Executed replies, replies) + replies `deepseq` return (Executed replies, replies) return $ replies !! repliesIndex return (Pipeline newStateVar, evaluateAction) @@ -221,9 +253,10 @@ nodeConnectionForCommand :: Connection -> ShardMap -> [B.ByteString] -> IO NodeC nodeConnectionForCommand (Connection nodeConns _ _ infoMap) (ShardMap shardMap) request = do keys <- case CMD.keysForRequest infoMap request of Nothing -> throwIO $ UnsupportedClusterCommandException request + Just [] -> throwIO $ UnsupportedClusterCommandException request Just k -> return k let shards = nub $ mapMaybe ((flip IntMap.lookup shardMap) . fromEnum . keyToSlot) keys - node <- case shards of + node <- case shards of [] -> throwIO $ MissingNodeException request [Shard master _] -> return master _ -> throwIO $ CrossSlotException request @@ -272,3 +305,17 @@ hasLocked msg action = action `catches` [ Handler $ \exc@BlockedIndefinitelyOnMVar -> sayString ("[MVar]: " ++ msg) >> throwIO exc ] + + +requestMasterNodes :: Connection -> [B.ByteString] -> IO [Reply] +requestMasterNodes conn req = do + masterNodeConns <- masterNodes conn + concat <$> mapM (`requestNode` [req]) masterNodeConns + +masterNodes :: Connection -> IO [NodeConnection] +masterNodes (Connection nodeConns _ shardMapVar _) = do + (ShardMap shardMap) <- readMVar shardMapVar + let masters = map ((\(Shard m _) -> m) . snd) $ IntMap.toList shardMap + let masterNodeIds = map nodeId masters + return $ mapMaybe (`HM.lookup` nodeConns) masterNodeIds + diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index 1bde0cdf..11a19917 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -97,7 +97,8 @@ keysForRequest (InfoMap infoMap) request@(command:_) = do info <- HM.lookup (map toLower $ Char8.unpack command) infoMap if isMovable info then parseMovable request else do let possibleKeys = case lastKeyPosition info of - LastKeyPosition end -> take (fromEnum $ 1 + end - firstKeyPosition info) $ drop (fromEnum $ firstKeyPosition info) request + LastKeyPosition 0 -> [] + LastKeyPosition end -> take (fromEnum $ 1 + end - firstKeyPosition info) $ drop (fromEnum $ firstKeyPosition info) request UnlimitedKeys -> drop (fromEnum $ firstKeyPosition info) request return $ takeEvery (fromEnum $ stepCount info) possibleKeys keysForRequest _ [] = Nothing diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs index 80b2d697..dc66b55d 100644 --- a/src/Database/Redis/Connection.hs +++ b/src/Database/Redis/Connection.hs @@ -178,7 +178,7 @@ withCheckedConnect connInfo = bracket (checkedConnect connInfo) disconnect runRedis :: Connection -> Redis a -> IO a runRedis (NonClusteredConnection pool) redis = withResource pool $ \conn -> runRedisInternal conn redis -runRedis (ClusteredConnection _ pool) redis = +runRedis (ClusteredConnection _ pool) redis = withResource pool $ \conn -> runRedisClusteredInternal conn (refreshShardMap conn) redis newtype ClusterConnectError = ClusterConnectError Reply @@ -198,7 +198,7 @@ connectCluster bootstrapConnInfo = do shardMap <- shardMapFromClusterSlotsResponse slots newMVar shardMap commandInfos <- runRedisInternal conn command - case commandInfos of + case commandInfos of Left e -> throwIO $ ClusterConnectError e Right infos -> do pool <- createPool (Cluster.connect infos shardMapVar Nothing) Cluster.disconnect 1 (connectMaxIdleTime bootstrapConnInfo) (connectMaxConnections bootstrapConnInfo) @@ -218,7 +218,7 @@ shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr m nodeFromClusterSlotNode isMaster ClusterSlotsNode{..} = let hostname = Char8.unpack clusterSlotsNodeIP role = if isMaster then Cluster.Master else Cluster.Slave - in + in Cluster.Node clusterSlotsNodeID role hostname (toEnum clusterSlotsNodePort) refreshShardMap :: Cluster.Connection -> IO ShardMap diff --git a/src/Database/Redis/Core.hs b/src/Database/Redis/Core.hs index 6281533b..54ecdc6f 100644 --- a/src/Database/Redis/Core.hs +++ b/src/Database/Redis/Core.hs @@ -5,7 +5,7 @@ module Database.Redis.Core ( Redis(), unRedis, reRedis, RedisCtx(..), MonadRedis(..), - send, recv, sendRequest, + send, recv, sendRequest, sendToAllMasterNodes, runRedisInternal, runRedisClusteredInternal, RedisEnv(..), @@ -19,6 +19,7 @@ import Control.Applicative #endif import Control.Monad.Reader import Control.Monad.Fail(MonadFail) +--import Control.Concurrent.MVar(MVar, readMVar, putMVar, newMVar) import qualified Data.ByteString as B import Data.IORef @@ -45,12 +46,17 @@ deriving instance MonadFail Redis #endif data RedisEnv - = NonClusteredEnv { envConn :: PP.Connection, envLastReply :: IORef Reply } + = NonClusteredEnv { envConn :: PP.Connection, nonClusteredLastReply :: IORef Reply } | ClusteredEnv { refreshAction :: IO ShardMap , connection :: Cluster.Connection + , clusteredLastReply :: IORef Reply } +envLastReply :: RedisEnv -> IORef Reply +envLastReply NonClusteredEnv{..} = nonClusteredLastReply +envLastReply ClusteredEnv{..} = clusteredLastReply + -- |This class captures the following behaviour: In a context @m@, a command -- will return its result wrapped in a \"container\" of type @f@. -- @@ -96,8 +102,9 @@ runRedisInternal conn (Redis redis) = do runRedisClusteredInternal :: Cluster.Connection -> IO ShardMap -> Redis a -> IO a runRedisClusteredInternal connection refreshShardmapAction (Redis redis) = do - r <- runReaderT redis (ClusteredEnv refreshShardmapAction connection) - r `seq` return () + ref <- newIORef (SingleLine "nobody will ever see this") + r <- runReaderT redis (ClusteredEnv refreshShardmapAction connection ref) + readIORef ref >>= (`seq` return ()) return r setLastReply :: Reply -> ReaderT RedisEnv IO () @@ -137,5 +144,23 @@ sendRequest req = do r <- liftIO $ PP.request envConn (renderRequest req) setLastReply r return r - ClusteredEnv{..} -> liftIO $ Cluster.requestPipelined refreshAction connection req + ClusteredEnv{..} -> do + liftIO $ putStrLn $ "sendRequest: " ++ show req + r <- liftIO $ Cluster.requestPipelined refreshAction connection req + lift (writeIORef clusteredLastReply r) + --setLastReply r + return r returnDecode r' + +sendToAllMasterNodes :: (RedisResult a, MonadRedis m) => [B.ByteString] -> m [Either Reply a] +sendToAllMasterNodes req = do + r' <- liftRedis $ Redis $ do + env <- ask + case env of + NonClusteredEnv{..} -> do + r <- liftIO $ PP.request envConn (renderRequest req) + r `seq` return [r] + ClusteredEnv{..} -> do + r <- liftIO $ Cluster.requestMasterNodes connection req + return r + return $ map decode r' diff --git a/test/Test.hs b/test/Test.hs index 3287e560..d43b2bf6 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -16,6 +16,7 @@ import Data.Time.Clock.POSIX import qualified Test.Framework as Test (Test, defaultMain) import qualified Test.Framework.Providers.HUnit as Test (testCase) import qualified Test.HUnit as HUnit +import qualified Data.ByteString as BS import Database.Redis import PubSubTest @@ -25,15 +26,37 @@ import PubSubTest -- main :: IO () main = do - conn <- connect defaultConnectInfo - Test.defaultMain (tests conn) + singleNodeConn <- connect defaultConnectInfo + let singleNodeTests = tests singleNodeConn + clusterConn <- connectCluster $ defaultConnectInfo { connectPort = PortNumber 7001 } + let clusterTestCases = clusterTests clusterConn + Test.defaultMain $ clusterTestCases ++ singleNodeTests -type Test = Connection -> Test.Test + +data TestType = Cluster | SingleNode + +instance Show TestType where + show Cluster = "Cluster" + show SingleNode = "SingleNode" + +type Test = TestType -> Connection -> Test.Test + + +resetDb :: Connection -> IO () +resetDb conn = do + resps <- runRedis conn $ sendToAllMasterNodes ["FLUSHDB"] + let combined = sequence resps + case combined of + Left reply -> HUnit.assertFailure $ "Redis error when flushing: " ++ show reply + Right replies -> if all (\r -> r == Ok) replies + then return () + else HUnit.assertFailure "Redis error when flushing, non OK reply received" testCase :: String -> Redis () -> Test -testCase name r conn = Test.testCase name $ do - withTimeLimit 0.5 $ runRedis conn $ flushdb >>=? Ok >> r +testCase name r testType conn = Test.testCase nameWithTestType $ + withTimeLimit 0.5 $ resetDb conn >> runRedis conn r where + nameWithTestType = show testType ++ ": " ++ name withTimeLimit limit act = do start <- getCurrentTime _ <- act @@ -55,16 +78,21 @@ assert = liftIO . HUnit.assert -- Tests -- tests :: Connection -> [Test.Test] -tests conn = map ($conn) $ concat +tests conn = map (\t -> t SingleNode conn) $ concat [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog] , testsZSets, [testPubSub], [testTransaction], [testScripting] , testsConnection, testsServer, [testScans], [testZrangelex] , [testXAddRead, testXReadGroup, testXRange, testXpending, testXClaim, testXInfo, testXDel, testXTrim] - , testPubSubThreaded + , (map (\f -> (\_ c -> f c)) testPubSubThreaded) -- should always be run last as connection gets closed after it , [testQuit] ] +clusterTests :: Connection -> [Test.Test] +clusterTests conn = map (\t -> t Cluster conn) + [ testPipelining , testConstantSpacePipelining, testForceErrorReply + , testEvalReplies ] + ------------------------------------------------------------------------------ -- Miscellaneous -- @@ -78,7 +106,7 @@ testConstantSpacePipelining :: Test testConstantSpacePipelining = testCase "constant-space pipelining" $ do -- This testcase should not exceed the maximum heap size, as set in -- the run-test.sh script. - replicateM_ 100000 ping + replicateM_ 100000 (set "key" "val") -- If the program didn't crash, pipelining takes constant memory. assert True @@ -95,13 +123,15 @@ testForceErrorReply = testCase "force error reply" $ do testPipelining :: Test testPipelining = testCase "pipelining" $ do - let n = 100 + let n = 200 tPipe <- deltaT $ do - pongs <- replicateM n ping - assert $ pongs == replicate n (Right Pong) + oks <- replicateM n (set "pipelinekey" "pipelineval") + assert $ oks == replicate n (Right Ok) - tNoPipe <- deltaT $ replicateM_ n (ping >>=? Pong) + tNoPipe <- deltaT $ replicateM_ n ((set "pipelinekey" "pipelineval") >>=? Ok) -- pipelining should at least be twice as fast. + liftIO $ putStrLn $ "tPipe: " ++ show tPipe + liftIO $ putStrLn $ "tNoPipe: " ++ show tNoPipe assert $ tNoPipe / tPipe > 2 where deltaT redis = do @@ -110,17 +140,23 @@ testPipelining = testCase "pipelining" $ do liftIO $ fmap (`diffUTCTime` start) getCurrentTime testEvalReplies :: Test -testEvalReplies conn = testCase "eval unused replies" go conn +testEvalReplies testType conn = testCase "eval unused replies" go testType conn where go = do - _ignored <- set "key" "value" - (liftIO $ do + _ <- set "key" "value" + liftIO $ putStrLn "SET sent" + result <- liftIO $ do threadDelay $ 10 ^ (5 :: Int) mvar <- newEmptyMVar - _ <- - (Async.wait =<< Async.async (runRedis conn (get "key"))) >>= putMVar mvar - takeMVar mvar) >>=? - Just "value" + _ <- asyncGet mvar >>= Async.wait + takeMVar mvar + pure result >>=? Just "value" + --asyncGet :: MVar (Either Reply (Maybe BS.ByteString)) -> IO (Async.Async (Either Reply (Maybe BS.ByteString))) + asyncGet :: MVar (Either Reply (Maybe BS.ByteString)) -> IO (Async.Async ()) + asyncGet mvar = Async.async $ do + result <- runRedis conn $ get "key" + _ <- putMVar mvar result + return () ------------------------------------------------------------------------------ -- Keys @@ -420,7 +456,7 @@ testHyperLogLog = testCase "hyperloglog" $ do -- Pub/Sub -- testPubSub :: Test -testPubSub conn = testCase "pubSub" go conn +testPubSub testType conn = testCase "pubSub" go testType conn where go = do -- producer @@ -471,7 +507,7 @@ testTransaction = testCase "transaction" $ do -- Scripting -- testScripting :: Test -testScripting conn = testCase "scripting" go conn +testScripting testType conn = testCase "scripting" go testType conn where go = do let script = "return {false, 42}" From 8a271c1a0ffd616858ffb3a967ed52f0c2b796f2 Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 3 Jun 2020 10:57:01 +1200 Subject: [PATCH 007/103] Version bump, 8.8 support --- .gitignore | 1 + hedis.cabal | 3 +-- src/Database/Redis/Cluster/HashSlot.hs | 21 +++++++++++++++++---- src/Database/Redis/Core.hs | 4 ++++ src/Database/Redis/PubSub.hs | 3 +++ src/Database/Redis/URL.hs | 3 +++ stack.yaml | 6 +++--- 7 files changed, 32 insertions(+), 9 deletions(-) diff --git a/.gitignore b/.gitignore index 86fb5ffa..7b46696c 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,4 @@ Main.hs .stack-work TAGS stack.yaml.lock +.nvimrc diff --git a/hedis.cabal b/hedis.cabal index 465bf2d9..d3ff35a3 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.12.8 +version: 0.12.8.1 synopsis: Client library for the Redis datastore: supports full command set, pipelining. @@ -87,7 +87,6 @@ library HTTP, errors, network-uri, - crc16 == 0.1.0, say if !impl(ghc >= 8.0) build-depends: diff --git a/src/Database/Redis/Cluster/HashSlot.hs b/src/Database/Redis/Cluster/HashSlot.hs index 3a502902..2db3a7ba 100644 --- a/src/Database/Redis/Cluster/HashSlot.hs +++ b/src/Database/Redis/Cluster/HashSlot.hs @@ -2,11 +2,10 @@ {-# LANGUAGE OverloadedStrings #-} module Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot) where -import Data.Bits((.&.)) +import Data.Bits((.&.), xor, shiftL) import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString as BS -import Data.Word(Word16) -import qualified Data.Digest.CRC16 as CRC16 +import Data.Word(Word8, Word16) newtype HashSlot = HashSlot Word16 deriving (Num, Eq, Ord, Real, Enum, Integral, Show) @@ -26,5 +25,19 @@ findSubKey key = case Char8.break (=='{') key of (subKey, _) -> subKey crc16 :: BS.ByteString -> Word16 -crc16 = BS.foldl (CRC16.crc16_update 0x1021 False) 0 +crc16 = BS.foldl (crc16Update 0x1021) 0 +-- Taken from crc16 package +crc16Update :: Word16 -- ^ polynomial + -> Word16 -- ^ initial crc + -> Word8 -- ^ data byte + -> Word16 -- ^ new crc +crc16Update poly crc b = + foldl crc16UpdateBit newCrc [1 :: Int .. 8] + where + newCrc = crc `xor` shiftL (fromIntegral b :: Word16) 8 + crc16UpdateBit crc' _ = + if (crc' .&. 0x8000) /= 0x0000 + then shiftL crc' 1 `xor` poly + else shiftL crc' 1 + diff --git a/src/Database/Redis/Core.hs b/src/Database/Redis/Core.hs index 6281533b..f3c57d8a 100644 --- a/src/Database/Redis/Core.hs +++ b/src/Database/Redis/Core.hs @@ -18,7 +18,11 @@ import Control.Applicative #if __GLASGOW_HASKELL__ > 711 #endif import Control.Monad.Reader +#if MIN_VERSION_base(4,13,0) + +#else import Control.Monad.Fail(MonadFail) +#endif import qualified Data.ByteString as B import Data.IORef diff --git a/src/Database/Redis/PubSub.hs b/src/Database/Redis/PubSub.hs index 5c2d3da3..e32a9469 100644 --- a/src/Database/Redis/PubSub.hs +++ b/src/Database/Redis/PubSub.hs @@ -33,7 +33,10 @@ import Data.ByteString.Char8 (ByteString) import Data.List (foldl') import Data.Maybe (isJust) import Data.Pool +#if MIN_VERSION_base(4,13,0) +#else import Data.Semigroup (Semigroup(..)) +#endif import qualified Data.HashMap.Strict as HM import qualified Database.Redis.Core as Core import qualified Database.Redis.Connection as Connection diff --git a/src/Database/Redis/URL.hs b/src/Database/Redis/URL.hs index 6541ce7f..96aca98d 100644 --- a/src/Database/Redis/URL.hs +++ b/src/Database/Redis/URL.hs @@ -8,7 +8,10 @@ import Control.Applicative ((<$>)) #endif import Control.Error.Util (note) import Control.Monad (guard) +#if MIN_VERSION_base(4,13,0) +#else import Data.Monoid ((<>)) +#endif import Database.Redis.Connection (ConnectInfo(..), defaultConnectInfo) import qualified Database.Redis.ConnectionContext as CC import Network.HTTP.Base diff --git a/stack.yaml b/stack.yaml index bfa11f28..2bcbdec9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,8 +1,8 @@ -resolver: lts-13.21 +resolver: lts-15.15 packages: -- '.' + - '.' extra-deps: - - crc16-0.1.0 + - crc16-0.1.1 flags: hedis: dev: true From 8e152fdc7dc66bc47af23fe739daa9289163043a Mon Sep 17 00:00:00 2001 From: Koz Ross Date: Wed, 3 Jun 2020 11:03:23 +1200 Subject: [PATCH 008/103] Remove crc16 from extra-deps --- stack.yaml | 2 -- 1 file changed, 2 deletions(-) diff --git a/stack.yaml b/stack.yaml index 2bcbdec9..55ea5b70 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,8 +1,6 @@ resolver: lts-15.15 packages: - '.' -extra-deps: - - crc16-0.1.1 flags: hedis: dev: true From ae3dd395175c3928f637d2ef757ecc85bb1d2c36 Mon Sep 17 00:00:00 2001 From: Harpo Roeder Date: Sun, 9 Aug 2020 12:23:06 +0000 Subject: [PATCH 009/103] publically expose ConnectTimeout exception --- src/Database/Redis.hs | 5 +++-- src/Database/Redis/ProtocolPipelining.hs | 1 + 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Database/Redis.hs b/src/Database/Redis.hs index f723bf96..3112b103 100644 --- a/src/Database/Redis.hs +++ b/src/Database/Redis.hs @@ -178,7 +178,8 @@ module Database.Redis ( -- * Low-Level Command API sendRequest, - Reply(..),Status(..),RedisResult(..),ConnectionLostException(..), + Reply(..), Status(..), RedisResult(..), ConnectionLostException(..), + ConnectTimeout(..) -- |[Solution to Exercise] -- @@ -196,7 +197,7 @@ import Database.Redis.Core import Database.Redis.PubSub import Database.Redis.Protocol import Database.Redis.ProtocolPipelining - (PortID(..), ConnectionLostException(..)) + (PortID(..), ConnectionLostException(..), ConnectTimeout(..)) import Database.Redis.Transactions import Database.Redis.Types import Database.Redis.URL diff --git a/src/Database/Redis/ProtocolPipelining.hs b/src/Database/Redis/ProtocolPipelining.hs index 1e6388d3..64926775 100644 --- a/src/Database/Redis/ProtocolPipelining.hs +++ b/src/Database/Redis/ProtocolPipelining.hs @@ -20,6 +20,7 @@ module Database.Redis.ProtocolPipelining ( Connection, connect, enableTLS, beginReceiving, disconnect, request, send, recv, flush, ConnectionLostException(..), + ConnectTimeout(..), PortID(..) ) where From 17d732cd68cd2f7afd3e18e12422239de5a8453e Mon Sep 17 00:00:00 2001 From: Alex Good Date: Sun, 9 Aug 2020 13:46:14 +0100 Subject: [PATCH 010/103] Fix testEvalUnusedReplies --- src/Database/Redis/Cluster.hs | 33 +++++++++++++-------------------- src/Database/Redis/Core.hs | 2 -- test/Test.hs | 4 +--- 3 files changed, 14 insertions(+), 25 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 9805d06b..17bc15c3 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -20,14 +20,14 @@ module Database.Redis.Cluster import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as Char8 import qualified Data.IORef as IOR -import Data.Maybe(listToMaybe, mapMaybe) -import Data.List(nub, sortBy) +import Data.Maybe(mapMaybe) +import Data.List(nub, sortBy, find) import Data.Map(fromListWith, assocs) import Data.Function(on) import Control.Exception(Exception, throwIO, BlockedIndefinitelyOnMVar(..), catches, Handler(..)) import Control.Concurrent.MVar(MVar, newMVar, readMVar, modifyMVar, modifyMVar_) import Control.DeepSeq(deepseq) -import Control.Monad(zipWithM, when) +import Control.Monad(zipWithM, when, replicateM) import Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot) import qualified Database.Redis.ConnectionContext as CC import qualified Data.HashMap.Strict as HM @@ -62,10 +62,10 @@ instance Eq NodeConnection where instance Ord NodeConnection where compare (NodeConnection _ _ id1) (NodeConnection _ _ id2) = compare id1 id2 -data PipelineState = +data PipelineState = -- Nothing in the pipeline has been evaluated yet so nothing has been -- sent - Pending [[B.ByteString]] + Pending [[B.ByteString]] -- This pipeline has been executed, the replies are contained within it | Executed [Reply] -- A pipeline has an MVar for the current state, this state is actually always @@ -130,27 +130,20 @@ disconnect (Connection nodeConnMap _ _ _) = mapM_ disconnectNode (HM.elems nodeC -- evaluated. requestPipelined :: IO ShardMap -> Connection -> [B.ByteString] -> IO Reply requestPipelined refreshAction conn@(Connection _ pipelineVar shardMapVar _) nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do - putStrLn $ "requestPipeline: " ++ show nextRequest (newStateVar, repliesIndex) <- hasLocked "locked adding to pipeline" $ modifyMVar stateVar $ \case Pending requests | length requests > 1000 -> do - putStrLn "Forcing pipeline as there are over 1000 requests pending" replies <- evaluatePipeline shardMapVar refreshAction conn (nextRequest:requests) return (Executed replies, (stateVar, length requests)) - Pending requests -> do - putStrLn $ "Adding to pending requests, pipeline is now: " ++ show (nextRequest:requests) + Pending requests -> return (Pending (nextRequest:requests), (stateVar, length requests)) e@(Executed _) -> do - putStrLn $ "Pipeline already executed, creating new pipeline, new pipeline is " ++ show [nextRequest] s' <- newMVar $ Pending [nextRequest] return (e, (s', 0)) evaluateAction <- unsafeInterleaveIO $ do - putStrLn $ "Executing request: " ++ show nextRequest replies <- hasLocked "locked evaluating replies" $ modifyMVar newStateVar $ \case - Executed replies -> do - putStrLn $ "Pipeline already executed, responses are: " ++ show replies + Executed replies -> return (Executed replies, replies) Pending requests-> do - putStrLn $ "Total pipeline is: " ++ show requests replies <- evaluatePipeline shardMapVar refreshAction conn requests replies `deepseq` return (Executed replies, replies) return $ replies !! repliesIndex @@ -189,7 +182,7 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do shardMap <- hasLocked "reading shardmap in evaluatePipeline" $ readMVar shardMapVar requestsByNode <- getRequestsByNode shardMap resps <- concat <$> mapM (uncurry executeRequests) requestsByNode - _ <- when (any (moved . rawResponse) resps) (refreshShardMapVar "locked refreshing due to moved responses") + when (any (moved . rawResponse) resps) (refreshShardMapVar "locked refreshing due to moved responses") retriedResps <- mapM (retry 0) resps return $ map rawResponse $ sortBy (on compare responseIndex) retriedResps where getRequestsByNode :: ShardMap -> IO [(NodeConnection, [PendingRequest])] @@ -203,7 +196,7 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do executeRequests :: NodeConnection -> [PendingRequest] -> IO [CompletedRequest] executeRequests nodeConn nodeRequests = do replies <- requestNode nodeConn $ map rawRequest nodeRequests - return $ map (\(PendingRequest i r, rep) -> CompletedRequest i r rep) (zip nodeRequests replies) + return $ zipWith (curry (\(PendingRequest i r, rep) -> CompletedRequest i r rep)) nodeRequests replies retry :: Int -> CompletedRequest -> IO CompletedRequest retry retryCount resp@(CompletedRequest index request thisReply) = do retryReply <- case thisReply of @@ -255,7 +248,7 @@ nodeConnectionForCommand (Connection nodeConns _ _ infoMap) (ShardMap shardMap) Nothing -> throwIO $ UnsupportedClusterCommandException request Just [] -> throwIO $ UnsupportedClusterCommandException request Just k -> return k - let shards = nub $ mapMaybe ((flip IntMap.lookup shardMap) . fromEnum . keyToSlot) keys + let shards = nub $ mapMaybe (flip IntMap.lookup shardMap . fromEnum . keyToSlot) keys node <- case shards of [] -> throwIO $ MissingNodeException request [Shard master _] -> return master @@ -266,9 +259,9 @@ nodeConnectionForCommand (Connection nodeConns _ _ infoMap) (ShardMap shardMap) requestNode :: NodeConnection -> [[B.ByteString]] -> IO [Reply] requestNode (NodeConnection ctx lastRecvRef _) requests = do - _ <- mapM_ (sendNode . renderRequest) requests + mapM_ (sendNode . renderRequest) requests _ <- CC.flush ctx - sequence $ take (length requests) (repeat recvNode) + replicateM (length requests) recvNode where @@ -295,7 +288,7 @@ nodes (ShardMap shardMap) = concatMap snd $ IntMap.toList $ fmap shardNodes shar nodeWithHostAndPort :: ShardMap -> Host -> Port -> Maybe Node -nodeWithHostAndPort shardMap host port = listToMaybe $ filter (\(Node _ _ nodeHost nodePort) -> port == nodePort && host == nodeHost) $ nodes shardMap +nodeWithHostAndPort shardMap host port = find (\(Node _ _ nodeHost nodePort) -> port == nodePort && host == nodeHost) (nodes shardMap) nodeId :: Node -> NodeID nodeId (Node theId _ _ _) = theId diff --git a/src/Database/Redis/Core.hs b/src/Database/Redis/Core.hs index 54ecdc6f..fd185725 100644 --- a/src/Database/Redis/Core.hs +++ b/src/Database/Redis/Core.hs @@ -145,10 +145,8 @@ sendRequest req = do setLastReply r return r ClusteredEnv{..} -> do - liftIO $ putStrLn $ "sendRequest: " ++ show req r <- liftIO $ Cluster.requestPipelined refreshAction connection req lift (writeIORef clusteredLastReply r) - --setLastReply r return r returnDecode r' diff --git a/test/Test.hs b/test/Test.hs index d43b2bf6..64ed3386 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -143,15 +143,13 @@ testEvalReplies :: Test testEvalReplies testType conn = testCase "eval unused replies" go testType conn where go = do - _ <- set "key" "value" - liftIO $ putStrLn "SET sent" + _ <- liftIO $ runRedis conn $ set "key" "value" result <- liftIO $ do threadDelay $ 10 ^ (5 :: Int) mvar <- newEmptyMVar _ <- asyncGet mvar >>= Async.wait takeMVar mvar pure result >>=? Just "value" - --asyncGet :: MVar (Either Reply (Maybe BS.ByteString)) -> IO (Async.Async (Either Reply (Maybe BS.ByteString))) asyncGet :: MVar (Either Reply (Maybe BS.ByteString)) -> IO (Async.Async ()) asyncGet mvar = Async.async $ do result <- runRedis conn $ get "key" From 878edcbfd174727d64c83ffc2792a0d82ac0f549 Mon Sep 17 00:00:00 2001 From: Kostiantyn Rybnikov Date: Sun, 9 Aug 2020 19:38:53 +0300 Subject: [PATCH 011/103] 0.12.4 changelog --- CHANGELOG | 4 ++++ hedis.cabal | 2 +- stack.yaml | 2 +- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 016b26f5..c575ce34 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,9 @@ # Changelog for Hedis +## 0.12.14 + +* PR #153. Publicly expose ConnectTimeout exception + ## 0.12.13 * PR #150, Issue #143. Leaking sockets when connection fails diff --git a/hedis.cabal b/hedis.cabal index d0dcb519..6ee3803e 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.12.13 +version: 0.12.14 synopsis: Client library for the Redis datastore: supports full command set, pipelining. diff --git a/stack.yaml b/stack.yaml index 2b9f3345..51c30d5d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-14.12 +resolver: lts-16.8 packages: - '.' extra-deps: From 09cd28572d2115dbc9eaac12f6a45bf287b40043 Mon Sep 17 00:00:00 2001 From: Kostiantyn Rybnikov Date: Sun, 9 Aug 2020 19:41:14 +0300 Subject: [PATCH 012/103] Fix for newer cabal --- hedis.cabal | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/hedis.cabal b/hedis.cabal index 6ee3803e..ebfb21a9 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -43,7 +43,7 @@ maintainer: Kostiantyn Rybnikov copyright: Copyright (c) 2011 Falko Peters category: Database build-type: Simple -cabal-version: >=1.8 +cabal-version: >=1.10 homepage: https://github.com/informatikr/hedis bug-reports: https://github.com/informatikr/hedis/issues extra-source-files: CHANGELOG @@ -58,6 +58,7 @@ flag dev manual: True library + default-language: Haskell2010 hs-source-dirs: src ghc-options: -Wall -fwarn-tabs if impl(ghc >= 8.6.0) @@ -102,6 +103,7 @@ library Database.Redis.URL benchmark hedis-benchmark + default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: benchmark/Benchmark.hs build-depends: @@ -116,6 +118,7 @@ benchmark hedis-benchmark ghc-prof-options: -auto-all test-suite hedis-test + default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Test.hs @@ -140,6 +143,7 @@ test-suite hedis-test ghc-prof-options: -auto-all test-suite doctest + default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: DocTest.hs ghc-options: -O0 -rtsopts From bdfef08051b72d38967a0390e0dfbb017a273956 Mon Sep 17 00:00:00 2001 From: Vasily Gorev Date: Thu, 27 Aug 2020 11:33:59 +0300 Subject: [PATCH 013/103] added MultiExecWithHash for redis-cluster --- src/Database/Redis/Cluster.hs | 30 ++++++++++++++++++++---------- src/Database/Redis/Connection.hs | 12 ++++++------ src/Database/Redis/Core.hs | 10 +++++----- src/Database/Redis/Transactions.hs | 26 +++++++++++++++++++++++++- 4 files changed, 56 insertions(+), 22 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index c4a6e3b3..aabe2965 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -19,7 +19,7 @@ module Database.Redis.Cluster import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as Char8 import qualified Data.IORef as IOR -import Data.Maybe(listToMaybe, mapMaybe) +import Data.Maybe(listToMaybe, mapMaybe, fromMaybe) import Data.List(nub, sortBy) import Data.Map(fromListWith, assocs) import Data.Function(on) @@ -41,7 +41,7 @@ import qualified Database.Redis.Cluster.Command as CMD -- This module implements a clustered connection whilst maintaining -- compatibility with the original Hedis codebase. In particular it still -- performs implicit pipelining using `unsafeInterleaveIO` as the single node --- codebase does. To achieve this each connection carries around with it a +-- codebase does. To achieve this each connection carries around with it a -- pipeline of commands. Every time `sendRequest` is called the command is -- added to the pipeline and an IO action is returned which will, upon being -- evaluated, execute the entire pipeline. If the pipeline is already executed @@ -107,7 +107,7 @@ disconnect (Connection nodeConnMap _ _ _) = mapM_ disconnectNode (HM.elems nodeC -- Add a request to the current pipeline for this connection. The pipeline will -- be executed implicitly as soon as any result returned from this function is --- evaluated. +-- evaluated. requestPipelined :: IO ShardMap -> Connection -> [B.ByteString] -> IO Reply requestPipelined refreshAction conn@(Connection _ pipelineVar shardMapVar _) nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do (newStateVar, repliesIndex) <- hasLocked "locked adding to pipeline" $ modifyMVar stateVar $ \case @@ -141,7 +141,7 @@ rawResponse (CompletedRequest _ _ r) = r requestForResponse :: CompletedRequest -> [B.ByteString] requestForResponse (CompletedRequest _ r _) = r --- The approach we take here is similar to that taken by the redis-py-cluster +-- The approach we take here is similar to that taken by the redis-py-cluster -- library, which is described at https://redis-py-cluster.readthedocs.io/en/master/pipelines.html -- -- Essentially we group all the commands by node (based on the current shardmap) @@ -150,7 +150,7 @@ requestForResponse (CompletedRequest _ r _) = r -- the commands have resulted in a MOVED error we refresh the shard map, then -- we run through all the responses and retry any MOVED or ASK errors. This retry -- step is not pipelined, there is a request per error. This is probably --- acceptable in most cases as these errors should only occur in the case of +-- acceptable in most cases as these errors should only occur in the case of -- cluster reconfiguration events, which should be rare. evaluatePipeline :: MVar ShardMap -> IO ShardMap -> Connection -> [[B.ByteString]] -> IO [Reply] evaluatePipeline shardMapVar refreshShardmapAction conn requests = do @@ -159,10 +159,11 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do resps <- concat <$> mapM (uncurry executeRequests) requestsByNode _ <- when (any (moved . rawResponse) resps) (refreshShardMapVar "locked refreshing due to moved responses") retriedResps <- mapM (retry 0) resps - return $ map rawResponse $ sortBy (on compare responseIndex) retriedResps where + return $ map rawResponse $ sortBy (on compare responseIndex) retriedResps + where getRequestsByNode :: ShardMap -> IO [(NodeConnection, [PendingRequest])] getRequestsByNode shardMap = do - commandsWithNodes <- zipWithM (requestWithNode shardMap) [0..] (reverse requests) + commandsWithNodes <- zipWithM (requestWithNode shardMap) (reverse [0..(length requests - 1)]) requests return $ assocs $ fromListWith (++) commandsWithNodes requestWithNode :: ShardMap -> Int -> [B.ByteString] -> IO (NodeConnection, [PendingRequest]) requestWithNode shardMap index request = do @@ -219,21 +220,30 @@ nodeConnWithHostAndPort shardMap (Connection nodeConns _ _ _) host port = do nodeConnectionForCommand :: Connection -> ShardMap -> [B.ByteString] -> IO NodeConnection nodeConnectionForCommand (Connection nodeConns _ _ infoMap) (ShardMap shardMap) request = do + let mek = case request of + ("MULTI" : key : _) -> Just [key] + ("EXEC" : key : _) -> Just [key] + _ -> Nothing keys <- case CMD.keysForRequest infoMap request of Nothing -> throwIO $ UnsupportedClusterCommandException request Just k -> return k - let shards = nub $ mapMaybe ((flip IntMap.lookup shardMap) . fromEnum . keyToSlot) keys - node <- case shards of + let shards = nub $ mapMaybe ((flip IntMap.lookup shardMap) . fromEnum . keyToSlot) (fromMaybe keys mek) + node <- case shards of [] -> throwIO $ MissingNodeException request [Shard master _] -> return master _ -> throwIO $ CrossSlotException request maybe (throwIO $ MissingNodeException request) return (HM.lookup (nodeId node) nodeConns) +cleanRequest :: [B.ByteString] -> [B.ByteString] +cleanRequest ("MULTI" : _) = ["MULTI"] +cleanRequest ("EXEC" : _) = ["EXEC"] +cleanRequest req = req requestNode :: NodeConnection -> [[B.ByteString]] -> IO [Reply] requestNode (NodeConnection ctx lastRecvRef _) requests = do - _ <- mapM_ (sendNode . renderRequest) requests + let reqs = map cleanRequest requests + _ <- mapM_ (sendNode . renderRequest) reqs _ <- CC.flush ctx sequence $ take (length requests) (repeat recvNode) diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs index 80b2d697..fe817a2a 100644 --- a/src/Database/Redis/Connection.hs +++ b/src/Database/Redis/Connection.hs @@ -140,7 +140,7 @@ createConnection ConnInfo{..} = do _ -> return () return conn' --- |Constructs a 'Connection' pool to a Redis server designated by the +-- |Constructs a 'Connection' pool to a Redis server designated by the -- given 'ConnectInfo'. The first connection is not actually established -- until the first call to the server. connect :: ConnectInfo -> IO Connection @@ -148,7 +148,7 @@ connect cInfo@ConnInfo{..} = NonClusteredConnection <$> createPool (createConnection cInfo) PP.disconnect 1 connectMaxIdleTime connectMaxConnections -- |Constructs a 'Connection' pool to a Redis server designated by the --- given 'ConnectInfo', then tests if the server is actually there. +-- given 'ConnectInfo', then tests if the server is actually there. -- Throws an exception if the connection to the Redis server can't be -- established. checkedConnect :: ConnectInfo -> IO Connection @@ -162,7 +162,7 @@ disconnect :: Connection -> IO () disconnect (NonClusteredConnection pool) = destroyAllResources pool disconnect (ClusteredConnection _ pool) = destroyAllResources pool --- | Memory bracket around 'connect' and 'disconnect'. +-- | Memory bracket around 'connect' and 'disconnect'. withConnect :: ConnectInfo -> (Connection -> IO c) -> IO c withConnect connInfo = bracket (connect connInfo) disconnect @@ -178,7 +178,7 @@ withCheckedConnect connInfo = bracket (checkedConnect connInfo) disconnect runRedis :: Connection -> Redis a -> IO a runRedis (NonClusteredConnection pool) redis = withResource pool $ \conn -> runRedisInternal conn redis -runRedis (ClusteredConnection _ pool) redis = +runRedis (ClusteredConnection _ pool) redis = withResource pool $ \conn -> runRedisClusteredInternal conn (refreshShardMap conn) redis newtype ClusterConnectError = ClusterConnectError Reply @@ -198,7 +198,7 @@ connectCluster bootstrapConnInfo = do shardMap <- shardMapFromClusterSlotsResponse slots newMVar shardMap commandInfos <- runRedisInternal conn command - case commandInfos of + case commandInfos of Left e -> throwIO $ ClusterConnectError e Right infos -> do pool <- createPool (Cluster.connect infos shardMapVar Nothing) Cluster.disconnect 1 (connectMaxIdleTime bootstrapConnInfo) (connectMaxConnections bootstrapConnInfo) @@ -218,7 +218,7 @@ shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr m nodeFromClusterSlotNode isMaster ClusterSlotsNode{..} = let hostname = Char8.unpack clusterSlotsNodeIP role = if isMaster then Cluster.Master else Cluster.Slave - in + in Cluster.Node clusterSlotsNodeID role hostname (toEnum clusterSlotsNodePort) refreshShardMap :: Cluster.Connection -> IO ShardMap diff --git a/src/Database/Redis/Core.hs b/src/Database/Redis/Core.hs index f3c57d8a..560b4194 100644 --- a/src/Database/Redis/Core.hs +++ b/src/Database/Redis/Core.hs @@ -50,8 +50,8 @@ deriving instance MonadFail Redis data RedisEnv = NonClusteredEnv { envConn :: PP.Connection, envLastReply :: IORef Reply } - | ClusteredEnv - { refreshAction :: IO ShardMap + | ClusteredEnv + { refreshAction :: IO ShardMap , connection :: Cluster.Connection } @@ -77,7 +77,7 @@ instance MonadRedis Redis where -- -- 'unRedis' and 'reRedis' can be used to define instances for -- arbitrary typeclasses. --- +-- -- WARNING! These functions are considered internal and no guarantee -- is given at this point that they will not break in future. unRedis :: Redis a -> ReaderT RedisEnv IO a @@ -100,7 +100,7 @@ runRedisInternal conn (Redis redis) = do runRedisClusteredInternal :: Cluster.Connection -> IO ShardMap -> Redis a -> IO a runRedisClusteredInternal connection refreshShardmapAction (Redis redis) = do - r <- runReaderT redis (ClusteredEnv refreshShardmapAction connection) + r <- runReaderT redis (ClusteredEnv refreshShardmapAction connection) r `seq` return () return r @@ -136,7 +136,7 @@ sendRequest :: (RedisCtx m f, RedisResult a) sendRequest req = do r' <- liftRedis $ Redis $ do env <- ask - case env of + case env of NonClusteredEnv{..} -> do r <- liftIO $ PP.request envConn (renderRequest req) setLastReply r diff --git a/src/Database/Redis/Transactions.hs b/src/Database/Redis/Transactions.hs index 56b7fee0..fe2d33d6 100644 --- a/src/Database/Redis/Transactions.hs +++ b/src/Database/Redis/Transactions.hs @@ -3,7 +3,7 @@ GeneralizedNewtypeDeriving #-} module Database.Redis.Transactions ( - watch, unwatch, multiExec, + watch, unwatch, multiExec, multiExecWithHash, Queued(), TxResult(..), RedisTx(), ) where @@ -134,3 +134,27 @@ multi = sendRequest ["MULTI"] exec :: Redis Reply exec = either id id <$> sendRequest ["EXEC"] + +-------------- + +multiExecWithHash :: ByteString -> RedisTx (Queued a) -> Redis (TxResult a) +multiExecWithHash h rtx = do + -- We don't need to catch exceptions and call DISCARD. The pool will close + -- the connection anyway. + _ <- multiWithHash h + Queued f <- runRedisTx rtx + r <- execWithHash h + case r of + MultiBulk rs -> + + return $ maybe + TxAborted + (either (TxError . show) TxSuccess . f . fromList) + rs + _ -> error $ "hedis: EXEC returned " ++ show r + +multiWithHash :: ByteString -> Redis (Either Reply Status) +multiWithHash h = sendRequest ["MULTI", h] + +execWithHash :: ByteString -> Redis Reply +execWithHash h = either id id <$> sendRequest ["EXEC", h] \ No newline at end of file From 640699b04fcd639ce6f4687c1714aa805edd2c24 Mon Sep 17 00:00:00 2001 From: Maxim Koltsov Date: Thu, 17 Sep 2020 15:22:10 +0300 Subject: [PATCH 014/103] Implement Redis Sentinel support --- hedis.cabal | 1 + src/Database/Redis/Sentinel.hs | 218 +++++++++++++++++++++++++++++++++ 2 files changed, 219 insertions(+) create mode 100644 src/Database/Redis/Sentinel.hs diff --git a/hedis.cabal b/hedis.cabal index ebfb21a9..80e138fa 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -68,6 +68,7 @@ library if flag(dev) ghc-prof-options: -auto-all exposed-modules: Database.Redis + , Database.Redis.Sentinel , Database.Redis.Core.Internal build-depends: scanner >= 0.2, async >= 2.1, diff --git a/src/Database/Redis/Sentinel.hs b/src/Database/Redis/Sentinel.hs new file mode 100644 index 00000000..0add2cd0 --- /dev/null +++ b/src/Database/Redis/Sentinel.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} + +-- | "Database.Redis" like interface with connection through Redis Sentinel. +-- +-- More details here: . +-- +-- Example: +-- +-- @ +-- conn <- 'connect' 'SentinelConnectionInfo' (("localhost", PortNumber 26379) :| []) "mymaster" 'defaultConnectInfo' +-- +-- 'runRedis' conn $ do +-- 'set' "hello" "world" +-- @ +-- +-- When connection is opened, the Sentinels will be queried to get current master. Subsequent 'runRedis' +-- calls will talk to that master. +-- +-- If 'runRedis' call fails, the next call will choose a new master to talk to. +-- +-- This implementation is based on Gist by Emanuel Borsboom +-- at +module Database.Redis.Sentinel + ( + -- * Connection + SentinelConnectInfo(..) + , SentinelConnection + , connect + -- * runRedis with Sentinel support + , runRedis + , RedisSentinelException(..) + + -- * Re-export Database.Redis + , 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 + +-- | Interact with a Redis datastore. See 'Database.Redis.runRedis' for details. +runRedis :: SentinelConnection + -> Redis (Either Reply a) + -> IO (Either Reply a) +runRedis (SentinelConnection connMVar) action = do + (baseConn, preToken) <- modifyMVar connMVar $ \oldConnection@SentinelConnection' + { rcCheckFailover + , rcToken = oldToken + , rcSentinelConnectInfo = oldConnectInfo + , rcMasterConnectInfo = oldMasterConnectInfo + , rcBaseConnection = oldBaseConnection } -> + if rcCheckFailover + then do + (newConnectInfo, newMasterConnectInfo) <- updateMaster oldConnectInfo + newToken <- newUnique + (connInfo, conn) <- + if sameHost newMasterConnectInfo oldMasterConnectInfo + then return (oldMasterConnectInfo, oldBaseConnection) + else do + newConn <- Redis.connect newMasterConnectInfo + return (newMasterConnectInfo, newConn) + + return + ( SentinelConnection' + { rcCheckFailover = False + , rcToken = newToken + , rcSentinelConnectInfo = newConnectInfo + , rcMasterConnectInfo = connInfo + , rcBaseConnection = conn + } + , (conn, newToken) + ) + else return (oldConnection, (oldBaseConnection, oldToken)) + + -- Use evaluate to make sure we catch exceptions from 'runRedis'. + reply <- (Redis.runRedis baseConn action >>= evaluate) + `catchRedisRethrow` (\_ -> setCheckSentinel preToken) + case reply of + Left (Error e) | "READONLY " `BS.isPrefixOf` e -> + -- This means our connection has turned into a slave + setCheckSentinel preToken + _ -> return () + return reply + + where + sameHost :: Redis.ConnectInfo -> Redis.ConnectInfo -> Bool + sameHost l r = connectHost l == connectHost r && connectPort l == connectPort r + + setCheckSentinel preToken = modifyMVar_ connMVar $ \conn@SentinelConnection'{rcToken} -> + if preToken == rcToken + then do + newToken <- newUnique + return (conn{rcToken = newToken, rcCheckFailover = True}) + else return conn + + +connect :: SentinelConnectInfo -> IO SentinelConnection +connect origConnectInfo = do + (connectInfo, masterConnectInfo) <- updateMaster origConnectInfo + conn <- Redis.connect masterConnectInfo + token <- newUnique + + SentinelConnection <$> newMVar SentinelConnection' + { rcCheckFailover = False + , rcToken = token + , rcSentinelConnectInfo = connectInfo + , rcMasterConnectInfo = masterConnectInfo + , rcBaseConnection = conn + } + +updateMaster :: SentinelConnectInfo + -> IO (SentinelConnectInfo, Redis.ConnectInfo) +updateMaster sci@SentinelConnectInfo{..} = do + -- This is using the Either monad "backwards" -- Left means stop because we've made a connection, + -- Right means try again. + resultEither <- runExceptT $ forM_ connectSentinels $ \(host, port) -> do + trySentinel host port `catchRedis` (\_ -> return ()) + + + case resultEither of + Left (conn, sentinelPair) -> return + ( sci + { connectSentinels = sentinelPair :| delete sentinelPair (toList connectSentinels) + } + , conn + ) + Right () -> throwIO $ NoSentinels connectSentinels + where + trySentinel :: HostName -> PortID -> ExceptT (Redis.ConnectInfo, (HostName, PortID)) IO () + trySentinel sentinelHost sentinelPort = do + -- bang to ensure exceptions from runRedis get thrown immediately. + !replyE <- liftIO $ do + !sentinelConn <- Redis.connect $ Redis.defaultConnectInfo + { connectHost = sentinelHost + , connectPort = sentinelPort + , connectMaxConnections = 1 + } + Redis.runRedis sentinelConn $ sendRequest + ["SENTINEL", "get-master-addr-by-name", connectMasterName] + + case replyE of + Right [host, port] -> + throwError + ( connectBaseInfo + { connectHost = BS8.unpack host + , connectPort = + maybe + (PortNumber 26379) + (PortNumber . fromIntegral . fst) + $ BS8.readInt port + } + , (sentinelHost, sentinelPort) + ) + _ -> return () + +catchRedisRethrow :: MonadCatch m => m a -> (String -> m ()) -> m a +catchRedisRethrow action handler = + action `catches` + [ Handler $ \ex -> handler (show @IOException ex) >> throwM ex + , Handler $ \ex -> handler (show @ConnectionLostException ex) >> throwM ex + ] + +catchRedis :: MonadCatch m => m a -> (String -> m a) -> m a +catchRedis action handler = + action `catches` + [ Handler $ \ex -> handler (show @IOException ex) + , Handler $ \ex -> handler (show @ConnectionLostException ex) + ] + +newtype SentinelConnection = SentinelConnection (MVar SentinelConnection') + +data SentinelConnection' + = SentinelConnection' + { rcCheckFailover :: Bool + , rcToken :: Unique + , rcSentinelConnectInfo :: SentinelConnectInfo + , rcMasterConnectInfo :: Redis.ConnectInfo + , rcBaseConnection :: Redis.Connection + } + +-- | Configuration of Sentinel hosts. +data SentinelConnectInfo + = SentinelConnectInfo + { connectSentinels :: NonEmpty (HostName, PortID) + -- ^ List of sentinels. + , connectMasterName :: ByteString + -- ^ Name of master to connect to. + , connectBaseInfo :: Redis.ConnectInfo + -- ^ This is used to configure auth and other parameters for Redis connection, + -- but 'Redis.connectHost' and 'Redis.connectPort' are ignored. + } + deriving (Show) + +-- | Exception thrown by "Database.Redis.Sentinel". +data RedisSentinelException + = NoSentinels (NonEmpty (HostName, PortID)) + -- ^ Thrown if no sentinel can be reached. + deriving (Show, Typeable, Exception) From 5175b5b7d240cdda7289c14e62f163c04ef59b3c Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 9 Oct 2020 14:21:12 +0100 Subject: [PATCH 015/103] Fix `takeEvery` implementation The original `takeEvery` implementation wasn't wrong per se. It did select one out of every `n` elements passed in. It was however incompatible with the way we are using it. We're passing it a list of possible keys, the first element of that list definitely being a key. We need `takeEvery` to select that first element, then every `n`th element that follows. --- src/Database/Redis/Cluster/Command.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index 1bde0cdf..a0154e8b 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -121,9 +121,8 @@ readNumKeys (rawNumKeys:rest) = do readNumKeys _ = Nothing takeEvery :: Int -> [a] -> [a] -takeEvery n xs = case drop (n-1) xs of - (y:ys) -> y : takeEvery n ys - [] -> [] +takeEvery _ [] = [] +takeEvery n (x:xs) = x : takeEvery n (drop (n-1) xs) readMaybe :: Read a => String -> Maybe a readMaybe s = case reads s of From 7242d1e4bcd13669348764e10149b8f78c638076 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 9 Oct 2020 15:41:56 +0100 Subject: [PATCH 016/103] Update src/Database/Redis/Cluster/Command.hs Co-authored-by: Michael Glass --- src/Database/Redis/Cluster/Command.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index a0154e8b..3cd953ba 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -119,7 +119,9 @@ readNumKeys (rawNumKeys:rest) = do numKeys <- readMaybe (Char8.unpack rawNumKeys) return $ take numKeys rest readNumKeys _ = Nothing - +-- takeEvery 1 [1,2,3,4,5] ->[1,2,3,4,5] +-- takeEvery 2 [1,2,3,4,5] ->[1,3,5] +-- takeEvery 3 [1,2,3,4,5] ->[1,4] takeEvery :: Int -> [a] -> [a] takeEvery _ [] = [] takeEvery n (x:xs) = x : takeEvery n (drop (n-1) xs) From d3f36cb37b05eb8594a64fd548ae341c301bc390 Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Sun, 11 Oct 2020 13:01:06 +0300 Subject: [PATCH 017/103] Version 0.12.15 --- CHANGELOG | 4 ++++ hedis.cabal | 2 +- stack.yaml | 2 +- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index c575ce34..f53b9e42 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,9 @@ # Changelog for Hedis +## 0.12.15 + +* PR #154. Implement Redis Sentinel support + ## 0.12.14 * PR #153. Publicly expose ConnectTimeout exception diff --git a/hedis.cabal b/hedis.cabal index 80e138fa..ed398154 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.12.14 +version: 0.12.15 synopsis: Client library for the Redis datastore: supports full command set, pipelining. diff --git a/stack.yaml b/stack.yaml index 51c30d5d..fa637900 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-16.8 +resolver: lts-16.18 packages: - '.' extra-deps: From c32cee5b5c4cfc7ec695b31f7115b6784b339994 Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Sun, 11 Oct 2020 13:27:34 +0300 Subject: [PATCH 018/103] Fix some tests --- test/PubSubTest.hs | 111 ++++++++++++++++++++++----------------------- 1 file changed, 55 insertions(+), 56 deletions(-) diff --git a/test/PubSubTest.hs b/test/PubSubTest.hs index eb147044..05596c98 100644 --- a/test/PubSubTest.hs +++ b/test/PubSubTest.hs @@ -70,35 +70,34 @@ removeAllTest conn = Test.testCase "Multithreaded Pub/Sub - basic" $ do ctrl <- newPubSubController [("foo1", handler "InitialFoo1" msgVar), ("foo2", handler "InitialFoo2" msgVar)] [("bar1:*", phandler "InitialBar1" msgVar), ("bar2:*", phandler "InitialBar2" msgVar)] withAsync (pubSubForever conn ctrl (atomically $ writeTVar initialComplete True)) $ \_ -> do + -- wait for initial + atomically $ readTVar initialComplete >>= \b -> if b then return () else retry + expectRedisChannels conn ["foo1", "foo2"] - -- wait for initial - atomically $ readTVar initialComplete >>= \b -> if b then return () else retry - expectRedisChannels conn ["foo1", "foo2"] - - runRedis conn $ publish "foo1" "Hello" - waitForMessage msgVar "InitialFoo1" "Hello" + runRedis conn $ publish "foo1" "Hello" + waitForMessage msgVar "InitialFoo1" "Hello" - runRedis conn $ publish "bar2:zzz" "World" - waitForPMessage msgVar "InitialBar2" "bar2:zzz" "World" + runRedis conn $ publish "bar2:zzz" "World" + waitForPMessage msgVar "InitialBar2" "bar2:zzz" "World" - -- subscribe to foo1 and bar1 again - addChannelsAndWait ctrl [("foo1", handler "NewFoo1" msgVar)] [("bar1:*", phandler "NewBar1" msgVar)] - expectRedisChannels conn ["foo1", "foo2"] + -- subscribe to foo1 and bar1 again + addChannelsAndWait ctrl [("foo1", handler "NewFoo1" msgVar)] [("bar1:*", phandler "NewBar1" msgVar)] + expectRedisChannels conn ["foo1", "foo2"] - runRedis conn $ publish "foo1" "abcdef" - waitForMessage msgVar "InitialFoo1" "abcdef" - waitForMessage msgVar "NewFoo1" "abcdef" + runRedis conn $ publish "foo1" "abcdef" + waitForMessage msgVar "InitialFoo1" "abcdef" + waitForMessage msgVar "NewFoo1" "abcdef" - -- unsubscribe from foo1 and bar1 - removeChannelsAndWait ctrl ["foo1", "unusued"] ["bar1:*", "unused:*"] - expectRedisChannels conn ["foo2"] + -- unsubscribe from foo1 and bar1 + removeChannelsAndWait ctrl ["foo1", "unusued"] ["bar1:*", "unused:*"] + expectRedisChannels conn ["foo2"] - -- foo2 and bar2 are still subscribed - runRedis conn $ publish "foo2" "12345" - waitForMessage msgVar "InitialFoo2" "12345" + -- foo2 and bar2 are still subscribed + runRedis conn $ publish "foo2" "12345" + waitForMessage msgVar "InitialFoo2" "12345" - runRedis conn $ publish "bar2:aaa" "0987" - waitForPMessage msgVar "InitialBar2" "bar2:aaa" "0987" + runRedis conn $ publish "bar2:aaa" "0987" + waitForPMessage msgVar "InitialBar2" "bar2:aaa" "0987" data TestError = TestError ByteString deriving (Eq, Show, Typeable) @@ -127,48 +126,48 @@ removeFromUnregister conn = Test.testCase "Multithreaded Pub/Sub - unregister ha initialComplete <- newTVarIO False ctrl <- newPubSubController [] [] withAsync (pubSubForever conn ctrl (atomically $ writeTVar initialComplete True)) $ \_ -> do - atomically $ readTVar initialComplete >>= \b -> if b then return () else retry + atomically $ readTVar initialComplete >>= \b -> if b then return () else retry - -- register to some channels - void $ addChannelsAndWait ctrl - [("abc", handler "InitialAbc" msgVar), ("xyz", handler "InitialXyz" msgVar)] - [("def:*", phandler "InitialDef" msgVar), ("uvw", phandler "InitialUvw" msgVar)] - expectRedisChannels conn ["abc", "xyz"] + -- register to some channels + void $ addChannelsAndWait ctrl + [("abc", handler "InitialAbc" msgVar), ("xyz", handler "InitialXyz" msgVar)] + [("def:*", phandler "InitialDef" msgVar), ("uvw", phandler "InitialUvw" msgVar)] + expectRedisChannels conn ["abc", "xyz"] - runRedis conn $ publish "abc" "Hello" - waitForMessage msgVar "InitialAbc" "Hello" + runRedis conn $ publish "abc" "Hello" + waitForMessage msgVar "InitialAbc" "Hello" - -- register to some more channels - unreg <- addChannelsAndWait ctrl - [("abc", handler "SecondAbc" msgVar), ("123", handler "Second123" msgVar)] - [("def:*", phandler "SecondDef" msgVar), ("890:*", phandler "Second890" msgVar)] - expectRedisChannels conn ["abc", "xyz", "123"] + -- register to some more channels + unreg <- addChannelsAndWait ctrl + [("abc", handler "SecondAbc" msgVar), ("123", handler "Second123" msgVar)] + [("def:*", phandler "SecondDef" msgVar), ("890:*", phandler "Second890" msgVar)] + expectRedisChannels conn ["abc", "xyz", "123"] - -- check messages on all channels - runRedis conn $ publish "abc" "World" - waitForMessage msgVar "InitialAbc" "World" - waitForMessage msgVar "SecondAbc" "World" + -- check messages on all channels + runRedis conn $ publish "abc" "World" + waitForMessage msgVar "InitialAbc" "World" + waitForMessage msgVar "SecondAbc" "World" - runRedis conn $ publish "123" "World2" - waitForMessage msgVar "Second123" "World2" + runRedis conn $ publish "123" "World2" + waitForMessage msgVar "Second123" "World2" - runRedis conn $ publish "def:bbbb" "World3" - waitForPMessage msgVar "InitialDef" "def:bbbb" "World3" - waitForPMessage msgVar "SecondDef" "def:bbbb" "World3" + runRedis conn $ publish "def:bbbb" "World3" + waitForPMessage msgVar "InitialDef" "def:bbbb" "World3" + waitForPMessage msgVar "SecondDef" "def:bbbb" "World3" - runRedis conn $ publish "890:tttt" "World4" - waitForPMessage msgVar "Second890" "890:tttt" "World4" + runRedis conn $ publish "890:tttt" "World4" + waitForPMessage msgVar "Second890" "890:tttt" "World4" - -- unregister - unreg + -- unregister + unreg - -- we have no way of waiting until unregister actually happened, so just delay and hope - threadDelay $ 1000*1000 -- 1 second - expectRedisChannels conn ["abc", "xyz"] + -- we have no way of waiting until unregister actually happened, so just delay and hope + threadDelay $ 1000*1000 -- 1 second + expectRedisChannels conn ["abc", "xyz"] - -- now only initial should be around. In particular, abc should still be subscribed - runRedis conn $ publish "abc" "World5" - waitForMessage msgVar "InitialAbc" "World5" + -- now only initial should be around. In particular, abc should still be subscribed + runRedis conn $ publish "abc" "World5" + waitForMessage msgVar "InitialAbc" "World5" - runRedis conn $ publish "def:cccc" "World6" - waitForPMessage msgVar "InitialDef" "def:cccc" "World6" + runRedis conn $ publish "def:cccc" "World6" + waitForPMessage msgVar "InitialDef" "def:cccc" "World6" From 9a947c6942f9e5314bf406de31706a3b4efe4b4a Mon Sep 17 00:00:00 2001 From: Alex Good Date: Sun, 9 Aug 2020 13:46:14 +0100 Subject: [PATCH 019/103] Fix testEvalUnusedReplies --- src/Database/Redis/Cluster.hs | 40 ++++++++++++++++++++++++----------- test/Test.hs | 8 +++---- 2 files changed, 32 insertions(+), 16 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index aabe2965..72effef5 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -19,13 +19,13 @@ module Database.Redis.Cluster import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as Char8 import qualified Data.IORef as IOR -import Data.Maybe(listToMaybe, mapMaybe, fromMaybe) -import Data.List(nub, sortBy) +import Data.Maybe(mapMaybe, fromMaybe) +import Data.List(nub, sortBy, find) import Data.Map(fromListWith, assocs) import Data.Function(on) import Control.Exception(Exception, throwIO, BlockedIndefinitelyOnMVar(..), catches, Handler(..)) import Control.Concurrent.MVar(MVar, newMVar, readMVar, modifyMVar, modifyMVar_) -import Control.Monad(zipWithM, when) +import Control.Monad(zipWithM, when, replicateM) import Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot) import qualified Database.Redis.ConnectionContext as CC import qualified Data.HashMap.Strict as HM @@ -60,7 +60,18 @@ instance Eq NodeConnection where instance Ord NodeConnection where compare (NodeConnection _ _ id1) (NodeConnection _ _ id2) = compare id1 id2 -data PipelineState = Pending [[B.ByteString]] | Executed [Reply] +data PipelineState = + -- Nothing in the pipeline has been evaluated yet so nothing has been + -- sent + Pending [[B.ByteString]] + -- This pipeline has been executed, the replies are contained within it + | Executed [Reply] +-- A pipeline has an MVar for the current state, this state is actually always +-- `Pending` because the first thing the implementation does when executing a +-- pipeline is to take the current pipeline state out of the MVar and replace +-- it with a new `Pending` state. The executed state is held on to by the +-- replies within it. + newtype Pipeline = Pipeline (MVar PipelineState) data NodeRole = Master | Slave deriving (Show, Eq, Ord) @@ -111,13 +122,18 @@ disconnect (Connection nodeConnMap _ _ _) = mapM_ disconnectNode (HM.elems nodeC requestPipelined :: IO ShardMap -> Connection -> [B.ByteString] -> IO Reply requestPipelined refreshAction conn@(Connection _ pipelineVar shardMapVar _) nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do (newStateVar, repliesIndex) <- hasLocked "locked adding to pipeline" $ modifyMVar stateVar $ \case - Pending requests -> return (Pending (nextRequest:requests), (stateVar, length requests)) + Pending requests | length requests > 1000 -> do + replies <- evaluatePipeline shardMapVar refreshAction conn (nextRequest:requests) + return (Executed replies, (stateVar, length requests)) + Pending requests -> + return (Pending (nextRequest:requests), (stateVar, length requests)) e@(Executed _) -> do s' <- newMVar $ Pending [nextRequest] return (e, (s', 0)) evaluateAction <- unsafeInterleaveIO $ do replies <- hasLocked "locked evaluating replies" $ modifyMVar newStateVar $ \case - Executed replies -> return (Executed replies, replies) + Executed replies -> + return (Executed replies, replies) Pending requests-> do replies <- evaluatePipeline shardMapVar refreshAction conn requests return (Executed replies, replies) @@ -157,7 +173,7 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do shardMap <- hasLocked "reading shardmap in evaluatePipeline" $ readMVar shardMapVar requestsByNode <- getRequestsByNode shardMap resps <- concat <$> mapM (uncurry executeRequests) requestsByNode - _ <- when (any (moved . rawResponse) resps) (refreshShardMapVar "locked refreshing due to moved responses") + when (any (moved . rawResponse) resps) (refreshShardMapVar "locked refreshing due to moved responses") retriedResps <- mapM (retry 0) resps return $ map rawResponse $ sortBy (on compare responseIndex) retriedResps where @@ -172,7 +188,7 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do executeRequests :: NodeConnection -> [PendingRequest] -> IO [CompletedRequest] executeRequests nodeConn nodeRequests = do replies <- requestNode nodeConn $ map rawRequest nodeRequests - return $ map (\(PendingRequest i r, rep) -> CompletedRequest i r rep) (zip nodeRequests replies) + return $ zipWith (curry (\(PendingRequest i r, rep) -> CompletedRequest i r rep)) nodeRequests replies retry :: Int -> CompletedRequest -> IO CompletedRequest retry retryCount resp@(CompletedRequest index request thisReply) = do retryReply <- case thisReply of @@ -227,7 +243,7 @@ nodeConnectionForCommand (Connection nodeConns _ _ infoMap) (ShardMap shardMap) keys <- case CMD.keysForRequest infoMap request of Nothing -> throwIO $ UnsupportedClusterCommandException request Just k -> return k - let shards = nub $ mapMaybe ((flip IntMap.lookup shardMap) . fromEnum . keyToSlot) (fromMaybe keys mek) + let shards = nub $ mapMaybe (flip IntMap.lookup shardMap . fromEnum . keyToSlot) (fromMaybe keys mek) node <- case shards of [] -> throwIO $ MissingNodeException request [Shard master _] -> return master @@ -243,9 +259,9 @@ cleanRequest req = req requestNode :: NodeConnection -> [[B.ByteString]] -> IO [Reply] requestNode (NodeConnection ctx lastRecvRef _) requests = do let reqs = map cleanRequest requests - _ <- mapM_ (sendNode . renderRequest) reqs + mapM_ (sendNode . renderRequest) reqs _ <- CC.flush ctx - sequence $ take (length requests) (repeat recvNode) + replicateM (length requests) recvNode where @@ -272,7 +288,7 @@ nodes (ShardMap shardMap) = concatMap snd $ IntMap.toList $ fmap shardNodes shar nodeWithHostAndPort :: ShardMap -> Host -> Port -> Maybe Node -nodeWithHostAndPort shardMap host port = listToMaybe $ filter (\(Node _ _ nodeHost nodePort) -> port == nodePort && host == nodeHost) $ nodes shardMap +nodeWithHostAndPort shardMap host port = find (\(Node _ _ nodeHost nodePort) -> port == nodePort && host == nodeHost) (nodes shardMap) nodeId :: Node -> NodeID nodeId (Node theId _ _ _) = theId diff --git a/test/Test.hs b/test/Test.hs index 3287e560..6f52aa6b 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -113,14 +113,14 @@ testEvalReplies :: Test testEvalReplies conn = testCase "eval unused replies" go conn where go = do - _ignored <- set "key" "value" - (liftIO $ do + _ <- liftIO $ runRedis conn $ set "key" "value" + result <- liftIO $ do threadDelay $ 10 ^ (5 :: Int) mvar <- newEmptyMVar _ <- (Async.wait =<< Async.async (runRedis conn (get "key"))) >>= putMVar mvar - takeMVar mvar) >>=? - Just "value" + takeMVar mvar + pure result >>=? Just "value" ------------------------------------------------------------------------------ -- Keys From a42ad48fecf5e084744bd53304c2b74eb550d238 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Thu, 26 Nov 2020 11:49:35 +0100 Subject: [PATCH 020/103] Support BLPOP and BRPOP commands in cluster mode We were incorreclty identifying the keys in the BLPOP and BRPOP Redis commands in cluster mode. Cluster mode needs to identify keys in commands to know which shard to send the command too. To know which arguments of redis commands are redis keys, cluster mode parses the output of the COMMANDS command, which contains information about the amount and placement of keys in various commands. One bit of information is the placement of the last key in a command. For commands that take an arbitrary amount of keys, Redis documentation specifies the 'last key' value should be -1. For BLPOP and BRPOP the 'last key' value is -2. I cannot find anything about this in current Redis documentation, but the meaning of this value seems to be that the final key is the penultimate argument instead of the last argument. That fits these commands, which take an arbitrary amount of keys and then, at the very end, a timeout argument which is not a key. This commit changes COMMANDS parsing logic to be support these arbitrary negative values. --- src/Database/Redis/Cluster/Command.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index 3cd953ba..5455c5e6 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -28,7 +28,7 @@ data Flag data AritySpec = Required Integer | MinimumRequired Integer deriving (Show) -data LastKeyPositionSpec = LastKeyPosition Integer | UnlimitedKeys deriving (Show) +data LastKeyPositionSpec = LastKeyPosition Integer | UnlimitedKeys Integer deriving (Show) newtype InfoMap = InfoMap (HM.HashMap String CommandInfo) @@ -84,7 +84,7 @@ instance RedisResult CommandInfo where parseFlag bad = Left bad parseLastKeyPos :: Either Reply LastKeyPositionSpec parseLastKeyPos = return $ case lastKeyPos of - i | i == -1 -> UnlimitedKeys + i | i < 0 -> UnlimitedKeys (-i - 1) i -> LastKeyPosition i decode e = Left e @@ -98,7 +98,9 @@ keysForRequest (InfoMap infoMap) request@(command:_) = do if isMovable info then parseMovable request else do let possibleKeys = case lastKeyPosition info of LastKeyPosition end -> take (fromEnum $ 1 + end - firstKeyPosition info) $ drop (fromEnum $ firstKeyPosition info) request - UnlimitedKeys -> drop (fromEnum $ firstKeyPosition info) request + UnlimitedKeys end -> + drop (fromEnum $ firstKeyPosition info) $ + take (length request - fromEnum end) request return $ takeEvery (fromEnum $ stepCount info) possibleKeys keysForRequest _ [] = Nothing From 3fab179bb845877dda6f94d3a3128273dbf114b7 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Thu, 26 Nov 2020 12:53:13 +0100 Subject: [PATCH 021/103] Fix typo in command --- src/Database/Redis/Cluster/Command.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index 5455c5e6..5c7b2901 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -110,7 +110,7 @@ isMovable CommandInfo{..} = MovableKeys `elem` flags parseMovable :: [BS.ByteString] -> Maybe [BS.ByteString] parseMovable ("SORT":key:_) = Just [key] parseMovable ("EVAL":_:rest) = readNumKeys rest -parseMovable ("EVALSH":_:rest) = readNumKeys rest +parseMovable ("EVALSHA":_:rest) = readNumKeys rest parseMovable ("ZUNIONSTORE":_:rest) = readNumKeys rest parseMovable ("ZINTERSTORE":_:rest) = readNumKeys rest parseMovable _ = Nothing From 83cd79b89cd65b73437b8861573a3d88acc5e7fe Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Thu, 26 Nov 2020 15:04:39 +0100 Subject: [PATCH 022/103] Create separate pipelines for transactions This will allow us to evaluate such transation pipelines differently, giving us access to all the commands and their keys in the transaction. This makes it so we ensure the queries in a transaction all go do the same node. --- src/Database/Redis/Cluster.hs | 34 +++++++++++++++++++++++++++++++++- 1 file changed, 33 insertions(+), 1 deletion(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 72effef5..ac162bd2 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -66,6 +66,11 @@ data PipelineState = Pending [[B.ByteString]] -- This pipeline has been executed, the replies are contained within it | Executed [Reply] + -- We're in a MULTI-EXEC transaction. All commands in the transaction + -- should go to the same node, but we won't know what node that is until + -- we see a command with a key. We're storing these transactions and will + -- send them all together when we see an EXEC. + | TransactionPending [[B.ByteString]] -- A pipeline has an MVar for the current state, this state is actually always -- `Pending` because the first thing the implementation does when executing a -- pipeline is to take the current pipeline state out of the MVar and replace @@ -122,13 +127,27 @@ disconnect (Connection nodeConnMap _ _ _) = mapM_ disconnectNode (HM.elems nodeC requestPipelined :: IO ShardMap -> Connection -> [B.ByteString] -> IO Reply requestPipelined refreshAction conn@(Connection _ pipelineVar shardMapVar _) nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do (newStateVar, repliesIndex) <- hasLocked "locked adding to pipeline" $ modifyMVar stateVar $ \case + Pending requests | isMulti nextRequest -> do + replies <- evaluatePipeline shardMapVar refreshAction conn requests + s' <- newMVar $ TransactionPending [nextRequest] + return (Executed replies, (s', 0)) Pending requests | length requests > 1000 -> do replies <- evaluatePipeline shardMapVar refreshAction conn (nextRequest:requests) return (Executed replies, (stateVar, length requests)) Pending requests -> return (Pending (nextRequest:requests), (stateVar, length requests)) + TransactionPending requests -> + if isExec nextRequest then do + replies <- evaluateTransactionPipeline shardMapVar refreshAction conn (nextRequest:requests) + return (Executed replies, (stateVar, length requests)) + else + return (TransactionPending (nextRequest:requests), (stateVar, length requests)) e@(Executed _) -> do - s' <- newMVar $ Pending [nextRequest] + s' <- newMVar $ + if isMulti nextRequest then + TransactionPending [nextRequest] + else + Pending [nextRequest] return (e, (s', 0)) evaluateAction <- unsafeInterleaveIO $ do replies <- hasLocked "locked evaluating replies" $ modifyMVar newStateVar $ \case @@ -137,10 +156,19 @@ requestPipelined refreshAction conn@(Connection _ pipelineVar shardMapVar _) nex Pending requests-> do replies <- evaluatePipeline shardMapVar refreshAction conn requests return (Executed replies, replies) + TransactionPending requests-> do + replies <- evaluateTransactionPipeline shardMapVar refreshAction conn requests + return (Executed replies, replies) return $ replies !! repliesIndex return (Pipeline newStateVar, evaluateAction) +isMulti :: [B.ByteString] -> Bool +isMulti ("MULTI" : _) = True +isMulti _ = False +isExec :: [B.ByteString] -> Bool +isExec ("EXEC" : _) = True +isExec _ = False data PendingRequest = PendingRequest Int [B.ByteString] data CompletedRequest = CompletedRequest Int [B.ByteString] Reply @@ -211,6 +239,10 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do refreshShardMapVar :: String -> IO () refreshShardMapVar msg = hasLocked msg $ modifyMVar_ shardMapVar (const refreshShardmapAction) +-- Like `evaluateOnPipeline`, except we expect to be able to run all commands +-- on a single shard. Failing to meet this expectation is an error. +evaluateTransactionPipeline :: MVar ShardMap -> IO ShardMap -> Connection -> [[B.ByteString]] -> IO [Reply] +evaluateTransactionPipeline = undefined askingRedirection :: Reply -> Maybe (Host, Port) askingRedirection (Error errString) = case Char8.words errString of From 947b31a4696df81b267fe9a1a33050625374a208 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Thu, 26 Nov 2020 17:07:14 +0100 Subject: [PATCH 023/103] Implement cluster transactions This removes the need for a `multiExecWithHash` function. We can now use regular `multiExec` instead. --- src/Database/Redis/Cluster.hs | 74 +++++++++++++++++++-------- src/Database/Redis/Cluster/Command.hs | 2 +- src/Database/Redis/Transactions.hs | 26 +--------- 3 files changed, 54 insertions(+), 48 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index ac162bd2..f0c72e93 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -19,7 +19,6 @@ module Database.Redis.Cluster import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as Char8 import qualified Data.IORef as IOR -import Data.Maybe(mapMaybe, fromMaybe) import Data.List(nub, sortBy, find) import Data.Map(fromListWith, assocs) import Data.Function(on) @@ -101,6 +100,8 @@ instance Exception UnsupportedClusterCommandException newtype CrossSlotException = CrossSlotException [B.ByteString] deriving (Show, Typeable) instance Exception CrossSlotException +newtype MultiExecCrossSlotException = MultiExecCrossSlotException (String, [[B.ByteString]]) deriving (Show, Typeable) +instance Exception MultiExecCrossSlotException connect :: [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> IO Connection connect commandInfos shardMapVar timeoutOpt = do @@ -242,7 +243,50 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do -- Like `evaluateOnPipeline`, except we expect to be able to run all commands -- on a single shard. Failing to meet this expectation is an error. evaluateTransactionPipeline :: MVar ShardMap -> IO ShardMap -> Connection -> [[B.ByteString]] -> IO [Reply] -evaluateTransactionPipeline = undefined +evaluateTransactionPipeline shardMapVar refreshShardmapAction conn requests' = do + let requests = reverse requests' + (ShardMap shardMap) <- hasLocked "reading shardmap in evaluatePipeline" $ readMVar shardMapVar + let (Connection nodeConns _ _ infoMap) = conn + keys <- mconcat <$> mapM (requestKeys infoMap) requests + -- In cluster mode Redis expects commands in transactions to all work on the + -- same hashslot. We find that hashslot here. + -- We could be more permissive and allow transactions that touch multiple + -- hashslots, as long as those hashslots are on the same node. This allows + -- a new failure case though: if some of the transactions hashslots are + -- moved to a different node we could end up in a situation where some of + -- the commands in a transaction are applied and some are not. Better to + -- fail early. + hashSlot <- hashSlotForKeys (MultiExecCrossSlotException (show keys, requests)) keys + node <- + case IntMap.lookup (fromEnum hashSlot) shardMap of + Nothing -> throwIO $ MissingNodeException (head requests) + Just (Shard master _) -> return master + nodeConn <- + case HM.lookup (nodeId node) nodeConns of + Nothing -> throwIO $ MissingNodeException (head requests) + Just nodeConn' -> return nodeConn' + resps <- requestNode nodeConn requests + -- It's unclear what to do if one of the commands in a transaction asks us + -- to redirect. Run only the redirected commands in another transaction? + -- That doesn't seem very transactional. + when (any moved resps) + (hasLocked "locked refreshing due to moved responses" $ modifyMVar_ shardMapVar (const refreshShardmapAction)) + return resps + +hashSlotForKeys :: Exception e => e -> [B.ByteString] -> IO HashSlot +hashSlotForKeys exception keys = + case nub (keyToSlot <$> keys) of + -- If none of the commands contain a key we can send them to any + -- node. Let's pick the first one. + [] -> return 0 + [hashSlot] -> return hashSlot + _ -> throwIO $ exception + +requestKeys :: CMD.InfoMap -> [B.ByteString] -> IO [B.ByteString] +requestKeys infoMap request = + case CMD.keysForRequest infoMap request of + Nothing -> throwIO $ UnsupportedClusterCommandException request + Just k -> return k askingRedirection :: Reply -> Maybe (Host, Port) askingRedirection (Error errString) = case Char8.words errString of @@ -268,30 +312,16 @@ nodeConnWithHostAndPort shardMap (Connection nodeConns _ _ _) host port = do nodeConnectionForCommand :: Connection -> ShardMap -> [B.ByteString] -> IO NodeConnection nodeConnectionForCommand (Connection nodeConns _ _ infoMap) (ShardMap shardMap) request = do - let mek = case request of - ("MULTI" : key : _) -> Just [key] - ("EXEC" : key : _) -> Just [key] - _ -> Nothing - keys <- case CMD.keysForRequest infoMap request of - Nothing -> throwIO $ UnsupportedClusterCommandException request - Just k -> return k - let shards = nub $ mapMaybe (flip IntMap.lookup shardMap . fromEnum . keyToSlot) (fromMaybe keys mek) - node <- case shards of - [] -> throwIO $ MissingNodeException request - [Shard master _] -> return master - _ -> throwIO $ CrossSlotException request + keys <- requestKeys infoMap request + hashSlot <- hashSlotForKeys (CrossSlotException request) keys + node <- case IntMap.lookup (fromEnum hashSlot) shardMap of + Nothing -> throwIO $ MissingNodeException request + Just (Shard master _) -> return master maybe (throwIO $ MissingNodeException request) return (HM.lookup (nodeId node) nodeConns) -cleanRequest :: [B.ByteString] -> [B.ByteString] -cleanRequest ("MULTI" : _) = ["MULTI"] -cleanRequest ("EXEC" : _) = ["EXEC"] -cleanRequest req = req - - requestNode :: NodeConnection -> [[B.ByteString]] -> IO [Reply] requestNode (NodeConnection ctx lastRecvRef _) requests = do - let reqs = map cleanRequest requests - mapM_ (sendNode . renderRequest) reqs + mapM_ (sendNode . renderRequest) requests _ <- CC.flush ctx replicateM (length requests) recvNode diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index 5c7b2901..389c33bd 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -95,7 +95,7 @@ newInfoMap = InfoMap . HM.fromList . map (\c -> (Char8.unpack $ name c, c)) keysForRequest :: InfoMap -> [BS.ByteString] -> Maybe [BS.ByteString] keysForRequest (InfoMap infoMap) request@(command:_) = do info <- HM.lookup (map toLower $ Char8.unpack command) infoMap - if isMovable info then parseMovable request else do + if isMovable info then parseMovable request else if stepCount info == 0 then Just [] else do let possibleKeys = case lastKeyPosition info of LastKeyPosition end -> take (fromEnum $ 1 + end - firstKeyPosition info) $ drop (fromEnum $ firstKeyPosition info) request UnlimitedKeys end -> diff --git a/src/Database/Redis/Transactions.hs b/src/Database/Redis/Transactions.hs index fe2d33d6..56b7fee0 100644 --- a/src/Database/Redis/Transactions.hs +++ b/src/Database/Redis/Transactions.hs @@ -3,7 +3,7 @@ GeneralizedNewtypeDeriving #-} module Database.Redis.Transactions ( - watch, unwatch, multiExec, multiExecWithHash, + watch, unwatch, multiExec, Queued(), TxResult(..), RedisTx(), ) where @@ -134,27 +134,3 @@ multi = sendRequest ["MULTI"] exec :: Redis Reply exec = either id id <$> sendRequest ["EXEC"] - --------------- - -multiExecWithHash :: ByteString -> RedisTx (Queued a) -> Redis (TxResult a) -multiExecWithHash h rtx = do - -- We don't need to catch exceptions and call DISCARD. The pool will close - -- the connection anyway. - _ <- multiWithHash h - Queued f <- runRedisTx rtx - r <- execWithHash h - case r of - MultiBulk rs -> - - return $ maybe - TxAborted - (either (TxError . show) TxSuccess . f . fromList) - rs - _ -> error $ "hedis: EXEC returned " ++ show r - -multiWithHash :: ByteString -> Redis (Either Reply Status) -multiWithHash h = sendRequest ["MULTI", h] - -execWithHash :: ByteString -> Redis Reply -execWithHash h = either id id <$> sendRequest ["EXEC", h] \ No newline at end of file From 641b53cfaea613995af5b0997436bd630dbd4203 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 27 Nov 2020 09:07:08 +0100 Subject: [PATCH 024/103] Fix transaction tests --- src/Database/Redis/Cluster.hs | 45 +++++++++++++++++++++++------------ 1 file changed, 30 insertions(+), 15 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index f0c72e93..1732339e 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module Database.Redis.Cluster ( Connection(..) @@ -208,12 +209,12 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do where getRequestsByNode :: ShardMap -> IO [(NodeConnection, [PendingRequest])] getRequestsByNode shardMap = do - commandsWithNodes <- zipWithM (requestWithNode shardMap) (reverse [0..(length requests - 1)]) requests - return $ assocs $ fromListWith (++) commandsWithNodes - requestWithNode :: ShardMap -> Int -> [B.ByteString] -> IO (NodeConnection, [PendingRequest]) - requestWithNode shardMap index request = do - nodeConn <- nodeConnectionForCommand conn shardMap request - return (nodeConn, [PendingRequest index request]) + commandsWithNodes <- zipWithM (requestWithNodes shardMap) (reverse [0..(length requests - 1)]) requests + return $ assocs $ fromListWith (++) (mconcat commandsWithNodes) + requestWithNodes :: ShardMap -> Int -> [B.ByteString] -> IO [(NodeConnection, [PendingRequest])] + requestWithNodes shardMap index request = do + nodeConns <- nodeConnectionForCommand conn shardMap request + return $ (, [PendingRequest index request]) <$> nodeConns executeRequests :: NodeConnection -> [PendingRequest] -> IO [CompletedRequest] executeRequests nodeConn nodeRequests = do replies <- requestNode nodeConn $ map rawRequest nodeRequests @@ -223,7 +224,7 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do retryReply <- case thisReply of (Error errString) | B.isPrefixOf "MOVED" errString -> do shardMap <- hasLocked "reading shard map in retry MOVED" $ readMVar shardMapVar - nodeConn <- nodeConnectionForCommand conn shardMap (requestForResponse resp) + nodeConn <- head <$> nodeConnectionForCommand conn shardMap (requestForResponse resp) head <$> requestNode nodeConn [request] (askingRedirection -> Just (host, port)) -> do shardMap <- hasLocked "reading shardmap in retry ASK" $ readMVar shardMapVar @@ -310,14 +311,28 @@ nodeConnWithHostAndPort shardMap (Connection nodeConns _ _ _) host port = do node <- nodeWithHostAndPort shardMap host port HM.lookup (nodeId node) nodeConns -nodeConnectionForCommand :: Connection -> ShardMap -> [B.ByteString] -> IO NodeConnection -nodeConnectionForCommand (Connection nodeConns _ _ infoMap) (ShardMap shardMap) request = do - keys <- requestKeys infoMap request - hashSlot <- hashSlotForKeys (CrossSlotException request) keys - node <- case IntMap.lookup (fromEnum hashSlot) shardMap of - Nothing -> throwIO $ MissingNodeException request - Just (Shard master _) -> return master - maybe (throwIO $ MissingNodeException request) return (HM.lookup (nodeId node) nodeConns) +nodeConnectionForCommand :: Connection -> ShardMap -> [B.ByteString] -> IO [NodeConnection] +nodeConnectionForCommand conn@(Connection nodeConns _ _ infoMap) (ShardMap shardMap) request = + case request of + ["UNWATCH"] -> + -- Per Redis documentation UNWATCH discards all previously watched + -- keys. That requires us to send it to every master node. + case allMasterNodes conn (ShardMap shardMap) of + Nothing -> throwIO $ MissingNodeException request + Just masterNodes -> return masterNodes + _ -> do + keys <- requestKeys infoMap request + hashSlot <- hashSlotForKeys (CrossSlotException request) keys + node <- case IntMap.lookup (fromEnum hashSlot) shardMap of + Nothing -> throwIO $ MissingNodeException request + Just (Shard master _) -> return master + maybe (throwIO $ MissingNodeException request) (return . return) (HM.lookup (nodeId node) nodeConns) + +allMasterNodes :: Connection -> ShardMap -> Maybe [NodeConnection] +allMasterNodes (Connection nodeConns _ _ _) (ShardMap shardMap) = + mapM (flip HM.lookup nodeConns . nodeId) masterNodes + where + masterNodes = (\(Shard master _) -> master) <$> nub (IntMap.elems shardMap) requestNode :: NodeConnection -> [[B.ByteString]] -> IO [Reply] requestNode (NodeConnection ctx lastRecvRef _) requests = do From 2c2b7cc7a86d491899937175c1e9a360e4a9890d Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 27 Nov 2020 09:34:54 +0100 Subject: [PATCH 025/103] Refactor keysForRequest The function has acculumated a lot of branches. This makes the different branches a bit more visible. --- src/Database/Redis/Cluster/Command.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index 389c33bd..a5466d37 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -95,14 +95,22 @@ newInfoMap = InfoMap . HM.fromList . map (\c -> (Char8.unpack $ name c, c)) keysForRequest :: InfoMap -> [BS.ByteString] -> Maybe [BS.ByteString] keysForRequest (InfoMap infoMap) request@(command:_) = do info <- HM.lookup (map toLower $ Char8.unpack command) infoMap - if isMovable info then parseMovable request else if stepCount info == 0 then Just [] else do + keysForRequest' info request +keysForRequest _ [] = Nothing + +keysForRequest' :: CommandInfo -> [BS.ByteString] -> Maybe [BS.ByteString] +keysForRequest' info request + | isMovable info = + parseMovable request + | stepCount info == 0 = + Just [] + | otherwise = do let possibleKeys = case lastKeyPosition info of LastKeyPosition end -> take (fromEnum $ 1 + end - firstKeyPosition info) $ drop (fromEnum $ firstKeyPosition info) request UnlimitedKeys end -> drop (fromEnum $ firstKeyPosition info) $ take (length request - fromEnum end) request return $ takeEvery (fromEnum $ stepCount info) possibleKeys -keysForRequest _ [] = Nothing isMovable :: CommandInfo -> Bool isMovable CommandInfo{..} = MovableKeys `elem` flags From c5dd36e52cc5963c5cf176caebb33d3ed42816cb Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 27 Nov 2020 09:39:12 +0100 Subject: [PATCH 026/103] Fix debugObject command in cluster mode --- src/Database/Redis/Cluster/Command.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index a5466d37..48197476 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -99,6 +99,10 @@ keysForRequest (InfoMap infoMap) request@(command:_) = do keysForRequest _ [] = Nothing keysForRequest' :: CommandInfo -> [BS.ByteString] -> Maybe [BS.ByteString] +keysForRequest' _ ["DEBUG", "OBJECT", key] = + -- `COMMAND` output for `DEBUG` would let us believe it doesn't have any + -- keys, but the `DEBUG OBJECT` subcommand does. + Just [key] keysForRequest' info request | isMovable info = parseMovable request From 50e59cd57fc55d71837170da9201e7bea763845f Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 27 Nov 2020 10:44:27 +0100 Subject: [PATCH 027/103] Add cluster test boilerplate Adding this as a separate test endpoint so it's possible to run non-cluster tests without needing to have a locally running redis cluster. We're starting out running the same test suite for clustered mode we do for non-clustered mode, but that's not going to last. Some Redis commands we don't currently support in cluster mode, some we might never be able to support. We'll need to adjust tests to reflect this. --- hedis.cabal | 29 ++++++++++++++++++++++++++++- test/ClusterMain.hs | 15 +++++++++++++++ test/{Test.hs => Tests.hs} | 11 +++-------- 3 files changed, 46 insertions(+), 9 deletions(-) create mode 100644 test/ClusterMain.hs rename test/{Test.hs => Tests.hs} (99%) diff --git a/hedis.cabal b/hedis.cabal index 43e1934b..33fe71be 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -130,8 +130,35 @@ test-suite hedis-test default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: Test.hs + main-is: Main.hs other-modules: PubSubTest + Tests + build-depends: + base == 4.*, + bytestring >= 0.10, + hedis, + HUnit, + async, + stm, + text, + mtl == 2.*, + test-framework, + test-framework-hunit, + time + -- We use -O0 here, since GHC takes *very* long to compile so many constants + ghc-options: -O0 -Wall -rtsopts -fno-warn-unused-do-bind + if flag(dev) + ghc-options: -Werror + if flag(dev) + ghc-prof-options: -auto-all + +test-suite hedis-test-cluster + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: ClusterMain.hs + other-modules: PubSubTest + Tests build-depends: base == 4.*, bytestring >= 0.10, diff --git a/test/ClusterMain.hs b/test/ClusterMain.hs new file mode 100644 index 00000000..2100cd3f --- /dev/null +++ b/test/ClusterMain.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import qualified Test.Framework as Test +import Database.Redis +import Tests (tests) + +main :: IO () +main = do + -- We're looking for the cluster on a non-default port to support running + -- this test in parallel witht the regular non-cluster tests. To quickly + -- spin up a cluster on this port using docker you can run: + -- + -- docker run -e "IP=0.0.0.0" -p 7000-7010:7000-7010 grokzen/redis-cluster:5.0.6 + conn <- connectCluster defaultConnectInfo { connectPort = PortNumber 7000 } + Test.defaultMain (tests conn) diff --git a/test/Test.hs b/test/Tests.hs similarity index 99% rename from test/Test.hs rename to test/Tests.hs index 6f52aa6b..13697dc9 100644 --- a/test/Test.hs +++ b/test/Tests.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, LambdaCase #-} -module Main (main) where +module Tests (tests) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative @@ -13,7 +13,7 @@ import Control.Monad.Trans import qualified Data.List as L import Data.Time import Data.Time.Clock.POSIX -import qualified Test.Framework as Test (Test, defaultMain) +import qualified Test.Framework as Test (Test) import qualified Test.Framework.Providers.HUnit as Test (testCase) import qualified Test.HUnit as HUnit @@ -21,13 +21,8 @@ import Database.Redis import PubSubTest ------------------------------------------------------------------------------ --- Main and helpers +-- helpers -- -main :: IO () -main = do - conn <- connect defaultConnectInfo - Test.defaultMain (tests conn) - type Test = Connection -> Test.Test testCase :: String -> Redis () -> Test From 77cc2f8193c676d3c9ef3fb2194fbcef46ae6b18 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 27 Nov 2020 10:49:28 +0100 Subject: [PATCH 028/103] Run FLUSHALL and FLUSHDB on all cluster nodes We need to do this if we really want to flush all keys, as the Redis documentation says we should. --- src/Database/Redis/Cluster.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 1732339e..1108f10f 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -314,12 +314,9 @@ nodeConnWithHostAndPort shardMap (Connection nodeConns _ _ _) host port = do nodeConnectionForCommand :: Connection -> ShardMap -> [B.ByteString] -> IO [NodeConnection] nodeConnectionForCommand conn@(Connection nodeConns _ _ infoMap) (ShardMap shardMap) request = case request of - ["UNWATCH"] -> - -- Per Redis documentation UNWATCH discards all previously watched - -- keys. That requires us to send it to every master node. - case allMasterNodes conn (ShardMap shardMap) of - Nothing -> throwIO $ MissingNodeException request - Just masterNodes -> return masterNodes + ("FLUSHALL" : _) -> allNodes + ("FLUSHDB" : _) -> allNodes + ("UNWATCH" : _) -> allNodes _ -> do keys <- requestKeys infoMap request hashSlot <- hashSlotForKeys (CrossSlotException request) keys @@ -327,6 +324,11 @@ nodeConnectionForCommand conn@(Connection nodeConns _ _ infoMap) (ShardMap shard Nothing -> throwIO $ MissingNodeException request Just (Shard master _) -> return master maybe (throwIO $ MissingNodeException request) (return . return) (HM.lookup (nodeId node) nodeConns) + where + allNodes = + case allMasterNodes conn (ShardMap shardMap) of + Nothing -> throwIO $ MissingNodeException request + Just allNodes' -> return allNodes' allMasterNodes :: Connection -> ShardMap -> Maybe [NodeConnection] allMasterNodes (Connection nodeConns _ _ _) (ShardMap shardMap) = From 399ce34598da527c4ecc085dc56750471d80cc5c Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 27 Nov 2020 11:19:49 +0100 Subject: [PATCH 029/103] Move tests lists into Main modules This will allow us to run a separate set of tests in the clustered and non-clustered suites. We're going to make use of that in commits to come, to remove tests in the cluster suite of commands we do not support. --- test/ClusterMain.hs | 23 ++++++++++++++++++++++- test/Tests.hs | 26 +------------------------- 2 files changed, 23 insertions(+), 26 deletions(-) diff --git a/test/ClusterMain.hs b/test/ClusterMain.hs index 2100cd3f..662bf46e 100644 --- a/test/ClusterMain.hs +++ b/test/ClusterMain.hs @@ -2,7 +2,8 @@ module Main (main) where import qualified Test.Framework as Test import Database.Redis -import Tests (tests) +import Tests +import PubSubTest main :: IO () main = do @@ -13,3 +14,23 @@ main = do -- docker run -e "IP=0.0.0.0" -p 7000-7010:7000-7010 grokzen/redis-cluster:5.0.6 conn <- connectCluster defaultConnectInfo { connectPort = PortNumber 7000 } Test.defaultMain (tests conn) + +tests :: Connection -> [Test.Test] +tests conn = map ($conn) $ concat + [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog] + , testsZSets, [testPubSub], [testTransaction], [testScripting] + , testsConnection, testsServer, [testScans], [testZrangelex] + , [testXAddRead, testXReadGroup, testXRange, testXpending, testXClaim, testXInfo, testXDel, testXTrim] + , testPubSubThreaded + -- should always be run last as connection gets closed after it + , [testQuit] + ] + +testsServer :: [Test] +testsServer = + [testServer, testBgrewriteaof, testFlushall, testInfo, testConfig + ,testSlowlog, testDebugObject] + +testsConnection :: [Test] +testsConnection = [ testConnectAuth, testConnectAuthUnexpected, testConnectDb + , testConnectDbUnexisting, testEcho, testPing, testSelect ] diff --git a/test/Tests.hs b/test/Tests.hs index 13697dc9..93f4638f 100644 --- a/test/Tests.hs +++ b/test/Tests.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, LambdaCase #-} -module Tests (tests) where +module Tests where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative @@ -18,7 +18,6 @@ import qualified Test.Framework.Providers.HUnit as Test (testCase) import qualified Test.HUnit as HUnit import Database.Redis -import PubSubTest ------------------------------------------------------------------------------ -- helpers @@ -46,20 +45,6 @@ redis >>=? expected = do assert :: Bool -> Redis () assert = liftIO . HUnit.assert ------------------------------------------------------------------------------- --- Tests --- -tests :: Connection -> [Test.Test] -tests conn = map ($conn) $ concat - [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog] - , testsZSets, [testPubSub], [testTransaction], [testScripting] - , testsConnection, testsServer, [testScans], [testZrangelex] - , [testXAddRead, testXReadGroup, testXRange, testXpending, testXClaim, testXInfo, testXDel, testXTrim] - , testPubSubThreaded - -- should always be run last as connection gets closed after it - , [testQuit] - ] - ------------------------------------------------------------------------------ -- Miscellaneous -- @@ -498,10 +483,6 @@ testScripting conn = testCase "scripting" go conn ------------------------------------------------------------------------------ -- Connection -- -testsConnection :: [Test] -testsConnection = [ testConnectAuth, testConnectAuthUnexpected, testConnectDb - , testConnectDbUnexisting, testEcho, testPing, testSelect ] - testConnectAuth :: Test testConnectAuth = testCase "connect/auth" $ do configSet "requirepass" "pass" >>=? Ok @@ -558,11 +539,6 @@ testSelect = testCase "select" $ do ------------------------------------------------------------------------------ -- Server -- -testsServer :: [Test] -testsServer = - [testServer, testBgrewriteaof, testFlushall, testInfo, testConfig - ,testSlowlog, testDebugObject] - testServer :: Test testServer = testCase "server" $ do time >>= \case From 15033ff6e0c4f066af37dcfdd3eeeff4de10ca70 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 27 Nov 2020 11:52:16 +0100 Subject: [PATCH 030/103] Remove cluster tests for unsupported commands Some of these commands we might support in cluster mode, but currenty we don't. --- test/ClusterMain.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/test/ClusterMain.hs b/test/ClusterMain.hs index 662bf46e..902b6d6d 100644 --- a/test/ClusterMain.hs +++ b/test/ClusterMain.hs @@ -19,8 +19,7 @@ tests :: Connection -> [Test.Test] tests conn = map ($conn) $ concat [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog] , testsZSets, [testPubSub], [testTransaction], [testScripting] - , testsConnection, testsServer, [testScans], [testZrangelex] - , [testXAddRead, testXReadGroup, testXRange, testXpending, testXClaim, testXInfo, testXDel, testXTrim] + , testsConnection, testsServer, [testZrangelex] , testPubSubThreaded -- should always be run last as connection gets closed after it , [testQuit] @@ -28,9 +27,8 @@ tests conn = map ($conn) $ concat testsServer :: [Test] testsServer = - [testServer, testBgrewriteaof, testFlushall, testInfo, testConfig - ,testSlowlog, testDebugObject] + [testServer, testBgrewriteaof, testFlushall, testSlowlog, testDebugObject] testsConnection :: [Test] -testsConnection = [ testConnectAuth, testConnectAuthUnexpected, testConnectDb +testsConnection = [ testConnectAuthUnexpected, testConnectDb , testConnectDbUnexisting, testEcho, testPing, testSelect ] From 739d42d4a9c00c9b97ff876161f2b2939803ac68 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 27 Nov 2020 12:28:50 +0100 Subject: [PATCH 031/103] Text fixes for cluster mode Some tests we cannot run in cluster mode because they use commands we currently don't support in cluster mode. A lot of tests can be ran if we ensure the keys touched by the test are in the same hashslot. We can adopt existing tests by adding a common expression in curly braces to the keys, which will ensure those keys end up in the same hashslot. This will not affect how the test runs in non-cluster mode. --- test/ClusterMain.hs | 17 +++++ test/Tests.hs | 158 ++++++++++++++++++++++---------------------- 2 files changed, 97 insertions(+), 78 deletions(-) diff --git a/test/ClusterMain.hs b/test/ClusterMain.hs index 902b6d6d..96dcbf67 100644 --- a/test/ClusterMain.hs +++ b/test/ClusterMain.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + module Main (main) where import qualified Test.Framework as Test @@ -32,3 +35,17 @@ testsServer = testsConnection :: [Test] testsConnection = [ testConnectAuthUnexpected, testConnectDb , testConnectDbUnexisting, testEcho, testPing, testSelect ] + +testsKeys :: [Test] +testsKeys = [ testKeys, testExpireAt, testSortCluster, testGetType, testObject ] + +testSortCluster :: Test +testSortCluster = testCase "sort" $ do + lpush "{same}ids" ["1","2","3"] >>=? 3 + sort "{same}ids" defaultSortOpts >>=? ["1","2","3"] + sortStore "{same}ids" "{same}anotherKey" defaultSortOpts >>=? 3 + let opts = defaultSortOpts { sortOrder = Desc, sortAlpha = True + , sortLimit = (1,2) + , sortBy = Nothing + , sortGet = [] } + sort "{same}ids" opts >>=? ["2", "1"] diff --git a/test/Tests.hs b/test/Tests.hs index 93f4638f..0048087c 100644 --- a/test/Tests.hs +++ b/test/Tests.hs @@ -105,37 +105,39 @@ testEvalReplies conn = testCase "eval unused replies" go conn ------------------------------------------------------------------------------ -- Keys -- -testsKeys :: [Test] -testsKeys = [ testKeys, testExpireAt, testSort, testGetType, testObject ] - testKeys :: Test testKeys = testCase "keys" $ do - set "key" "value" >>=? Ok - get "key" >>=? Just "value" - exists "key" >>=? True - keys "*" >>=? ["key"] - randomkey >>=? Just "key" - move "key" 13 >>=? True - select 13 >>=? Ok - expire "key" 1 >>=? True - pexpire "key" 1000 >>=? True - ttl "key" >>= \case + set "{same}key" "value" >>=? Ok + get "{same}key" >>=? Just "value" + exists "{same}key" >>=? True + expire "{same}key" 1 >>=? True + pexpire "{same}key" 1000 >>=? True + ttl "{same}key" >>= \case Left _ -> error "error" Right t -> do assert $ t `elem` [0..1] - pttl "key" >>= \case + pttl "{same}key" >>= \case Left _ -> error "error" Right pt -> do assert $ pt `elem` [990..1000] - persist "key" >>=? True - dump "key" >>= \case + persist "{same}key" >>=? True + dump "{same}key" >>= \case Left _ -> error "impossible" Right s -> do - restore "key'" 0 s >>=? Ok - rename "key" "key'" >>=? Ok - renamenx "key'" "key" >>=? True - del ["key"] >>=? 1 - select 0 >>=? Ok + restore "{same}key'" 0 s >>=? Ok + rename "{same}key" "{same}key'" >>=? Ok + renamenx "{same}key'" "{same}key" >>=? True + del ["{same}key"] >>=? 1 + +testKeysNoncluster :: Test +testKeysNoncluster = testCase "keysNoncluster" $ do + set "key" "value" >>=? Ok + keys "*" >>=? ["key"] + randomkey >>=? Just "key" + move "key" 13 >>=? True + select 13 >>=? Ok + get "key" >>=? Just "value" + select 0 >>=? Ok testExpireAt :: Test testExpireAt = testCase "expireat" $ do @@ -199,36 +201,36 @@ testsStrings = [testStrings, testBitops] testStrings :: Test testStrings = testCase "strings" $ do - setnx "key" "value" >>=? True - getset "key" "hello" >>=? Just "value" - append "key" "world" >>=? 10 - strlen "key" >>=? 10 - setrange "key" 0 "hello" >>=? 10 - getrange "key" 0 4 >>=? "hello" - mset [("k1","v1"), ("k2","v2")] >>=? Ok - msetnx [("k1","v1"), ("k2","v2")] >>=? False - mget ["key"] >>=? [Just "helloworld"] - setex "key" 1 "42" >>=? Ok - psetex "key" 1000 "42" >>=? Ok - decr "key" >>=? 41 - decrby "key" 1 >>=? 40 - incr "key" >>=? 41 - incrby "key" 1 >>=? 42 - incrbyfloat "key" 1 >>=? 43 - del ["key"] >>=? 1 - setbit "key" 42 "1" >>=? 0 - getbit "key" 42 >>=? 1 - bitcount "key" >>=? 1 - bitcountRange "key" 0 (-1) >>=? 1 + setnx "key" "value" >>=? True + getset "key" "hello" >>=? Just "value" + append "key" "world" >>=? 10 + strlen "key" >>=? 10 + setrange "key" 0 "hello" >>=? 10 + getrange "key" 0 4 >>=? "hello" + mset [("{same}k1","v1"), ("{same}k2","v2")] >>=? Ok + msetnx [("{same}k1","v1"), ("{same}k2","v2")] >>=? False + mget ["key"] >>=? [Just "helloworld"] + setex "key" 1 "42" >>=? Ok + psetex "key" 1000 "42" >>=? Ok + decr "key" >>=? 41 + decrby "key" 1 >>=? 40 + incr "key" >>=? 41 + incrby "key" 1 >>=? 42 + incrbyfloat "key" 1 >>=? 43 + del ["key"] >>=? 1 + setbit "key" 42 "1" >>=? 0 + getbit "key" 42 >>=? 1 + bitcount "key" >>=? 1 + bitcountRange "key" 0 (-1) >>=? 1 testBitops :: Test testBitops = testCase "bitops" $ do - set "k1" "a" >>=? Ok - set "k2" "b" >>=? Ok - bitopAnd "k3" ["k1", "k2"] >>=? 1 - bitopOr "k3" ["k1", "k2"] >>=? 1 - bitopXor "k3" ["k1", "k2"] >>=? 1 - bitopNot "k3" "k1" >>=? 1 + set "{same}k1" "a" >>=? Ok + set "{same}k2" "b" >>=? Ok + bitopAnd "{same}k3" ["{same}k1", "{same}k2"] >>=? 1 + bitopOr "{same}k3" ["{same}k1", "{same}k2"] >>=? 1 + bitopXor "{same}k3" ["{same}k1", "{same}k2"] >>=? 1 + bitopNot "{same}k3" "{same}k1" >>=? 1 ------------------------------------------------------------------------------ -- Hashes @@ -276,12 +278,12 @@ testLists = testCase "lists" $ do testBpop :: Test testBpop = testCase "blocking push/pop" $ do - lpush "key" ["v3","v2","v1"] >>=? 3 - blpop ["key"] 1 >>=? Just ("key","v1") - brpop ["key"] 1 >>=? Just ("key","v3") - rpush "k1" ["v1","v2"] >>=? 2 - brpoplpush "k1" "k2" 1 >>=? Just "v2" - rpoplpush "k1" "k2" >>=? Just "v1" + lpush "{same}key" ["v3","v2","v1"] >>=? 3 + blpop ["{same}key"] 1 >>=? Just ("{same}key","v1") + brpop ["{same}key"] 1 >>=? Just ("{same}key","v3") + rpush "{same}k1" ["v1","v2"] >>=? 2 + brpoplpush "{same}k1" "{same}k2" 1 >>=? Just "v2" + rpoplpush "{same}k1" "{same}k2" >>=? Just "v1" ------------------------------------------------------------------------------ -- Sets @@ -298,7 +300,7 @@ testSets = testCase "sets" $ do srandmember "set" >>=? Just "member" spop "set" >>=? Just "member" srem "set" ["member"] >>=? 0 - smove "set" "set'" "member" >>=? False + smove "{same}set" "{same}set'" "member" >>=? False _ <- sadd "set" ["member1", "member2"] (fmap L.sort <$> spopN "set" 2) >>=? ["member1", "member2"] _ <- sadd "set" ["member1", "member2"] @@ -306,13 +308,13 @@ testSets = testCase "sets" $ do testSetAlgebra :: Test testSetAlgebra = testCase "set algebra" $ do - sadd "s1" ["member"] >>=? 1 - sdiff ["s1", "s2"] >>=? ["member"] - sunion ["s1", "s2"] >>=? ["member"] - sinter ["s1", "s2"] >>=? [] - sdiffstore "s3" ["s1", "s2"] >>=? 1 - sunionstore "s3" ["s1", "s2"] >>=? 1 - sinterstore "s3" ["s1", "s2"] >>=? 0 + sadd "{same}s1" ["member"] >>=? 1 + sdiff ["{same}s1", "{same}s2"] >>=? ["member"] + sunion ["{same}s1", "{same}s2"] >>=? ["member"] + sinter ["{same}s1", "{same}s2"] >>=? [] + sdiffstore "{same}s3" ["{same}s1", "{same}s2"] >>=? 1 + sunionstore "{same}s3" ["{same}s1", "{same}s2"] >>=? 1 + sinterstore "{same}s3" ["{same}s1", "{same}s2"] >>=? 0 ------------------------------------------------------------------------------ -- Sorted Sets @@ -351,16 +353,16 @@ testZSets = testCase "sorted sets" $ do testZStore :: Test testZStore = testCase "zunionstore/zinterstore" $ do - zadd "k1" [(1, "v1"), (2, "v2")] >>= \case + zadd "{same}k1" [(1, "v1"), (2, "v2")] >>= \case Left _ -> error "error" _ -> return () - zadd "k2" [(2, "v2"), (3, "v3")] >>= \case + zadd "{same}k2" [(2, "v2"), (3, "v3")] >>= \case Left _ -> error "error" _ -> return () - zinterstore "newkey" ["k1","k2"] Sum >>=? 1 - zinterstoreWeights "newkey" [("k1",1),("k2",2)] Max >>=? 1 - zunionstore "newkey" ["k1","k2"] Sum >>=? 3 - zunionstoreWeights "newkey" [("k1",1),("k2",2)] Min >>=? 3 + zinterstore "{same}newkey" ["{same}k1","{same}k2"] Sum >>=? 1 + zinterstoreWeights "{same}newkey" [("{same}k1",1),("{same}k2",2)] Max >>=? 1 + zunionstore "{same}newkey" ["{same}k1","{same}k2"] Sum >>=? 3 + zunionstoreWeights "{same}newkey" [("{same}k1",1),("{same}k2",2)] Min >>=? 3 ------------------------------------------------------------------------------ -- HyperLogLog @@ -383,18 +385,18 @@ testHyperLogLog = testCase "hyperloglog" $ do _ -> return () pfcount ["hll1"] >>=? 5 -- test merge - pfadd "hll2" ["1", "2", "3"] >>= \case + pfadd "{same}hll2" ["1", "2", "3"] >>= \case Left _ -> error "error" _ -> return () - pfadd "hll3" ["4", "5", "6"] >>= \case + pfadd "{same}hll3" ["4", "5", "6"] >>= \case Left _ -> error "error" _ -> return () - pfmerge "hll4" ["hll2", "hll3"] >>= \case + pfmerge "{same}hll4" ["{same}hll2", "{same}hll3"] >>= \case Left _ -> error "error" _ -> return () - pfcount ["hll4"] >>=? 6 + pfcount ["{same}hll4"] >>=? 6 -- test union cardinality - pfcount ["hll2", "hll3"] >>=? 6 + pfcount ["{same}hll2", "{same}hll3"] >>=? 6 ------------------------------------------------------------------------------ -- Pub/Sub @@ -432,17 +434,17 @@ testPubSub conn = testCase "pubSub" go conn -- testTransaction :: Test testTransaction = testCase "transaction" $ do - watch ["k1", "k2"] >>=? Ok + watch ["{same}k1", "{same}k2"] >>=? Ok unwatch >>=? Ok - set "foo" "foo" >>= \case + set "{same}foo" "foo" >>= \case Left _ -> error "error" _ -> return () - set "bar" "bar" >>= \case + set "{same}bar" "bar" >>= \case Left _ -> error "error" _ -> return () foobar <- multiExec $ do - foo <- get "foo" - bar <- get "bar" + foo <- get "{same}foo" + bar <- get "{same}bar" return $ (,) <$> foo <*> bar assert $ foobar == TxSuccess (Just "foo", Just "bar") From 47d26a4d7378af187a66b2dc0924c24191ed9e03 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 27 Nov 2020 14:15:11 +0100 Subject: [PATCH 032/103] Don't test unsupported cluster features This removes some more tests from the cluster suite of commands that we aren't currently supporting in cluster mode. --- test/ClusterMain.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/test/ClusterMain.hs b/test/ClusterMain.hs index 96dcbf67..cfcba303 100644 --- a/test/ClusterMain.hs +++ b/test/ClusterMain.hs @@ -6,7 +6,6 @@ module Main (main) where import qualified Test.Framework as Test import Database.Redis import Tests -import PubSubTest main :: IO () main = do @@ -21,20 +20,20 @@ main = do tests :: Connection -> [Test.Test] tests conn = map ($conn) $ concat [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog] - , testsZSets, [testPubSub], [testTransaction], [testScripting] + , testsZSets, [testTransaction], [testScripting] , testsConnection, testsServer, [testZrangelex] - , testPubSubThreaded -- should always be run last as connection gets closed after it , [testQuit] ] testsServer :: [Test] testsServer = - [testServer, testBgrewriteaof, testFlushall, testSlowlog, testDebugObject] + [testBgrewriteaof, testFlushall, testSlowlog, testDebugObject] testsConnection :: [Test] testsConnection = [ testConnectAuthUnexpected, testConnectDb - , testConnectDbUnexisting, testEcho, testPing, testSelect ] + , testConnectDbUnexisting, testEcho, testPing + ] testsKeys :: [Test] testsKeys = [ testKeys, testExpireAt, testSortCluster, testGetType, testObject ] From 28f3a5e158a63dadda881c85c0ba06f24cd94fea Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 27 Nov 2020 14:23:57 +0100 Subject: [PATCH 033/103] Fix QUIT command in cluster mode --- src/Database/Redis/Cluster.hs | 1 + src/Database/Redis/Cluster/Command.hs | 11 +++++++---- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 1108f10f..44fafd07 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -316,6 +316,7 @@ nodeConnectionForCommand conn@(Connection nodeConns _ _ infoMap) (ShardMap shard case request of ("FLUSHALL" : _) -> allNodes ("FLUSHDB" : _) -> allNodes + ("QUIT" : _) -> allNodes ("UNWATCH" : _) -> allNodes _ -> do keys <- requestKeys infoMap request diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index 48197476..c13f4caf 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -93,16 +93,19 @@ newInfoMap :: [CommandInfo] -> InfoMap newInfoMap = InfoMap . HM.fromList . map (\c -> (Char8.unpack $ name c, c)) keysForRequest :: InfoMap -> [BS.ByteString] -> Maybe [BS.ByteString] +keysForRequest _ ["DEBUG", "OBJECT", key] = + -- `COMMAND` output for `DEBUG` would let us believe it doesn't have any + -- keys, but the `DEBUG OBJECT` subcommand does. + Just [key] +keysForRequest _ ["QUIT"] = + -- The `QUIT` command is not listed in the `COMMAND` output. + Just [] keysForRequest (InfoMap infoMap) request@(command:_) = do info <- HM.lookup (map toLower $ Char8.unpack command) infoMap keysForRequest' info request keysForRequest _ [] = Nothing keysForRequest' :: CommandInfo -> [BS.ByteString] -> Maybe [BS.ByteString] -keysForRequest' _ ["DEBUG", "OBJECT", key] = - -- `COMMAND` output for `DEBUG` would let us believe it doesn't have any - -- keys, but the `DEBUG OBJECT` subcommand does. - Just [key] keysForRequest' info request | isMovable info = parseMovable request From c01e4c53c370b148c3e5415e57381153cd9d1810 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 27 Nov 2020 14:38:58 +0100 Subject: [PATCH 034/103] Test cluster mode in Travis --- .travis.yml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/.travis.yml b/.travis.yml index 994cd526..50291f06 100644 --- a/.travis.yml +++ b/.travis.yml @@ -8,6 +8,9 @@ cache: - $HOME/.cabal - $HOME/.stack +services: + - docker + before_install: - mkdir -p ~/.local/bin - mkdir -p ~/tmp @@ -21,6 +24,7 @@ before_install: - sudo apt-get update - sudo apt-get -y install redis-server - cd ${TRAVIS_BUILD_DIR} + - docker run -d -p 7000-7010:7000-7010 grokzen/redis-cluster:5.0.6 matrix: include: From b8e01759a08237b8f5f3a881f4b961d6497cd5a6 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 27 Nov 2020 15:06:10 +0100 Subject: [PATCH 035/103] Add back tests for SSCAN, HSCAN, and ZSCAN These are supported in cluster mode. It's only SCAN which scans across multiple keys which is problematic. --- test/ClusterMain.hs | 2 +- test/Tests.hs | 13 +++++++++++-- 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/test/ClusterMain.hs b/test/ClusterMain.hs index cfcba303..84d6b37c 100644 --- a/test/ClusterMain.hs +++ b/test/ClusterMain.hs @@ -21,7 +21,7 @@ tests :: Connection -> [Test.Test] tests conn = map ($conn) $ concat [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog] , testsZSets, [testTransaction], [testScripting] - , testsConnection, testsServer, [testZrangelex] + , testsConnection, testsServer, [testSScan, testHScan, testZScan], [testZrangelex] -- should always be run last as connection gets closed after it , [testQuit] ] diff --git a/test/Tests.hs b/test/Tests.hs index 0048087c..64db5551 100644 --- a/test/Tests.hs +++ b/test/Tests.hs @@ -605,14 +605,23 @@ testScans = testCase "scans" $ do scan cursor0 >>=? (cursor0, ["key"]) scanOpts cursor0 sOpts1 >>=? (cursor0, ["key"]) scanOpts cursor0 sOpts2 >>=? (cursor0, []) + where sOpts1 = defaultScanOpts { scanMatch = Just "k*" } + sOpts2 = defaultScanOpts { scanMatch = Just "not*"} + +testSScan :: Test +testSScan = testCase "sscan" $ do sadd "set" ["1"] >>=? 1 sscan "set" cursor0 >>=? (cursor0, ["1"]) + +testHScan :: Test +testHScan = testCase "hscan" $ do hset "hash" "k" "v" >>=? True hscan "hash" cursor0 >>=? (cursor0, [("k", "v")]) + +testZScan :: Test +testZScan = testCase "zscan" $ do zadd "zset" [(42, "2")] >>=? 1 zscan "zset" cursor0 >>=? (cursor0, [("2", 42)]) - where sOpts1 = defaultScanOpts { scanMatch = Just "k*" } - sOpts2 = defaultScanOpts { scanMatch = Just "not*"} testZrangelex ::Test testZrangelex = testCase "zrangebylex" $ do From 97b0970ee488611cbce2509f955149b70b8e20a9 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 27 Nov 2020 15:09:29 +0100 Subject: [PATCH 036/103] Add test/Main.hs --- test/Main.hs | 34 ++++++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) create mode 100644 test/Main.hs diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 00000000..06151067 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,34 @@ +module Main (main) where + +import qualified Test.Framework as Test +import Database.Redis +import Tests +import PubSubTest + +main :: IO () +main = do + conn <- connect defaultConnectInfo + Test.defaultMain (tests conn) + +tests :: Connection -> [Test.Test] +tests conn = map ($conn) $ concat + [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog] + , testsZSets, [testPubSub], [testTransaction], [testScripting] + , testsConnection, testsServer, [testScans, testSScan, testHScan, testZScan], [testZrangelex] + , [testXAddRead, testXReadGroup, testXRange, testXpending, testXClaim, testXInfo, testXDel, testXTrim] + , testPubSubThreaded + -- should always be run last as connection gets closed after it + , [testQuit] + ] + +testsServer :: [Test] +testsServer = + [testServer, testBgrewriteaof, testFlushall, testInfo, testConfig + ,testSlowlog, testDebugObject] + +testsConnection :: [Test] +testsConnection = [ testConnectAuth, testConnectAuthUnexpected, testConnectDb + , testConnectDbUnexisting, testEcho, testPing, testSelect ] + +testsKeys :: [Test] +testsKeys = [ testKeys, testKeysNoncluster, testExpireAt, testSort, testGetType, testObject ] From 3f7cf709af45e9ae0a677bab84e5e9175c261005 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 27 Nov 2020 15:28:42 +0100 Subject: [PATCH 037/103] Support stream commands in cluster mode --- src/Database/Redis/Cluster/Command.hs | 14 ++++++++++++++ test/ClusterMain.hs | 1 + test/Tests.hs | 16 ++++++++-------- 3 files changed, 23 insertions(+), 8 deletions(-) diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index c13f4caf..cf67f17b 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -128,8 +128,22 @@ parseMovable ("EVAL":_:rest) = readNumKeys rest parseMovable ("EVALSHA":_:rest) = readNumKeys rest parseMovable ("ZUNIONSTORE":_:rest) = readNumKeys rest parseMovable ("ZINTERSTORE":_:rest) = readNumKeys rest +parseMovable ("XREAD":rest) = readXreadKeys rest +parseMovable ("XREADGROUP":"GROUP":_:_:rest) = readXreadgroupKeys rest parseMovable _ = Nothing +readXreadKeys :: [BS.ByteString] -> Maybe [BS.ByteString] +readXreadKeys ("COUNT":_:rest) = readXreadKeys rest +readXreadKeys ("BLOCK":_:rest) = readXreadKeys rest +readXreadKeys ("STREAMS":rest) = Just $ take (length rest `div` 2) rest +readXreadKeys _ = Nothing + +readXreadgroupKeys :: [BS.ByteString] -> Maybe [BS.ByteString] +readXreadgroupKeys ("COUNT":_:rest) = readXreadKeys rest +readXreadgroupKeys ("BLOCK":_:rest) = readXreadKeys rest +readXreadgroupKeys ("NOACK":rest) = readXreadKeys rest +readXreadgroupKeys ("STREAMS":rest) = Just $ take (length rest `div` 2) rest +readXreadgroupKeys _ = Nothing readNumKeys :: [BS.ByteString] -> Maybe [BS.ByteString] readNumKeys (rawNumKeys:rest) = do diff --git a/test/ClusterMain.hs b/test/ClusterMain.hs index 84d6b37c..838f138a 100644 --- a/test/ClusterMain.hs +++ b/test/ClusterMain.hs @@ -22,6 +22,7 @@ tests conn = map ($conn) $ concat [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog] , testsZSets, [testTransaction], [testScripting] , testsConnection, testsServer, [testSScan, testHScan, testZScan], [testZrangelex] + , [testXAddRead, testXReadGroup, testXRange, testXpending, testXClaim, testXInfo, testXDel, testXTrim] -- should always be run last as connection gets closed after it , [testQuit] ] diff --git a/test/Tests.hs b/test/Tests.hs index 64db5551..77e14d56 100644 --- a/test/Tests.hs +++ b/test/Tests.hs @@ -634,20 +634,20 @@ testZrangelex = testCase "zrangebylex" $ do testXAddRead ::Test testXAddRead = testCase "xadd/xread" $ do - xadd "somestream" "123" [("key", "value"), ("key2", "value2")] - xadd "otherstream" "456" [("key1", "value1")] - xaddOpts "thirdstream" "*" [("k", "v")] (Maxlen 1) - xaddOpts "thirdstream" "*" [("k", "v")] (ApproxMaxlen 1) - xread [("somestream", "0"), ("otherstream", "0")] >>=? Just [ + xadd "{same}somestream" "123" [("key", "value"), ("key2", "value2")] + xadd "{same}otherstream" "456" [("key1", "value1")] + xaddOpts "{same}thirdstream" "*" [("k", "v")] (Maxlen 1) + xaddOpts "{same}thirdstream" "*" [("k", "v")] (ApproxMaxlen 1) + xread [("{same}somestream", "0"), ("{same}otherstream", "0")] >>=? Just [ XReadResponse { - stream = "somestream", + stream = "{same}somestream", records = [StreamsRecord{recordId = "123-0", keyValues = [("key", "value"), ("key2", "value2")]}] }, XReadResponse { - stream = "otherstream", + stream = "{same}otherstream", records = [StreamsRecord{recordId = "456-0", keyValues = [("key1", "value1")]}] }] - xlen "somestream" >>=? 1 + xlen "{same}somestream" >>=? 1 testXReadGroup ::Test testXReadGroup = testCase "XGROUP */xreadgroup/xack" $ do From 6915a8cf9b9482a97dabc3e5e865d5c74f7bb4eb Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Fri, 27 Nov 2020 15:34:38 +0100 Subject: [PATCH 038/103] Document unsupported commands --- src/Database/Redis/Connection.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs index fae61424..507abb74 100644 --- a/src/Database/Redis/Connection.hs +++ b/src/Database/Redis/Connection.hs @@ -189,6 +189,12 @@ instance Exception ClusterConnectError -- |Constructs a 'ShardMap' of connections to clustered nodes. The argument is -- a 'ConnectInfo' for any node in the cluster +-- +-- Some Redis commands are currently not supported in cluster mode +-- - CONFIG, AUTH +-- - SCAN +-- - MOVE, SELECT +-- - PUBLISH, SUBSCRIBE, PSUBSCRIBE, UNSUBSCRIBE, PUNSUBSCRIBE, RESET connectCluster :: ConnectInfo -> IO Connection connectCluster bootstrapConnInfo = do conn <- createConnection bootstrapConnInfo From 840dade218b02e09bb963df77ec2d3af26e197cd Mon Sep 17 00:00:00 2001 From: Martin Betak Date: Sat, 28 Nov 2020 15:39:41 +0100 Subject: [PATCH 039/103] Make HSET return integer instead of bool Fixes informatikr/hedis#152 --- codegen/commands.json | 2 +- src/Database/Redis/Commands.hs | 2 +- test/Test.hs | 8 +++++--- 3 files changed, 7 insertions(+), 5 deletions(-) diff --git a/codegen/commands.json b/codegen/commands.json index 8066249a..11382b8d 100644 --- a/codegen/commands.json +++ b/codegen/commands.json @@ -1203,7 +1203,7 @@ ], "since": "2.0.0", "group": "hash", - "returns": "bool" + "returns": "integer" }, "HSETNX": { "summary": "Set the value of a hash field, only if the field does not exist", diff --git a/src/Database/Redis/Commands.hs b/src/Database/Redis/Commands.hs index e26129b8..99a3e52b 100644 --- a/src/Database/Redis/Commands.hs +++ b/src/Database/Redis/Commands.hs @@ -830,7 +830,7 @@ hset => ByteString -- ^ key -> ByteString -- ^ field -> ByteString -- ^ value - -> m (f Bool) + -> m (f Integer) hset key field value = sendRequest (["HSET"] ++ [encode key] ++ [encode field] ++ [encode value] ) brpoplpush diff --git a/test/Test.hs b/test/Test.hs index 3287e560..efe074a0 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -196,7 +196,7 @@ testGetType = testCase "getType" $ do del ["key"] >>=? 1 where ts = [ (set "key" "value" >>=? Ok, String) - , (hset "key" "field" "value" >>=? True, Hash) + , (hset "key" "field" "value" >>=? 1, Hash) , (lpush "key" ["value"] >>=? 1, List) , (sadd "key" ["member"] >>=? 1, Set) , (zadd "key" [(42,"member"),(12.3,"value")] >>=? 2, ZSet) @@ -255,7 +255,9 @@ testBitops = testCase "bitops" $ do -- testHashes :: Test testHashes = testCase "hashes" $ do - hset "key" "field" "value" >>=? True + hset "key" "field" "another" >>=? 1 + hset "key" "field" "another" >>=? 0 + hset "key" "field" "value" >>=? 0 hsetnx "key" "field" "value" >>=? False hexists "key" "field" >>=? True hlen "key" >>=? 1 @@ -634,7 +636,7 @@ testScans = testCase "scans" $ do scanOpts cursor0 sOpts2 >>=? (cursor0, []) sadd "set" ["1"] >>=? 1 sscan "set" cursor0 >>=? (cursor0, ["1"]) - hset "hash" "k" "v" >>=? True + hset "hash" "k" "v" >>=? 1 hscan "hash" cursor0 >>=? (cursor0, [("k", "v")]) zadd "zset" [(42, "2")] >>=? 1 zscan "zset" cursor0 >>=? (cursor0, [("2", 42)]) From 049a3f7ff1aae2e7a92570e05dbedb3f4a202120 Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Sat, 28 Nov 2020 16:47:17 +0200 Subject: [PATCH 040/103] 0.13.0 changelog --- CHANGELOG | 4 ++++ hedis.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index f53b9e42..2fe522da 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,9 @@ # Changelog for Hedis +## 0.13.0 + +* PR #159. Issue #152. Make HSET return integer instead of bool + ## 0.12.15 * PR #154. Implement Redis Sentinel support diff --git a/hedis.cabal b/hedis.cabal index ed398154..619ac3cd 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.12.15 +version: 0.13.0 synopsis: Client library for the Redis datastore: supports full command set, pipelining. From 60e4fc3b2e5633ba71c0bd57a97ca41d39d640d5 Mon Sep 17 00:00:00 2001 From: Martin Betak Date: Sat, 28 Nov 2020 14:58:52 +0100 Subject: [PATCH 041/103] travis: Upgrade to Redis 6.0.9 & Fix auth test Fixes informatikr/hedis#155 --- .travis.yml | 13 ++++---- src/Database/Redis/ManualCommands.hs | 44 ++++++++++++++++++++-------- test/Test.hs | 2 +- 3 files changed, 39 insertions(+), 20 deletions(-) diff --git a/.travis.yml b/.travis.yml index 994cd526..feb2c51e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -2,6 +2,13 @@ language: c # sudo: false dist: bionic +addons: + apt: + sources: + - sourceline: ppa:redislabs/redis + packages: + - redis + cache: directories: - $HOME/.ghc @@ -14,12 +21,6 @@ before_install: - export PATH=~/.local/bin:$PATH - curl -L https://github.com/commercialhaskell/stack/releases/download/v2.1.3/stack-2.1.3-linux-x86_64.tar.gz | tar xz -C ~/tmp - mv ~/tmp/stack-2.1.3-linux-x86_64/stack ~/.local/bin/ - # - curl -L https://github.com/antirez/redis/archive/5.0.2.tar.gz | tar xz -C ~/tmp - # - cd ~/tmp/redis-5.0.2 && make - # - ~/tmp/redis-5.0.2/src/redis-server & - - sudo add-apt-repository -y ppa:chris-lea/redis-server - - sudo apt-get update - - sudo apt-get -y install redis-server - cd ${TRAVIS_BUILD_DIR} matrix: diff --git a/src/Database/Redis/ManualCommands.hs b/src/Database/Redis/ManualCommands.hs index d4aaeb89..b4dbfd8a 100644 --- a/src/Database/Redis/ManualCommands.hs +++ b/src/Database/Redis/ManualCommands.hs @@ -1,10 +1,13 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleContexts #-} +{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, FlexibleContexts #-} module Database.Redis.ManualCommands where import Prelude hiding (min, max) import Data.ByteString (ByteString, empty, append) import Data.Maybe (maybeToList) +#if __GLASGOW_HASKELL__ < 808 +import Data.Semigroup ((<>)) +#endif import Database.Redis.Core import Database.Redis.Protocol import Database.Redis.Types @@ -1157,18 +1160,33 @@ data XInfoStreamResponse = XInfoStreamResponse } deriving (Show, Eq) instance RedisResult XInfoStreamResponse where - decode (MultiBulk (Just [ - Bulk (Just "length"),Integer xinfoStreamLength, - Bulk (Just "radix-tree-keys"),Integer xinfoStreamRadixTreeKeys, - Bulk (Just "radix-tree-nodes"),Integer xinfoStreamRadixTreeNodes, - Bulk (Just "groups"),Integer xinfoStreamNumGroups, - Bulk (Just "last-generated-id"),Bulk (Just xinfoStreamLastEntryId), - Bulk (Just "first-entry"), rawFirstEntry , - Bulk (Just "last-entry"), rawLastEntry ])) = do - xinfoStreamFirstEntry <- decode rawFirstEntry - xinfoStreamLastEntry <- decode rawLastEntry - return XInfoStreamResponse{..} - decode a = Left a + decode = decodeRedis5 <> decodeRedis6 + where + decodeRedis5 (MultiBulk (Just [ + Bulk (Just "length"),Integer xinfoStreamLength, + Bulk (Just "radix-tree-keys"),Integer xinfoStreamRadixTreeKeys, + Bulk (Just "radix-tree-nodes"),Integer xinfoStreamRadixTreeNodes, + Bulk (Just "groups"),Integer xinfoStreamNumGroups, + Bulk (Just "last-generated-id"),Bulk (Just xinfoStreamLastEntryId), + Bulk (Just "first-entry"), rawFirstEntry , + Bulk (Just "last-entry"), rawLastEntry ])) = do + xinfoStreamFirstEntry <- decode rawFirstEntry + xinfoStreamLastEntry <- decode rawLastEntry + return XInfoStreamResponse{..} + decodeRedis5 a = Left a + + decodeRedis6 (MultiBulk (Just [ + Bulk (Just "length"),Integer xinfoStreamLength, + Bulk (Just "radix-tree-keys"),Integer xinfoStreamRadixTreeKeys, + Bulk (Just "radix-tree-nodes"),Integer xinfoStreamRadixTreeNodes, + Bulk (Just "last-generated-id"),Bulk (Just xinfoStreamLastEntryId), + Bulk (Just "groups"),Integer xinfoStreamNumGroups, + Bulk (Just "first-entry"), rawFirstEntry , + Bulk (Just "last-entry"), rawLastEntry ])) = do + xinfoStreamFirstEntry <- decode rawFirstEntry + xinfoStreamLastEntry <- decode rawLastEntry + return XInfoStreamResponse{..} + decodeRedis6 a = Left a xinfoStream :: (RedisCtx m f) diff --git a/test/Test.hs b/test/Test.hs index 3287e560..9a370475 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -524,7 +524,7 @@ testConnectAuthUnexpected = testCase "connect/auth/unexpected" $ do where connInfo = defaultConnectInfo { connectAuth = Just "pass" } err = Left $ ConnectAuthError $ - Error "ERR Client sent AUTH, but no password is set" + Error "ERR AUTH called without any password configured for the default user. Are you sure your configuration is correct?" testConnectDb :: Test testConnectDb = testCase "connect/db" $ do From cc05cdd2bd8812d41f9bf46267dab543bc229a5c Mon Sep 17 00:00:00 2001 From: Martin Betak Date: Sun, 29 Nov 2020 17:37:25 +0100 Subject: [PATCH 042/103] Fix GHC 8.0.1 compat Fixes build on GHC 8.0.1 --- src/Database/Redis/Sentinel.hs | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/src/Database/Redis/Sentinel.hs b/src/Database/Redis/Sentinel.hs index 0add2cd0..d3a4f0d8 100644 --- a/src/Database/Redis/Sentinel.hs +++ b/src/Database/Redis/Sentinel.hs @@ -1,10 +1,11 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE StandaloneDeriving #-} -- | "Database.Redis" like interface with connection through Redis Sentinel. -- @@ -215,4 +216,6 @@ data SentinelConnectInfo data RedisSentinelException = NoSentinels (NonEmpty (HostName, PortID)) -- ^ Thrown if no sentinel can be reached. - deriving (Show, Typeable, Exception) + deriving (Show, Typeable) + +deriving instance Exception RedisSentinelException From 4f0c5697f344e4645e9f700ad3a700c8830de131 Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Sun, 29 Nov 2020 23:01:59 +0200 Subject: [PATCH 043/103] 0.13.1 --- CHANGELOG | 5 +++++ hedis.cabal | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index 2fe522da..7d5ebc94 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,10 @@ # Changelog for Hedis +## 0.13.1 + +* PR #158. Upgrade to Redis 6.0.9 & Fix auth test +* PR #160. Fix GHC 8.0.1 compat + ## 0.13.0 * PR #159. Issue #152. Make HSET return integer instead of bool diff --git a/hedis.cabal b/hedis.cabal index 619ac3cd..8728ef40 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.13.0 +version: 0.13.1 synopsis: Client library for the Redis datastore: supports full command set, pipelining. From 199c1444bf44c662c18d10de778584bf56e1da21 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Wed, 2 Dec 2020 10:57:14 +0100 Subject: [PATCH 044/103] Extract nodeConnForHashSlot function This is preparation for using the same logic in retry logic. --- src/Database/Redis/Cluster.hs | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 44fafd07..789ed2d0 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -246,8 +246,7 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do evaluateTransactionPipeline :: MVar ShardMap -> IO ShardMap -> Connection -> [[B.ByteString]] -> IO [Reply] evaluateTransactionPipeline shardMapVar refreshShardmapAction conn requests' = do let requests = reverse requests' - (ShardMap shardMap) <- hasLocked "reading shardmap in evaluatePipeline" $ readMVar shardMapVar - let (Connection nodeConns _ _ infoMap) = conn + let (Connection _ _ _ infoMap) = conn keys <- mconcat <$> mapM (requestKeys infoMap) requests -- In cluster mode Redis expects commands in transactions to all work on the -- same hashslot. We find that hashslot here. @@ -258,14 +257,7 @@ evaluateTransactionPipeline shardMapVar refreshShardmapAction conn requests' = d -- the commands in a transaction are applied and some are not. Better to -- fail early. hashSlot <- hashSlotForKeys (MultiExecCrossSlotException (show keys, requests)) keys - node <- - case IntMap.lookup (fromEnum hashSlot) shardMap of - Nothing -> throwIO $ MissingNodeException (head requests) - Just (Shard master _) -> return master - nodeConn <- - case HM.lookup (nodeId node) nodeConns of - Nothing -> throwIO $ MissingNodeException (head requests) - Just nodeConn' -> return nodeConn' + nodeConn <- nodeConnForHashSlot shardMapVar conn (MissingNodeException (head requests)) hashSlot resps <- requestNode nodeConn requests -- It's unclear what to do if one of the commands in a transaction asks us -- to redirect. Run only the redirected commands in another transaction? @@ -274,6 +266,18 @@ evaluateTransactionPipeline shardMapVar refreshShardmapAction conn requests' = d (hasLocked "locked refreshing due to moved responses" $ modifyMVar_ shardMapVar (const refreshShardmapAction)) return resps +nodeConnForHashSlot :: Exception e => MVar ShardMap -> Connection -> e -> HashSlot -> IO NodeConnection +nodeConnForHashSlot shardMapVar conn exception hashSlot = do + let (Connection nodeConns _ _ _) = conn + (ShardMap shardMap) <- hasLocked "reading shardmap in evaluatePipeline" $ readMVar shardMapVar + node <- + case IntMap.lookup (fromEnum hashSlot) shardMap of + Nothing -> throwIO exception + Just (Shard master _) -> return master + case HM.lookup (nodeId node) nodeConns of + Nothing -> throwIO exception + Just nodeConn' -> return nodeConn' + hashSlotForKeys :: Exception e => e -> [B.ByteString] -> IO HashSlot hashSlotForKeys exception keys = case nub (keyToSlot <$> keys) of From a79bc71ac60b253d1a5a90621a769b68e8435969 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Wed, 2 Dec 2020 11:24:58 +0100 Subject: [PATCH 045/103] Extract retry function for transactions This is the first step towards reusing this logic in transaction pipelines too. --- src/Database/Redis/Cluster.hs | 39 +++++++++++++++++++---------------- 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 789ed2d0..d0778f45 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -220,27 +220,30 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do replies <- requestNode nodeConn $ map rawRequest nodeRequests return $ zipWith (curry (\(PendingRequest i r, rep) -> CompletedRequest i r rep)) nodeRequests replies retry :: Int -> CompletedRequest -> IO CompletedRequest - retry retryCount resp@(CompletedRequest index request thisReply) = do - retryReply <- case thisReply of - (Error errString) | B.isPrefixOf "MOVED" errString -> do - shardMap <- hasLocked "reading shard map in retry MOVED" $ readMVar shardMapVar - nodeConn <- head <$> nodeConnectionForCommand conn shardMap (requestForResponse resp) - head <$> requestNode nodeConn [request] - (askingRedirection -> Just (host, port)) -> do - shardMap <- hasLocked "reading shardmap in retry ASK" $ readMVar shardMapVar - let maybeAskNode = nodeConnWithHostAndPort shardMap conn host port - case maybeAskNode of - Just askNode -> last <$> requestNode askNode [["ASKING"], requestForResponse resp] - Nothing -> case retryCount of - 0 -> do - _ <- refreshShardMapVar "missing node in first retry of ASK" - rawResponse <$> retry (retryCount + 1) resp - _ -> throwIO $ MissingNodeException (requestForResponse resp) - _ -> return thisReply - return (CompletedRequest index request retryReply) + retry = retry' shardMapVar refreshShardmapAction conn refreshShardMapVar :: String -> IO () refreshShardMapVar msg = hasLocked msg $ modifyMVar_ shardMapVar (const refreshShardmapAction) +retry' :: MVar ShardMap -> IO ShardMap -> Connection -> Int -> CompletedRequest -> IO CompletedRequest +retry' shardMapVar refreshShardmapAction conn retryCount resp@(CompletedRequest index request thisReply) = do + retryReply <- case thisReply of + (Error errString) | B.isPrefixOf "MOVED" errString -> do + shardMap <- hasLocked "reading shard map in retry MOVED" $ readMVar shardMapVar + nodeConn <- head <$> nodeConnectionForCommand conn shardMap (requestForResponse resp) + head <$> requestNode nodeConn [request] + (askingRedirection -> Just (host, port)) -> do + shardMap <- hasLocked "reading shardmap in retry ASK" $ readMVar shardMapVar + let maybeAskNode = nodeConnWithHostAndPort shardMap conn host port + case maybeAskNode of + Just askNode -> last <$> requestNode askNode [["ASKING"], requestForResponse resp] + Nothing -> case retryCount of + 0 -> do + _ <- hasLocked "missing node in first retry of ASK" $ modifyMVar_ shardMapVar (const refreshShardmapAction) + rawResponse <$> retry' shardMapVar refreshShardmapAction conn (retryCount + 1) resp + _ -> throwIO $ MissingNodeException (requestForResponse resp) + _ -> return thisReply + return (CompletedRequest index request retryReply) + -- Like `evaluateOnPipeline`, except we expect to be able to run all commands -- on a single shard. Failing to meet this expectation is an error. evaluateTransactionPipeline :: MVar ShardMap -> IO ShardMap -> Connection -> [[B.ByteString]] -> IO [Reply] From 046e4b91016321f1642a912a5c886aafbc4f28eb Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Wed, 2 Dec 2020 11:32:12 +0100 Subject: [PATCH 046/103] Extract `CompletedRequest` from common retry logic We don't have the `CompletedRequest` concept in the pipeline evaluation, it's specific to non-pipeline evaluation. --- src/Database/Redis/Cluster.hs | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index d0778f45..39ab8a3c 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -184,9 +184,6 @@ responseIndex (CompletedRequest i _ _) = i rawResponse :: CompletedRequest -> Reply rawResponse (CompletedRequest _ _ r) = r -requestForResponse :: CompletedRequest -> [B.ByteString] -requestForResponse (CompletedRequest _ r _) = r - -- The approach we take here is similar to that taken by the redis-py-cluster -- library, which is described at https://redis-py-cluster.readthedocs.io/en/master/pipelines.html -- @@ -220,29 +217,30 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do replies <- requestNode nodeConn $ map rawRequest nodeRequests return $ zipWith (curry (\(PendingRequest i r, rep) -> CompletedRequest i r rep)) nodeRequests replies retry :: Int -> CompletedRequest -> IO CompletedRequest - retry = retry' shardMapVar refreshShardmapAction conn + retry retryCount (CompletedRequest index request thisReply) = do + retryReply <- retry' shardMapVar refreshShardmapAction conn retryCount request thisReply + return (CompletedRequest index request retryReply) refreshShardMapVar :: String -> IO () refreshShardMapVar msg = hasLocked msg $ modifyMVar_ shardMapVar (const refreshShardmapAction) -retry' :: MVar ShardMap -> IO ShardMap -> Connection -> Int -> CompletedRequest -> IO CompletedRequest -retry' shardMapVar refreshShardmapAction conn retryCount resp@(CompletedRequest index request thisReply) = do - retryReply <- case thisReply of +retry' :: MVar ShardMap -> IO ShardMap -> Connection -> Int -> [B.ByteString] -> Reply -> IO Reply +retry' shardMapVar refreshShardmapAction conn retryCount request thisReply = + case thisReply of (Error errString) | B.isPrefixOf "MOVED" errString -> do shardMap <- hasLocked "reading shard map in retry MOVED" $ readMVar shardMapVar - nodeConn <- head <$> nodeConnectionForCommand conn shardMap (requestForResponse resp) + nodeConn <- head <$> nodeConnectionForCommand conn shardMap request head <$> requestNode nodeConn [request] (askingRedirection -> Just (host, port)) -> do shardMap <- hasLocked "reading shardmap in retry ASK" $ readMVar shardMapVar let maybeAskNode = nodeConnWithHostAndPort shardMap conn host port case maybeAskNode of - Just askNode -> last <$> requestNode askNode [["ASKING"], requestForResponse resp] + Just askNode -> last <$> requestNode askNode [["ASKING"], request] Nothing -> case retryCount of 0 -> do _ <- hasLocked "missing node in first retry of ASK" $ modifyMVar_ shardMapVar (const refreshShardmapAction) - rawResponse <$> retry' shardMapVar refreshShardmapAction conn (retryCount + 1) resp - _ -> throwIO $ MissingNodeException (requestForResponse resp) + retry' shardMapVar refreshShardmapAction conn (retryCount + 1) request thisReply + _ -> throwIO $ MissingNodeException request _ -> return thisReply - return (CompletedRequest index request retryReply) -- Like `evaluateOnPipeline`, except we expect to be able to run all commands -- on a single shard. Failing to meet this expectation is an error. From 5ae85a5bf4bfebf04e6db93c1174a047a4bfacbc Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Wed, 2 Dec 2020 11:45:09 +0100 Subject: [PATCH 047/103] Support retry-ing a batch of commands Inching closer to being able to use the retry logic for transactions too. --- src/Database/Redis/Cluster.hs | 28 +++++++++++++++------------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 39ab8a3c..1e7a6809 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -218,28 +218,30 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do return $ zipWith (curry (\(PendingRequest i r, rep) -> CompletedRequest i r rep)) nodeRequests replies retry :: Int -> CompletedRequest -> IO CompletedRequest retry retryCount (CompletedRequest index request thisReply) = do - retryReply <- retry' shardMapVar refreshShardmapAction conn retryCount request thisReply + retryReply <- retryBatch shardMapVar refreshShardmapAction conn retryCount [request] thisReply return (CompletedRequest index request retryReply) refreshShardMapVar :: String -> IO () refreshShardMapVar msg = hasLocked msg $ modifyMVar_ shardMapVar (const refreshShardmapAction) -retry' :: MVar ShardMap -> IO ShardMap -> Connection -> Int -> [B.ByteString] -> Reply -> IO Reply -retry' shardMapVar refreshShardmapAction conn retryCount request thisReply = +retryBatch :: MVar ShardMap -> IO ShardMap -> Connection -> Int -> [[B.ByteString]] -> Reply -> IO Reply +retryBatch shardMapVar refreshShardmapAction conn retryCount requests thisReply = case thisReply of (Error errString) | B.isPrefixOf "MOVED" errString -> do - shardMap <- hasLocked "reading shard map in retry MOVED" $ readMVar shardMapVar - nodeConn <- head <$> nodeConnectionForCommand conn shardMap request - head <$> requestNode nodeConn [request] + let (Connection _ _ _ infoMap) = conn + keys <- mconcat <$> mapM (requestKeys infoMap) requests + hashSlot <- hashSlotForKeys (CrossSlotException (head requests)) keys + nodeConn <- nodeConnForHashSlot "MOVED" shardMapVar conn (MissingNodeException (head requests)) hashSlot + head <$> requestNode nodeConn requests (askingRedirection -> Just (host, port)) -> do shardMap <- hasLocked "reading shardmap in retry ASK" $ readMVar shardMapVar let maybeAskNode = nodeConnWithHostAndPort shardMap conn host port case maybeAskNode of - Just askNode -> last <$> requestNode askNode [["ASKING"], request] + Just askNode -> last <$> requestNode askNode (["ASKING"] : requests) Nothing -> case retryCount of 0 -> do _ <- hasLocked "missing node in first retry of ASK" $ modifyMVar_ shardMapVar (const refreshShardmapAction) - retry' shardMapVar refreshShardmapAction conn (retryCount + 1) request thisReply - _ -> throwIO $ MissingNodeException request + retryBatch shardMapVar refreshShardmapAction conn (retryCount + 1) requests thisReply + _ -> throwIO $ MissingNodeException (head requests) _ -> return thisReply -- Like `evaluateOnPipeline`, except we expect to be able to run all commands @@ -258,7 +260,7 @@ evaluateTransactionPipeline shardMapVar refreshShardmapAction conn requests' = d -- the commands in a transaction are applied and some are not. Better to -- fail early. hashSlot <- hashSlotForKeys (MultiExecCrossSlotException (show keys, requests)) keys - nodeConn <- nodeConnForHashSlot shardMapVar conn (MissingNodeException (head requests)) hashSlot + nodeConn <- nodeConnForHashSlot "evaluatePipeline" shardMapVar conn (MissingNodeException (head requests)) hashSlot resps <- requestNode nodeConn requests -- It's unclear what to do if one of the commands in a transaction asks us -- to redirect. Run only the redirected commands in another transaction? @@ -267,10 +269,10 @@ evaluateTransactionPipeline shardMapVar refreshShardmapAction conn requests' = d (hasLocked "locked refreshing due to moved responses" $ modifyMVar_ shardMapVar (const refreshShardmapAction)) return resps -nodeConnForHashSlot :: Exception e => MVar ShardMap -> Connection -> e -> HashSlot -> IO NodeConnection -nodeConnForHashSlot shardMapVar conn exception hashSlot = do +nodeConnForHashSlot :: Exception e => String -> MVar ShardMap -> Connection -> e -> HashSlot -> IO NodeConnection +nodeConnForHashSlot location shardMapVar conn exception hashSlot = do let (Connection nodeConns _ _ _) = conn - (ShardMap shardMap) <- hasLocked "reading shardmap in evaluatePipeline" $ readMVar shardMapVar + (ShardMap shardMap) <- hasLocked ("reading shardmap in " ++ location) $ readMVar shardMapVar node <- case IntMap.lookup (fromEnum hashSlot) shardMap of Nothing -> throwIO exception From 113d35ed9c578ecbd3037c400248482f81600240 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Wed, 2 Dec 2020 11:46:11 +0100 Subject: [PATCH 048/103] Remove MultiExecCrossSlotException This exception was only used for debugging. --- src/Database/Redis/Cluster.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 1e7a6809..1b44e5b1 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -101,9 +101,6 @@ instance Exception UnsupportedClusterCommandException newtype CrossSlotException = CrossSlotException [B.ByteString] deriving (Show, Typeable) instance Exception CrossSlotException -newtype MultiExecCrossSlotException = MultiExecCrossSlotException (String, [[B.ByteString]]) deriving (Show, Typeable) -instance Exception MultiExecCrossSlotException - connect :: [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> IO Connection connect commandInfos shardMapVar timeoutOpt = do shardMap <- readMVar shardMapVar @@ -259,7 +256,7 @@ evaluateTransactionPipeline shardMapVar refreshShardmapAction conn requests' = d -- moved to a different node we could end up in a situation where some of -- the commands in a transaction are applied and some are not. Better to -- fail early. - hashSlot <- hashSlotForKeys (MultiExecCrossSlotException (show keys, requests)) keys + hashSlot <- hashSlotForKeys (CrossSlotException (head requests)) keys nodeConn <- nodeConnForHashSlot "evaluatePipeline" shardMapVar conn (MissingNodeException (head requests)) hashSlot resps <- requestNode nodeConn requests -- It's unclear what to do if one of the commands in a transaction asks us From bcde08bdf4aa6f6790f09e5731ded318c7c6c174 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Wed, 2 Dec 2020 11:47:07 +0100 Subject: [PATCH 049/103] Improve CrossSlotException It now shows more useful data in case it's triggered for a transaction containing multiple commands. --- src/Database/Redis/Cluster.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 1b44e5b1..fd9ed407 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -98,7 +98,7 @@ instance Exception MissingNodeException newtype UnsupportedClusterCommandException = UnsupportedClusterCommandException [B.ByteString] deriving (Show, Typeable) instance Exception UnsupportedClusterCommandException -newtype CrossSlotException = CrossSlotException [B.ByteString] deriving (Show, Typeable) +newtype CrossSlotException = CrossSlotException [[B.ByteString]] deriving (Show, Typeable) instance Exception CrossSlotException connect :: [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> IO Connection @@ -226,7 +226,7 @@ retryBatch shardMapVar refreshShardmapAction conn retryCount requests thisReply (Error errString) | B.isPrefixOf "MOVED" errString -> do let (Connection _ _ _ infoMap) = conn keys <- mconcat <$> mapM (requestKeys infoMap) requests - hashSlot <- hashSlotForKeys (CrossSlotException (head requests)) keys + hashSlot <- hashSlotForKeys (CrossSlotException requests) keys nodeConn <- nodeConnForHashSlot "MOVED" shardMapVar conn (MissingNodeException (head requests)) hashSlot head <$> requestNode nodeConn requests (askingRedirection -> Just (host, port)) -> do @@ -256,7 +256,7 @@ evaluateTransactionPipeline shardMapVar refreshShardmapAction conn requests' = d -- moved to a different node we could end up in a situation where some of -- the commands in a transaction are applied and some are not. Better to -- fail early. - hashSlot <- hashSlotForKeys (CrossSlotException (head requests)) keys + hashSlot <- hashSlotForKeys (CrossSlotException requests) keys nodeConn <- nodeConnForHashSlot "evaluatePipeline" shardMapVar conn (MissingNodeException (head requests)) hashSlot resps <- requestNode nodeConn requests -- It's unclear what to do if one of the commands in a transaction asks us @@ -324,7 +324,7 @@ nodeConnectionForCommand conn@(Connection nodeConns _ _ infoMap) (ShardMap shard ("UNWATCH" : _) -> allNodes _ -> do keys <- requestKeys infoMap request - hashSlot <- hashSlotForKeys (CrossSlotException request) keys + hashSlot <- hashSlotForKeys (CrossSlotException [request]) keys node <- case IntMap.lookup (fromEnum hashSlot) shardMap of Nothing -> throwIO $ MissingNodeException request Just (Shard master _) -> return master From 3346c7bf4a747c53a74f5dbae0cd3d92f4c49f8e Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Wed, 2 Dec 2020 13:08:03 +0100 Subject: [PATCH 050/103] retryBatch can handle multiple replies --- src/Database/Redis/Cluster.hs | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index fd9ed407..e2bee3f4 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -215,31 +215,36 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do return $ zipWith (curry (\(PendingRequest i r, rep) -> CompletedRequest i r rep)) nodeRequests replies retry :: Int -> CompletedRequest -> IO CompletedRequest retry retryCount (CompletedRequest index request thisReply) = do - retryReply <- retryBatch shardMapVar refreshShardmapAction conn retryCount [request] thisReply + retryReply <- head <$> retryBatch shardMapVar refreshShardmapAction conn retryCount [request] [thisReply] return (CompletedRequest index request retryReply) refreshShardMapVar :: String -> IO () refreshShardMapVar msg = hasLocked msg $ modifyMVar_ shardMapVar (const refreshShardmapAction) -retryBatch :: MVar ShardMap -> IO ShardMap -> Connection -> Int -> [[B.ByteString]] -> Reply -> IO Reply -retryBatch shardMapVar refreshShardmapAction conn retryCount requests thisReply = - case thisReply of +-- Retry a batch of requests if any of the responses is a redirect instruction. +-- If multiple requests are passed in they're assumed to be a MULTI..EXEC +-- transaction and will all be retried. +retryBatch :: MVar ShardMap -> IO ShardMap -> Connection -> Int -> [[B.ByteString]] -> [Reply] -> IO [Reply] +retryBatch shardMapVar refreshShardmapAction conn retryCount requests replies = + -- The last reply will be the `EXEC` reply containing the redirection, if + -- there is one. + case last replies of (Error errString) | B.isPrefixOf "MOVED" errString -> do let (Connection _ _ _ infoMap) = conn keys <- mconcat <$> mapM (requestKeys infoMap) requests hashSlot <- hashSlotForKeys (CrossSlotException requests) keys nodeConn <- nodeConnForHashSlot "MOVED" shardMapVar conn (MissingNodeException (head requests)) hashSlot - head <$> requestNode nodeConn requests + requestNode nodeConn requests (askingRedirection -> Just (host, port)) -> do shardMap <- hasLocked "reading shardmap in retry ASK" $ readMVar shardMapVar let maybeAskNode = nodeConnWithHostAndPort shardMap conn host port case maybeAskNode of - Just askNode -> last <$> requestNode askNode (["ASKING"] : requests) + Just askNode -> tail <$> requestNode askNode (["ASKING"] : requests) Nothing -> case retryCount of 0 -> do _ <- hasLocked "missing node in first retry of ASK" $ modifyMVar_ shardMapVar (const refreshShardmapAction) - retryBatch shardMapVar refreshShardmapAction conn (retryCount + 1) requests thisReply + retryBatch shardMapVar refreshShardmapAction conn (retryCount + 1) requests replies _ -> throwIO $ MissingNodeException (head requests) - _ -> return thisReply + _ -> return replies -- Like `evaluateOnPipeline`, except we expect to be able to run all commands -- on a single shard. Failing to meet this expectation is an error. From 249ff2989166d717f63b496348e5ae4c53b874c1 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Wed, 2 Dec 2020 13:16:05 +0100 Subject: [PATCH 051/103] Handle redirects for MULTI..EXEC transactions --- src/Database/Redis/Cluster.hs | 32 ++++++++++++++++++++++++++++---- 1 file changed, 28 insertions(+), 4 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index e2bee3f4..64a3e6ba 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -264,12 +264,36 @@ evaluateTransactionPipeline shardMapVar refreshShardmapAction conn requests' = d hashSlot <- hashSlotForKeys (CrossSlotException requests) keys nodeConn <- nodeConnForHashSlot "evaluatePipeline" shardMapVar conn (MissingNodeException (head requests)) hashSlot resps <- requestNode nodeConn requests - -- It's unclear what to do if one of the commands in a transaction asks us - -- to redirect. Run only the redirected commands in another transaction? - -- That doesn't seem very transactional. + -- The Redis documentation has the following to say on the effect of + -- resharding on multi-key operations: + -- + -- Multi-key operations may become unavailable when a resharding of the + -- hash slot the keys belong to is in progress. + -- + -- More specifically, even during a resharding the multi-key operations + -- targeting keys that all exist and all still hash to the same slot + -- (either the source or destination node) are still available. + -- + -- Operations on keys that don't exist or are - during the resharding - + -- split between the source and destination nodes, will generate a + -- -TRYAGAIN error. The client can try the operation after some time, + -- or report back the error. + -- + -- https://redis.io/topics/cluster-spec#multiple-keys-operations + -- + -- An important take-away here is that MULTI..EXEC transactions can fail + -- with a redirect in which case we need to repeat the full transaction on + -- the node we're redirected too. + -- + -- A second important takeway is that MULTI..EXEC transactions might + -- temporarily fail during resharding with a -TRYAGAIN error. We can only + -- make arbitrary decisions about how long to paus before the retry and how + -- often to retry, so instead we'll propagate the error to the library user + -- and let them decide how they would like to handle the error. when (any moved resps) (hasLocked "locked refreshing due to moved responses" $ modifyMVar_ shardMapVar (const refreshShardmapAction)) - return resps + retriedResps <- retryBatch shardMapVar refreshShardmapAction conn 0 requests resps + return retriedResps nodeConnForHashSlot :: Exception e => String -> MVar ShardMap -> Connection -> e -> HashSlot -> IO NodeConnection nodeConnForHashSlot location shardMapVar conn exception hashSlot = do From 77559ac2493c2edb30df89a3fea7df6901385d8b Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Thu, 3 Dec 2020 14:47:54 +0100 Subject: [PATCH 052/103] Fix CI error I changed this accidentally in a previous commit because I seem to get a different error message locally (maybe due to different Redis versions?). That made it break CI though, so reverting the change here. --- test/Tests.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Tests.hs b/test/Tests.hs index 6b33bfda..6eb13290 100644 --- a/test/Tests.hs +++ b/test/Tests.hs @@ -504,7 +504,7 @@ testConnectAuthUnexpected = testCase "connect/auth/unexpected" $ do where connInfo = defaultConnectInfo { connectAuth = Just "pass" } err = Left $ ConnectAuthError $ - Error "ERR Client sent AUTH, but no password is set" + Error "ERR AUTH called without any password configured for the default user. Are you sure your configuration is correct?" testConnectDb :: Test testConnectDb = testCase "connect/db" $ do From 168b4b04cfdead949c015c2fef48f2161bcb92b6 Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Thu, 3 Dec 2020 14:57:47 +0100 Subject: [PATCH 053/103] Remove some debugging code --- hedis.cabal | 4 +--- src/Database/Redis/Cluster.hs | 35 +++++++++++++++++------------------ 2 files changed, 18 insertions(+), 21 deletions(-) diff --git a/hedis.cabal b/hedis.cabal index bb85bcd3..1228223f 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -72,7 +72,6 @@ library , Database.Redis.Core.Internal build-depends: scanner >= 0.2, async >= 2.1, - array >= 0.5.3, base >= 4.8 && < 5, bytestring >= 0.9, bytestring-lexing >= 0.5, @@ -90,8 +89,7 @@ library vector >= 0.9, HTTP, errors, - network-uri, - say + network-uri if !impl(ghc >= 8.0) build-depends: semigroups >= 0.11 && < 0.19 diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 64a3e6ba..2f577bc2 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -33,7 +33,6 @@ import qualified Data.IntMap.Strict as IntMap import Data.Typeable import qualified Scanner import System.IO.Unsafe(unsafeInterleaveIO) -import Say(sayString) import Database.Redis.Protocol(Reply(Error), renderRequest, reply) import qualified Database.Redis.Cluster.Command as CMD @@ -125,7 +124,7 @@ disconnect (Connection nodeConnMap _ _ _) = mapM_ disconnectNode (HM.elems nodeC -- evaluated. requestPipelined :: IO ShardMap -> Connection -> [B.ByteString] -> IO Reply requestPipelined refreshAction conn@(Connection _ pipelineVar shardMapVar _) nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do - (newStateVar, repliesIndex) <- hasLocked "locked adding to pipeline" $ modifyMVar stateVar $ \case + (newStateVar, repliesIndex) <- hasLocked $ modifyMVar stateVar $ \case Pending requests | isMulti nextRequest -> do replies <- evaluatePipeline shardMapVar refreshAction conn requests s' <- newMVar $ TransactionPending [nextRequest] @@ -149,7 +148,7 @@ requestPipelined refreshAction conn@(Connection _ pipelineVar shardMapVar _) nex Pending [nextRequest] return (e, (s', 0)) evaluateAction <- unsafeInterleaveIO $ do - replies <- hasLocked "locked evaluating replies" $ modifyMVar newStateVar $ \case + replies <- hasLocked $ modifyMVar newStateVar $ \case Executed replies -> return (Executed replies, replies) Pending requests-> do @@ -194,10 +193,10 @@ rawResponse (CompletedRequest _ _ r) = r -- cluster reconfiguration events, which should be rare. evaluatePipeline :: MVar ShardMap -> IO ShardMap -> Connection -> [[B.ByteString]] -> IO [Reply] evaluatePipeline shardMapVar refreshShardmapAction conn requests = do - shardMap <- hasLocked "reading shardmap in evaluatePipeline" $ readMVar shardMapVar + shardMap <- hasLocked $ readMVar shardMapVar requestsByNode <- getRequestsByNode shardMap resps <- concat <$> mapM (uncurry executeRequests) requestsByNode - when (any (moved . rawResponse) resps) (refreshShardMapVar "locked refreshing due to moved responses") + when (any (moved . rawResponse) resps) refreshShardMapVar retriedResps <- mapM (retry 0) resps return $ map rawResponse $ sortBy (on compare responseIndex) retriedResps where @@ -217,8 +216,8 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do retry retryCount (CompletedRequest index request thisReply) = do retryReply <- head <$> retryBatch shardMapVar refreshShardmapAction conn retryCount [request] [thisReply] return (CompletedRequest index request retryReply) - refreshShardMapVar :: String -> IO () - refreshShardMapVar msg = hasLocked msg $ modifyMVar_ shardMapVar (const refreshShardmapAction) + refreshShardMapVar :: IO () + refreshShardMapVar = hasLocked $ modifyMVar_ shardMapVar (const refreshShardmapAction) -- Retry a batch of requests if any of the responses is a redirect instruction. -- If multiple requests are passed in they're assumed to be a MULTI..EXEC @@ -232,16 +231,16 @@ retryBatch shardMapVar refreshShardmapAction conn retryCount requests replies = let (Connection _ _ _ infoMap) = conn keys <- mconcat <$> mapM (requestKeys infoMap) requests hashSlot <- hashSlotForKeys (CrossSlotException requests) keys - nodeConn <- nodeConnForHashSlot "MOVED" shardMapVar conn (MissingNodeException (head requests)) hashSlot + nodeConn <- nodeConnForHashSlot shardMapVar conn (MissingNodeException (head requests)) hashSlot requestNode nodeConn requests (askingRedirection -> Just (host, port)) -> do - shardMap <- hasLocked "reading shardmap in retry ASK" $ readMVar shardMapVar + shardMap <- hasLocked $ readMVar shardMapVar let maybeAskNode = nodeConnWithHostAndPort shardMap conn host port case maybeAskNode of Just askNode -> tail <$> requestNode askNode (["ASKING"] : requests) Nothing -> case retryCount of 0 -> do - _ <- hasLocked "missing node in first retry of ASK" $ modifyMVar_ shardMapVar (const refreshShardmapAction) + _ <- hasLocked $ modifyMVar_ shardMapVar (const refreshShardmapAction) retryBatch shardMapVar refreshShardmapAction conn (retryCount + 1) requests replies _ -> throwIO $ MissingNodeException (head requests) _ -> return replies @@ -262,7 +261,7 @@ evaluateTransactionPipeline shardMapVar refreshShardmapAction conn requests' = d -- the commands in a transaction are applied and some are not. Better to -- fail early. hashSlot <- hashSlotForKeys (CrossSlotException requests) keys - nodeConn <- nodeConnForHashSlot "evaluatePipeline" shardMapVar conn (MissingNodeException (head requests)) hashSlot + nodeConn <- nodeConnForHashSlot shardMapVar conn (MissingNodeException (head requests)) hashSlot resps <- requestNode nodeConn requests -- The Redis documentation has the following to say on the effect of -- resharding on multi-key operations: @@ -291,14 +290,14 @@ evaluateTransactionPipeline shardMapVar refreshShardmapAction conn requests' = d -- often to retry, so instead we'll propagate the error to the library user -- and let them decide how they would like to handle the error. when (any moved resps) - (hasLocked "locked refreshing due to moved responses" $ modifyMVar_ shardMapVar (const refreshShardmapAction)) + (hasLocked $ modifyMVar_ shardMapVar (const refreshShardmapAction)) retriedResps <- retryBatch shardMapVar refreshShardmapAction conn 0 requests resps return retriedResps -nodeConnForHashSlot :: Exception e => String -> MVar ShardMap -> Connection -> e -> HashSlot -> IO NodeConnection -nodeConnForHashSlot location shardMapVar conn exception hashSlot = do +nodeConnForHashSlot :: Exception e => MVar ShardMap -> Connection -> e -> HashSlot -> IO NodeConnection +nodeConnForHashSlot shardMapVar conn exception hashSlot = do let (Connection nodeConns _ _ _) = conn - (ShardMap shardMap) <- hasLocked ("reading shardmap in " ++ location) $ readMVar shardMapVar + (ShardMap shardMap) <- hasLocked $ readMVar shardMapVar node <- case IntMap.lookup (fromEnum hashSlot) shardMap of Nothing -> throwIO exception @@ -406,8 +405,8 @@ nodeWithHostAndPort shardMap host port = find (\(Node _ _ nodeHost nodePort) -> nodeId :: Node -> NodeID nodeId (Node theId _ _ _) = theId -hasLocked :: String -> IO a -> IO a -hasLocked msg action = +hasLocked :: IO a -> IO a +hasLocked action = action `catches` - [ Handler $ \exc@BlockedIndefinitelyOnMVar -> sayString ("[MVar]: " ++ msg) >> throwIO exc + [ Handler $ \exc@BlockedIndefinitelyOnMVar -> throwIO exc ] From 8453e17fff65232554fe2da7fbe22185acd86ada Mon Sep 17 00:00:00 2001 From: Jasper Woudenberg Date: Thu, 3 Dec 2020 16:13:21 +0100 Subject: [PATCH 054/103] Replace <> with ++ for older GHC's --- src/Database/Redis/ConnectionContext.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Database/Redis/ConnectionContext.hs b/src/Database/Redis/ConnectionContext.hs index bc27e15b..5249db2f 100644 --- a/src/Database/Redis/ConnectionContext.hs +++ b/src/Database/Redis/ConnectionContext.hs @@ -43,7 +43,7 @@ data Connection = Connection , lastRecvRef :: IOR.IORef (Maybe B.ByteString) } instance Show Connection where - show Connection{..} = "Connection{ ctx = " <> show ctx <> ", lastRecvRef = IORef}" + show Connection{..} = "Connection{ ctx = " ++ show ctx ++ ", lastRecvRef = IORef}" data ConnectPhase = PhaseUnknown From 405739e5a6d9da21b4c24d89e2ac8dc06eded35d Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Thu, 31 Dec 2020 19:41:43 +0200 Subject: [PATCH 055/103] 0.14.0 changelog --- CHANGELOG | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CHANGELOG b/CHANGELOG index 7d5ebc94..9bc1d915 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,9 @@ # Changelog for Hedis +## 0.14.0 + +* PR #157. Clustering support + ## 0.13.1 * PR #158. Upgrade to Redis 6.0.9 & Fix auth test From bbe302050a2efae31ca3150f07e4fb82941a7d31 Mon Sep 17 00:00:00 2001 From: Konstantine Rybnikov Date: Thu, 31 Dec 2020 19:42:04 +0200 Subject: [PATCH 056/103] 0.14.0 version --- hedis.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hedis.cabal b/hedis.cabal index 1228223f..0e9a2bb1 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.13.1 +version: 0.14.0 synopsis: Client library for the Redis datastore: supports full command set, pipelining. From c8ed5539817221fcffcd7c527a51bfb250becfd0 Mon Sep 17 00:00:00 2001 From: Phil Freeman Date: Tue, 19 Jan 2021 17:39:07 -0800 Subject: [PATCH 057/103] Improved documentation for EVALSHA This was confusing me because the existing documentation suggested the first argument was the script itself, but the docs indicate that argument should contain the Base16-encoded SHA1 hash of the script. See https://redis.io/commands/eval#bandwidth-and-evalsha --- src/Database/Redis/ManualCommands.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Database/Redis/ManualCommands.hs b/src/Database/Redis/ManualCommands.hs index acb1c11d..87bb1d30 100644 --- a/src/Database/Redis/ManualCommands.hs +++ b/src/Database/Redis/ManualCommands.hs @@ -360,9 +360,11 @@ eval script keys args = where numkeys = toInteger (length keys) +-- | Works like 'eval', but sends the SHA1 hash of the script instead of the script itself. +-- Fails if the server does not recognise the hash, in which case, 'eval' should be used instead. evalsha :: (RedisCtx m f, RedisResult a) - => ByteString -- ^ script + => ByteString -- ^ base16-encoded sha1 hash of the script -> [ByteString] -- ^ keys -> [ByteString] -- ^ args -> m (f a) From f3ca2fab460082a929bd2e227d1230ee0b1de6b2 Mon Sep 17 00:00:00 2001 From: Kon Rybnikov Date: Wed, 20 Jan 2021 13:42:21 +0200 Subject: [PATCH 058/103] 0.14.1 --- CHANGELOG | 4 ++++ hedis.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index 9bc1d915..c41470b4 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,9 @@ # Changelog for Hedis +## 0.14.1 + +* PR #162. Improved documentation for EVALSHA + ## 0.14.0 * PR #157. Clustering support diff --git a/hedis.cabal b/hedis.cabal index 0e9a2bb1..3d56e31c 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.14.0 +version: 0.14.1 synopsis: Client library for the Redis datastore: supports full command set, pipelining. From f162184807cab12c9b3ad28515f507668bd3a6a7 Mon Sep 17 00:00:00 2001 From: Honma Masahiro Date: Sat, 30 Jan 2021 09:34:05 +0900 Subject: [PATCH 059/103] feat: support for redis 6.0 COMMAND format See: https://github.com/redis/redis/pull/5836 --- src/Database/Redis/Cluster/Command.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index cf67f17b..cf87f760 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -86,6 +86,17 @@ instance RedisResult CommandInfo where parseLastKeyPos = return $ case lastKeyPos of i | i < 0 -> UnlimitedKeys (-i - 1) i -> LastKeyPosition i + -- since redis 6.0 + decode (MultiBulk (Just + [ name@(Bulk (Just _)) + , arity@(Integer _) + , flags@(MultiBulk (Just _)) + , firstPos@(Integer _) + , lastPos@(Integer _) + , step@(Integer _) + , MultiBulk _ -- ACL categories + ])) = + decode (MultiBulk (Just [name, arity, flags, firstPos, lastPos, step])) decode e = Left e From ee5a7e335927cfc8f5ec2c631bc6242bca242d55 Mon Sep 17 00:00:00 2001 From: Masahiro Honma Date: Sat, 30 Jan 2021 14:47:17 +0900 Subject: [PATCH 060/103] test: remove invalid tests Redis Cluster doesn't support the SELECT command. --- test/ClusterMain.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/test/ClusterMain.hs b/test/ClusterMain.hs index 838f138a..89c834b8 100644 --- a/test/ClusterMain.hs +++ b/test/ClusterMain.hs @@ -32,8 +32,7 @@ testsServer = [testBgrewriteaof, testFlushall, testSlowlog, testDebugObject] testsConnection :: [Test] -testsConnection = [ testConnectAuthUnexpected, testConnectDb - , testConnectDbUnexisting, testEcho, testPing +testsConnection = [ testConnectAuthUnexpected, testEcho, testPing ] testsKeys :: [Test] From 407a9fd2cc3fb5a3ace0282e9074285115cf2adf Mon Sep 17 00:00:00 2001 From: Kon Rybnikov Date: Sat, 30 Jan 2021 14:10:51 +0200 Subject: [PATCH 061/103] 0.14.2 --- CHANGELOG | 5 +++++ hedis.cabal | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index c41470b4..5d098944 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,10 @@ # Changelog for Hedis +## 0.14.2 + +* PR #163. support for redis 6.0 COMMAND format +* PR #164. remove invalid tests for Redis Cluster + ## 0.14.1 * PR #162. Improved documentation for EVALSHA diff --git a/hedis.cabal b/hedis.cabal index 3d56e31c..4670b425 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.14.1 +version: 0.14.2 synopsis: Client library for the Redis datastore: supports full command set, pipelining. From e9afad7b1acb65bf0b9e497d6171ebf957bf77a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Martin=20Bet=C3=A1k?= Date: Sun, 7 Mar 2021 04:38:04 +0100 Subject: [PATCH 062/103] Add GHC 8.10 to build matrix --- .gitignore | 1 + .travis.yml | 2 +- stack-7.10.yaml => stack-8.10.yaml | 3 +-- 3 files changed, 3 insertions(+), 3 deletions(-) rename stack-7.10.yaml => stack-8.10.yaml (71%) diff --git a/.gitignore b/.gitignore index 3b9c2d0a..3fd028cb 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,4 @@ Main.hs .stack-work TAGS stack*.yaml.lock +.vscode diff --git a/.travis.yml b/.travis.yml index c6dc23be..ef7ea422 100644 --- a/.travis.yml +++ b/.travis.yml @@ -29,12 +29,12 @@ before_install: matrix: include: - # - env: GHCVER=7.10.3 STACK_YAML=stack-7.10.yaml - env: GHCVER=8.0.1 STACK_YAML=stack-8.0.yaml - env: GHCVER=8.2.2 STACK_YAML=stack-8.2.yaml - env: GHCVER=8.4.1 STACK_YAML=stack-8.4.yaml - env: GHCVER=8.6.5 STACK_YAML=stack-8.6.yaml - env: GHCVER=8.8.1 STACK_YAML=stack-8.8.yaml + - env: GHCVER=8.10.4 STACK_YAML=stack-8.10.yaml allow_failures: - env: GHCVER=head STACK_YAML=stack-head.yaml diff --git a/stack-7.10.yaml b/stack-8.10.yaml similarity index 71% rename from stack-7.10.yaml rename to stack-8.10.yaml index 53b55670..57ea3295 100644 --- a/stack-7.10.yaml +++ b/stack-8.10.yaml @@ -1,8 +1,7 @@ -resolver: lts-5.1 +resolver: lts-17.5 packages: - '.' extra-deps: -- scanner-0.2 flags: hedis: dev: true From 936dc77aa807f50f72a5ee7d26bac9ce49023dd7 Mon Sep 17 00:00:00 2001 From: Kon Rybnikov Date: Sun, 7 Mar 2021 10:42:42 +0200 Subject: [PATCH 063/103] Update .travis.yml --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index ef7ea422..3eb6faad 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,6 @@ language: c # sudo: false -dist: bionic +dist: focal addons: apt: From 42adc4df7a36f6af2465f40fc62c58c598aa3714 Mon Sep 17 00:00:00 2001 From: Kon Rybnikov Date: Sun, 7 Mar 2021 10:48:44 +0200 Subject: [PATCH 064/103] Update .travis.yml --- .travis.yml | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/.travis.yml b/.travis.yml index 3eb6faad..8719cb26 100644 --- a/.travis.yml +++ b/.travis.yml @@ -2,12 +2,12 @@ language: c # sudo: false dist: focal -addons: - apt: - sources: - - sourceline: ppa:redislabs/redis - packages: - - redis +# addons: +# apt: +# sources: +# - sourceline: ppa:redislabs/redis +# packages: +# - redis cache: directories: @@ -19,6 +19,8 @@ services: - docker before_install: + - sudo apt-get update + - sudo apt-get -y install redis-server - mkdir -p ~/.local/bin - mkdir -p ~/tmp - export PATH=~/.local/bin:$PATH From c636b53f2894f77ed1a0f8fc536bf378f3ed9ca4 Mon Sep 17 00:00:00 2001 From: Kon Rybnikov Date: Sun, 7 Mar 2021 10:51:43 +0200 Subject: [PATCH 065/103] Update .travis.yml --- .travis.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 8719cb26..db1d3d39 100644 --- a/.travis.yml +++ b/.travis.yml @@ -24,8 +24,8 @@ before_install: - mkdir -p ~/.local/bin - mkdir -p ~/tmp - export PATH=~/.local/bin:$PATH - - curl -L https://github.com/commercialhaskell/stack/releases/download/v2.1.3/stack-2.1.3-linux-x86_64.tar.gz | tar xz -C ~/tmp - - mv ~/tmp/stack-2.1.3-linux-x86_64/stack ~/.local/bin/ + - curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-linux-x86_64.tar.gz | tar xz -C ~/tmp + - mv ~/tmp/stack-2.5.1-linux-x86_64/stack ~/.local/bin/ - cd ${TRAVIS_BUILD_DIR} - docker run -d -p 7000-7010:7000-7010 grokzen/redis-cluster:5.0.6 From 60260d41678be30079dd55b966fc57a142a50a5f Mon Sep 17 00:00:00 2001 From: Tom Sydney Kerckhove Date: Sun, 7 Mar 2021 14:18:45 +0100 Subject: [PATCH 066/103] recommend concurrently instead of forkIO --- src/Database/Redis/PubSub.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Database/Redis/PubSub.hs b/src/Database/Redis/PubSub.hs index 8747db9b..71022b2c 100644 --- a/src/Database/Redis/PubSub.hs +++ b/src/Database/Redis/PubSub.hs @@ -545,11 +545,13 @@ sendThread ctrl rawConn = forever $ do -- main = do -- conn <- connect defaultConnectInfo -- pubSubCtrl <- newPubSubController [("mychannel", myhandler)] [] --- forkIO $ forever $ +-- concurrently ( forever $ -- pubSubForever conn pubSubCtrl onInitialComplete -- \`catch\` (\\(e :: SomeException) -> do -- putStrLn $ "Got error: " ++ show e -- threadDelay $ 50*1000) -- TODO: use exponential backoff +-- ) $ restOfYourProgram +-- -- -- {- elsewhere in your program, use pubSubCtrl to change subscriptions -} -- @ From 8b61416f44d7ae781f2cd1e4d842577971243aba Mon Sep 17 00:00:00 2001 From: Kon Rybnikov Date: Sun, 14 Mar 2021 21:07:33 +0200 Subject: [PATCH 067/103] Use latest lts --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 226dee18..fb4a000a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-16.18 +resolver: lts-17.5 packages: - '.' flags: From bb3f9e2c38027633d9ccc98e071fb1838a237376 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Fri, 7 May 2021 10:53:36 -0600 Subject: [PATCH 068/103] Support GHC 9 --- cabal.project | 12 ++++++++++++ src/Database/Redis/Transactions.hs | 2 +- 2 files changed, 13 insertions(+), 1 deletion(-) create mode 100644 cabal.project diff --git a/cabal.project b/cabal.project new file mode 100644 index 00000000..a7046abe --- /dev/null +++ b/cabal.project @@ -0,0 +1,12 @@ +packages: + ./ + +source-repository-package + type: git + location: https://github.com/parsonsmatt/hs-memory + tag: 21e8720739b45dbee4faa1470db243ec9f487e44 + +source-repository-package + type: git + location: https://github.com/amesgen/cryptonite + tag: c5b2630ac396ad2d14ee1ed5d216907acaf2e79e diff --git a/src/Database/Redis/Transactions.hs b/src/Database/Redis/Transactions.hs index 56b7fee0..86d750f7 100644 --- a/src/Database/Redis/Transactions.hs +++ b/src/Database/Redis/Transactions.hs @@ -41,7 +41,7 @@ instance RedisCtx RedisTx Queued where -- future index in EXEC result list i <- get put (i+1) - return $ Queued (decode . (!i)) + return $ Queued (decode . (! i)) -- |A 'Queued' value represents the result of a command inside a transaction. It -- is a proxy object for the /actual/ result, which will only be available From 33bfb1c412d0e091cb2962e9f02cee53433e6659 Mon Sep 17 00:00:00 2001 From: Kon Rybnikov Date: Fri, 14 May 2021 10:37:10 +0300 Subject: [PATCH 069/103] 0.14.3 --- CHANGELOG | 4 ++++ hedis.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index 5d098944..1ee29464 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,9 @@ # Changelog for Hedis +## 0.14.3 + +* PR #171. Support GHC 9 + ## 0.14.2 * PR #163. support for redis 6.0 COMMAND format diff --git a/hedis.cabal b/hedis.cabal index 4670b425..1ba6a316 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.14.2 +version: 0.14.3 synopsis: Client library for the Redis datastore: supports full command set, pipelining. From 783c09b8dac82182a264f9a1fcb02c59be32ed99 Mon Sep 17 00:00:00 2001 From: Kon Rybnikov Date: Sat, 15 May 2021 17:10:19 +0300 Subject: [PATCH 070/103] Remove source-repository-package sections --- cabal.project | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/cabal.project b/cabal.project index a7046abe..3b98a43d 100644 --- a/cabal.project +++ b/cabal.project @@ -1,12 +1,2 @@ packages: ./ - -source-repository-package - type: git - location: https://github.com/parsonsmatt/hs-memory - tag: 21e8720739b45dbee4faa1470db243ec9f487e44 - -source-repository-package - type: git - location: https://github.com/amesgen/cryptonite - tag: c5b2630ac396ad2d14ee1ed5d216907acaf2e79e From 460d20c608b6bc7fad2272ea1534b7bff9f982b2 Mon Sep 17 00:00:00 2001 From: Kon Rybnikov Date: Sat, 15 May 2021 17:10:47 +0300 Subject: [PATCH 071/103] 0.14.4 --- hedis.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hedis.cabal b/hedis.cabal index 1ba6a316..84bbb51a 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.14.3 +version: 0.14.4 synopsis: Client library for the Redis datastore: supports full command set, pipelining. From b647cdaf604b7c8325bdf6ff7b284e5a974612cd Mon Sep 17 00:00:00 2001 From: Ilya Kopeshtianski Date: Fri, 3 Sep 2021 15:48:18 +0300 Subject: [PATCH 072/103] Support cases when response of xstreamInfo does not contain entries. When redis stream does not contain any entry fields 'first-entry' and 'last-entry' fields may be missing. Before this patch hedis failed to read a reponse and filed with `Bulk Nothing` exception. In this patch we provide a means to support that by introducing an extra constructor to the XInfoStreamResponse. We introduced a constructor instead of wrapping fields into Maybe, because this change leads to a fewer refactoring and in addition in maintains an invariant that the first and the last entries are either full or empty simultaniously. --- src/Database/Redis/ManualCommands.hs | 31 ++++++++++++++++++++++++++-- 1 file changed, 29 insertions(+), 2 deletions(-) diff --git a/src/Database/Redis/ManualCommands.hs b/src/Database/Redis/ManualCommands.hs index 87bb1d30..b0f616b0 100644 --- a/src/Database/Redis/ManualCommands.hs +++ b/src/Database/Redis/ManualCommands.hs @@ -1154,7 +1154,8 @@ xinfoGroups -> m (f [XInfoGroupsResponse]) xinfoGroups stream = sendRequest ["XINFO", "GROUPS", stream] -data XInfoStreamResponse = XInfoStreamResponse +data XInfoStreamResponse + = XInfoStreamResponse { xinfoStreamLength :: Integer , xinfoStreamRadixTreeKeys :: Integer , xinfoStreamRadixTreeNodes :: Integer @@ -1162,11 +1163,28 @@ data XInfoStreamResponse = XInfoStreamResponse , xinfoStreamLastEntryId :: ByteString , xinfoStreamFirstEntry :: StreamsRecord , xinfoStreamLastEntry :: StreamsRecord - } deriving (Show, Eq) + } + | XInfoStreamEmptyResponse + { xinfoStreamLength :: Integer + , xinfoStreamRadixTreeKeys :: Integer + , xinfoStreamRadixTreeNodes :: Integer + , xinfoStreamNumGroups :: Integer + , xinfoStreamLastEntryId :: ByteString + } + deriving (Show, Eq) instance RedisResult XInfoStreamResponse where decode = decodeRedis5 <> decodeRedis6 where + decodeRedis5 (MultiBulk (Just [ + Bulk (Just "length"),Integer xinfoStreamLength, + Bulk (Just "radix-tree-keys"),Integer xinfoStreamRadixTreeKeys, + Bulk (Just "radix-tree-nodes"),Integer xinfoStreamRadixTreeNodes, + Bulk (Just "groups"),Integer xinfoStreamNumGroups, + Bulk (Just "last-generated-id"),Bulk (Just xinfoStreamLastEntryId), + Bulk (Just "first-entry"), Bulk Nothing , + Bulk (Just "last-entry"), Bulk Nothing ])) = do + return XInfoStreamEmptyResponse{..} decodeRedis5 (MultiBulk (Just [ Bulk (Just "length"),Integer xinfoStreamLength, Bulk (Just "radix-tree-keys"),Integer xinfoStreamRadixTreeKeys, @@ -1180,6 +1198,15 @@ instance RedisResult XInfoStreamResponse where return XInfoStreamResponse{..} decodeRedis5 a = Left a + decodeRedis6 (MultiBulk (Just [ + Bulk (Just "length"),Integer xinfoStreamLength, + Bulk (Just "radix-tree-keys"),Integer xinfoStreamRadixTreeKeys, + Bulk (Just "radix-tree-nodes"),Integer xinfoStreamRadixTreeNodes, + Bulk (Just "last-generated-id"),Bulk (Just xinfoStreamLastEntryId), + Bulk (Just "groups"),Integer xinfoStreamNumGroups, + Bulk (Just "first-entry"), Bulk Nothing , + Bulk (Just "last-entry"), Bulk Nothing ])) = do + return XInfoStreamEmptyResponse{..} decodeRedis6 (MultiBulk (Just [ Bulk (Just "length"),Integer xinfoStreamLength, Bulk (Just "radix-tree-keys"),Integer xinfoStreamRadixTreeKeys, From ae271d142662eea430e309bf53cfe3ddb9e888b9 Mon Sep 17 00:00:00 2001 From: Kon Rybnikov Date: Sun, 5 Sep 2021 11:46:40 +0300 Subject: [PATCH 073/103] Update GHC 8.10 --- .travis.yml | 2 +- stack-8.0.yaml | 10 ---------- stack-8.10.yaml | 2 +- stack.yaml | 8 +------- 4 files changed, 3 insertions(+), 19 deletions(-) delete mode 100644 stack-8.0.yaml mode change 100644 => 120000 stack.yaml diff --git a/.travis.yml b/.travis.yml index db1d3d39..2b8f448e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -31,12 +31,12 @@ before_install: matrix: include: - - env: GHCVER=8.0.1 STACK_YAML=stack-8.0.yaml - env: GHCVER=8.2.2 STACK_YAML=stack-8.2.yaml - env: GHCVER=8.4.1 STACK_YAML=stack-8.4.yaml - env: GHCVER=8.6.5 STACK_YAML=stack-8.6.yaml - env: GHCVER=8.8.1 STACK_YAML=stack-8.8.yaml - env: GHCVER=8.10.4 STACK_YAML=stack-8.10.yaml + - env: GHCVER=8.10.6 STACK_YAML=stack-8.10.yaml allow_failures: - env: GHCVER=head STACK_YAML=stack-head.yaml diff --git a/stack-8.0.yaml b/stack-8.0.yaml deleted file mode 100644 index 3edb1eb8..00000000 --- a/stack-8.0.yaml +++ /dev/null @@ -1,10 +0,0 @@ -resolver: nightly-2016-05-31 -packages: -- '.' -extra-deps: -- slave-thread-1.0.1 -- partial-handler-1.0.1 -flags: - hedis: - dev: true -extra-package-dbs: [] diff --git a/stack-8.10.yaml b/stack-8.10.yaml index 57ea3295..d8eb746d 100644 --- a/stack-8.10.yaml +++ b/stack-8.10.yaml @@ -1,4 +1,4 @@ -resolver: lts-17.5 +resolver: lts-18.8 packages: - '.' extra-deps: diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index fb4a000a..00000000 --- a/stack.yaml +++ /dev/null @@ -1,7 +0,0 @@ -resolver: lts-17.5 -packages: - - '.' -flags: - hedis: - dev: true -extra-package-dbs: [] diff --git a/stack.yaml b/stack.yaml new file mode 120000 index 00000000..1b471944 --- /dev/null +++ b/stack.yaml @@ -0,0 +1 @@ +stack-8.10.yaml \ No newline at end of file From 02440c1e6a2d77d5d2cff76eda00d95f820d86fb Mon Sep 17 00:00:00 2001 From: Kon Rybnikov Date: Sun, 5 Sep 2021 11:47:54 +0300 Subject: [PATCH 074/103] 0.15.0 changelog --- CHANGELOG | 4 ++++ hedis.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index 1ee29464..e95324e3 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,9 @@ # Changelog for Hedis +## 0.15.0 + +* PR #174, Issue #173. Hedis fails to decode xstreamInfo response in case when the stream is empty + ## 0.14.3 * PR #171. Support GHC 9 diff --git a/hedis.cabal b/hedis.cabal index 84bbb51a..8d20c468 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.14.4 +version: 0.15.0 synopsis: Client library for the Redis datastore: supports full command set, pipelining. From 7b13739ef2d7dc7ff5c41933a0d38d94e9dc1446 Mon Sep 17 00:00:00 2001 From: Simon Jakobi Date: Sun, 28 Nov 2021 19:03:34 +0100 Subject: [PATCH 075/103] Record StrictData in other-extensions This tells Cabal not to attempt building with GHC < 8. Fixes #177. --- hedis.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/hedis.cabal b/hedis.cabal index 8d20c468..50e96f89 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -108,6 +108,7 @@ library Database.Redis.ManualCommands, Database.Redis.URL, Database.Redis.ConnectionContext + other-extensions: StrictData benchmark hedis-benchmark default-language: Haskell2010 From 68778b97d4c43e6a0ecfc36332b0940df1b6a9f1 Mon Sep 17 00:00:00 2001 From: qwbarch Date: Wed, 26 Jan 2022 16:12:11 -0500 Subject: [PATCH 076/103] Add MonadUnliftIO instance --- hedis.cabal | 3 ++- src/Database/Redis/Core/Internal.hs | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/hedis.cabal b/hedis.cabal index 50e96f89..923d9d0c 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -89,7 +89,8 @@ library vector >= 0.9, HTTP, errors, - network-uri + network-uri, + unliftio if !impl(ghc >= 8.0) build-depends: semigroups >= 0.11 && < 0.19 diff --git a/src/Database/Redis/Core/Internal.hs b/src/Database/Redis/Core/Internal.hs index 7c692a6a..8ab9a9a7 100644 --- a/src/Database/Redis/Core/Internal.hs +++ b/src/Database/Redis/Core/Internal.hs @@ -9,6 +9,7 @@ import Control.Monad.Fail (MonadFail) import Control.Monad.Reader import Data.IORef import Database.Redis.Protocol +import UnliftIO (MonadUnliftIO) import qualified Database.Redis.ProtocolPipelining as PP import qualified Database.Redis.Cluster as Cluster @@ -19,7 +20,7 @@ import qualified Database.Redis.Cluster as Cluster -- possibility of Redis returning an 'Error' reply. newtype Redis a = Redis (ReaderT RedisEnv IO a) - deriving (Monad, MonadIO, Functor, Applicative) + deriving (Monad, MonadIO, Functor, Applicative, MonadUnliftIO) #if __GLASGOW_HASKELL__ > 711 deriving instance MonadFail Redis #endif From 51a0ee3fe4d1e82a094818c4b442100a483f07de Mon Sep 17 00:00:00 2001 From: qwbarch Date: Thu, 27 Jan 2022 15:12:53 -0500 Subject: [PATCH 077/103] Use unliftio-core --- hedis.cabal | 2 +- src/Database/Redis/Core/Internal.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/hedis.cabal b/hedis.cabal index 923d9d0c..dc5c1ef5 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -90,7 +90,7 @@ library HTTP, errors, network-uri, - unliftio + unliftio-core if !impl(ghc >= 8.0) build-depends: semigroups >= 0.11 && < 0.19 diff --git a/src/Database/Redis/Core/Internal.hs b/src/Database/Redis/Core/Internal.hs index 8ab9a9a7..be25769b 100644 --- a/src/Database/Redis/Core/Internal.hs +++ b/src/Database/Redis/Core/Internal.hs @@ -9,7 +9,7 @@ import Control.Monad.Fail (MonadFail) import Control.Monad.Reader import Data.IORef import Database.Redis.Protocol -import UnliftIO (MonadUnliftIO) +import Control.Monad.IO.Unlift (MonadUnliftIO) import qualified Database.Redis.ProtocolPipelining as PP import qualified Database.Redis.Cluster as Cluster From 018ecf78e8a1251cb77047d7ab3ac7014f487b5a Mon Sep 17 00:00:00 2001 From: Kon Rybnikov Date: Thu, 27 Jan 2022 22:23:20 +0200 Subject: [PATCH 078/103] 0.15.1 --- CHANGELOG | 4 ++++ hedis.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index e95324e3..d0be90fc 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,9 @@ # Changelog for Hedis +## 0.15.1 + +* PR #181. Add MonadUnliftIO instance + ## 0.15.0 * PR #174, Issue #173. Hedis fails to decode xstreamInfo response in case when the stream is empty diff --git a/hedis.cabal b/hedis.cabal index dc5c1ef5..abc43538 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.15.0 +version: 0.15.1 synopsis: Client library for the Redis datastore: supports full command set, pipelining. From 25777dca19b7fd0543c4c1939a5eb65af41bd585 Mon Sep 17 00:00:00 2001 From: Kon Rybnikov Date: Thu, 27 Jan 2022 22:24:00 +0200 Subject: [PATCH 079/103] Update stack --- stack-8.10.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack-8.10.yaml b/stack-8.10.yaml index d8eb746d..169abd72 100644 --- a/stack-8.10.yaml +++ b/stack-8.10.yaml @@ -1,4 +1,4 @@ -resolver: lts-18.8 +resolver: lts-18.23 packages: - '.' extra-deps: From c92d376eab732616222a19af5c6ba37f9cb6107f Mon Sep 17 00:00:00 2001 From: Parth Vora Date: Mon, 10 Oct 2022 21:46:48 +0530 Subject: [PATCH 080/103] FIX: Adding XREAD commands in the command parser --- src/Database/Redis/Cluster/Command.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index 1bde0cdf..96940447 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -111,8 +111,22 @@ parseMovable ("EVAL":_:rest) = readNumKeys rest parseMovable ("EVALSH":_:rest) = readNumKeys rest parseMovable ("ZUNIONSTORE":_:rest) = readNumKeys rest parseMovable ("ZINTERSTORE":_:rest) = readNumKeys rest +parseMovable ("XREAD":rest) = readXreadKeys rest +parseMovable ("XREADGROUP":"GROUP":_:_:rest) = readXreadgroupKeys rest parseMovable _ = Nothing +readXreadKeys :: [BS.ByteString] -> Maybe [BS.ByteString] +readXreadKeys ("COUNT":_:rest) = readXreadKeys rest +readXreadKeys ("BLOCK":_:rest) = readXreadKeys rest +readXreadKeys ("STREAMS":rest) = Just $ take (length rest `div` 2) rest +readXreadKeys _ = Nothing + +readXreadgroupKeys :: [BS.ByteString] -> Maybe [BS.ByteString] +readXreadgroupKeys ("COUNT":_:rest) = readXreadKeys rest +readXreadgroupKeys ("BLOCK":_:rest) = readXreadKeys rest +readXreadgroupKeys ("NOACK":rest) = readXreadKeys rest +readXreadgroupKeys ("STREAMS":rest) = Just $ take (length rest `div` 2) rest +readXreadgroupKeys _ = Nothing readNumKeys :: [BS.ByteString] -> Maybe [BS.ByteString] readNumKeys (rawNumKeys:rest) = do From cb8593a643b1b7fde97e9499c6e4b90302bd49b7 Mon Sep 17 00:00:00 2001 From: Ag Date: Tue, 1 Nov 2022 19:24:52 +0530 Subject: [PATCH 081/103] Inlined nodes and logging the exception. --- src/Database/Redis/Cluster.hs | 1 + src/Database/Redis/ConnectionContext.hs | 8 ++++---- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index aabe2965..6b1bdd83 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -265,6 +265,7 @@ requestNode (NodeConnection ctx lastRecvRef _) requests = do IOR.writeIORef lastRecvRef (Just rest') return r +{-# INLINE nodes #-} nodes :: ShardMap -> [Node] nodes (ShardMap shardMap) = concatMap snd $ IntMap.toList $ fmap shardNodes shardMap where shardNodes :: Shard -> [Node] diff --git a/src/Database/Redis/ConnectionContext.hs b/src/Database/Redis/ConnectionContext.hs index 6ed88124..fb496429 100644 --- a/src/Database/Redis/ConnectionContext.hs +++ b/src/Database/Redis/ConnectionContext.hs @@ -10,7 +10,7 @@ module Database.Redis.ConnectionContext ( , connect , disconnect , send - , recv + , recv , errConnClosed , enableTLS , flush @@ -126,9 +126,9 @@ connectSocket (addr:rest) = tryConnect >>= \case send :: ConnectionContext -> B.ByteString -> IO () send (NormalHandle h) requestData = - ioErrorToConnLost (B.hPut h requestData) + ioErrorToConnLost (B.hPut h requestData) send (TLSContext ctx) requestData = - ioErrorToConnLost (TLS.sendData ctx (LB.fromStrict requestData)) + ioErrorToConnLost (TLS.sendData ctx (LB.fromStrict requestData)) recv :: ConnectionContext -> IO B.ByteString recv (NormalHandle h) = ioErrorToConnLost $ B.hGetSome h 4096 @@ -136,7 +136,7 @@ recv (TLSContext ctx) = TLS.recvData ctx ioErrorToConnLost :: IO a -> IO a -ioErrorToConnLost a = a `catchIOError` const errConnClosed +ioErrorToConnLost a = a `catchIOError` (\x -> putStrLn ("exception while running redis query: " <> show x) *> errConnClosed) errConnClosed :: IO a errConnClosed = throwIO ConnectionLost From 64f48e8df2f57e3c173d7d491cfd81121de6d089 Mon Sep 17 00:00:00 2001 From: Arpit Suman Date: Sat, 5 Nov 2022 21:02:39 +0530 Subject: [PATCH 082/103] added noack and opts in xreadgroup --- src/Database/Redis/ManualCommands.hs | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/src/Database/Redis/ManualCommands.hs b/src/Database/Redis/ManualCommands.hs index d7c01d2c..4649f99b 100644 --- a/src/Database/Redis/ManualCommands.hs +++ b/src/Database/Redis/ManualCommands.hs @@ -850,19 +850,21 @@ instance RedisResult StreamsRecord where data XReadOpts = XReadOpts { block :: Maybe Integer , recordCount :: Maybe Integer + , noack :: Bool } deriving (Show, Eq) -- |Redis default 'XReadOpts'. Equivalent to omitting all optional parameters. -- -- @ -- XReadOpts --- { block = Nothing -- Don't block waiting for more records --- , recordCount = Nothing -- no record count +-- { block = Nothing -- Don't block waiting for more records +-- , recordCount = Nothing -- no record count +-- , noack = False -- Add read records to the PEL if acknowledgement is not received -- } -- @ -- defaultXreadOpts :: XReadOpts -defaultXreadOpts = XReadOpts { block = Nothing, recordCount = Nothing } +defaultXreadOpts = XReadOpts { block = Nothing, recordCount = Nothing, noack = False} data XReadResponse = XReadResponse { stream :: ByteString @@ -885,10 +887,11 @@ xreadOpts streamsAndIds opts = sendRequest $ internalXreadArgs :: [(ByteString, ByteString)] -> XReadOpts -> [ByteString] internalXreadArgs streamsAndIds XReadOpts{..} = - concat [blockArgs, countArgs, ["STREAMS"], streams, recordIds] + concat [blockArgs, countArgs, noackArgs, ["STREAMS"], streams, recordIds] where blockArgs = maybe [] (\blockMillis -> ["BLOCK", encode blockMillis]) block countArgs = maybe [] (\countRecords -> ["COUNT", encode countRecords]) recordCount + noackArgs = if noack == False then [] else ["NOACK", "true"] -- true supported only for xreadgroup calls streams = map (\(stream, _) -> stream) streamsAndIds recordIds = map (\(_, recordId) -> recordId) streamsAndIds @@ -917,6 +920,15 @@ xreadGroup -> m (f (Maybe [XReadResponse])) xreadGroup groupName consumerName streamsAndIds = xreadGroupOpts groupName consumerName streamsAndIds defaultXreadOpts +xreadGroupWithOpts + :: (RedisCtx m f) + => ByteString -- ^ group name + -> ByteString -- ^ consumer name + -> [(ByteString, ByteString)] -- ^ (stream, id) pairs + -> XReadOpts -- ^ optional args {block, recordCount, noack} + -> m (f (Maybe [XReadResponse])) +xreadGroupWithOpts groupName consumerName streamsAndIds opts = xreadGroupOpts groupName consumerName streamsAndIds opts + xgroupCreate :: (RedisCtx m f) => ByteString -- ^ stream @@ -1377,4 +1389,4 @@ clusterGetKeysInSlot clusterGetKeysInSlot slot count = sendRequest ["CLUSTER", "GETKEYSINSLOT", (encode slot), (encode count)] command :: (RedisCtx m f) => m (f [CMD.CommandInfo]) -command = sendRequest ["COMMAND"] +command = sendRequest ["COMMAND"] \ No newline at end of file From 6454c72a98f821908cf3ec498f920db2049e1534 Mon Sep 17 00:00:00 2001 From: Arpit Suman Date: Mon, 7 Nov 2022 12:12:29 +0530 Subject: [PATCH 083/103] removed redundant func --- src/Database/Redis/ManualCommands.hs | 9 --------- 1 file changed, 9 deletions(-) diff --git a/src/Database/Redis/ManualCommands.hs b/src/Database/Redis/ManualCommands.hs index 4649f99b..5d3c7a92 100644 --- a/src/Database/Redis/ManualCommands.hs +++ b/src/Database/Redis/ManualCommands.hs @@ -920,15 +920,6 @@ xreadGroup -> m (f (Maybe [XReadResponse])) xreadGroup groupName consumerName streamsAndIds = xreadGroupOpts groupName consumerName streamsAndIds defaultXreadOpts -xreadGroupWithOpts - :: (RedisCtx m f) - => ByteString -- ^ group name - -> ByteString -- ^ consumer name - -> [(ByteString, ByteString)] -- ^ (stream, id) pairs - -> XReadOpts -- ^ optional args {block, recordCount, noack} - -> m (f (Maybe [XReadResponse])) -xreadGroupWithOpts groupName consumerName streamsAndIds opts = xreadGroupOpts groupName consumerName streamsAndIds opts - xgroupCreate :: (RedisCtx m f) => ByteString -- ^ stream From 216088b7fcf805dc53353ec8738664b003087315 Mon Sep 17 00:00:00 2001 From: Arpit Suman Date: Mon, 7 Nov 2022 14:58:50 +0530 Subject: [PATCH 084/103] added MKSTREAM in xgroupCreate --- src/Database/Redis/ManualCommands.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Database/Redis/ManualCommands.hs b/src/Database/Redis/ManualCommands.hs index 5d3c7a92..8be9652f 100644 --- a/src/Database/Redis/ManualCommands.hs +++ b/src/Database/Redis/ManualCommands.hs @@ -926,7 +926,7 @@ xgroupCreate -> ByteString -- ^ group name -> ByteString -- ^ start ID -> m (f Status) -xgroupCreate stream groupName startId = sendRequest $ ["XGROUP", "CREATE", stream, groupName, startId] +xgroupCreate stream groupName startId = sendRequest $ ["XGROUP", "CREATE", stream, groupName, startId, "MKSTREAM"] xgroupSetId :: (RedisCtx m f) From 9cae3a99f2538f029cc9243e2b256e16f2ec3e3b Mon Sep 17 00:00:00 2001 From: Arpit Suman Date: Mon, 14 Nov 2022 14:24:16 +0530 Subject: [PATCH 085/103] fix noack --- src/Database/Redis/ManualCommands.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Database/Redis/ManualCommands.hs b/src/Database/Redis/ManualCommands.hs index 8be9652f..688393c2 100644 --- a/src/Database/Redis/ManualCommands.hs +++ b/src/Database/Redis/ManualCommands.hs @@ -891,7 +891,7 @@ internalXreadArgs streamsAndIds XReadOpts{..} = where blockArgs = maybe [] (\blockMillis -> ["BLOCK", encode blockMillis]) block countArgs = maybe [] (\countRecords -> ["COUNT", encode countRecords]) recordCount - noackArgs = if noack == False then [] else ["NOACK", "true"] -- true supported only for xreadgroup calls + noackArgs = if noack == False then [] else ["NOACK"] -- NOACK supported only for xreadgroup calls streams = map (\(stream, _) -> stream) streamsAndIds recordIds = map (\(_, recordId) -> recordId) streamsAndIds From 065fe6dc1e47de5c2b3aa7d6678ca8e31aaceb37 Mon Sep 17 00:00:00 2001 From: Vivek Shukla Date: Tue, 6 Dec 2022 16:52:52 +0530 Subject: [PATCH 086/103] hedis version upgrade decode fixes --- src/Database/Redis/Cluster/Command.hs | 24 +++++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index 96940447..969efa2d 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -86,7 +86,29 @@ instance RedisResult CommandInfo where parseLastKeyPos = return $ case lastKeyPos of i | i == -1 -> UnlimitedKeys i -> LastKeyPosition i - + decode (MultiBulk (Just + [ name@(Bulk (Just _)) + , arity@(Integer _) + , flags@(MultiBulk (Just _)) + , firstPos@(Integer _) + , lastPos@(Integer _) + , step@(Integer _) + , MultiBulk _ -- ACL categories + ])) = + decode (MultiBulk (Just [name, arity, flags, firstPos, lastPos, step])) + decode (MultiBulk (Just + [ name@(Bulk (Just _)) + , arity@(Integer _) + , flags@(MultiBulk (Just _)) + , firstPos@(Integer _) + , lastPos@(Integer _) + , step@(Integer _) + , MultiBulk _ -- ACL categories + , MultiBulk _ -- Tips + , MultiBulk _ -- Key specifications + , MultiBulk _ -- Sub commands + ])) = + decode (MultiBulk (Just [name, arity, flags, firstPos, lastPos, step])) decode e = Left e newInfoMap :: [CommandInfo] -> InfoMap From 6c95355a3e714a21096b0fe47d347cc485ee0a57 Mon Sep 17 00:00:00 2001 From: Shubhranshu Singh Date: Wed, 21 Dec 2022 18:45:19 +0530 Subject: [PATCH 087/103] Added Support for readonly enabled connection --- src/Database/Redis/Cluster.hs | 32 ++++++++++++++++++--------- src/Database/Redis/Cluster/Command.hs | 7 ++++++ src/Database/Redis/Commands.hs | 3 ++- src/Database/Redis/Connection.hs | 26 ++++++++++++++++++++-- src/Database/Redis/ManualCommands.hs | 4 ++++ 5 files changed, 58 insertions(+), 14 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index aabe2965..a3bb9b46 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -49,7 +49,9 @@ import qualified Database.Redis.Cluster.Command as CMD -- | A connection to a redis cluster, it is compoesed of a map from Node IDs to -- | 'NodeConnection's, a 'Pipeline', and a 'ShardMap' -data Connection = Connection (HM.HashMap NodeID NodeConnection) (MVar Pipeline) (MVar ShardMap) CMD.InfoMap +type IsReadOnly = Bool + +data Connection = Connection (HM.HashMap NodeID NodeConnection) (MVar Pipeline) (MVar ShardMap) CMD.InfoMap IsReadOnly -- | A connection to a single node in the cluster, similar to 'ProtocolPipelining.Connection' data NodeConnection = NodeConnection CC.ConnectionContext (IOR.IORef (Maybe B.ByteString)) NodeID @@ -86,13 +88,13 @@ newtype CrossSlotException = CrossSlotException [B.ByteString] deriving (Show, T instance Exception CrossSlotException -connect :: [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> IO Connection -connect commandInfos shardMapVar timeoutOpt = do +connect :: [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> Bool -> IO Connection +connect commandInfos shardMapVar timeoutOpt isReadOnly = do shardMap <- readMVar shardMapVar stateVar <- newMVar $ Pending [] pipelineVar <- newMVar $ Pipeline stateVar nodeConns <- nodeConnections shardMap - return $ Connection nodeConns pipelineVar shardMapVar (CMD.newInfoMap commandInfos) where + return $ Connection nodeConns pipelineVar shardMapVar (CMD.newInfoMap commandInfos) isReadOnly where nodeConnections :: ShardMap -> IO (HM.HashMap NodeID NodeConnection) nodeConnections shardMap = HM.fromList <$> mapM connectNode (nub $ nodes shardMap) connectNode :: Node -> IO (NodeID, NodeConnection) @@ -102,14 +104,14 @@ connect commandInfos shardMapVar timeoutOpt = do return (n, NodeConnection ctx ref n) disconnect :: Connection -> IO () -disconnect (Connection nodeConnMap _ _ _) = mapM_ disconnectNode (HM.elems nodeConnMap) where +disconnect (Connection nodeConnMap _ _ _ _ ) = mapM_ disconnectNode (HM.elems nodeConnMap) where disconnectNode (NodeConnection nodeCtx _ _) = CC.disconnect nodeCtx -- Add a request to the current pipeline for this connection. The pipeline will -- be executed implicitly as soon as any result returned from this function is -- evaluated. requestPipelined :: IO ShardMap -> Connection -> [B.ByteString] -> IO Reply -requestPipelined refreshAction conn@(Connection _ pipelineVar shardMapVar _) nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do +requestPipelined refreshAction conn@(Connection _ pipelineVar shardMapVar _ _) nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do (newStateVar, repliesIndex) <- hasLocked "locked adding to pipeline" $ modifyMVar stateVar $ \case Pending requests -> return (Pending (nextRequest:requests), (stateVar, length requests)) e@(Executed _) -> do @@ -214,23 +216,31 @@ moved _ = False nodeConnWithHostAndPort :: ShardMap -> Connection -> Host -> Port -> Maybe NodeConnection -nodeConnWithHostAndPort shardMap (Connection nodeConns _ _ _) host port = do +nodeConnWithHostAndPort shardMap (Connection nodeConns _ _ _ _) host port = do node <- nodeWithHostAndPort shardMap host port HM.lookup (nodeId node) nodeConns nodeConnectionForCommand :: Connection -> ShardMap -> [B.ByteString] -> IO NodeConnection -nodeConnectionForCommand (Connection nodeConns _ _ infoMap) (ShardMap shardMap) request = do +nodeConnectionForCommand (Connection nodeConns _ _ infoMap connReadOnly) (ShardMap shardMap) request = do let mek = case request of ("MULTI" : key : _) -> Just [key] ("EXEC" : key : _) -> Just [key] _ -> Nothing + isCmdReadOnly = CMD.isCommandReadonly infoMap request keys <- case CMD.keysForRequest infoMap request of Nothing -> throwIO $ UnsupportedClusterCommandException request Just k -> return k let shards = nub $ mapMaybe ((flip IntMap.lookup shardMap) . fromEnum . keyToSlot) (fromMaybe keys mek) - node <- case shards of - [] -> throwIO $ MissingNodeException request - [Shard master _] -> return master + node <- case (shards, connReadOnly) of + ([],_) -> throwIO $ MissingNodeException request + ([Shard master _], False) -> + return master + ([Shard master []], True) -> + return master + ([Shard master (slave: _)], True) -> + if isCmdReadOnly + then return slave + else return master _ -> throwIO $ CrossSlotException request maybe (throwIO $ MissingNodeException request) return (HM.lookup (nodeId node) nodeConns) diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index 96940447..fea3b136 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -102,6 +102,13 @@ keysForRequest (InfoMap infoMap) request@(command:_) = do return $ takeEvery (fromEnum $ stepCount info) possibleKeys keysForRequest _ [] = Nothing +isCommandReadonly :: InfoMap -> [BS.ByteString] -> Bool +isCommandReadonly (InfoMap infoMap) (command: _) = + let + info = HM.lookup (map toLower $ Char8.unpack command) infoMap + in maybe (False) (ReadOnly `elem`) (flags <$> info) +isCommandReadonly _ _ = False + isMovable :: CommandInfo -> Bool isMovable CommandInfo{..} = MovableKeys `elem` flags diff --git a/src/Database/Redis/Commands.hs b/src/Database/Redis/Commands.hs index 69f9859e..debd2e32 100644 --- a/src/Database/Redis/Commands.hs +++ b/src/Database/Redis/Commands.hs @@ -274,7 +274,8 @@ clusterSetSlotStable, clusterSetSlotImporting, clusterSetSlotMigrating, clusterGetKeysInSlot, -command +command, +readOnly -- * Unimplemented Commands -- |These commands are not implemented, as of now. Library -- users can implement these or other commands from diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs index fe817a2a..a8179407 100644 --- a/src/Database/Redis/Connection.hs +++ b/src/Database/Redis/Connection.hs @@ -31,6 +31,7 @@ import Database.Redis.Commands , auth , clusterSlots , command + , readOnly , ClusterSlotsResponse(..) , ClusterSlotsResponseEntry(..) , ClusterSlotsNode(..)) @@ -61,6 +62,7 @@ data ConnectInfo = ConnInfo { connectHost :: NS.HostName , connectPort :: CC.PortID , connectAuth :: Maybe B.ByteString + , connectReadOnly :: Bool -- ^ When the server is protected by a password, set 'connectAuth' to 'Just' -- the password. Each connection will then authenticate by the 'auth' -- command. @@ -106,6 +108,7 @@ defaultConnectInfo = ConnInfo { connectHost = "localhost" , connectPort = CC.PortNumber 6379 , connectAuth = Nothing + , connectReadOnly = False , connectDatabase = 0 , connectMaxConnections = 50 , connectMaxIdleTime = 30 @@ -201,8 +204,27 @@ connectCluster bootstrapConnInfo = do case commandInfos of Left e -> throwIO $ ClusterConnectError e Right infos -> do - pool <- createPool (Cluster.connect infos shardMapVar Nothing) Cluster.disconnect 1 (connectMaxIdleTime bootstrapConnInfo) (connectMaxConnections bootstrapConnInfo) + let + isConnectionReadOnly = connectReadOnly bootstrapConnInfo + clusterConnection = Cluster.connect infos shardMapVar Nothing isConnectionReadOnly + pool <- createPool (clusterConnect isConnectionReadOnly clusterConnection) Cluster.disconnect 1 (connectMaxIdleTime bootstrapConnInfo) (connectMaxConnections bootstrapConnInfo) return $ ClusteredConnection shardMapVar pool + where + clusterConnect :: Bool -> IO Cluster.Connection -> IO Cluster.Connection + clusterConnect readOnlyConnection connection = do + clusterConn@(Cluster.Connection nodeMap _ _ _ _) <- connection + nodesConns <- sequence $ ( PP.fromCtx . (\(Cluster.NodeConnection ctx _ _) -> ctx ) . snd) <$> (HM.toList nodeMap) + void $ if readOnlyConnection + then + mapM_ (\conn -> do + PP.beginReceiving conn + runRedisInternal conn readOnly + ) nodesConns + else + return () + return clusterConn + + shardMapFromClusterSlotsResponse :: ClusterSlotsResponse -> IO ShardMap shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr mkShardMap (pure IntMap.empty) clusterSlotsResponseEntries where @@ -222,7 +244,7 @@ shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr m Cluster.Node clusterSlotsNodeID role hostname (toEnum clusterSlotsNodePort) refreshShardMap :: Cluster.Connection -> IO ShardMap -refreshShardMap (Cluster.Connection nodeConns _ _ _) = do +refreshShardMap (Cluster.Connection nodeConns _ _ _ _) = do let (Cluster.NodeConnection ctx _ _) = head $ HM.elems nodeConns pipelineConn <- PP.fromCtx ctx _ <- PP.beginReceiving pipelineConn diff --git a/src/Database/Redis/ManualCommands.hs b/src/Database/Redis/ManualCommands.hs index d7c01d2c..057f1d44 100644 --- a/src/Database/Redis/ManualCommands.hs +++ b/src/Database/Redis/ManualCommands.hs @@ -1378,3 +1378,7 @@ clusterGetKeysInSlot slot count = sendRequest ["CLUSTER", "GETKEYSINSLOT", (enco command :: (RedisCtx m f) => m (f [CMD.CommandInfo]) command = sendRequest ["COMMAND"] + +readOnly :: (RedisCtx m f) => m (f Status) +readOnly = sendRequest ["READONLY"] + From 74691061073065e82ec175d1bc90c29bb701c8a1 Mon Sep 17 00:00:00 2001 From: shubhranshu0103 Date: Tue, 27 Dec 2022 11:58:58 +0530 Subject: [PATCH 088/103] Resolved Comments --- src/Database/Redis/Cluster.hs | 10 +++++++++- src/Database/Redis/Cluster/Command.hs | 7 ------- src/Database/Redis/Connection.hs | 5 +---- 3 files changed, 10 insertions(+), 12 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 782e36f0..2c7d3b48 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -17,6 +17,7 @@ module Database.Redis.Cluster ) where import qualified Data.ByteString as B +import Data.Char(toLower) import qualified Data.ByteString.Char8 as Char8 import qualified Data.IORef as IOR import Data.Maybe(listToMaybe, mapMaybe, fromMaybe) @@ -226,7 +227,7 @@ nodeConnectionForCommand (Connection nodeConns _ _ infoMap connReadOnly) (ShardM ("MULTI" : key : _) -> Just [key] ("EXEC" : key : _) -> Just [key] _ -> Nothing - isCmdReadOnly = CMD.isCommandReadonly infoMap request + isCmdReadOnly = isCommandReadonly infoMap request keys <- case CMD.keysForRequest infoMap request of Nothing -> throwIO $ UnsupportedClusterCommandException request Just k -> return k @@ -243,6 +244,13 @@ nodeConnectionForCommand (Connection nodeConns _ _ infoMap connReadOnly) (ShardM else return master _ -> throwIO $ CrossSlotException request maybe (throwIO $ MissingNodeException request) return (HM.lookup (nodeId node) nodeConns) + where + isCommandReadonly :: CMD.InfoMap -> [B.ByteString] -> Bool + isCommandReadonly (CMD.InfoMap iMap) (command: _) = + let + info = HM.lookup (map toLower $ Char8.unpack command) iMap + in maybe False (CMD.ReadOnly `elem`) (CMD.flags <$> info) + isCommandReadonly _ _ = False cleanRequest :: [B.ByteString] -> [B.ByteString] cleanRequest ("MULTI" : _) = ["MULTI"] diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index fea3b136..96940447 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -102,13 +102,6 @@ keysForRequest (InfoMap infoMap) request@(command:_) = do return $ takeEvery (fromEnum $ stepCount info) possibleKeys keysForRequest _ [] = Nothing -isCommandReadonly :: InfoMap -> [BS.ByteString] -> Bool -isCommandReadonly (InfoMap infoMap) (command: _) = - let - info = HM.lookup (map toLower $ Char8.unpack command) infoMap - in maybe (False) (ReadOnly `elem`) (flags <$> info) -isCommandReadonly _ _ = False - isMovable :: CommandInfo -> Bool isMovable CommandInfo{..} = MovableKeys `elem` flags diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs index a8179407..be1ff9d8 100644 --- a/src/Database/Redis/Connection.hs +++ b/src/Database/Redis/Connection.hs @@ -214,14 +214,11 @@ connectCluster bootstrapConnInfo = do clusterConnect readOnlyConnection connection = do clusterConn@(Cluster.Connection nodeMap _ _ _ _) <- connection nodesConns <- sequence $ ( PP.fromCtx . (\(Cluster.NodeConnection ctx _ _) -> ctx ) . snd) <$> (HM.toList nodeMap) - void $ if readOnlyConnection - then + when readOnlyConnection $ mapM_ (\conn -> do PP.beginReceiving conn runRedisInternal conn readOnly ) nodesConns - else - return () return clusterConn From 8fe20a15189e819de3bc43b6742805b4b74a5965 Mon Sep 17 00:00:00 2001 From: Ag Date: Tue, 3 Jan 2023 16:09:53 +0530 Subject: [PATCH 089/103] Added auth support for cluster. --- src/Database/Redis/Cluster.hs | 6 ++-- src/Database/Redis/Connection.hs | 46 +++++++++++++++++------- src/Database/Redis/ProtocolPipelining.hs | 4 ++- 3 files changed, 40 insertions(+), 16 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 2c7d3b48..97fc07f3 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -89,8 +89,8 @@ newtype CrossSlotException = CrossSlotException [B.ByteString] deriving (Show, T instance Exception CrossSlotException -connect :: [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> Bool -> IO Connection -connect commandInfos shardMapVar timeoutOpt isReadOnly = do +connect :: (Host -> CC.PortID -> Maybe Int -> IO CC.ConnectionContext) -> [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> Bool -> IO Connection +connect withAuth commandInfos shardMapVar timeoutOpt isReadOnly = do shardMap <- readMVar shardMapVar stateVar <- newMVar $ Pending [] pipelineVar <- newMVar $ Pipeline stateVar @@ -100,7 +100,7 @@ connect commandInfos shardMapVar timeoutOpt isReadOnly = do nodeConnections shardMap = HM.fromList <$> mapM connectNode (nub $ nodes shardMap) connectNode :: Node -> IO (NodeID, NodeConnection) connectNode (Node n _ host port) = do - ctx <- CC.connect host (CC.PortNumber $ toEnum port) timeoutOpt + ctx <- withAuth host (CC.PortNumber $ toEnum port) timeoutOpt ref <- IOR.newIORef Nothing return (n, NodeConnection ctx ref n) diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs index be1ff9d8..7e925442 100644 --- a/src/Database/Redis/Connection.hs +++ b/src/Database/Redis/Connection.hs @@ -204,24 +204,46 @@ connectCluster bootstrapConnInfo = do case commandInfos of Left e -> throwIO $ ClusterConnectError e Right infos -> do - let + let isConnectionReadOnly = connectReadOnly bootstrapConnInfo - clusterConnection = Cluster.connect infos shardMapVar Nothing isConnectionReadOnly + clusterConnection = Cluster.connect withAuthAndSelectDB infos shardMapVar Nothing isConnectionReadOnly pool <- createPool (clusterConnect isConnectionReadOnly clusterConnection) Cluster.disconnect 1 (connectMaxIdleTime bootstrapConnInfo) (connectMaxConnections bootstrapConnInfo) return $ ClusteredConnection shardMapVar pool where - clusterConnect :: Bool -> IO Cluster.Connection -> IO Cluster.Connection - clusterConnect readOnlyConnection connection = do - clusterConn@(Cluster.Connection nodeMap _ _ _ _) <- connection - nodesConns <- sequence $ ( PP.fromCtx . (\(Cluster.NodeConnection ctx _ _) -> ctx ) . snd) <$> (HM.toList nodeMap) - when readOnlyConnection $ - mapM_ (\conn -> do - PP.beginReceiving conn - runRedisInternal conn readOnly - ) nodesConns - return clusterConn + withAuthAndSelectDB host port timeout = do + conn <- PP.connect host port timeout + conn' <- case connectTLSParams bootstrapConnInfo of + Nothing -> return conn + Just tlsParams -> PP.enableTLS tlsParams conn + PP.beginReceiving conn' + runRedisInternal conn' $ do + -- AUTH + case connectAuth bootstrapConnInfo of + Nothing -> return () + Just pass -> do + resp <- auth pass + case resp of + Left r -> liftIO $ throwIO $ ConnectAuthError r + _ -> return () + -- SELECT + when (connectDatabase bootstrapConnInfo /= 0) $ do + resp <- select $ connectDatabase bootstrapConnInfo + case resp of + Left r -> liftIO $ throwIO $ ConnectSelectError r + _ -> return () + return $ PP.toCtx conn' + clusterConnect :: Bool -> IO Cluster.Connection -> IO Cluster.Connection + clusterConnect readOnlyConnection connection = do + clusterConn@(Cluster.Connection nodeMap _ _ _ _) <- connection + nodesConns <- sequence $ ( PP.fromCtx . (\(Cluster.NodeConnection ctx _ _) -> ctx ) . snd) <$> (HM.toList nodeMap) + when readOnlyConnection $ + mapM_ (\conn -> do + PP.beginReceiving conn + runRedisInternal conn readOnly + ) nodesConns + return clusterConn shardMapFromClusterSlotsResponse :: ClusterSlotsResponse -> IO ShardMap shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr mkShardMap (pure IntMap.empty) clusterSlotsResponseEntries where diff --git a/src/Database/Redis/ProtocolPipelining.hs b/src/Database/Redis/ProtocolPipelining.hs index 2989b4f2..8ba3cc87 100644 --- a/src/Database/Redis/ProtocolPipelining.hs +++ b/src/Database/Redis/ProtocolPipelining.hs @@ -16,7 +16,7 @@ -- module Database.Redis.ProtocolPipelining ( Connection, - connect, enableTLS, beginReceiving, disconnect, request, send, recv, flush, fromCtx + connect, enableTLS, beginReceiving, disconnect, request, send, recv, flush, fromCtx, toCtx ) where import Prelude @@ -47,6 +47,8 @@ data Connection = Conn fromCtx :: CC.ConnectionContext -> IO Connection fromCtx ctx = Conn ctx <$> newIORef [] <*> newIORef [] <*> newIORef 0 +toCtx :: Connection -> CC.ConnectionContext +toCtx = connCtx connect :: NS.HostName -> CC.PortID -> Maybe Int -> IO Connection connect hostName portId timeoutOpt = do From 60ccfed574f87807239354e5fac46250420af63f Mon Sep 17 00:00:00 2001 From: Ag Date: Tue, 3 Jan 2023 16:27:16 +0530 Subject: [PATCH 090/103] Fixed tests. --- src/Database/Redis/URL.hs | 4 ++-- test/Test.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Database/Redis/URL.hs b/src/Database/Redis/URL.hs index 96aca98d..07cc1c7b 100644 --- a/src/Database/Redis/URL.hs +++ b/src/Database/Redis/URL.hs @@ -25,7 +25,7 @@ import qualified Data.ByteString.Char8 as C8 -- Username is ignored, path is used to specify the database: -- -- >>> parseConnectInfo "redis://username:password@host:42/2" --- Right (ConnInfo {connectHost = "host", connectPort = PortNumber 42, connectAuth = Just "password", connectDatabase = 2, connectMaxConnections = 50, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing}) +-- Right (ConnInfo {connectHost = "host", connectPort = PortNumber 42, connectAuth = Just "password", connectReadOnly = False, connectDatabase = 2, connectMaxConnections = 50, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing}) -- -- >>> parseConnectInfo "redis://username:password@host:42/db" -- Left "Invalid port: db" @@ -39,7 +39,7 @@ import qualified Data.ByteString.Char8 as C8 -- @'defaultConnectInfo'@: -- -- >>> parseConnectInfo "redis://" --- Right (ConnInfo {connectHost = "localhost", connectPort = PortNumber 6379, connectAuth = Nothing, connectDatabase = 0, connectMaxConnections = 50, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing}) +-- Right (ConnInfo {connectHost = "localhost", connectPort = PortNumber 6379, connectAuth = Nothing, connectReadOnly = False, connectDatabase = 0, connectMaxConnections = 50, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing}) -- parseConnectInfo :: String -> Either String ConnectInfo parseConnectInfo url = do diff --git a/test/Test.hs b/test/Test.hs index 3287e560..9a370475 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -524,7 +524,7 @@ testConnectAuthUnexpected = testCase "connect/auth/unexpected" $ do where connInfo = defaultConnectInfo { connectAuth = Just "pass" } err = Left $ ConnectAuthError $ - Error "ERR Client sent AUTH, but no password is set" + Error "ERR AUTH called without any password configured for the default user. Are you sure your configuration is correct?" testConnectDb :: Test testConnectDb = testCase "connect/db" $ do From 43c39a1d682eaf1ebc9034ebb62b45ddf87dc902 Mon Sep 17 00:00:00 2001 From: Ag Date: Wed, 4 Jan 2023 00:15:24 +0530 Subject: [PATCH 091/103] Removed select DB for cluster since it's not supported. --- src/Database/Redis/Connection.hs | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs index 7e925442..c5116368 100644 --- a/src/Database/Redis/Connection.hs +++ b/src/Database/Redis/Connection.hs @@ -206,11 +206,11 @@ connectCluster bootstrapConnInfo = do Right infos -> do let isConnectionReadOnly = connectReadOnly bootstrapConnInfo - clusterConnection = Cluster.connect withAuthAndSelectDB infos shardMapVar Nothing isConnectionReadOnly + clusterConnection = Cluster.connect withAuth infos shardMapVar Nothing isConnectionReadOnly pool <- createPool (clusterConnect isConnectionReadOnly clusterConnection) Cluster.disconnect 1 (connectMaxIdleTime bootstrapConnInfo) (connectMaxConnections bootstrapConnInfo) return $ ClusteredConnection shardMapVar pool where - withAuthAndSelectDB host port timeout = do + withAuth host port timeout = do conn <- PP.connect host port timeout conn' <- case connectTLSParams bootstrapConnInfo of Nothing -> return conn @@ -226,12 +226,6 @@ connectCluster bootstrapConnInfo = do case resp of Left r -> liftIO $ throwIO $ ConnectAuthError r _ -> return () - -- SELECT - when (connectDatabase bootstrapConnInfo /= 0) $ do - resp <- select $ connectDatabase bootstrapConnInfo - case resp of - Left r -> liftIO $ throwIO $ ConnectSelectError r - _ -> return () return $ PP.toCtx conn' clusterConnect :: Bool -> IO Cluster.Connection -> IO Cluster.Connection From 3e811212c685e309d0f259dbe0672939585f2cb5 Mon Sep 17 00:00:00 2001 From: Ag Date: Fri, 6 Jan 2023 20:19:56 +0530 Subject: [PATCH 092/103] Refresh the cluster info on connection timeout. --- src/Database/Redis/Cluster.hs | 29 +++++++++++++++++++++-------- src/Database/Redis/Connection.hs | 12 ++++++++---- 2 files changed, 29 insertions(+), 12 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 2c7d3b48..416ab54c 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} module Database.Redis.Cluster ( Connection(..) , NodeRole(..) @@ -24,7 +25,7 @@ import Data.Maybe(listToMaybe, mapMaybe, fromMaybe) import Data.List(nub, sortBy) import Data.Map(fromListWith, assocs) import Data.Function(on) -import Control.Exception(Exception, throwIO, BlockedIndefinitelyOnMVar(..), catches, Handler(..)) +import Control.Exception(Exception, SomeException, throwIO, BlockedIndefinitelyOnMVar(..), catches, Handler(..), try) import Control.Concurrent.MVar(MVar, newMVar, readMVar, modifyMVar, modifyMVar_) import Control.Monad(zipWithM, when) import Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot) @@ -89,12 +90,22 @@ newtype CrossSlotException = CrossSlotException [B.ByteString] deriving (Show, T instance Exception CrossSlotException -connect :: [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> Bool -> IO Connection -connect commandInfos shardMapVar timeoutOpt isReadOnly = do +connect :: [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> Bool -> (Bool -> IO ShardMap) -> IO Connection +connect commandInfos shardMapVar timeoutOpt isReadOnly refreshShardMap = do shardMap <- readMVar shardMapVar stateVar <- newMVar $ Pending [] pipelineVar <- newMVar $ Pipeline stateVar - nodeConns <- nodeConnections shardMap + eNodeConns <- try $ nodeConnections shardMap + -- whenever one of the node connection is not established, + -- will refresh the slots and retry node connections. + -- This would handle fail over, IP change use cases. + nodeConns <- + case eNodeConns of + Right nodeConns -> return nodeConns + Left (_ :: SomeException) -> do + newShardMap <- refreshShardMap True + refreshShardMapVar "locked refreshing due to connection issues" newShardMap + nodeConnections newShardMap return $ Connection nodeConns pipelineVar shardMapVar (CMD.newInfoMap commandInfos) isReadOnly where nodeConnections :: ShardMap -> IO (HM.HashMap NodeID NodeConnection) nodeConnections shardMap = HM.fromList <$> mapM connectNode (nub $ nodes shardMap) @@ -103,6 +114,8 @@ connect commandInfos shardMapVar timeoutOpt isReadOnly = do ctx <- CC.connect host (CC.PortNumber $ toEnum port) timeoutOpt ref <- IOR.newIORef Nothing return (n, NodeConnection ctx ref n) + refreshShardMapVar :: String -> ShardMap -> IO () + refreshShardMapVar msg shardMap = hasLocked msg $ modifyMVar_ shardMapVar (const (pure shardMap)) disconnect :: Connection -> IO () disconnect (Connection nodeConnMap _ _ _ _ ) = mapM_ disconnectNode (HM.elems nodeConnMap) where @@ -234,11 +247,11 @@ nodeConnectionForCommand (Connection nodeConns _ _ infoMap connReadOnly) (ShardM let shards = nub $ mapMaybe ((flip IntMap.lookup shardMap) . fromEnum . keyToSlot) (fromMaybe keys mek) node <- case (shards, connReadOnly) of ([],_) -> throwIO $ MissingNodeException request - ([Shard master _], False) -> + ([Shard master _], False) -> return master - ([Shard master []], True) -> + ([Shard master []], True) -> return master - ([Shard master (slave: _)], True) -> + ([Shard master (slave: _)], True) -> if isCmdReadOnly then return slave else return master @@ -246,7 +259,7 @@ nodeConnectionForCommand (Connection nodeConns _ _ infoMap connReadOnly) (ShardM maybe (throwIO $ MissingNodeException request) return (HM.lookup (nodeId node) nodeConns) where isCommandReadonly :: CMD.InfoMap -> [B.ByteString] -> Bool - isCommandReadonly (CMD.InfoMap iMap) (command: _) = + isCommandReadonly (CMD.InfoMap iMap) (command: _) = let info = HM.lookup (map toLower $ Char8.unpack command) iMap in maybe False (CMD.ReadOnly `elem`) (CMD.flags <$> info) diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs index be1ff9d8..26e446dc 100644 --- a/src/Database/Redis/Connection.hs +++ b/src/Database/Redis/Connection.hs @@ -193,6 +193,8 @@ instance Exception ClusterConnectError -- a 'ConnectInfo' for any node in the cluster connectCluster :: ConnectInfo -> IO Connection connectCluster bootstrapConnInfo = do + let timeoutOptUs = + round . (1000000 *) <$> connectTimeout bootstrapConnInfo conn <- createConnection bootstrapConnInfo slotsResponse <- runRedisInternal conn clusterSlots shardMapVar <- case slotsResponse of @@ -204,9 +206,9 @@ connectCluster bootstrapConnInfo = do case commandInfos of Left e -> throwIO $ ClusterConnectError e Right infos -> do - let + let isConnectionReadOnly = connectReadOnly bootstrapConnInfo - clusterConnection = Cluster.connect infos shardMapVar Nothing isConnectionReadOnly + clusterConnection = Cluster.connect infos shardMapVar timeoutOptUs isConnectionReadOnly (refreshShardMapWithConn conn) pool <- createPool (clusterConnect isConnectionReadOnly clusterConnection) Cluster.disconnect 1 (connectMaxIdleTime bootstrapConnInfo) (connectMaxConnections bootstrapConnInfo) return $ ClusteredConnection shardMapVar pool where @@ -221,8 +223,6 @@ connectCluster bootstrapConnInfo = do ) nodesConns return clusterConn - - shardMapFromClusterSlotsResponse :: ClusterSlotsResponse -> IO ShardMap shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr mkShardMap (pure IntMap.empty) clusterSlotsResponseEntries where mkShardMap :: ClusterSlotsResponseEntry -> IO (IntMap.IntMap Shard) -> IO (IntMap.IntMap Shard) @@ -244,6 +244,10 @@ refreshShardMap :: Cluster.Connection -> IO ShardMap refreshShardMap (Cluster.Connection nodeConns _ _ _ _) = do let (Cluster.NodeConnection ctx _ _) = head $ HM.elems nodeConns pipelineConn <- PP.fromCtx ctx + refreshShardMapWithConn pipelineConn True + +refreshShardMapWithConn :: PP.Connection -> Bool -> IO ShardMap +refreshShardMapWithConn pipelineConn _ = do _ <- PP.beginReceiving pipelineConn slotsResponse <- runRedisInternal pipelineConn clusterSlots case slotsResponse of From dd99e12038fd2dfa576115e13fd91285c3e0c41f Mon Sep 17 00:00:00 2001 From: Ag Date: Tue, 10 Jan 2023 13:03:37 +0530 Subject: [PATCH 093/103] Send the command to another node in case of any exception. The new node will give `moved` as response with new node info which will be sent to the right one. --- src/Database/Redis/Cluster.hs | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index e5c9fc66..3ed506c8 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -22,8 +22,8 @@ import qualified Data.ByteString as B import Data.Char(toLower) import qualified Data.ByteString.Char8 as Char8 import qualified Data.IORef as IOR -import Data.Maybe(mapMaybe, fromMaybe) -import Data.List(nub, sortBy, find) +import Data.Maybe(listToMaybe, mapMaybe, fromMaybe) +import Data.List(nub, sortBy, find, findIndex) import Data.Map(fromListWith, assocs) import Data.Function(on) import Control.Exception(Exception, SomeException, throwIO, BlockedIndefinitelyOnMVar(..), catches, Handler(..), try) @@ -196,11 +196,26 @@ evaluatePipeline :: MVar ShardMap -> IO ShardMap -> Connection -> [[B.ByteString evaluatePipeline shardMapVar refreshShardmapAction conn requests = do shardMap <- hasLocked "reading shardmap in evaluatePipeline" $ readMVar shardMapVar requestsByNode <- getRequestsByNode shardMap - resps <- concat <$> mapM (uncurry executeRequests) requestsByNode + -- catch the exception thrown at each node level + -- send the command to random node. + -- merge the current responses with new responses. + eresps <- mapM (try . uncurry executeRequests) requestsByNode + -- take a random connection where there are no exceptions. + let (nc, _) = (requestsByNode !!) $ fromMaybe 0 $ findIndex isRight eresps + -- PERF_CONCERN: Since usually we send only one request at time, this won't be + -- heavy perf issue. but still should be evaluated and figured out with complete rewrite. + resps <- concat <$> mapM (\(resp, (_, r)) -> case resp of + Right v -> return v + Left (_ :: SomeException) -> executeRequests nc r + ) (zip eresps requestsByNode) + -- check for any moved in both responses and continue the flow. when (any (moved . rawResponse) resps) (refreshShardMapVar "locked refreshing due to moved responses") retriedResps <- mapM (retry 0) resps return $ map rawResponse $ sortBy (on compare responseIndex) retriedResps where + isRight :: Either a b -> Bool + isRight (Right _) = True + isRight _ = False getRequestsByNode :: ShardMap -> IO [(NodeConnection, [PendingRequest])] getRequestsByNode shardMap = do commandsWithNodes <- zipWithM (requestWithNode shardMap) (reverse [0..(length requests - 1)]) requests From 16d2038532d26c64c87eaebad6f43f57fd9dfefb Mon Sep 17 00:00:00 2001 From: Ag Date: Tue, 10 Jan 2023 18:11:01 +0530 Subject: [PATCH 094/103] Using the succesful node connect rather than default one in cluster connect. --- src/Database/Redis/Cluster.hs | 52 +++++++++++++++++++++----------- src/Database/Redis/Connection.hs | 9 ++++-- 2 files changed, 40 insertions(+), 21 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 3ed506c8..a96b3386 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -109,25 +109,41 @@ instance Exception UnsupportedClusterCommandException newtype CrossSlotException = CrossSlotException [B.ByteString] deriving (Show, Typeable) instance Exception CrossSlotException -connect :: (Host -> CC.PortID -> Maybe Int -> IO CC.ConnectionContext) -> [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> Bool -> (Bool -> IO ShardMap) -> IO Connection +data NoNodeException = NoNodeException deriving (Show, Typeable) +instance Exception NoNodeException + +connect :: (Host -> CC.PortID -> Maybe Int -> IO CC.ConnectionContext) -> [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> Bool -> (NodeConnection -> IO ShardMap) -> IO Connection connect withAuth commandInfos shardMapVar timeoutOpt isReadOnly refreshShardMap = do - shardMap <- readMVar shardMapVar - stateVar <- newMVar $ Pending [] - pipelineVar <- newMVar $ Pipeline stateVar - eNodeConns <- try $ nodeConnections shardMap - -- whenever one of the node connection is not established, - -- will refresh the slots and retry node connections. - -- This would handle fail over, IP change use cases. - nodeConns <- - case eNodeConns of - Right nodeConns -> return nodeConns - Left (_ :: SomeException) -> do - newShardMap <- refreshShardMap True - refreshShardMapVar "locked refreshing due to connection issues" newShardMap - nodeConnections newShardMap - return $ Connection nodeConns pipelineVar shardMapVar (CMD.newInfoMap commandInfos) isReadOnly where - nodeConnections :: ShardMap -> IO (HM.HashMap NodeID NodeConnection) - nodeConnections shardMap = HM.fromList <$> mapM connectNode (nub $ nodes shardMap) + shardMap <- readMVar shardMapVar + stateVar <- newMVar $ Pending [] + pipelineVar <- newMVar $ Pipeline stateVar + (eNodeConns, shouldRetry) <- nodeConnections shardMap + -- whenever one of the node connection is not established, + -- will refresh the slots and retry node connections. + -- This would handle fail over, IP change use cases. + nodeConns <- + if shouldRetry + then if not (HM.null eNodeConns) + then do + newShardMap <- refreshShardMap (head $ HM.elems eNodeConns) + refreshShardMapVar "locked refreshing due to connection issues" newShardMap + simpleNodeConnections newShardMap + else + throwIO NoNodeException + else + return eNodeConns + return $ Connection nodeConns pipelineVar shardMapVar (CMD.newInfoMap commandInfos) isReadOnly + where + simpleNodeConnections :: ShardMap -> IO (HM.HashMap NodeID NodeConnection) + simpleNodeConnections shardMap = HM.fromList <$> mapM connectNode (nub $ nodes shardMap) + nodeConnections :: ShardMap -> IO (HM.HashMap NodeID NodeConnection, Bool) + nodeConnections shardMap = do + info <- mapM (try . connectNode) (nub $ nodes shardMap) + return $ + foldl (\(acc, accB) x -> case x of + Right (v, nc) -> (HM.insert v nc acc, accB) + Left (_ :: SomeException) -> (acc, True) + ) (mempty, False) info connectNode :: Node -> IO (NodeID, NodeConnection) connectNode (Node n _ host port) = do ctx <- withAuth host (CC.PortNumber $ toEnum port) timeoutOpt diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs index be9ae653..df7f727c 100644 --- a/src/Database/Redis/Connection.hs +++ b/src/Database/Redis/Connection.hs @@ -208,7 +208,7 @@ connectCluster bootstrapConnInfo = do Right infos -> do let isConnectionReadOnly = connectReadOnly bootstrapConnInfo - clusterConnection = Cluster.connect withAuth infos shardMapVar timeoutOptUs isConnectionReadOnly (refreshShardMapWithConn conn) + clusterConnection = Cluster.connect withAuth infos shardMapVar timeoutOptUs isConnectionReadOnly refreshShardMapWithNodeConn pool <- createPool (clusterConnect isConnectionReadOnly clusterConnection) Cluster.disconnect 1 (connectMaxIdleTime bootstrapConnInfo) (connectMaxConnections bootstrapConnInfo) return $ ClusteredConnection shardMapVar pool where @@ -259,8 +259,11 @@ shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr m Cluster.Node clusterSlotsNodeID role hostname (toEnum clusterSlotsNodePort) refreshShardMap :: Cluster.Connection -> IO ShardMap -refreshShardMap (Cluster.Connection nodeConns _ _ _ _) = do - let (Cluster.NodeConnection ctx _ _) = head $ HM.elems nodeConns +refreshShardMap (Cluster.Connection nodeConns _ _ _ _) = + refreshShardMapWithNodeConn (head $ HM.elems nodeConns) + +refreshShardMapWithNodeConn :: Cluster.NodeConnection -> IO ShardMap +refreshShardMapWithNodeConn (Cluster.NodeConnection ctx _ _) = do pipelineConn <- PP.fromCtx ctx refreshShardMapWithConn pipelineConn True From f3330e1b00aefa5245d8c2b780524a8bc433fac7 Mon Sep 17 00:00:00 2001 From: Ag Date: Wed, 11 Jan 2023 14:06:46 +0530 Subject: [PATCH 095/103] squash! Using the succesful node connect rather than default one in cluster connect. --- src/Database/Redis/Cluster.hs | 41 +++++++++++++++++------------------ 1 file changed, 20 insertions(+), 21 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index a96b3386..8286357d 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -22,7 +22,7 @@ import qualified Data.ByteString as B import Data.Char(toLower) import qualified Data.ByteString.Char8 as Char8 import qualified Data.IORef as IOR -import Data.Maybe(listToMaybe, mapMaybe, fromMaybe) +import Data.Maybe(mapMaybe, fromMaybe) import Data.List(nub, sortBy, find, findIndex) import Data.Map(fromListWith, assocs) import Data.Function(on) @@ -114,26 +114,25 @@ instance Exception NoNodeException connect :: (Host -> CC.PortID -> Maybe Int -> IO CC.ConnectionContext) -> [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> Bool -> (NodeConnection -> IO ShardMap) -> IO Connection connect withAuth commandInfos shardMapVar timeoutOpt isReadOnly refreshShardMap = do - shardMap <- readMVar shardMapVar - stateVar <- newMVar $ Pending [] - pipelineVar <- newMVar $ Pipeline stateVar - (eNodeConns, shouldRetry) <- nodeConnections shardMap - -- whenever one of the node connection is not established, - -- will refresh the slots and retry node connections. - -- This would handle fail over, IP change use cases. - nodeConns <- - if shouldRetry - then if not (HM.null eNodeConns) - then do - newShardMap <- refreshShardMap (head $ HM.elems eNodeConns) - refreshShardMapVar "locked refreshing due to connection issues" newShardMap - simpleNodeConnections newShardMap - else - throwIO NoNodeException - else - return eNodeConns - return $ Connection nodeConns pipelineVar shardMapVar (CMD.newInfoMap commandInfos) isReadOnly - where + shardMap <- readMVar shardMapVar + stateVar <- newMVar $ Pending [] + pipelineVar <- newMVar $ Pipeline stateVar + (eNodeConns, shouldRetry) <- nodeConnections shardMap + -- whenever one of the node connection is not established, + -- will refresh the slots and retry node connections. + -- This would handle fail over, IP change use cases. + nodeConns <- + if shouldRetry + then if not (HM.null eNodeConns) + then do + newShardMap <- refreshShardMap (head $ HM.elems eNodeConns) + refreshShardMapVar "locked refreshing due to connection issues" newShardMap + simpleNodeConnections newShardMap + else + throwIO NoNodeException + else + return eNodeConns + return $ Connection nodeConns pipelineVar shardMapVar (CMD.newInfoMap commandInfos) isReadOnly where simpleNodeConnections :: ShardMap -> IO (HM.HashMap NodeID NodeConnection) simpleNodeConnections shardMap = HM.fromList <$> mapM connectNode (nub $ nodes shardMap) nodeConnections :: ShardMap -> IO (HM.HashMap NodeID NodeConnection, Bool) From ee82c3f0df8f2c8f4b836b7ef67e7cc7b7caba39 Mon Sep 17 00:00:00 2001 From: Ag Date: Wed, 11 Jan 2023 14:55:14 +0530 Subject: [PATCH 096/103] changed finding the random node. --- src/Database/Redis/Cluster.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 8286357d..05a5c073 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -23,7 +23,7 @@ import Data.Char(toLower) import qualified Data.ByteString.Char8 as Char8 import qualified Data.IORef as IOR import Data.Maybe(mapMaybe, fromMaybe) -import Data.List(nub, sortBy, find, findIndex) +import Data.List(nub, sortBy, find) import Data.Map(fromListWith, assocs) import Data.Function(on) import Control.Exception(Exception, SomeException, throwIO, BlockedIndefinitelyOnMVar(..), catches, Handler(..), try) @@ -216,21 +216,22 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do -- merge the current responses with new responses. eresps <- mapM (try . uncurry executeRequests) requestsByNode -- take a random connection where there are no exceptions. - let (nc, _) = (requestsByNode !!) $ fromMaybe 0 $ findIndex isRight eresps -- PERF_CONCERN: Since usually we send only one request at time, this won't be -- heavy perf issue. but still should be evaluated and figured out with complete rewrite. - resps <- concat <$> mapM (\(resp, (_, r)) -> case resp of + resps <- concat <$> mapM (\(resp, (cc, r)) -> case resp of Right v -> return v - Left (_ :: SomeException) -> executeRequests nc r + Left (_ :: SomeException) -> executeRequests (getRandomConnection cc) r ) (zip eresps requestsByNode) -- check for any moved in both responses and continue the flow. when (any (moved . rawResponse) resps) (refreshShardMapVar "locked refreshing due to moved responses") retriedResps <- mapM (retry 0) resps return $ map rawResponse $ sortBy (on compare responseIndex) retriedResps where - isRight :: Either a b -> Bool - isRight (Right _) = True - isRight _ = False + getRandomConnection :: NodeConnection -> NodeConnection + getRandomConnection nc = + let (Connection hmn _ _ _ _) = conn + conns = HM.elems hmn + in fromMaybe (head conns) $ find (nc /= ) conns getRequestsByNode :: ShardMap -> IO [(NodeConnection, [PendingRequest])] getRequestsByNode shardMap = do commandsWithNodes <- zipWithM (requestWithNode shardMap) (reverse [0..(length requests - 1)]) requests From 514cf241016deb56df71a730e362d123a7534b84 Mon Sep 17 00:00:00 2001 From: Vivek Shukla Date: Fri, 13 Jan 2023 11:39:23 +0530 Subject: [PATCH 097/103] requestNode fix --- src/Database/Redis/Cluster.hs | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 05a5c073..27b018d3 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -27,6 +27,8 @@ import Data.List(nub, sortBy, find) import Data.Map(fromListWith, assocs) import Data.Function(on) import Control.Exception(Exception, SomeException, throwIO, BlockedIndefinitelyOnMVar(..), catches, Handler(..), try) +import Control.Concurrent.Async(race) +import Control.Concurrent(threadDelay) import Control.Concurrent.MVar(MVar, newMVar, readMVar, modifyMVar, modifyMVar_) import Control.DeepSeq(deepseq) import Control.Monad(zipWithM, when, replicateM) @@ -326,16 +328,21 @@ cleanRequest ("MULTI" : _) = ["MULTI"] cleanRequest ("EXEC" : _) = ["EXEC"] cleanRequest req = req - requestNode :: NodeConnection -> [[B.ByteString]] -> IO [Reply] requestNode (NodeConnection ctx lastRecvRef _) requests = do - let reqs = map cleanRequest requests - _ <- mapM_ (sendNode . renderRequest) reqs - _ <- CC.flush ctx - replicateM (length requests) recvNode - + eresp <- race requestNodeImpl (threadDelay 1000000) -- 100 ms + case eresp of + Left e -> return e + Right _ -> putStrLn "timeout happened" *> throwIO NoNodeException where + requestNodeImpl :: IO [Reply] + requestNodeImpl = do + let reqs = map cleanRequest requests + _ <- mapM_ (sendNode . renderRequest) reqs + _ <- CC.flush ctx + replicateM (length requests) recvNode + sendNode :: B.ByteString -> IO () sendNode = CC.send ctx recvNode :: IO Reply From 798825c0b00ce23ad2d8f642f468911f48792aa4 Mon Sep 17 00:00:00 2001 From: Ag Date: Fri, 13 Jan 2023 17:56:20 +0530 Subject: [PATCH 098/103] Setup a connection timeout ENV and removed slaves. --- src/Database/Redis/Connection.hs | 4 ++-- src/Database/Redis/ConnectionContext.hs | 20 +++++++++++--------- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs index df7f727c..2ff87f09 100644 --- a/src/Database/Redis/Connection.hs +++ b/src/Database/Redis/Connection.hs @@ -247,8 +247,8 @@ shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr m mkShardMap ClusterSlotsResponseEntry{..} accumulator = do accumulated <- accumulator let master = nodeFromClusterSlotNode True clusterSlotsResponseEntryMaster - let replicas = map (nodeFromClusterSlotNode False) clusterSlotsResponseEntryReplicas - let shard = Shard master replicas + -- let replicas = map (nodeFromClusterSlotNode False) clusterSlotsResponseEntryReplicas + let shard = Shard master [] let slotMap = IntMap.fromList $ map (, shard) [clusterSlotsResponseEntryStartSlot..clusterSlotsResponseEntryEndSlot] return $ IntMap.union slotMap accumulated nodeFromClusterSlotNode :: Bool -> ClusterSlotsNode -> Node diff --git a/src/Database/Redis/ConnectionContext.hs b/src/Database/Redis/ConnectionContext.hs index fb496429..91a57f70 100644 --- a/src/Database/Redis/ConnectionContext.hs +++ b/src/Database/Redis/ConnectionContext.hs @@ -23,14 +23,18 @@ import Control.Monad(when) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import qualified Data.IORef as IOR +import qualified Data.Time as Time +import Data.Maybe (fromMaybe) import Control.Concurrent.MVar(newMVar, readMVar, swapMVar) import Control.Exception(bracketOnError, Exception, throwIO, try) import Data.Typeable import Data.Functor(void) import qualified Network.Socket as NS import qualified Network.TLS as TLS +import System.Environment (lookupEnv) import System.IO(Handle, hSetBinaryMode, hClose, IOMode(..), hFlush, hIsOpen) import System.IO.Error(catchIOError) +import Text.Read (readMaybe) data ConnectionContext = NormalHandle Handle | TLSContext TLS.Context @@ -72,15 +76,13 @@ connect hostName portId timeoutOpt = hConnect = do phaseMVar <- newMVar PhaseUnknown let doConnect = hConnect' phaseMVar - case timeoutOpt of - Nothing -> doConnect - Just micros -> do - result <- race doConnect (threadDelay micros) - case result of - Left h -> return h - Right () -> do - phase <- readMVar phaseMVar - errConnectTimeout phase + envTimeout <- round . (\x -> (x :: Time.NominalDiffTime) * 1000000) . realToFrac . fromMaybe (0.5 :: Double) . (>>= readMaybe) <$> lookupEnv "REDIS_DEFAULT_TIMEOUT" + result <- race doConnect (threadDelay $ fromMaybe envTimeout timeoutOpt) + case result of + Left h -> return h + Right () -> do + phase <- readMVar phaseMVar + errConnectTimeout phase hConnect' mvar = bracketOnError createSock NS.close $ \sock -> do NS.setSocketOption sock NS.KeepAlive 1 void $ swapMVar mvar PhaseResolve From 556e77f8ed367a14a5808f92bbe583110797ba70 Mon Sep 17 00:00:00 2001 From: Ag Date: Mon, 16 Jan 2023 16:02:51 +0530 Subject: [PATCH 099/103] Updated with upstream --- .gitignore | 4 +- .travis.yml | 29 ++- CHANGELOG | 58 +++++ cabal.project | 2 + codegen/commands.json | 2 +- hedis.cabal | 45 +++- src/Database/Redis.hs | 22 +- src/Database/Redis/Cluster.hs | 276 +++++++++++++++-------- src/Database/Redis/Cluster/Command.hs | 43 +++- src/Database/Redis/Commands.hs | 2 +- src/Database/Redis/Connection.hs | 13 +- src/Database/Redis/ConnectionContext.hs | 6 +- src/Database/Redis/Core.hs | 33 +-- src/Database/Redis/Core/Internal.hs | 38 ++++ src/Database/Redis/ManualCommands.hs | 91 ++++++-- src/Database/Redis/PubSub.hs | 19 +- src/Database/Redis/Sentinel.hs | 221 +++++++++++++++++++ src/Database/Redis/Transactions.hs | 28 +-- src/Database/Redis/URL.hs | 3 +- stack-8.0.yaml | 10 - stack-8.4.3.yaml => stack-8.10.yaml | 2 +- stack-7.10.yaml => stack-8.8.yaml | 3 +- stack-head.yaml | 2 +- stack.yaml | 8 +- stack.yaml~HEAD | 7 + test/ClusterMain.hs | 50 +++++ test/Main.hs | 34 +++ test/PubSubTest.hs | 111 +++++----- test/{Test.hs => Tests.hs} | 278 ++++++++++-------------- test/run-test.sh | 6 +- 30 files changed, 979 insertions(+), 467 deletions(-) create mode 100644 cabal.project create mode 100644 src/Database/Redis/Core/Internal.hs create mode 100644 src/Database/Redis/Sentinel.hs delete mode 100644 stack-8.0.yaml rename stack-8.4.3.yaml => stack-8.10.yaml (80%) rename stack-7.10.yaml => stack-8.8.yaml (71%) mode change 100644 => 120000 stack.yaml create mode 100644 stack.yaml~HEAD create mode 100644 test/ClusterMain.hs create mode 100644 test/Main.hs rename test/{Test.hs => Tests.hs} (78%) diff --git a/.gitignore b/.gitignore index 7b46696c..3fd028cb 100644 --- a/.gitignore +++ b/.gitignore @@ -10,5 +10,5 @@ appendonly.aof Main.hs .stack-work TAGS -stack.yaml.lock -.nvimrc +stack*.yaml.lock +.vscode diff --git a/.travis.yml b/.travis.yml index baabafa2..2b8f448e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,13 @@ language: c # sudo: false -dist: xenial +dist: focal + +# addons: +# apt: +# sources: +# - sourceline: ppa:redislabs/redis +# packages: +# - redis cache: directories: @@ -8,24 +15,28 @@ cache: - $HOME/.cabal - $HOME/.stack +services: + - docker + before_install: + - sudo apt-get update + - sudo apt-get -y install redis-server - mkdir -p ~/.local/bin - mkdir -p ~/tmp - export PATH=~/.local/bin:$PATH - - curl -L https://github.com/commercialhaskell/stack/releases/download/v1.9.3/stack-1.9.3-linux-x86_64.tar.gz | tar xz -C ~/tmp - - mv ~/tmp/stack-1.9.3-linux-x86_64/stack ~/.local/bin/ - - curl -L https://github.com/antirez/redis/archive/5.0.2.tar.gz | tar xz -C ~/tmp - - cd ~/tmp/redis-5.0.2 && make - - ~/tmp/redis-5.0.2/src/redis-server & + - curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-linux-x86_64.tar.gz | tar xz -C ~/tmp + - mv ~/tmp/stack-2.5.1-linux-x86_64/stack ~/.local/bin/ - cd ${TRAVIS_BUILD_DIR} + - docker run -d -p 7000-7010:7000-7010 grokzen/redis-cluster:5.0.6 matrix: include: - - env: GHCVER=7.10.3 STACK_YAML=stack-7.10.yaml - - env: GHCVER=8.0.1 STACK_YAML=stack-8.0.yaml - env: GHCVER=8.2.2 STACK_YAML=stack-8.2.yaml - env: GHCVER=8.4.1 STACK_YAML=stack-8.4.yaml - - env: GHCVER=8.6.3 STACK_YAML=stack-8.6.yaml + - env: GHCVER=8.6.5 STACK_YAML=stack-8.6.yaml + - env: GHCVER=8.8.1 STACK_YAML=stack-8.8.yaml + - env: GHCVER=8.10.4 STACK_YAML=stack-8.10.yaml + - env: GHCVER=8.10.6 STACK_YAML=stack-8.10.yaml allow_failures: - env: GHCVER=head STACK_YAML=stack-head.yaml diff --git a/CHANGELOG b/CHANGELOG index 59d6d6b4..d0be90fc 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,63 @@ # Changelog for Hedis +## 0.15.1 + +* PR #181. Add MonadUnliftIO instance + +## 0.15.0 + +* PR #174, Issue #173. Hedis fails to decode xstreamInfo response in case when the stream is empty + +## 0.14.3 + +* PR #171. Support GHC 9 + +## 0.14.2 + +* PR #163. support for redis 6.0 COMMAND format +* PR #164. remove invalid tests for Redis Cluster + +## 0.14.1 + +* PR #162. Improved documentation for EVALSHA + +## 0.14.0 + +* PR #157. Clustering support + +## 0.13.1 + +* PR #158. Upgrade to Redis 6.0.9 & Fix auth test +* PR #160. Fix GHC 8.0.1 compat + +## 0.13.0 + +* PR #159. Issue #152. Make HSET return integer instead of bool + +## 0.12.15 + +* PR #154. Implement Redis Sentinel support + +## 0.12.14 + +* PR #153. Publicly expose ConnectTimeout exception + +## 0.12.13 + +* PR #150, Issue #143. Leaking sockets when connection fails + +## 0.12.12 + +* PR #149. Make withConnect friendly to transformer stack + +## 0.12.11 + +* Expose `withCheckedConnect`, `withConnect` + +## 0.12.9 + +* Expose the `Database.Redis.Core.Internal` module (see https://github.com/informatikr/hedis/issues/144 ) + ## 0.12.8 * PR #140. Added support of +/- inf redis argument diff --git a/cabal.project b/cabal.project new file mode 100644 index 00000000..3b98a43d --- /dev/null +++ b/cabal.project @@ -0,0 +1,2 @@ +packages: + ./ diff --git a/codegen/commands.json b/codegen/commands.json index 8066249a..11382b8d 100644 --- a/codegen/commands.json +++ b/codegen/commands.json @@ -1203,7 +1203,7 @@ ], "since": "2.0.0", "group": "hash", - "returns": "bool" + "returns": "integer" }, "HSETNX": { "summary": "Set the value of a hash field, only if the field does not exist", diff --git a/hedis.cabal b/hedis.cabal index f94239e1..abc43538 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.12.8.1 +version: 0.15.1 synopsis: Client library for the Redis datastore: supports full command set, pipelining. @@ -43,7 +43,7 @@ maintainer: Kostiantyn Rybnikov copyright: Copyright (c) 2011 Falko Peters category: Database build-type: Simple -cabal-version: >=1.8 +cabal-version: >=1.10 homepage: https://github.com/informatikr/hedis bug-reports: https://github.com/informatikr/hedis/issues extra-source-files: CHANGELOG @@ -58,6 +58,7 @@ flag dev manual: True library + default-language: Haskell2010 hs-source-dirs: src ghc-options: -Wall -fwarn-tabs if impl(ghc >= 8.6.0) @@ -67,12 +68,14 @@ library if flag(dev) ghc-prof-options: -auto-all exposed-modules: Database.Redis + , Database.Redis.Sentinel + , Database.Redis.Core.Internal build-depends: scanner >= 0.2, async >= 2.1, - array >= 0.5.3, base >= 4.8 && < 5, bytestring >= 0.9, bytestring-lexing >= 0.5, + exceptions, unordered-containers, containers, text, @@ -87,7 +90,7 @@ library HTTP, errors, network-uri, - say + unliftio-core if !impl(ghc >= 8.0) build-depends: semigroups >= 0.11 && < 0.19 @@ -106,8 +109,10 @@ library Database.Redis.ManualCommands, Database.Redis.URL, Database.Redis.ConnectionContext + other-extensions: StrictData benchmark hedis-benchmark + default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: benchmark/Benchmark.hs build-depends: @@ -122,10 +127,38 @@ benchmark hedis-benchmark ghc-prof-options: -auto-all test-suite hedis-test + default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: Test.hs + main-is: Main.hs other-modules: PubSubTest + Tests + build-depends: + base == 4.*, + bytestring >= 0.10, + hedis, + HUnit, + async, + stm, + text, + mtl == 2.*, + test-framework, + test-framework-hunit, + time + -- We use -O0 here, since GHC takes *very* long to compile so many constants + ghc-options: -O0 -Wall -rtsopts -fno-warn-unused-do-bind + if flag(dev) + ghc-options: -Werror + if flag(dev) + ghc-prof-options: -auto-all + +test-suite hedis-test-cluster + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: ClusterMain.hs + other-modules: PubSubTest + Tests build-depends: base == 4.*, bytestring >= 0.10, @@ -146,8 +179,10 @@ test-suite hedis-test ghc-prof-options: -auto-all test-suite doctest + default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: DocTest.hs + ghc-options: -O0 -rtsopts build-depends: base == 4.*, doctest diff --git a/src/Database/Redis.hs b/src/Database/Redis.hs index 557c2d6b..37e04eb1 100644 --- a/src/Database/Redis.hs +++ b/src/Database/Redis.hs @@ -23,7 +23,7 @@ module Database.Redis ( -- @ -- -- Send commands to the server: - -- + -- -- @ -- {-\# LANGUAGE OverloadedStrings \#-} -- ... @@ -114,7 +114,7 @@ module Database.Redis ( -- The Redis Scripting website () -- documents the exact semantics of the scripting commands and value -- conversion. - + -- ** Automatic Pipelining -- |Commands are automatically pipelined as much as possible. For example, -- in the above \"hello world\" example, all four commands are pipelined. @@ -130,7 +130,7 @@ module Database.Redis ( -- sent only when at least one reply has been received. That means, command -- functions may block until there are less than 1000 outstanding replies. -- - + -- ** Error Behavior -- | -- [Operations against keys holding the wrong kind of value:] Outside of a @@ -155,7 +155,7 @@ module Database.Redis ( -- sure it is not left in an unusable state, e.g. closed or inside a -- transaction. -- - + -- * The Redis Monad Redis(), runRedis, unRedis, reRedis, @@ -163,15 +163,16 @@ module Database.Redis ( -- * Connection Connection, ConnectError(..), connect, checkedConnect, disconnect, + withConnect, withCheckedConnect, ConnectInfo(..), defaultConnectInfo, parseConnectInfo, connectCluster, PortID(..), -- * Commands module Database.Redis.Commands, - + -- * Transactions module Database.Redis.Transactions, - + -- * Pub\/Sub module Database.Redis.PubSub, @@ -179,7 +180,8 @@ module Database.Redis ( sendRequest, sendToAllMasterNodes, Reply(..),Status(..),RedisResult(..),ConnectionLostException(..), - + ConnectTimeout(..), + -- |[Solution to Exercise] -- -- Type of 'expire' inside a transaction: @@ -203,8 +205,10 @@ import Database.Redis.Connection , checkedConnect , connect , ConnectError(..) - , Connection(..)) -import Database.Redis.ConnectionContext(PortID(..), ConnectionLostException(..)) + , Connection(..) + , withConnect + , withCheckedConnect) +import Database.Redis.ConnectionContext(PortID(..), ConnectionLostException(..), ConnectTimeout(..)) import Database.Redis.PubSub import Database.Redis.Protocol import Database.Redis.Transactions diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 27b018d3..76636c84 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} module Database.Redis.Cluster @@ -19,7 +20,6 @@ module Database.Redis.Cluster ) where import qualified Data.ByteString as B -import Data.Char(toLower) import qualified Data.ByteString.Char8 as Char8 import qualified Data.IORef as IOR import Data.Maybe(mapMaybe, fromMaybe) @@ -30,7 +30,6 @@ import Control.Exception(Exception, SomeException, throwIO, BlockedIndefinitelyO import Control.Concurrent.Async(race) import Control.Concurrent(threadDelay) import Control.Concurrent.MVar(MVar, newMVar, readMVar, modifyMVar, modifyMVar_) -import Control.DeepSeq(deepseq) import Control.Monad(zipWithM, when, replicateM) import Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot) import qualified Database.Redis.ConnectionContext as CC @@ -39,7 +38,6 @@ import qualified Data.IntMap.Strict as IntMap import Data.Typeable import qualified Scanner import System.IO.Unsafe(unsafeInterleaveIO) -import Say(sayString) import Database.Redis.Protocol(Reply(Error), renderRequest, reply) import qualified Database.Redis.Cluster.Command as CMD @@ -69,16 +67,22 @@ instance Ord NodeConnection where compare (NodeConnection _ _ id1) (NodeConnection _ _ id2) = compare id1 id2 data PipelineState = - -- Nothing in the pipeline has been evaluated yet so nothing has been + -- Nothing in the pipeline has been evaluated yet so nothing has been -- sent Pending [[B.ByteString]] -- This pipeline has been executed, the replies are contained within it | Executed [Reply] + -- We're in a MULTI-EXEC transaction. All commands in the transaction + -- should go to the same node, but we won't know what node that is until + -- we see a command with a key. We're storing these transactions and will + -- send them all together when we see an EXEC. + | TransactionPending [[B.ByteString]] -- A pipeline has an MVar for the current state, this state is actually always -- `Pending` because the first thing the implementation does when executing a -- pipeline is to take the current pipeline state out of the MVar and replace -- it with a new `Pending` state. The executed state is held on to by the -- replies within it. + newtype Pipeline = Pipeline (MVar PipelineState) data NodeRole = Master | Slave deriving (Show, Eq, Ord) @@ -108,7 +112,7 @@ instance Exception MissingNodeException newtype UnsupportedClusterCommandException = UnsupportedClusterCommandException [B.ByteString] deriving (Show, Typeable) instance Exception UnsupportedClusterCommandException -newtype CrossSlotException = CrossSlotException [B.ByteString] deriving (Show, Typeable) +newtype CrossSlotException = CrossSlotException [[B.ByteString]] deriving (Show, Typeable) instance Exception CrossSlotException data NoNodeException = NoNodeException deriving (Show, Typeable) @@ -128,7 +132,7 @@ connect withAuth commandInfos shardMapVar timeoutOpt isReadOnly refreshShardMap then if not (HM.null eNodeConns) then do newShardMap <- refreshShardMap (head $ HM.elems eNodeConns) - refreshShardMapVar "locked refreshing due to connection issues" newShardMap + refreshShardMapVar newShardMap simpleNodeConnections newShardMap else throwIO NoNodeException @@ -150,8 +154,8 @@ connect withAuth commandInfos shardMapVar timeoutOpt isReadOnly refreshShardMap ctx <- withAuth host (CC.PortNumber $ toEnum port) timeoutOpt ref <- IOR.newIORef Nothing return (n, NodeConnection ctx ref n) - refreshShardMapVar :: String -> ShardMap -> IO () - refreshShardMapVar msg shardMap = hasLocked msg $ modifyMVar_ shardMapVar (const (pure shardMap)) + refreshShardMapVar :: ShardMap -> IO () + refreshShardMapVar shardMap = hasLocked $ modifyMVar_ shardMapVar (const (pure shardMap)) disconnect :: Connection -> IO () disconnect (Connection nodeConnMap _ _ _ _ ) = mapM_ disconnectNode (HM.elems nodeConnMap) where @@ -162,26 +166,49 @@ disconnect (Connection nodeConnMap _ _ _ _ ) = mapM_ disconnectNode (HM.elems no -- evaluated. requestPipelined :: IO ShardMap -> Connection -> [B.ByteString] -> IO Reply requestPipelined refreshAction conn@(Connection _ pipelineVar shardMapVar _ _) nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do - (newStateVar, repliesIndex) <- hasLocked "locked adding to pipeline" $ modifyMVar stateVar $ \case + (newStateVar, repliesIndex) <- hasLocked $ modifyMVar stateVar $ \case + Pending requests | isMulti nextRequest -> do + replies <- evaluatePipeline shardMapVar refreshAction conn requests + s' <- newMVar $ TransactionPending [nextRequest] + return (Executed replies, (s', 0)) Pending requests | length requests > 1000 -> do replies <- evaluatePipeline shardMapVar refreshAction conn (nextRequest:requests) return (Executed replies, (stateVar, length requests)) Pending requests -> return (Pending (nextRequest:requests), (stateVar, length requests)) + TransactionPending requests -> + if isExec nextRequest then do + replies <- evaluateTransactionPipeline shardMapVar refreshAction conn (nextRequest:requests) + return (Executed replies, (stateVar, length requests)) + else + return (TransactionPending (nextRequest:requests), (stateVar, length requests)) e@(Executed _) -> do - s' <- newMVar $ Pending [nextRequest] + s' <- newMVar $ + if isMulti nextRequest then + TransactionPending [nextRequest] + else + Pending [nextRequest] return (e, (s', 0)) evaluateAction <- unsafeInterleaveIO $ do - replies <- hasLocked "locked evaluating replies" $ modifyMVar newStateVar $ \case + replies <- hasLocked $ modifyMVar newStateVar $ \case Executed replies -> return (Executed replies, replies) Pending requests-> do replies <- evaluatePipeline shardMapVar refreshAction conn requests - replies `deepseq` return (Executed replies, replies) + return (Executed replies, replies) + TransactionPending requests-> do + replies <- evaluateTransactionPipeline shardMapVar refreshAction conn requests + return (Executed replies, replies) return $ replies !! repliesIndex return (Pipeline newStateVar, evaluateAction) +isMulti :: [B.ByteString] -> Bool +isMulti ("MULTI" : _) = True +isMulti _ = False +isExec :: [B.ByteString] -> Bool +isExec ("EXEC" : _) = True +isExec _ = False data PendingRequest = PendingRequest Int [B.ByteString] data CompletedRequest = CompletedRequest Int [B.ByteString] Reply @@ -195,9 +222,6 @@ responseIndex (CompletedRequest i _ _) = i rawResponse :: CompletedRequest -> Reply rawResponse (CompletedRequest _ _ r) = r -requestForResponse :: CompletedRequest -> [B.ByteString] -requestForResponse (CompletedRequest _ r _) = r - -- The approach we take here is similar to that taken by the redis-py-cluster -- library, which is described at https://redis-py-cluster.readthedocs.io/en/master/pipelines.html -- @@ -211,7 +235,7 @@ requestForResponse (CompletedRequest _ r _) = r -- cluster reconfiguration events, which should be rare. evaluatePipeline :: MVar ShardMap -> IO ShardMap -> Connection -> [[B.ByteString]] -> IO [Reply] evaluatePipeline shardMapVar refreshShardmapAction conn requests = do - shardMap <- hasLocked "reading shardmap in evaluatePipeline" $ readMVar shardMapVar + shardMap <- hasLocked $ readMVar shardMapVar requestsByNode <- getRequestsByNode shardMap -- catch the exception thrown at each node level -- send the command to random node. @@ -225,7 +249,7 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do Left (_ :: SomeException) -> executeRequests (getRandomConnection cc) r ) (zip eresps requestsByNode) -- check for any moved in both responses and continue the flow. - when (any (moved . rawResponse) resps) (refreshShardMapVar "locked refreshing due to moved responses") + when (any (moved . rawResponse) resps) refreshShardMapVar retriedResps <- mapM (retry 0) resps return $ map rawResponse $ sortBy (on compare responseIndex) retriedResps where @@ -236,38 +260,124 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do in fromMaybe (head conns) $ find (nc /= ) conns getRequestsByNode :: ShardMap -> IO [(NodeConnection, [PendingRequest])] getRequestsByNode shardMap = do - commandsWithNodes <- zipWithM (requestWithNode shardMap) (reverse [0..(length requests - 1)]) requests - return $ assocs $ fromListWith (++) commandsWithNodes - requestWithNode :: ShardMap -> Int -> [B.ByteString] -> IO (NodeConnection, [PendingRequest]) - requestWithNode shardMap index request = do - nodeConn <- nodeConnectionForCommand conn shardMap request - return (nodeConn, [PendingRequest index request]) + commandsWithNodes <- zipWithM (requestWithNodes shardMap) (reverse [0..(length requests - 1)]) requests + return $ assocs $ fromListWith (++) (mconcat commandsWithNodes) + requestWithNodes :: ShardMap -> Int -> [B.ByteString] -> IO [(NodeConnection, [PendingRequest])] + requestWithNodes shardMap index request = do + nodeConns <- nodeConnectionForCommand conn shardMap request + return $ (, [PendingRequest index request]) <$> nodeConns executeRequests :: NodeConnection -> [PendingRequest] -> IO [CompletedRequest] executeRequests nodeConn nodeRequests = do replies <- requestNode nodeConn $ map rawRequest nodeRequests return $ zipWith (curry (\(PendingRequest i r, rep) -> CompletedRequest i r rep)) nodeRequests replies retry :: Int -> CompletedRequest -> IO CompletedRequest - retry retryCount resp@(CompletedRequest index request thisReply) = do - retryReply <- case thisReply of - (Error errString) | B.isPrefixOf "MOVED" errString -> do - shardMap <- hasLocked "reading shard map in retry MOVED" $ readMVar shardMapVar - nodeConn <- nodeConnectionForCommand conn shardMap (requestForResponse resp) - head <$> requestNode nodeConn [request] - (askingRedirection -> Just (host, port)) -> do - shardMap <- hasLocked "reading shardmap in retry ASK" $ readMVar shardMapVar - let maybeAskNode = nodeConnWithHostAndPort shardMap conn host port - case maybeAskNode of - Just askNode -> last <$> requestNode askNode [["ASKING"], requestForResponse resp] - Nothing -> case retryCount of - 0 -> do - _ <- refreshShardMapVar "missing node in first retry of ASK" - rawResponse <$> retry (retryCount + 1) resp - _ -> throwIO $ MissingNodeException (requestForResponse resp) - _ -> return thisReply + retry retryCount (CompletedRequest index request thisReply) = do + retryReply <- head <$> retryBatch shardMapVar refreshShardmapAction conn retryCount [request] [thisReply] return (CompletedRequest index request retryReply) - refreshShardMapVar :: String -> IO () - refreshShardMapVar msg = hasLocked msg $ modifyMVar_ shardMapVar (const refreshShardmapAction) - + refreshShardMapVar :: IO () + refreshShardMapVar = hasLocked $ modifyMVar_ shardMapVar (const refreshShardmapAction) + +-- Retry a batch of requests if any of the responses is a redirect instruction. +-- If multiple requests are passed in they're assumed to be a MULTI..EXEC +-- transaction and will all be retried. +retryBatch :: MVar ShardMap -> IO ShardMap -> Connection -> Int -> [[B.ByteString]] -> [Reply] -> IO [Reply] +retryBatch shardMapVar refreshShardmapAction conn retryCount requests replies = + -- The last reply will be the `EXEC` reply containing the redirection, if + -- there is one. + case last replies of + (Error errString) | B.isPrefixOf "MOVED" errString -> do + let (Connection _ _ _ infoMap _) = conn + keys <- mconcat <$> mapM (requestKeys infoMap) requests + hashSlot <- hashSlotForKeys (CrossSlotException requests) keys + nodeConn <- nodeConnForHashSlot shardMapVar conn (MissingNodeException (head requests)) hashSlot + requestNode nodeConn requests + (askingRedirection -> Just (host, port)) -> do + shardMap <- hasLocked $ readMVar shardMapVar + let maybeAskNode = nodeConnWithHostAndPort shardMap conn host port + case maybeAskNode of + Just askNode -> tail <$> requestNode askNode (["ASKING"] : requests) + Nothing -> case retryCount of + 0 -> do + _ <- hasLocked $ modifyMVar_ shardMapVar (const refreshShardmapAction) + retryBatch shardMapVar refreshShardmapAction conn (retryCount + 1) requests replies + _ -> throwIO $ MissingNodeException (head requests) + _ -> return replies + +-- Like `evaluateOnPipeline`, except we expect to be able to run all commands +-- on a single shard. Failing to meet this expectation is an error. +evaluateTransactionPipeline :: MVar ShardMap -> IO ShardMap -> Connection -> [[B.ByteString]] -> IO [Reply] +evaluateTransactionPipeline shardMapVar refreshShardmapAction conn requests' = do + let requests = reverse requests' + let (Connection _ _ _ infoMap _) = conn + keys <- mconcat <$> mapM (requestKeys infoMap) requests + -- In cluster mode Redis expects commands in transactions to all work on the + -- same hashslot. We find that hashslot here. + -- We could be more permissive and allow transactions that touch multiple + -- hashslots, as long as those hashslots are on the same node. This allows + -- a new failure case though: if some of the transactions hashslots are + -- moved to a different node we could end up in a situation where some of + -- the commands in a transaction are applied and some are not. Better to + -- fail early. + hashSlot <- hashSlotForKeys (CrossSlotException requests) keys + nodeConn <- nodeConnForHashSlot shardMapVar conn (MissingNodeException (head requests)) hashSlot + resps <- requestNode nodeConn requests + -- The Redis documentation has the following to say on the effect of + -- resharding on multi-key operations: + -- + -- Multi-key operations may become unavailable when a resharding of the + -- hash slot the keys belong to is in progress. + -- + -- More specifically, even during a resharding the multi-key operations + -- targeting keys that all exist and all still hash to the same slot + -- (either the source or destination node) are still available. + -- + -- Operations on keys that don't exist or are - during the resharding - + -- split between the source and destination nodes, will generate a + -- -TRYAGAIN error. The client can try the operation after some time, + -- or report back the error. + -- + -- https://redis.io/topics/cluster-spec#multiple-keys-operations + -- + -- An important take-away here is that MULTI..EXEC transactions can fail + -- with a redirect in which case we need to repeat the full transaction on + -- the node we're redirected too. + -- + -- A second important takeway is that MULTI..EXEC transactions might + -- temporarily fail during resharding with a -TRYAGAIN error. We can only + -- make arbitrary decisions about how long to paus before the retry and how + -- often to retry, so instead we'll propagate the error to the library user + -- and let them decide how they would like to handle the error. + when (any moved resps) + (hasLocked $ modifyMVar_ shardMapVar (const refreshShardmapAction)) + retriedResps <- retryBatch shardMapVar refreshShardmapAction conn 0 requests resps + return retriedResps + +nodeConnForHashSlot :: Exception e => MVar ShardMap -> Connection -> e -> HashSlot -> IO NodeConnection +nodeConnForHashSlot shardMapVar conn exception hashSlot = do + let (Connection nodeConns _ _ _ _) = conn + (ShardMap shardMap) <- hasLocked $ readMVar shardMapVar + node <- + case IntMap.lookup (fromEnum hashSlot) shardMap of + Nothing -> throwIO exception + Just (Shard master _) -> return master + case HM.lookup (nodeId node) nodeConns of + Nothing -> throwIO exception + Just nodeConn' -> return nodeConn' + +hashSlotForKeys :: Exception e => e -> [B.ByteString] -> IO HashSlot +hashSlotForKeys exception keys = + case nub (keyToSlot <$> keys) of + -- If none of the commands contain a key we can send them to any + -- node. Let's pick the first one. + [] -> return 0 + [hashSlot] -> return hashSlot + _ -> throwIO $ exception + +requestKeys :: CMD.InfoMap -> [B.ByteString] -> IO [B.ByteString] +requestKeys infoMap request = + case CMD.keysForRequest infoMap request of + Nothing -> throwIO $ UnsupportedClusterCommandException request + Just k -> return k askingRedirection :: Reply -> Maybe (Host, Port) askingRedirection (Error errString) = case Char8.words errString of @@ -291,58 +401,45 @@ nodeConnWithHostAndPort shardMap (Connection nodeConns _ _ _ _) host port = do node <- nodeWithHostAndPort shardMap host port HM.lookup (nodeId node) nodeConns -nodeConnectionForCommand :: Connection -> ShardMap -> [B.ByteString] -> IO NodeConnection -nodeConnectionForCommand (Connection nodeConns _ _ infoMap connReadOnly) (ShardMap shardMap) request = do - let mek = case request of - ("MULTI" : key : _) -> Just [key] - ("EXEC" : key : _) -> Just [key] - _ -> Nothing - isCmdReadOnly = isCommandReadonly infoMap request - keys <- case CMD.keysForRequest infoMap request of - Nothing -> throwIO $ UnsupportedClusterCommandException request - Just [] -> throwIO $ UnsupportedClusterCommandException request - Just k -> return k - let shards = nub $ mapMaybe ((flip IntMap.lookup shardMap) . fromEnum . keyToSlot) (fromMaybe keys mek) - node <- case (shards, connReadOnly) of - ([],_) -> throwIO $ MissingNodeException request - ([Shard master _], False) -> - return master - ([Shard master []], True) -> - return master - ([Shard master (slave: _)], True) -> - if isCmdReadOnly - then return slave - else return master - _ -> throwIO $ CrossSlotException request - maybe (throwIO $ MissingNodeException request) return (HM.lookup (nodeId node) nodeConns) +nodeConnectionForCommand :: Connection -> ShardMap -> [B.ByteString] -> IO [NodeConnection] +nodeConnectionForCommand conn@(Connection nodeConns _ _ infoMap _) (ShardMap shardMap) request = + case request of + ("FLUSHALL" : _) -> allNodes + ("FLUSHDB" : _) -> allNodes + ("QUIT" : _) -> allNodes + ("UNWATCH" : _) -> allNodes + _ -> do + keys <- requestKeys infoMap request + hashSlot <- hashSlotForKeys (CrossSlotException [request]) keys + node <- case IntMap.lookup (fromEnum hashSlot) shardMap of + Nothing -> throwIO $ MissingNodeException request + Just (Shard master _) -> return master + maybe (throwIO $ MissingNodeException request) (return . return) (HM.lookup (nodeId node) nodeConns) where - isCommandReadonly :: CMD.InfoMap -> [B.ByteString] -> Bool - isCommandReadonly (CMD.InfoMap iMap) (command: _) = - let - info = HM.lookup (map toLower $ Char8.unpack command) iMap - in maybe False (CMD.ReadOnly `elem`) (CMD.flags <$> info) - isCommandReadonly _ _ = False - -cleanRequest :: [B.ByteString] -> [B.ByteString] -cleanRequest ("MULTI" : _) = ["MULTI"] -cleanRequest ("EXEC" : _) = ["EXEC"] -cleanRequest req = req + allNodes = + case allMasterNodes conn (ShardMap shardMap) of + Nothing -> throwIO $ MissingNodeException request + Just allNodes' -> return allNodes' + +allMasterNodes :: Connection -> ShardMap -> Maybe [NodeConnection] +allMasterNodes (Connection nodeConns _ _ _ _) (ShardMap shardMap) = + mapM (flip HM.lookup nodeConns . nodeId) onlyMasterNodes + where + onlyMasterNodes = (\(Shard master _) -> master) <$> nub (IntMap.elems shardMap) requestNode :: NodeConnection -> [[B.ByteString]] -> IO [Reply] requestNode (NodeConnection ctx lastRecvRef _) requests = do - eresp <- race requestNodeImpl (threadDelay 1000000) -- 100 ms - case eresp of - Left e -> return e - Right _ -> putStrLn "timeout happened" *> throwIO NoNodeException - where + eresp <- race requestNodeImpl (threadDelay 1000000) -- 100 ms + case eresp of + Left e -> return e + Right _ -> putStrLn "timeout happened" *> throwIO NoNodeException + where requestNodeImpl :: IO [Reply] requestNodeImpl = do - let reqs = map cleanRequest requests - _ <- mapM_ (sendNode . renderRequest) reqs + mapM_ (sendNode . renderRequest) requests _ <- CC.flush ctx replicateM (length requests) recvNode - sendNode :: B.ByteString -> IO () sendNode = CC.send ctx recvNode :: IO Reply @@ -372,10 +469,10 @@ nodeWithHostAndPort shardMap host port = find (\(Node _ _ nodeHost nodePort) -> nodeId :: Node -> NodeID nodeId (Node theId _ _ _) = theId -hasLocked :: String -> IO a -> IO a -hasLocked msg action = +hasLocked :: IO a -> IO a +hasLocked action = action `catches` - [ Handler $ \exc@BlockedIndefinitelyOnMVar -> sayString ("[MVar]: " ++ msg) >> throwIO exc + [ Handler $ \exc@BlockedIndefinitelyOnMVar -> throwIO exc ] @@ -390,4 +487,3 @@ masterNodes (Connection nodeConns _ shardMapVar _ _) = do let masters = map ((\(Shard m _) -> m) . snd) $ IntMap.toList shardMap let masterNodeIds = map nodeId masters return $ mapMaybe (`HM.lookup` nodeConns) masterNodeIds - diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs index 72725248..63d174e8 100644 --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -28,7 +28,7 @@ data Flag data AritySpec = Required Integer | MinimumRequired Integer deriving (Show) -data LastKeyPositionSpec = LastKeyPosition Integer | UnlimitedKeys deriving (Show) +data LastKeyPositionSpec = LastKeyPosition Integer | UnlimitedKeys Integer deriving (Show) newtype InfoMap = InfoMap (HM.HashMap String CommandInfo) @@ -84,8 +84,9 @@ instance RedisResult CommandInfo where parseFlag bad = Left bad parseLastKeyPos :: Either Reply LastKeyPositionSpec parseLastKeyPos = return $ case lastKeyPos of - i | i == -1 -> UnlimitedKeys + i | i < 0 -> UnlimitedKeys (-i - 1) i -> LastKeyPosition i + -- since redis 6.0 decode (MultiBulk (Just [ name@(Bulk (Just _)) , arity@(Integer _) @@ -96,6 +97,7 @@ instance RedisResult CommandInfo where , MultiBulk _ -- ACL categories ])) = decode (MultiBulk (Just [name, arity, flags, firstPos, lastPos, step])) + -- since redis 7.0 decode (MultiBulk (Just [ name@(Bulk (Just _)) , arity@(Integer _) @@ -115,15 +117,31 @@ newInfoMap :: [CommandInfo] -> InfoMap newInfoMap = InfoMap . HM.fromList . map (\c -> (Char8.unpack $ name c, c)) keysForRequest :: InfoMap -> [BS.ByteString] -> Maybe [BS.ByteString] +keysForRequest _ ["DEBUG", "OBJECT", key] = + -- `COMMAND` output for `DEBUG` would let us believe it doesn't have any + -- keys, but the `DEBUG OBJECT` subcommand does. + Just [key] +keysForRequest _ ["QUIT"] = + -- The `QUIT` command is not listed in the `COMMAND` output. + Just [] keysForRequest (InfoMap infoMap) request@(command:_) = do info <- HM.lookup (map toLower $ Char8.unpack command) infoMap - if isMovable info then parseMovable request else do + keysForRequest' info request +keysForRequest _ [] = Nothing + +keysForRequest' :: CommandInfo -> [BS.ByteString] -> Maybe [BS.ByteString] +keysForRequest' info request + | isMovable info = + parseMovable request + | stepCount info == 0 = + Just [] + | otherwise = do let possibleKeys = case lastKeyPosition info of - LastKeyPosition 0 -> [] - LastKeyPosition end -> take (fromEnum $ 1 + end - firstKeyPosition info) $ drop (fromEnum $ firstKeyPosition info) request - UnlimitedKeys -> drop (fromEnum $ firstKeyPosition info) request + LastKeyPosition end -> take (fromEnum $ 1 + end - firstKeyPosition info) $ drop (fromEnum $ firstKeyPosition info) request + UnlimitedKeys end -> + drop (fromEnum $ firstKeyPosition info) $ + take (length request - fromEnum end) request return $ takeEvery (fromEnum $ stepCount info) possibleKeys -keysForRequest _ [] = Nothing isMovable :: CommandInfo -> Bool isMovable CommandInfo{..} = MovableKeys `elem` flags @@ -131,7 +149,7 @@ isMovable CommandInfo{..} = MovableKeys `elem` flags parseMovable :: [BS.ByteString] -> Maybe [BS.ByteString] parseMovable ("SORT":key:_) = Just [key] parseMovable ("EVAL":_:rest) = readNumKeys rest -parseMovable ("EVALSH":_:rest) = readNumKeys rest +parseMovable ("EVALSHA":_:rest) = readNumKeys rest parseMovable ("ZUNIONSTORE":_:rest) = readNumKeys rest parseMovable ("ZINTERSTORE":_:rest) = readNumKeys rest parseMovable ("XREAD":rest) = readXreadKeys rest @@ -156,11 +174,12 @@ readNumKeys (rawNumKeys:rest) = do numKeys <- readMaybe (Char8.unpack rawNumKeys) return $ take numKeys rest readNumKeys _ = Nothing - +-- takeEvery 1 [1,2,3,4,5] ->[1,2,3,4,5] +-- takeEvery 2 [1,2,3,4,5] ->[1,3,5] +-- takeEvery 3 [1,2,3,4,5] ->[1,4] takeEvery :: Int -> [a] -> [a] -takeEvery n xs = case drop (n-1) xs of - (y:ys) -> y : takeEvery n ys - [] -> [] +takeEvery _ [] = [] +takeEvery n (x:xs) = x : takeEvery n (drop (n-1) xs) readMaybe :: Read a => String -> Maybe a readMaybe s = case reads s of diff --git a/src/Database/Redis/Commands.hs b/src/Database/Redis/Commands.hs index debd2e32..800acf0a 100644 --- a/src/Database/Redis/Commands.hs +++ b/src/Database/Redis/Commands.hs @@ -844,7 +844,7 @@ hset => ByteString -- ^ key -> ByteString -- ^ field -> ByteString -- ^ value - -> m (f Bool) + -> m (f Integer) hset key field value = sendRequest (["HSET"] ++ [encode key] ++ [encode field] ++ [encode value] ) brpoplpush diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs index 2ff87f09..bce72674 100644 --- a/src/Database/Redis/Connection.hs +++ b/src/Database/Redis/Connection.hs @@ -4,7 +4,8 @@ module Database.Redis.Connection where import Control.Exception -import Control.Monad.IO.Class(liftIO) +import qualified Control.Monad.Catch as Catch +import Control.Monad.IO.Class(liftIO, MonadIO) import Control.Monad(when) import Control.Concurrent.MVar(MVar, newMVar) import qualified Data.ByteString as B @@ -166,8 +167,8 @@ disconnect (NonClusteredConnection pool) = destroyAllResources pool disconnect (ClusteredConnection _ pool) = destroyAllResources pool -- | Memory bracket around 'connect' and 'disconnect'. -withConnect :: ConnectInfo -> (Connection -> IO c) -> IO c -withConnect connInfo = bracket (connect connInfo) disconnect +withConnect :: (Catch.MonadMask m, MonadIO m) => ConnectInfo -> (Connection -> m c) -> m c +withConnect connInfo = Catch.bracket (liftIO $ connect connInfo) (liftIO . disconnect) -- | Memory bracket around 'checkedConnect' and 'disconnect' withCheckedConnect :: ConnectInfo -> (Connection -> IO c) -> IO c @@ -191,6 +192,12 @@ instance Exception ClusterConnectError -- |Constructs a 'ShardMap' of connections to clustered nodes. The argument is -- a 'ConnectInfo' for any node in the cluster +-- +-- Some Redis commands are currently not supported in cluster mode +-- - CONFIG, AUTH +-- - SCAN +-- - MOVE, SELECT +-- - PUBLISH, SUBSCRIBE, PSUBSCRIBE, UNSUBSCRIBE, PUNSUBSCRIBE, RESET connectCluster :: ConnectInfo -> IO Connection connectCluster bootstrapConnInfo = do let timeoutOptUs = diff --git a/src/Database/Redis/ConnectionContext.hs b/src/Database/Redis/ConnectionContext.hs index 91a57f70..1d02fd24 100644 --- a/src/Database/Redis/ConnectionContext.hs +++ b/src/Database/Redis/ConnectionContext.hs @@ -47,7 +47,7 @@ data Connection = Connection , lastRecvRef :: IOR.IORef (Maybe B.ByteString) } instance Show Connection where - show Connection{..} = "Connection{ ctx = " <> show ctx <> ", lastRecvRef = IORef}" + show Connection{..} = "Connection{ ctx = " ++ show ctx ++ ", lastRecvRef = IORef}" data ConnectPhase = PhaseUnknown @@ -65,7 +65,7 @@ instance Exception ConnectionLostException data PortID = PortNumber NS.PortNumber | UnixSocket String - deriving Show + deriving (Eq, Show) connect :: NS.HostName -> PortID -> Maybe Int -> IO ConnectionContext connect hostName portId timeoutOpt = @@ -120,7 +120,7 @@ connectSocket (addr:rest) = tryConnect >>= \case tryConnect = bracketOnError createSock NS.close $ \sock -> try (NS.connect sock $ NS.addrAddress addr) >>= \case Right () -> return (Right sock) - Left err -> return (Left err) + Left err -> NS.close sock >> return (Left err) where createSock = NS.socket (NS.addrFamily addr) (NS.addrSocketType addr) diff --git a/src/Database/Redis/Core.hs b/src/Database/Redis/Core.hs index 4c176ede..c76f88fe 100644 --- a/src/Database/Redis/Core.hs +++ b/src/Database/Redis/Core.hs @@ -15,17 +15,10 @@ import Prelude #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif -#if __GLASGOW_HASKELL__ > 711 -#endif import Control.Monad.Reader -#if MIN_VERSION_base(4,13,0) - -#else -import Control.Monad.Fail(MonadFail) -#endif import qualified Data.ByteString as B import Data.IORef - +import Database.Redis.Core.Internal import Database.Redis.Protocol import qualified Database.Redis.ProtocolPipelining as PP import Database.Redis.Types @@ -36,30 +29,6 @@ import qualified Database.Redis.Cluster as Cluster -- The Redis Monad -- --- |Context for normal command execution, outside of transactions. Use --- 'runRedis' to run actions of this type. --- --- In this context, each result is wrapped in an 'Either' to account for the --- possibility of Redis returning an 'Error' reply. -newtype Redis a = Redis (ReaderT RedisEnv IO a) - deriving (Monad, MonadIO, Functor, Applicative) - -#if __GLASGOW_HASKELL__ > 711 -deriving instance MonadFail Redis -#endif - -data RedisEnv - = NonClusteredEnv { envConn :: PP.Connection, nonClusteredLastReply :: IORef Reply } - | ClusteredEnv - { refreshAction :: IO ShardMap - , connection :: Cluster.Connection - , clusteredLastReply :: IORef Reply - } - -envLastReply :: RedisEnv -> IORef Reply -envLastReply NonClusteredEnv{..} = nonClusteredLastReply -envLastReply ClusteredEnv{..} = clusteredLastReply - -- |This class captures the following behaviour: In a context @m@, a command -- will return its result wrapped in a \"container\" of type @f@. -- diff --git a/src/Database/Redis/Core/Internal.hs b/src/Database/Redis/Core/Internal.hs new file mode 100644 index 00000000..e39a8106 --- /dev/null +++ b/src/Database/Redis/Core/Internal.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} + +module Database.Redis.Core.Internal where +#if __GLASGOW_HASKELL__ > 711 && __GLASGOW_HASKELL__ < 808 +import Control.Monad.Fail (MonadFail) +#endif +import Control.Monad.Reader +import Data.IORef +import Database.Redis.Protocol +import Control.Monad.IO.Unlift (MonadUnliftIO) +import qualified Database.Redis.ProtocolPipelining as PP +import qualified Database.Redis.Cluster as Cluster + +-- |Context for normal command execution, outside of transactions. Use +-- 'runRedis' to run actions of this type. +-- +-- In this context, each result is wrapped in an 'Either' to account for the +-- possibility of Redis returning an 'Error' reply. +newtype Redis a = + Redis (ReaderT RedisEnv IO a) + deriving (Monad, MonadIO, Functor, Applicative, MonadUnliftIO) +#if __GLASGOW_HASKELL__ > 711 +deriving instance MonadFail Redis +#endif +data RedisEnv + = NonClusteredEnv { envConn :: PP.Connection, nonClusteredLastReply :: IORef Reply } + | ClusteredEnv + { refreshAction :: IO Cluster.ShardMap + , connection :: Cluster.Connection + , clusteredLastReply :: IORef Reply + } + +envLastReply :: RedisEnv -> IORef Reply +envLastReply NonClusteredEnv{..} = nonClusteredLastReply +envLastReply ClusteredEnv{..} = clusteredLastReply diff --git a/src/Database/Redis/ManualCommands.hs b/src/Database/Redis/ManualCommands.hs index 549914f3..9c093321 100644 --- a/src/Database/Redis/ManualCommands.hs +++ b/src/Database/Redis/ManualCommands.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleContexts #-} +{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, FlexibleContexts #-} module Database.Redis.ManualCommands where @@ -7,6 +7,9 @@ import Data.ByteString (ByteString, empty, append) import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString as BS import Data.Maybe (maybeToList, catMaybes) +#if __GLASGOW_HASKELL__ < 808 +import Data.Semigroup ((<>)) +#endif import Database.Redis.Core import Database.Redis.Protocol import Database.Redis.Types @@ -357,9 +360,11 @@ eval script keys args = where numkeys = toInteger (length keys) +-- | Works like 'eval', but sends the SHA1 hash of the script instead of the script itself. +-- Fails if the server does not recognise the hash, in which case, 'eval' should be used instead. evalsha :: (RedisCtx m f, RedisResult a) - => ByteString -- ^ script + => ByteString -- ^ base16-encoded sha1 hash of the script -> [ByteString] -- ^ keys -> [ByteString] -- ^ args -> m (f a) @@ -1152,7 +1157,8 @@ xinfoGroups -> m (f [XInfoGroupsResponse]) xinfoGroups stream = sendRequest ["XINFO", "GROUPS", stream] -data XInfoStreamResponse = XInfoStreamResponse +data XInfoStreamResponse + = XInfoStreamResponse { xinfoStreamLength :: Integer , xinfoStreamRadixTreeKeys :: Integer , xinfoStreamRadixTreeNodes :: Integer @@ -1160,21 +1166,62 @@ data XInfoStreamResponse = XInfoStreamResponse , xinfoStreamLastEntryId :: ByteString , xinfoStreamFirstEntry :: StreamsRecord , xinfoStreamLastEntry :: StreamsRecord - } deriving (Show, Eq) + } + | XInfoStreamEmptyResponse + { xinfoStreamLength :: Integer + , xinfoStreamRadixTreeKeys :: Integer + , xinfoStreamRadixTreeNodes :: Integer + , xinfoStreamNumGroups :: Integer + , xinfoStreamLastEntryId :: ByteString + } + deriving (Show, Eq) instance RedisResult XInfoStreamResponse where - decode (MultiBulk (Just [ - Bulk (Just "length"),Integer xinfoStreamLength, - Bulk (Just "radix-tree-keys"),Integer xinfoStreamRadixTreeKeys, - Bulk (Just "radix-tree-nodes"),Integer xinfoStreamRadixTreeNodes, - Bulk (Just "groups"),Integer xinfoStreamNumGroups, - Bulk (Just "last-generated-id"),Bulk (Just xinfoStreamLastEntryId), - Bulk (Just "first-entry"), rawFirstEntry , - Bulk (Just "last-entry"), rawLastEntry ])) = do - xinfoStreamFirstEntry <- decode rawFirstEntry - xinfoStreamLastEntry <- decode rawLastEntry - return XInfoStreamResponse{..} - decode a = Left a + decode = decodeRedis5 <> decodeRedis6 + where + decodeRedis5 (MultiBulk (Just [ + Bulk (Just "length"),Integer xinfoStreamLength, + Bulk (Just "radix-tree-keys"),Integer xinfoStreamRadixTreeKeys, + Bulk (Just "radix-tree-nodes"),Integer xinfoStreamRadixTreeNodes, + Bulk (Just "groups"),Integer xinfoStreamNumGroups, + Bulk (Just "last-generated-id"),Bulk (Just xinfoStreamLastEntryId), + Bulk (Just "first-entry"), Bulk Nothing , + Bulk (Just "last-entry"), Bulk Nothing ])) = do + return XInfoStreamEmptyResponse{..} + decodeRedis5 (MultiBulk (Just [ + Bulk (Just "length"),Integer xinfoStreamLength, + Bulk (Just "radix-tree-keys"),Integer xinfoStreamRadixTreeKeys, + Bulk (Just "radix-tree-nodes"),Integer xinfoStreamRadixTreeNodes, + Bulk (Just "groups"),Integer xinfoStreamNumGroups, + Bulk (Just "last-generated-id"),Bulk (Just xinfoStreamLastEntryId), + Bulk (Just "first-entry"), rawFirstEntry , + Bulk (Just "last-entry"), rawLastEntry ])) = do + xinfoStreamFirstEntry <- decode rawFirstEntry + xinfoStreamLastEntry <- decode rawLastEntry + return XInfoStreamResponse{..} + decodeRedis5 a = Left a + + decodeRedis6 (MultiBulk (Just [ + Bulk (Just "length"),Integer xinfoStreamLength, + Bulk (Just "radix-tree-keys"),Integer xinfoStreamRadixTreeKeys, + Bulk (Just "radix-tree-nodes"),Integer xinfoStreamRadixTreeNodes, + Bulk (Just "last-generated-id"),Bulk (Just xinfoStreamLastEntryId), + Bulk (Just "groups"),Integer xinfoStreamNumGroups, + Bulk (Just "first-entry"), Bulk Nothing , + Bulk (Just "last-entry"), Bulk Nothing ])) = do + return XInfoStreamEmptyResponse{..} + decodeRedis6 (MultiBulk (Just [ + Bulk (Just "length"),Integer xinfoStreamLength, + Bulk (Just "radix-tree-keys"),Integer xinfoStreamRadixTreeKeys, + Bulk (Just "radix-tree-nodes"),Integer xinfoStreamRadixTreeNodes, + Bulk (Just "last-generated-id"),Bulk (Just xinfoStreamLastEntryId), + Bulk (Just "groups"),Integer xinfoStreamNumGroups, + Bulk (Just "first-entry"), rawFirstEntry , + Bulk (Just "last-entry"), rawLastEntry ])) = do + xinfoStreamFirstEntry <- decode rawFirstEntry + xinfoStreamLastEntry <- decode rawLastEntry + return XInfoStreamResponse{..} + decodeRedis6 a = Left a xinfoStream :: (RedisCtx m f) @@ -1311,7 +1358,7 @@ data ClusterSlotsNode = ClusterSlotsNode , clusterSlotsNodeID :: ByteString } deriving (Show) -data ClusterSlotsResponseEntry = ClusterSlotsResponseEntry +data ClusterSlotsResponseEntry = ClusterSlotsResponseEntry { clusterSlotsResponseEntryStartSlot :: Int , clusterSlotsResponseEntryEndSlot :: Int , clusterSlotsResponseEntryMaster :: ClusterSlotsNode @@ -1325,10 +1372,10 @@ instance RedisResult ClusterSlotsResponse where decode a = Left a instance RedisResult ClusterSlotsResponseEntry where - decode (MultiBulk (Just + decode (MultiBulk (Just ((Integer startSlot):(Integer endSlot):masterData:replicas))) = do clusterSlotsResponseEntryMaster <- decode masterData - clusterSlotsResponseEntryReplicas <- mapM decode replicas + clusterSlotsResponseEntryReplicas <- mapM decode replicas let clusterSlotsResponseEntryStartSlot = fromInteger startSlot let clusterSlotsResponseEntryEndSlot = fromInteger endSlot return ClusterSlotsResponseEntry{..} @@ -1338,21 +1385,21 @@ instance RedisResult ClusterSlotsNode where decode (MultiBulk (Just ((Bulk (Just clusterSlotsNodeIP)):(Integer port):(Bulk (Just clusterSlotsNodeID)):_))) = Right ClusterSlotsNode{..} where clusterSlotsNodePort = fromInteger port decode a = Left a - + clusterSlots :: (RedisCtx m f) => m (f ClusterSlotsResponse) clusterSlots = sendRequest $ ["CLUSTER", "SLOTS"] -clusterSetSlotImporting +clusterSetSlotImporting :: (RedisCtx m f) => Integer -> ByteString -> m (f Status) clusterSetSlotImporting slot sourceNodeId = sendRequest $ ["CLUSTER", "SETSLOT", (encode slot), "IMPORTING", sourceNodeId] -clusterSetSlotMigrating +clusterSetSlotMigrating :: (RedisCtx m f) => Integer -> ByteString diff --git a/src/Database/Redis/PubSub.hs b/src/Database/Redis/PubSub.hs index e32a9469..71022b2c 100644 --- a/src/Database/Redis/PubSub.hs +++ b/src/Database/Redis/PubSub.hs @@ -33,8 +33,7 @@ import Data.ByteString.Char8 (ByteString) import Data.List (foldl') import Data.Maybe (isJust) import Data.Pool -#if MIN_VERSION_base(4,13,0) -#else +#if __GLASGOW_HASKELL__ < 808 import Data.Semigroup (Semigroup(..)) #endif import qualified Data.HashMap.Strict as HM @@ -92,7 +91,7 @@ instance Semigroup (Cmd Subscribe a) where instance Monoid (Cmd Subscribe a) where mempty = DoNothing mappend = (<>) - + instance Semigroup (Cmd Unsubscribe a) where (<>) DoNothing x = x (<>) x DoNothing = x @@ -183,7 +182,7 @@ unsubscribe -> PubSub unsubscribe cs = mempty{ unsubs = Cmd cs } --- |Listen for messages published to channels matching the given patterns +-- |Listen for messages published to channels matching the given patterns -- (). psubscribe :: [ByteString] -- ^ pattern @@ -191,7 +190,7 @@ psubscribe psubscribe [] = mempty psubscribe ps = mempty{ psubs = Cmd ps } --- |Stop listening for messages posted to channels matching the given patterns +-- |Stop listening for messages posted to channels matching the given patterns -- (). punsubscribe :: [ByteString] -- ^ pattern @@ -201,11 +200,11 @@ punsubscribe ps = mempty{ punsubs = Cmd ps } -- |Listens to published messages on subscribed channels and channels matching -- the subscribed patterns. For documentation on the semantics of Redis -- Pub\/Sub see . --- --- The given callback function is called for each received message. +-- +-- The given callback function is called for each received message. -- Subscription changes are triggered by the returned 'PubSub'. To keep -- subscriptions unchanged, the callback can return 'mempty'. --- +-- -- Example: Subscribe to the \"news\" channel indefinitely. -- -- @ @@ -546,11 +545,13 @@ sendThread ctrl rawConn = forever $ do -- main = do -- conn <- connect defaultConnectInfo -- pubSubCtrl <- newPubSubController [("mychannel", myhandler)] [] --- forkIO $ forever $ +-- concurrently ( forever $ -- pubSubForever conn pubSubCtrl onInitialComplete -- \`catch\` (\\(e :: SomeException) -> do -- putStrLn $ "Got error: " ++ show e -- threadDelay $ 50*1000) -- TODO: use exponential backoff +-- ) $ restOfYourProgram +-- -- -- {- elsewhere in your program, use pubSubCtrl to change subscriptions -} -- @ diff --git a/src/Database/Redis/Sentinel.hs b/src/Database/Redis/Sentinel.hs new file mode 100644 index 00000000..d3a4f0d8 --- /dev/null +++ b/src/Database/Redis/Sentinel.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE StandaloneDeriving #-} + +-- | "Database.Redis" like interface with connection through Redis Sentinel. +-- +-- More details here: . +-- +-- Example: +-- +-- @ +-- conn <- 'connect' 'SentinelConnectionInfo' (("localhost", PortNumber 26379) :| []) "mymaster" 'defaultConnectInfo' +-- +-- 'runRedis' conn $ do +-- 'set' "hello" "world" +-- @ +-- +-- When connection is opened, the Sentinels will be queried to get current master. Subsequent 'runRedis' +-- calls will talk to that master. +-- +-- If 'runRedis' call fails, the next call will choose a new master to talk to. +-- +-- This implementation is based on Gist by Emanuel Borsboom +-- at +module Database.Redis.Sentinel + ( + -- * Connection + SentinelConnectInfo(..) + , SentinelConnection + , connect + -- * runRedis with Sentinel support + , runRedis + , RedisSentinelException(..) + + -- * Re-export Database.Redis + , 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 + +-- | Interact with a Redis datastore. See 'Database.Redis.runRedis' for details. +runRedis :: SentinelConnection + -> Redis (Either Reply a) + -> IO (Either Reply a) +runRedis (SentinelConnection connMVar) action = do + (baseConn, preToken) <- modifyMVar connMVar $ \oldConnection@SentinelConnection' + { rcCheckFailover + , rcToken = oldToken + , rcSentinelConnectInfo = oldConnectInfo + , rcMasterConnectInfo = oldMasterConnectInfo + , rcBaseConnection = oldBaseConnection } -> + if rcCheckFailover + then do + (newConnectInfo, newMasterConnectInfo) <- updateMaster oldConnectInfo + newToken <- newUnique + (connInfo, conn) <- + if sameHost newMasterConnectInfo oldMasterConnectInfo + then return (oldMasterConnectInfo, oldBaseConnection) + else do + newConn <- Redis.connect newMasterConnectInfo + return (newMasterConnectInfo, newConn) + + return + ( SentinelConnection' + { rcCheckFailover = False + , rcToken = newToken + , rcSentinelConnectInfo = newConnectInfo + , rcMasterConnectInfo = connInfo + , rcBaseConnection = conn + } + , (conn, newToken) + ) + else return (oldConnection, (oldBaseConnection, oldToken)) + + -- Use evaluate to make sure we catch exceptions from 'runRedis'. + reply <- (Redis.runRedis baseConn action >>= evaluate) + `catchRedisRethrow` (\_ -> setCheckSentinel preToken) + case reply of + Left (Error e) | "READONLY " `BS.isPrefixOf` e -> + -- This means our connection has turned into a slave + setCheckSentinel preToken + _ -> return () + return reply + + where + sameHost :: Redis.ConnectInfo -> Redis.ConnectInfo -> Bool + sameHost l r = connectHost l == connectHost r && connectPort l == connectPort r + + setCheckSentinel preToken = modifyMVar_ connMVar $ \conn@SentinelConnection'{rcToken} -> + if preToken == rcToken + then do + newToken <- newUnique + return (conn{rcToken = newToken, rcCheckFailover = True}) + else return conn + + +connect :: SentinelConnectInfo -> IO SentinelConnection +connect origConnectInfo = do + (connectInfo, masterConnectInfo) <- updateMaster origConnectInfo + conn <- Redis.connect masterConnectInfo + token <- newUnique + + SentinelConnection <$> newMVar SentinelConnection' + { rcCheckFailover = False + , rcToken = token + , rcSentinelConnectInfo = connectInfo + , rcMasterConnectInfo = masterConnectInfo + , rcBaseConnection = conn + } + +updateMaster :: SentinelConnectInfo + -> IO (SentinelConnectInfo, Redis.ConnectInfo) +updateMaster sci@SentinelConnectInfo{..} = do + -- This is using the Either monad "backwards" -- Left means stop because we've made a connection, + -- Right means try again. + resultEither <- runExceptT $ forM_ connectSentinels $ \(host, port) -> do + trySentinel host port `catchRedis` (\_ -> return ()) + + + case resultEither of + Left (conn, sentinelPair) -> return + ( sci + { connectSentinels = sentinelPair :| delete sentinelPair (toList connectSentinels) + } + , conn + ) + Right () -> throwIO $ NoSentinels connectSentinels + where + trySentinel :: HostName -> PortID -> ExceptT (Redis.ConnectInfo, (HostName, PortID)) IO () + trySentinel sentinelHost sentinelPort = do + -- bang to ensure exceptions from runRedis get thrown immediately. + !replyE <- liftIO $ do + !sentinelConn <- Redis.connect $ Redis.defaultConnectInfo + { connectHost = sentinelHost + , connectPort = sentinelPort + , connectMaxConnections = 1 + } + Redis.runRedis sentinelConn $ sendRequest + ["SENTINEL", "get-master-addr-by-name", connectMasterName] + + case replyE of + Right [host, port] -> + throwError + ( connectBaseInfo + { connectHost = BS8.unpack host + , connectPort = + maybe + (PortNumber 26379) + (PortNumber . fromIntegral . fst) + $ BS8.readInt port + } + , (sentinelHost, sentinelPort) + ) + _ -> return () + +catchRedisRethrow :: MonadCatch m => m a -> (String -> m ()) -> m a +catchRedisRethrow action handler = + action `catches` + [ Handler $ \ex -> handler (show @IOException ex) >> throwM ex + , Handler $ \ex -> handler (show @ConnectionLostException ex) >> throwM ex + ] + +catchRedis :: MonadCatch m => m a -> (String -> m a) -> m a +catchRedis action handler = + action `catches` + [ Handler $ \ex -> handler (show @IOException ex) + , Handler $ \ex -> handler (show @ConnectionLostException ex) + ] + +newtype SentinelConnection = SentinelConnection (MVar SentinelConnection') + +data SentinelConnection' + = SentinelConnection' + { rcCheckFailover :: Bool + , rcToken :: Unique + , rcSentinelConnectInfo :: SentinelConnectInfo + , rcMasterConnectInfo :: Redis.ConnectInfo + , rcBaseConnection :: Redis.Connection + } + +-- | Configuration of Sentinel hosts. +data SentinelConnectInfo + = SentinelConnectInfo + { connectSentinels :: NonEmpty (HostName, PortID) + -- ^ List of sentinels. + , connectMasterName :: ByteString + -- ^ Name of master to connect to. + , connectBaseInfo :: Redis.ConnectInfo + -- ^ This is used to configure auth and other parameters for Redis connection, + -- but 'Redis.connectHost' and 'Redis.connectPort' are ignored. + } + deriving (Show) + +-- | Exception thrown by "Database.Redis.Sentinel". +data RedisSentinelException + = NoSentinels (NonEmpty (HostName, PortID)) + -- ^ Thrown if no sentinel can be reached. + deriving (Show, Typeable) + +deriving instance Exception RedisSentinelException diff --git a/src/Database/Redis/Transactions.hs b/src/Database/Redis/Transactions.hs index fe2d33d6..86d750f7 100644 --- a/src/Database/Redis/Transactions.hs +++ b/src/Database/Redis/Transactions.hs @@ -3,7 +3,7 @@ GeneralizedNewtypeDeriving #-} module Database.Redis.Transactions ( - watch, unwatch, multiExec, multiExecWithHash, + watch, unwatch, multiExec, Queued(), TxResult(..), RedisTx(), ) where @@ -41,7 +41,7 @@ instance RedisCtx RedisTx Queued where -- future index in EXEC result list i <- get put (i+1) - return $ Queued (decode . (!i)) + return $ Queued (decode . (! i)) -- |A 'Queued' value represents the result of a command inside a transaction. It -- is a proxy object for the /actual/ result, which will only be available @@ -134,27 +134,3 @@ multi = sendRequest ["MULTI"] exec :: Redis Reply exec = either id id <$> sendRequest ["EXEC"] - --------------- - -multiExecWithHash :: ByteString -> RedisTx (Queued a) -> Redis (TxResult a) -multiExecWithHash h rtx = do - -- We don't need to catch exceptions and call DISCARD. The pool will close - -- the connection anyway. - _ <- multiWithHash h - Queued f <- runRedisTx rtx - r <- execWithHash h - case r of - MultiBulk rs -> - - return $ maybe - TxAborted - (either (TxError . show) TxSuccess . f . fromList) - rs - _ -> error $ "hedis: EXEC returned " ++ show r - -multiWithHash :: ByteString -> Redis (Either Reply Status) -multiWithHash h = sendRequest ["MULTI", h] - -execWithHash :: ByteString -> Redis Reply -execWithHash h = either id id <$> sendRequest ["EXEC", h] \ No newline at end of file diff --git a/src/Database/Redis/URL.hs b/src/Database/Redis/URL.hs index 07cc1c7b..ce64654a 100644 --- a/src/Database/Redis/URL.hs +++ b/src/Database/Redis/URL.hs @@ -8,8 +8,7 @@ import Control.Applicative ((<$>)) #endif import Control.Error.Util (note) import Control.Monad (guard) -#if MIN_VERSION_base(4,13,0) -#else +#if __GLASGOW_HASKELL__ < 808 import Data.Monoid ((<>)) #endif import Database.Redis.Connection (ConnectInfo(..), defaultConnectInfo) diff --git a/stack-8.0.yaml b/stack-8.0.yaml deleted file mode 100644 index 3edb1eb8..00000000 --- a/stack-8.0.yaml +++ /dev/null @@ -1,10 +0,0 @@ -resolver: nightly-2016-05-31 -packages: -- '.' -extra-deps: -- slave-thread-1.0.1 -- partial-handler-1.0.1 -flags: - hedis: - dev: true -extra-package-dbs: [] diff --git a/stack-8.4.3.yaml b/stack-8.10.yaml similarity index 80% rename from stack-8.4.3.yaml rename to stack-8.10.yaml index 739c0fcb..169abd72 100644 --- a/stack-8.4.3.yaml +++ b/stack-8.10.yaml @@ -1,4 +1,4 @@ -resolver: lts-12.5 +resolver: lts-18.23 packages: - '.' extra-deps: diff --git a/stack-7.10.yaml b/stack-8.8.yaml similarity index 71% rename from stack-7.10.yaml rename to stack-8.8.yaml index 53b55670..290c8675 100644 --- a/stack-7.10.yaml +++ b/stack-8.8.yaml @@ -1,8 +1,7 @@ -resolver: lts-5.1 +resolver: nightly-2019-11-29 packages: - '.' extra-deps: -- scanner-0.2 flags: hedis: dev: true diff --git a/stack-head.yaml b/stack-head.yaml index 806fa144..a92ee14f 100644 --- a/stack-head.yaml +++ b/stack-head.yaml @@ -1,4 +1,4 @@ -resolver: lts-10.3 +resolver: nightly-2019-11-29 packages: - '.' flags: diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index 545605b7..00000000 --- a/stack.yaml +++ /dev/null @@ -1,7 +0,0 @@ -resolver: lts-15.15 -packages: - - "." -flags: - hedis: - dev: true -extra-package-dbs: [] diff --git a/stack.yaml b/stack.yaml new file mode 120000 index 00000000..1b471944 --- /dev/null +++ b/stack.yaml @@ -0,0 +1 @@ +stack-8.10.yaml \ No newline at end of file diff --git a/stack.yaml~HEAD b/stack.yaml~HEAD new file mode 100644 index 00000000..545605b7 --- /dev/null +++ b/stack.yaml~HEAD @@ -0,0 +1,7 @@ +resolver: lts-15.15 +packages: + - "." +flags: + hedis: + dev: true +extra-package-dbs: [] diff --git a/test/ClusterMain.hs b/test/ClusterMain.hs new file mode 100644 index 00000000..23820651 --- /dev/null +++ b/test/ClusterMain.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import qualified Test.Framework as Test +import Database.Redis +import Tests + +main :: IO () +main = do + -- We're looking for the cluster on a non-default port to support running + -- this test in parallel witht the regular non-cluster tests. To quickly + -- spin up a cluster on this port using docker you can run: + -- + -- docker run -e "IP=0.0.0.0" -p 30001-30005:30001-30005 grokzen/redis-cluster:5.0.6 + conn <- connectCluster defaultConnectInfo { connectPort = PortNumber 30001 } + Test.defaultMain (tests conn) + +tests :: Connection -> [Test.Test] +tests conn = map ($conn) $ concat + [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog] + , testsZSets, [testTransaction], [testScripting] + , testsConnection, testsServer, [testSScan, testHScan, testZScan], [testZrangelex] + , [testXAddRead, testXReadGroup, testXRange, testXpending, testXClaim, testXInfo, testXDel, testXTrim] + -- should always be run last as connection gets closed after it + , [testQuit] + ] + +testsServer :: [Test] +testsServer = + [testBgrewriteaof, testFlushall, testSlowlog, testDebugObject] + +testsConnection :: [Test] +testsConnection = [ testConnectAuthUnexpected, testEcho, testPing + ] + +testsKeys :: [Test] +testsKeys = [ testKeys, testExpireAt, testSortCluster, testGetType, testObject ] + +testSortCluster :: Test +testSortCluster = testCase "sort" $ do + lpush "{same}ids" ["1","2","3"] >>=? 3 + sort "{same}ids" defaultSortOpts >>=? ["1","2","3"] + sortStore "{same}ids" "{same}anotherKey" defaultSortOpts >>=? 3 + let opts = defaultSortOpts { sortOrder = Desc, sortAlpha = True + , sortLimit = (1,2) + , sortBy = Nothing + , sortGet = [] } + sort "{same}ids" opts >>=? ["2", "1"] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 00000000..06151067 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,34 @@ +module Main (main) where + +import qualified Test.Framework as Test +import Database.Redis +import Tests +import PubSubTest + +main :: IO () +main = do + conn <- connect defaultConnectInfo + Test.defaultMain (tests conn) + +tests :: Connection -> [Test.Test] +tests conn = map ($conn) $ concat + [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog] + , testsZSets, [testPubSub], [testTransaction], [testScripting] + , testsConnection, testsServer, [testScans, testSScan, testHScan, testZScan], [testZrangelex] + , [testXAddRead, testXReadGroup, testXRange, testXpending, testXClaim, testXInfo, testXDel, testXTrim] + , testPubSubThreaded + -- should always be run last as connection gets closed after it + , [testQuit] + ] + +testsServer :: [Test] +testsServer = + [testServer, testBgrewriteaof, testFlushall, testInfo, testConfig + ,testSlowlog, testDebugObject] + +testsConnection :: [Test] +testsConnection = [ testConnectAuth, testConnectAuthUnexpected, testConnectDb + , testConnectDbUnexisting, testEcho, testPing, testSelect ] + +testsKeys :: [Test] +testsKeys = [ testKeys, testKeysNoncluster, testExpireAt, testSort, testGetType, testObject ] diff --git a/test/PubSubTest.hs b/test/PubSubTest.hs index eb147044..05596c98 100644 --- a/test/PubSubTest.hs +++ b/test/PubSubTest.hs @@ -70,35 +70,34 @@ removeAllTest conn = Test.testCase "Multithreaded Pub/Sub - basic" $ do ctrl <- newPubSubController [("foo1", handler "InitialFoo1" msgVar), ("foo2", handler "InitialFoo2" msgVar)] [("bar1:*", phandler "InitialBar1" msgVar), ("bar2:*", phandler "InitialBar2" msgVar)] withAsync (pubSubForever conn ctrl (atomically $ writeTVar initialComplete True)) $ \_ -> do + -- wait for initial + atomically $ readTVar initialComplete >>= \b -> if b then return () else retry + expectRedisChannels conn ["foo1", "foo2"] - -- wait for initial - atomically $ readTVar initialComplete >>= \b -> if b then return () else retry - expectRedisChannels conn ["foo1", "foo2"] - - runRedis conn $ publish "foo1" "Hello" - waitForMessage msgVar "InitialFoo1" "Hello" + runRedis conn $ publish "foo1" "Hello" + waitForMessage msgVar "InitialFoo1" "Hello" - runRedis conn $ publish "bar2:zzz" "World" - waitForPMessage msgVar "InitialBar2" "bar2:zzz" "World" + runRedis conn $ publish "bar2:zzz" "World" + waitForPMessage msgVar "InitialBar2" "bar2:zzz" "World" - -- subscribe to foo1 and bar1 again - addChannelsAndWait ctrl [("foo1", handler "NewFoo1" msgVar)] [("bar1:*", phandler "NewBar1" msgVar)] - expectRedisChannels conn ["foo1", "foo2"] + -- subscribe to foo1 and bar1 again + addChannelsAndWait ctrl [("foo1", handler "NewFoo1" msgVar)] [("bar1:*", phandler "NewBar1" msgVar)] + expectRedisChannels conn ["foo1", "foo2"] - runRedis conn $ publish "foo1" "abcdef" - waitForMessage msgVar "InitialFoo1" "abcdef" - waitForMessage msgVar "NewFoo1" "abcdef" + runRedis conn $ publish "foo1" "abcdef" + waitForMessage msgVar "InitialFoo1" "abcdef" + waitForMessage msgVar "NewFoo1" "abcdef" - -- unsubscribe from foo1 and bar1 - removeChannelsAndWait ctrl ["foo1", "unusued"] ["bar1:*", "unused:*"] - expectRedisChannels conn ["foo2"] + -- unsubscribe from foo1 and bar1 + removeChannelsAndWait ctrl ["foo1", "unusued"] ["bar1:*", "unused:*"] + expectRedisChannels conn ["foo2"] - -- foo2 and bar2 are still subscribed - runRedis conn $ publish "foo2" "12345" - waitForMessage msgVar "InitialFoo2" "12345" + -- foo2 and bar2 are still subscribed + runRedis conn $ publish "foo2" "12345" + waitForMessage msgVar "InitialFoo2" "12345" - runRedis conn $ publish "bar2:aaa" "0987" - waitForPMessage msgVar "InitialBar2" "bar2:aaa" "0987" + runRedis conn $ publish "bar2:aaa" "0987" + waitForPMessage msgVar "InitialBar2" "bar2:aaa" "0987" data TestError = TestError ByteString deriving (Eq, Show, Typeable) @@ -127,48 +126,48 @@ removeFromUnregister conn = Test.testCase "Multithreaded Pub/Sub - unregister ha initialComplete <- newTVarIO False ctrl <- newPubSubController [] [] withAsync (pubSubForever conn ctrl (atomically $ writeTVar initialComplete True)) $ \_ -> do - atomically $ readTVar initialComplete >>= \b -> if b then return () else retry + atomically $ readTVar initialComplete >>= \b -> if b then return () else retry - -- register to some channels - void $ addChannelsAndWait ctrl - [("abc", handler "InitialAbc" msgVar), ("xyz", handler "InitialXyz" msgVar)] - [("def:*", phandler "InitialDef" msgVar), ("uvw", phandler "InitialUvw" msgVar)] - expectRedisChannels conn ["abc", "xyz"] + -- register to some channels + void $ addChannelsAndWait ctrl + [("abc", handler "InitialAbc" msgVar), ("xyz", handler "InitialXyz" msgVar)] + [("def:*", phandler "InitialDef" msgVar), ("uvw", phandler "InitialUvw" msgVar)] + expectRedisChannels conn ["abc", "xyz"] - runRedis conn $ publish "abc" "Hello" - waitForMessage msgVar "InitialAbc" "Hello" + runRedis conn $ publish "abc" "Hello" + waitForMessage msgVar "InitialAbc" "Hello" - -- register to some more channels - unreg <- addChannelsAndWait ctrl - [("abc", handler "SecondAbc" msgVar), ("123", handler "Second123" msgVar)] - [("def:*", phandler "SecondDef" msgVar), ("890:*", phandler "Second890" msgVar)] - expectRedisChannels conn ["abc", "xyz", "123"] + -- register to some more channels + unreg <- addChannelsAndWait ctrl + [("abc", handler "SecondAbc" msgVar), ("123", handler "Second123" msgVar)] + [("def:*", phandler "SecondDef" msgVar), ("890:*", phandler "Second890" msgVar)] + expectRedisChannels conn ["abc", "xyz", "123"] - -- check messages on all channels - runRedis conn $ publish "abc" "World" - waitForMessage msgVar "InitialAbc" "World" - waitForMessage msgVar "SecondAbc" "World" + -- check messages on all channels + runRedis conn $ publish "abc" "World" + waitForMessage msgVar "InitialAbc" "World" + waitForMessage msgVar "SecondAbc" "World" - runRedis conn $ publish "123" "World2" - waitForMessage msgVar "Second123" "World2" + runRedis conn $ publish "123" "World2" + waitForMessage msgVar "Second123" "World2" - runRedis conn $ publish "def:bbbb" "World3" - waitForPMessage msgVar "InitialDef" "def:bbbb" "World3" - waitForPMessage msgVar "SecondDef" "def:bbbb" "World3" + runRedis conn $ publish "def:bbbb" "World3" + waitForPMessage msgVar "InitialDef" "def:bbbb" "World3" + waitForPMessage msgVar "SecondDef" "def:bbbb" "World3" - runRedis conn $ publish "890:tttt" "World4" - waitForPMessage msgVar "Second890" "890:tttt" "World4" + runRedis conn $ publish "890:tttt" "World4" + waitForPMessage msgVar "Second890" "890:tttt" "World4" - -- unregister - unreg + -- unregister + unreg - -- we have no way of waiting until unregister actually happened, so just delay and hope - threadDelay $ 1000*1000 -- 1 second - expectRedisChannels conn ["abc", "xyz"] + -- we have no way of waiting until unregister actually happened, so just delay and hope + threadDelay $ 1000*1000 -- 1 second + expectRedisChannels conn ["abc", "xyz"] - -- now only initial should be around. In particular, abc should still be subscribed - runRedis conn $ publish "abc" "World5" - waitForMessage msgVar "InitialAbc" "World5" + -- now only initial should be around. In particular, abc should still be subscribed + runRedis conn $ publish "abc" "World5" + waitForMessage msgVar "InitialAbc" "World5" - runRedis conn $ publish "def:cccc" "World6" - waitForPMessage msgVar "InitialDef" "def:cccc" "World6" + runRedis conn $ publish "def:cccc" "World6" + waitForPMessage msgVar "InitialDef" "def:cccc" "World6" diff --git a/test/Test.hs b/test/Tests.hs similarity index 78% rename from test/Test.hs rename to test/Tests.hs index 8b9275bb..b7223be1 100644 --- a/test/Test.hs +++ b/test/Tests.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, LambdaCase #-} -module Main (main) where +module Tests where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative @@ -13,50 +13,21 @@ import Control.Monad.Trans import qualified Data.List as L import Data.Time import Data.Time.Clock.POSIX -import qualified Test.Framework as Test (Test, defaultMain) +import qualified Test.Framework as Test (Test) import qualified Test.Framework.Providers.HUnit as Test (testCase) import qualified Test.HUnit as HUnit -import qualified Data.ByteString as BS import Database.Redis -import PubSubTest ------------------------------------------------------------------------------ --- Main and helpers +-- helpers -- -main :: IO () -main = do - singleNodeConn <- connect defaultConnectInfo - let singleNodeTests = tests singleNodeConn - clusterConn <- connectCluster $ defaultConnectInfo { connectPort = PortNumber 30001 } - let clusterTestCases = clusterTests clusterConn - Test.defaultMain $ clusterTestCases ++ singleNodeTests - - -data TestType = Cluster | SingleNode - -instance Show TestType where - show Cluster = "Cluster" - show SingleNode = "SingleNode" - -type Test = TestType -> Connection -> Test.Test - - -resetDb :: Connection -> IO () -resetDb conn = do - resps <- runRedis conn $ sendToAllMasterNodes ["FLUSHDB"] - let combined = sequence resps - case combined of - Left reply -> HUnit.assertFailure $ "Redis error when flushing: " ++ show reply - Right replies -> if all (\r -> r == Ok) replies - then return () - else HUnit.assertFailure "Redis error when flushing, non OK reply received" +type Test = Connection -> Test.Test testCase :: String -> Redis () -> Test -testCase name r testType conn = Test.testCase nameWithTestType $ - withTimeLimit 0.5 $ resetDb conn >> runRedis conn r +testCase name r conn = Test.testCase name $ do + withTimeLimit 0.5 $ runRedis conn $ flushdb >>=? Ok >> r where - nameWithTestType = show testType ++ ": " ++ name withTimeLimit limit act = do start <- getCurrentTime _ <- act @@ -74,25 +45,6 @@ redis >>=? expected = do assert :: Bool -> Redis () assert = liftIO . HUnit.assert ------------------------------------------------------------------------------- --- Tests --- -tests :: Connection -> [Test.Test] -tests conn = map (\t -> t SingleNode conn) $ concat - [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog] - , testsZSets, [testPubSub], [testTransaction], [testScripting] - , testsConnection, testsServer, [testScans], [testZrangelex] - , [testXAddRead, testXReadGroup, testXRange, testXpending, testXClaim, testXInfo, testXDel, testXTrim] - , (map (\f -> (\_ c -> f c)) testPubSubThreaded) - -- should always be run last as connection gets closed after it - , [testQuit] - ] - -clusterTests :: Connection -> [Test.Test] -clusterTests conn = map (\t -> t Cluster conn) - [ testPipelining , testConstantSpacePipelining, testForceErrorReply - , testEvalReplies ] - ------------------------------------------------------------------------------ -- Miscellaneous -- @@ -140,56 +92,54 @@ testPipelining = testCase "pipelining" $ do liftIO $ fmap (`diffUTCTime` start) getCurrentTime testEvalReplies :: Test -testEvalReplies testType conn = testCase "eval unused replies" go testType conn +testEvalReplies conn = testCase "eval unused replies" go conn where go = do _ <- liftIO $ runRedis conn $ set "key" "value" result <- liftIO $ do threadDelay $ 10 ^ (5 :: Int) mvar <- newEmptyMVar - _ <- asyncGet mvar >>= Async.wait + _ <- + (Async.wait =<< Async.async (runRedis conn (get "key"))) >>= putMVar mvar takeMVar mvar pure result >>=? Just "value" - asyncGet :: MVar (Either Reply (Maybe BS.ByteString)) -> IO (Async.Async ()) - asyncGet mvar = Async.async $ do - result <- runRedis conn $ get "key" - _ <- putMVar mvar result - return () ------------------------------------------------------------------------------ -- Keys -- -testsKeys :: [Test] -testsKeys = [ testKeys, testExpireAt, testSort, testGetType, testObject ] - testKeys :: Test testKeys = testCase "keys" $ do - set "key" "value" >>=? Ok - get "key" >>=? Just "value" - exists "key" >>=? True - keys "*" >>=? ["key"] - randomkey >>=? Just "key" - move "key" 13 >>=? True - select 13 >>=? Ok - expire "key" 1 >>=? True - pexpire "key" 1000 >>=? True - ttl "key" >>= \case + set "{same}key" "value" >>=? Ok + get "{same}key" >>=? Just "value" + exists "{same}key" >>=? True + expire "{same}key" 1 >>=? True + pexpire "{same}key" 1000 >>=? True + ttl "{same}key" >>= \case Left _ -> error "error" Right t -> do assert $ t `elem` [0..1] - pttl "key" >>= \case + pttl "{same}key" >>= \case Left _ -> error "error" Right pt -> do assert $ pt `elem` [990..1000] - persist "key" >>=? True - dump "key" >>= \case + persist "{same}key" >>=? True + dump "{same}key" >>= \case Left _ -> error "impossible" Right s -> do - restore "key'" 0 s >>=? Ok - rename "key" "key'" >>=? Ok - renamenx "key'" "key" >>=? True - del ["key"] >>=? 1 - select 0 >>=? Ok + restore "{same}key'" 0 s >>=? Ok + rename "{same}key" "{same}key'" >>=? Ok + renamenx "{same}key'" "{same}key" >>=? True + del ["{same}key"] >>=? 1 + +testKeysNoncluster :: Test +testKeysNoncluster = testCase "keysNoncluster" $ do + set "key" "value" >>=? Ok + keys "*" >>=? ["key"] + randomkey >>=? Just "key" + move "key" 13 >>=? True + select 13 >>=? Ok + get "key" >>=? Just "value" + select 0 >>=? Ok testExpireAt :: Test testExpireAt = testCase "expireat" $ do @@ -230,7 +180,7 @@ testGetType = testCase "getType" $ do del ["key"] >>=? 1 where ts = [ (set "key" "value" >>=? Ok, String) - , (hset "key" "field" "value" >>=? True, Hash) + , (hset "key" "field" "value" >>=? 1, Hash) , (lpush "key" ["value"] >>=? 1, List) , (sadd "key" ["member"] >>=? 1, Set) , (zadd "key" [(42,"member"),(12.3,"value")] >>=? 2, ZSet) @@ -253,43 +203,45 @@ testsStrings = [testStrings, testBitops] testStrings :: Test testStrings = testCase "strings" $ do - setnx "key" "value" >>=? True - getset "key" "hello" >>=? Just "value" - append "key" "world" >>=? 10 - strlen "key" >>=? 10 - setrange "key" 0 "hello" >>=? 10 - getrange "key" 0 4 >>=? "hello" - mset [("k1","v1"), ("k2","v2")] >>=? Ok - msetnx [("k1","v1"), ("k2","v2")] >>=? False - mget ["key"] >>=? [Just "helloworld"] - setex "key" 1 "42" >>=? Ok - psetex "key" 1000 "42" >>=? Ok - decr "key" >>=? 41 - decrby "key" 1 >>=? 40 - incr "key" >>=? 41 - incrby "key" 1 >>=? 42 - incrbyfloat "key" 1 >>=? 43 - del ["key"] >>=? 1 - setbit "key" 42 "1" >>=? 0 - getbit "key" 42 >>=? 1 - bitcount "key" >>=? 1 - bitcountRange "key" 0 (-1) >>=? 1 + setnx "key" "value" >>=? True + getset "key" "hello" >>=? Just "value" + append "key" "world" >>=? 10 + strlen "key" >>=? 10 + setrange "key" 0 "hello" >>=? 10 + getrange "key" 0 4 >>=? "hello" + mset [("{same}k1","v1"), ("{same}k2","v2")] >>=? Ok + msetnx [("{same}k1","v1"), ("{same}k2","v2")] >>=? False + mget ["key"] >>=? [Just "helloworld"] + setex "key" 1 "42" >>=? Ok + psetex "key" 1000 "42" >>=? Ok + decr "key" >>=? 41 + decrby "key" 1 >>=? 40 + incr "key" >>=? 41 + incrby "key" 1 >>=? 42 + incrbyfloat "key" 1 >>=? 43 + del ["key"] >>=? 1 + setbit "key" 42 "1" >>=? 0 + getbit "key" 42 >>=? 1 + bitcount "key" >>=? 1 + bitcountRange "key" 0 (-1) >>=? 1 testBitops :: Test testBitops = testCase "bitops" $ do - set "k1" "a" >>=? Ok - set "k2" "b" >>=? Ok - bitopAnd "k3" ["k1", "k2"] >>=? 1 - bitopOr "k3" ["k1", "k2"] >>=? 1 - bitopXor "k3" ["k1", "k2"] >>=? 1 - bitopNot "k3" "k1" >>=? 1 + set "{same}k1" "a" >>=? Ok + set "{same}k2" "b" >>=? Ok + bitopAnd "{same}k3" ["{same}k1", "{same}k2"] >>=? 1 + bitopOr "{same}k3" ["{same}k1", "{same}k2"] >>=? 1 + bitopXor "{same}k3" ["{same}k1", "{same}k2"] >>=? 1 + bitopNot "{same}k3" "{same}k1" >>=? 1 ------------------------------------------------------------------------------ -- Hashes -- testHashes :: Test testHashes = testCase "hashes" $ do - hset "key" "field" "value" >>=? True + hset "key" "field" "another" >>=? 1 + hset "key" "field" "another" >>=? 0 + hset "key" "field" "value" >>=? 0 hsetnx "key" "field" "value" >>=? False hexists "key" "field" >>=? True hlen "key" >>=? 1 @@ -330,12 +282,12 @@ testLists = testCase "lists" $ do testBpop :: Test testBpop = testCase "blocking push/pop" $ do - lpush "key" ["v3","v2","v1"] >>=? 3 - blpop ["key"] 1 >>=? Just ("key","v1") - brpop ["key"] 1 >>=? Just ("key","v3") - rpush "k1" ["v1","v2"] >>=? 2 - brpoplpush "k1" "k2" 1 >>=? Just "v2" - rpoplpush "k1" "k2" >>=? Just "v1" + lpush "{same}key" ["v3","v2","v1"] >>=? 3 + blpop ["{same}key"] 1 >>=? Just ("{same}key","v1") + brpop ["{same}key"] 1 >>=? Just ("{same}key","v3") + rpush "{same}k1" ["v1","v2"] >>=? 2 + brpoplpush "{same}k1" "{same}k2" 1 >>=? Just "v2" + rpoplpush "{same}k1" "{same}k2" >>=? Just "v1" ------------------------------------------------------------------------------ -- Sets @@ -352,7 +304,7 @@ testSets = testCase "sets" $ do srandmember "set" >>=? Just "member" spop "set" >>=? Just "member" srem "set" ["member"] >>=? 0 - smove "set" "set'" "member" >>=? False + smove "{same}set" "{same}set'" "member" >>=? False _ <- sadd "set" ["member1", "member2"] (fmap L.sort <$> spopN "set" 2) >>=? ["member1", "member2"] _ <- sadd "set" ["member1", "member2"] @@ -360,13 +312,13 @@ testSets = testCase "sets" $ do testSetAlgebra :: Test testSetAlgebra = testCase "set algebra" $ do - sadd "s1" ["member"] >>=? 1 - sdiff ["s1", "s2"] >>=? ["member"] - sunion ["s1", "s2"] >>=? ["member"] - sinter ["s1", "s2"] >>=? [] - sdiffstore "s3" ["s1", "s2"] >>=? 1 - sunionstore "s3" ["s1", "s2"] >>=? 1 - sinterstore "s3" ["s1", "s2"] >>=? 0 + sadd "{same}s1" ["member"] >>=? 1 + sdiff ["{same}s1", "{same}s2"] >>=? ["member"] + sunion ["{same}s1", "{same}s2"] >>=? ["member"] + sinter ["{same}s1", "{same}s2"] >>=? [] + sdiffstore "{same}s3" ["{same}s1", "{same}s2"] >>=? 1 + sunionstore "{same}s3" ["{same}s1", "{same}s2"] >>=? 1 + sinterstore "{same}s3" ["{same}s1", "{same}s2"] >>=? 0 ------------------------------------------------------------------------------ -- Sorted Sets @@ -405,16 +357,16 @@ testZSets = testCase "sorted sets" $ do testZStore :: Test testZStore = testCase "zunionstore/zinterstore" $ do - zadd "k1" [(1, "v1"), (2, "v2")] >>= \case + zadd "{same}k1" [(1, "v1"), (2, "v2")] >>= \case Left _ -> error "error" _ -> return () - zadd "k2" [(2, "v2"), (3, "v3")] >>= \case + zadd "{same}k2" [(2, "v2"), (3, "v3")] >>= \case Left _ -> error "error" _ -> return () - zinterstore "newkey" ["k1","k2"] Sum >>=? 1 - zinterstoreWeights "newkey" [("k1",1),("k2",2)] Max >>=? 1 - zunionstore "newkey" ["k1","k2"] Sum >>=? 3 - zunionstoreWeights "newkey" [("k1",1),("k2",2)] Min >>=? 3 + zinterstore "{same}newkey" ["{same}k1","{same}k2"] Sum >>=? 1 + zinterstoreWeights "{same}newkey" [("{same}k1",1),("{same}k2",2)] Max >>=? 1 + zunionstore "{same}newkey" ["{same}k1","{same}k2"] Sum >>=? 3 + zunionstoreWeights "{same}newkey" [("{same}k1",1),("{same}k2",2)] Min >>=? 3 ------------------------------------------------------------------------------ -- HyperLogLog @@ -437,24 +389,24 @@ testHyperLogLog = testCase "hyperloglog" $ do _ -> return () pfcount ["hll1"] >>=? 5 -- test merge - pfadd "hll2" ["1", "2", "3"] >>= \case + pfadd "{same}hll2" ["1", "2", "3"] >>= \case Left _ -> error "error" _ -> return () - pfadd "hll3" ["4", "5", "6"] >>= \case + pfadd "{same}hll3" ["4", "5", "6"] >>= \case Left _ -> error "error" _ -> return () - pfmerge "hll4" ["hll2", "hll3"] >>= \case + pfmerge "{same}hll4" ["{same}hll2", "{same}hll3"] >>= \case Left _ -> error "error" _ -> return () - pfcount ["hll4"] >>=? 6 + pfcount ["{same}hll4"] >>=? 6 -- test union cardinality - pfcount ["hll2", "hll3"] >>=? 6 + pfcount ["{same}hll2", "{same}hll3"] >>=? 6 ------------------------------------------------------------------------------ -- Pub/Sub -- testPubSub :: Test -testPubSub testType conn = testCase "pubSub" go testType conn +testPubSub conn = testCase "pubSub" go conn where go = do -- producer @@ -486,17 +438,17 @@ testPubSub testType conn = testCase "pubSub" go testType conn -- testTransaction :: Test testTransaction = testCase "transaction" $ do - watch ["k1", "k2"] >>=? Ok + watch ["{same}k1", "{same}k2"] >>=? Ok unwatch >>=? Ok - set "foo" "foo" >>= \case + set "{same}foo" "foo" >>= \case Left _ -> error "error" _ -> return () - set "bar" "bar" >>= \case + set "{same}bar" "bar" >>= \case Left _ -> error "error" _ -> return () foobar <- multiExec $ do - foo <- get "foo" - bar <- get "bar" + foo <- get "{same}foo" + bar <- get "{same}bar" return $ (,) <$> foo <*> bar assert $ foobar == TxSuccess (Just "foo", Just "bar") @@ -505,7 +457,7 @@ testTransaction = testCase "transaction" $ do -- Scripting -- testScripting :: Test -testScripting testType conn = testCase "scripting" go testType conn +testScripting conn = testCase "scripting" go conn where go = do let script = "return {false, 42}" @@ -537,10 +489,6 @@ testScripting testType conn = testCase "scripting" go testType conn ------------------------------------------------------------------------------ -- Connection -- -testsConnection :: [Test] -testsConnection = [ testConnectAuth, testConnectAuthUnexpected, testConnectDb - , testConnectDbUnexisting, testEcho, testPing, testSelect ] - testConnectAuth :: Test testConnectAuth = testCase "connect/auth" $ do configSet "requirepass" "pass" >>=? Ok @@ -597,11 +545,6 @@ testSelect = testCase "select" $ do ------------------------------------------------------------------------------ -- Server -- -testsServer :: [Test] -testsServer = - [testServer, testBgrewriteaof, testFlushall, testInfo, testConfig - ,testSlowlog, testDebugObject] - testServer :: Test testServer = testCase "server" $ do time >>= \case @@ -666,14 +609,23 @@ testScans = testCase "scans" $ do scan cursor0 >>=? (cursor0, ["key"]) scanOpts cursor0 sOpts1 >>=? (cursor0, ["key"]) scanOpts cursor0 sOpts2 >>=? (cursor0, []) + where sOpts1 = defaultScanOpts { scanMatch = Just "k*" } + sOpts2 = defaultScanOpts { scanMatch = Just "not*"} + +testSScan :: Test +testSScan = testCase "sscan" $ do sadd "set" ["1"] >>=? 1 sscan "set" cursor0 >>=? (cursor0, ["1"]) - hset "hash" "k" "v" >>=? True + +testHScan :: Test +testHScan = testCase "hscan" $ do + hset "hash" "k" "v" >>=? 1 hscan "hash" cursor0 >>=? (cursor0, [("k", "v")]) + +testZScan :: Test +testZScan = testCase "zscan" $ do zadd "zset" [(42, "2")] >>=? 1 zscan "zset" cursor0 >>=? (cursor0, [("2", 42)]) - where sOpts1 = defaultScanOpts { scanMatch = Just "k*" } - sOpts2 = defaultScanOpts { scanMatch = Just "not*"} testZrangelex ::Test testZrangelex = testCase "zrangebylex" $ do @@ -686,20 +638,20 @@ testZrangelex = testCase "zrangebylex" $ do testXAddRead ::Test testXAddRead = testCase "xadd/xread" $ do - xadd "somestream" "123" [("key", "value"), ("key2", "value2")] - xadd "otherstream" "456" [("key1", "value1")] - xaddOpts "thirdstream" "*" [("k", "v")] (Maxlen 1) - xaddOpts "thirdstream" "*" [("k", "v")] (ApproxMaxlen 1) - xread [("somestream", "0"), ("otherstream", "0")] >>=? Just [ + xadd "{same}somestream" "123" [("key", "value"), ("key2", "value2")] + xadd "{same}otherstream" "456" [("key1", "value1")] + xaddOpts "{same}thirdstream" "*" [("k", "v")] (Maxlen 1) + xaddOpts "{same}thirdstream" "*" [("k", "v")] (ApproxMaxlen 1) + xread [("{same}somestream", "0"), ("{same}otherstream", "0")] >>=? Just [ XReadResponse { - stream = "somestream", + stream = "{same}somestream", records = [StreamsRecord{recordId = "123-0", keyValues = [("key", "value"), ("key2", "value2")]}] }, XReadResponse { - stream = "otherstream", + stream = "{same}otherstream", records = [StreamsRecord{recordId = "456-0", keyValues = [("key1", "value1")]}] }] - xlen "somestream" >>=? 1 + xlen "{same}somestream" >>=? 1 testXReadGroup ::Test testXReadGroup = testCase "XGROUP */xreadgroup/xack" $ do diff --git a/test/run-test.sh b/test/run-test.sh index 16079bba..400c02fe 100755 --- a/test/run-test.sh +++ b/test/run-test.sh @@ -1,7 +1,11 @@ #!/usr/bin/env sh +set -e + +echo "**These tests assume there is a redis server running on port 6379**" # The -M argument limits heap size for 'testConstantSpacePipelining'. -cabal-dev test --test-options="+RTS -M3m" +cabal exec cabal test doctest +cabal test hedis-test --test-options="+RTS -M10m" echo "------------------" echo "hlint suggestions:" From fa35f69ce7b647caf60c000e67ffa624d6be67c2 Mon Sep 17 00:00:00 2001 From: Ag Date: Mon, 16 Jan 2023 16:12:22 +0530 Subject: [PATCH 100/103] Added retry on connection issue while running command in cluster txn. --- src/Database/Redis/Cluster.hs | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index 76636c84..e9f46cce 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -246,18 +246,13 @@ evaluatePipeline shardMapVar refreshShardmapAction conn requests = do -- heavy perf issue. but still should be evaluated and figured out with complete rewrite. resps <- concat <$> mapM (\(resp, (cc, r)) -> case resp of Right v -> return v - Left (_ :: SomeException) -> executeRequests (getRandomConnection cc) r + Left (_ :: SomeException) -> executeRequests (getRandomConnection cc conn) r ) (zip eresps requestsByNode) -- check for any moved in both responses and continue the flow. when (any (moved . rawResponse) resps) refreshShardMapVar retriedResps <- mapM (retry 0) resps return $ map rawResponse $ sortBy (on compare responseIndex) retriedResps where - getRandomConnection :: NodeConnection -> NodeConnection - getRandomConnection nc = - let (Connection hmn _ _ _ _) = conn - conns = HM.elems hmn - in fromMaybe (head conns) $ find (nc /= ) conns getRequestsByNode :: ShardMap -> IO [(NodeConnection, [PendingRequest])] getRequestsByNode shardMap = do commandsWithNodes <- zipWithM (requestWithNodes shardMap) (reverse [0..(length requests - 1)]) requests @@ -320,7 +315,13 @@ evaluateTransactionPipeline shardMapVar refreshShardmapAction conn requests' = d -- fail early. hashSlot <- hashSlotForKeys (CrossSlotException requests) keys nodeConn <- nodeConnForHashSlot shardMapVar conn (MissingNodeException (head requests)) hashSlot - resps <- requestNode nodeConn requests + -- catch the exception thrown, send the command to random node. + -- This change is required to handle the cluster topology change. + eresps <- try $ requestNode nodeConn requests + resps <- + case eresps of + Right v -> return v + Left (_ :: SomeException) -> requestNode (getRandomConnection nodeConn conn) requests -- The Redis documentation has the following to say on the effect of -- resharding on multi-key operations: -- @@ -487,3 +488,9 @@ masterNodes (Connection nodeConns _ shardMapVar _ _) = do let masters = map ((\(Shard m _) -> m) . snd) $ IntMap.toList shardMap let masterNodeIds = map nodeId masters return $ mapMaybe (`HM.lookup` nodeConns) masterNodeIds + +getRandomConnection :: NodeConnection -> Connection -> NodeConnection +getRandomConnection nc conn = + let (Connection hmn _ _ _ _) = conn + conns = HM.elems hmn + in fromMaybe (head conns) $ find (nc /= ) conns From 20a6f34f4b64b1a1bbdd9d5ef7fd0f15655f3cc6 Mon Sep 17 00:00:00 2001 From: Ag Date: Mon, 23 Jan 2023 19:39:14 +0530 Subject: [PATCH 101/103] Added the ENV for timeout. --- src/Database/Redis/Cluster.hs | 6 +++++- src/Database/Redis/ConnectionContext.hs | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index e9f46cce..acefbebb 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -35,9 +35,12 @@ import Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot) import qualified Database.Redis.ConnectionContext as CC import qualified Data.HashMap.Strict as HM import qualified Data.IntMap.Strict as IntMap +import qualified Data.Time as Time import Data.Typeable import qualified Scanner +import System.Environment (lookupEnv) import System.IO.Unsafe(unsafeInterleaveIO) +import Text.Read (readMaybe) import Database.Redis.Protocol(Reply(Error), renderRequest, reply) import qualified Database.Redis.Cluster.Command as CMD @@ -430,7 +433,8 @@ allMasterNodes (Connection nodeConns _ _ _ _) (ShardMap shardMap) = requestNode :: NodeConnection -> [[B.ByteString]] -> IO [Reply] requestNode (NodeConnection ctx lastRecvRef _) requests = do - eresp <- race requestNodeImpl (threadDelay 1000000) -- 100 ms + envTimeout <- round . (\x -> (x :: Time.NominalDiffTime) * 100000) . realToFrac . fromMaybe (0.5 :: Double) . (>>= readMaybe) <$> lookupEnv "REDIS_REQUEST_NODE_TIMEOUT" + eresp <- race requestNodeImpl (threadDelay envTimeout) case eresp of Left e -> return e Right _ -> putStrLn "timeout happened" *> throwIO NoNodeException diff --git a/src/Database/Redis/ConnectionContext.hs b/src/Database/Redis/ConnectionContext.hs index 1d02fd24..db43891d 100644 --- a/src/Database/Redis/ConnectionContext.hs +++ b/src/Database/Redis/ConnectionContext.hs @@ -76,7 +76,7 @@ connect hostName portId timeoutOpt = hConnect = do phaseMVar <- newMVar PhaseUnknown let doConnect = hConnect' phaseMVar - envTimeout <- round . (\x -> (x :: Time.NominalDiffTime) * 1000000) . realToFrac . fromMaybe (0.5 :: Double) . (>>= readMaybe) <$> lookupEnv "REDIS_DEFAULT_TIMEOUT" + envTimeout <- round . (\x -> (x :: Time.NominalDiffTime) * 1000000) . realToFrac . fromMaybe (0.5 :: Double) . (>>= readMaybe) <$> lookupEnv "REDIS_CONNECT_TIMEOUT" result <- race doConnect (threadDelay $ fromMaybe envTimeout timeoutOpt) case result of Left h -> return h From 3ad69581821f1b87f262ee834e1bb9dab5c3db11 Mon Sep 17 00:00:00 2001 From: Ag Date: Wed, 25 Jan 2023 17:04:52 +0530 Subject: [PATCH 102/103] Fixed missing zero in timeout --- src/Database/Redis/Cluster.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Database/Redis/Cluster.hs b/src/Database/Redis/Cluster.hs index acefbebb..e22bec04 100644 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -433,7 +433,7 @@ allMasterNodes (Connection nodeConns _ _ _ _) (ShardMap shardMap) = requestNode :: NodeConnection -> [[B.ByteString]] -> IO [Reply] requestNode (NodeConnection ctx lastRecvRef _) requests = do - envTimeout <- round . (\x -> (x :: Time.NominalDiffTime) * 100000) . realToFrac . fromMaybe (0.5 :: Double) . (>>= readMaybe) <$> lookupEnv "REDIS_REQUEST_NODE_TIMEOUT" + envTimeout <- round . (\x -> (x :: Time.NominalDiffTime) * 1000000) . realToFrac . fromMaybe (0.5 :: Double) . (>>= readMaybe) <$> lookupEnv "REDIS_REQUEST_NODE_TIMEOUT" eresp <- race requestNodeImpl (threadDelay envTimeout) case eresp of Left e -> return e From 582e021197059cc2007a7cd012c19ac8dc54f12c Mon Sep 17 00:00:00 2001 From: Ag Date: Tue, 7 Feb 2023 12:36:09 +0530 Subject: [PATCH 103/103] Created 0.15.2 --- CHANGELOG | 5 +++++ hedis.cabal | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index d0be90fc..228b0fe8 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,10 @@ # Changelog for Hedis +## 0.15.2 +* PR #14. Updated with hedis upstream +* PR #13. Added timeout for commands +* PR #11. Send the command to another node while exception occurred on running the query. + ## 0.15.1 * PR #181. Add MonadUnliftIO instance diff --git a/hedis.cabal b/hedis.cabal index abc43538..2fb965dd 100644 --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,5 @@ name: hedis -version: 0.15.1 +version: 0.15.2 synopsis: Client library for the Redis datastore: supports full command set, pipelining.