diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,68 @@ # Changelog for Hedis +## 0.16 + +- PR #176. Exposed RedisArg type class so it's possible to (de)serialize application data structures. +- PR #182. Add MonadTrans instance for MonadRedis. +- PR #198. Extended Redis 6 and 7 support. + - add `xgroupCreate`, `xgroupCreateConsumer`, `xgroupSetId`; + - added support of the message trimming by message; + - add support for count parameter for approximate trimming. +- New internal functions `unsubscribe1`, `punsubscribe1` functions that do not remove all subscriptions when empty lst is passed +- Fixes in cluster support: + - connect authorizes with all nodes + - TLS connection is instantiated with all nodes + - Fixed resource leakage +- Added new methods for the cluster mode: + - requestMasterNodes, masterNodes, getRandomConnection + + +Breaking changes: + +- **Connection** Fix connection API. + + ```haskell + data PortID = PortNumber NS.PortNumber + | UnixSocket String + deriving (Eq, Show) + ``` + + And introduce instead `ConnectAddr`: + + ```haskell + data ConnectAddr + = ConnectAddrHostPort NS.HostName NS.PortNumber + | ConnectAddrUnixSocket String + deriving (Eq, Show) + ``` + + It allow to remove a hack with ignored path. + +- **URI parsing** follows the redis client spec. Main changes: + + 1. In `redis://password@host`, `password` is parsed as a password instead of a username. + 2. `redis-socket://[[username:]password@]path` is supported. + +- **xpendingDetail** instead of 'Maybe ByteString' for a consumer name the method +receives XPendingOpts structure that can take number of milliseconds and consumer name. +In order to preserve an old behavior code should be rewritten as: + +``` haskell +xpendingDetails s g f l t Nothing -> xpendingSummary s g f l t defaultXPendingDetailOpts +xpendingDetails s g f l t (Just c) -> xpendingSummary s g f l t defaultXPendingDetailOpts{xPeedingDetailConsumer=Just c) +``` + +- **xpendingSummary** no longer accepts consumer arguments as it was done in violation to spec and methodd never worked this way +- **XTrimOpts** type changed, because previous type didn't hold library invariants now instead of a simple ADT XTrimOpts is data that defines strategy of trimming and type, exact or approximate. Here is a conversion table: + NoArg -> is not representable, + In xaddOpts options use Nothing instead; + In xtrim using NoArgs as a bug. + Maxlen n -> TrimOpts{trimOptsStrategy=TrimMaxlen n, trimOptsType=TrimExact}; + MaxlenApprox n -> TrimOpts{trumOptsStrategy=TrimMaxlen n, trimOptsType=TrimApprox Nothing}; +- 'addChannelsAndWait', 'removeChannelsAndWait' now wait only the channels that we run + operations on, instead of waiting changes from all threads. +- `xreadGroupOpts` now accepts new `XReadGroupOpts` instead of `XReadOpts` type. + ## 0.15.2 * PR #189. Document that UnixSocket ignores connectHost @@ -169,7 +232,7 @@ ## 0.9.9 -* PR #90. set SO_KEEPALIVE option on underlying connection socket +* PR #90. set SO_KEEPALIVE option on underlying connection socket ## 0.9.8 @@ -224,7 +287,7 @@ ## 0.7.0 -* Enforce all replies being recieved in runRedis. Pipelining between runRedis +* Enforce all replies being recieved in runRedis. Pipelining between runRedis calls doesn't work now. ## 0.6.10 diff --git a/DocTest.hs b/DocTest.hs deleted file mode 100644 --- a/DocTest.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main (main) where - -import Test.DocTest - -main :: IO () -main = doctest ["-isrc", "src"] diff --git a/benchmark/Benchmark.hs b/benchmark/Benchmark.hs --- a/benchmark/Benchmark.hs +++ b/benchmark/Benchmark.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, LambdaCase #-} +{-# LANGUAGE OverloadedStrings, LambdaCase, OverloadedLists #-} module Main where @@ -40,7 +40,8 @@ action liftIO $ putMVar done () - let timeAction name nActions action = do + let + timeAction name nActions action = do startT <- getCurrentTime -- each clients runs ACTION nRepetitions times let nRepetitions = nRequests `div` nClients `div` nActions diff --git a/hedis.cabal b/hedis.cabal --- a/hedis.cabal +++ b/hedis.cabal @@ -1,5 +1,7 @@ +cabal-version: 3.0 +build-type: Simple name: hedis -version: 0.15.2 +version: 0.16.0 synopsis: Client library for the Redis datastore: supports full command set, pipelining. @@ -36,18 +38,18 @@ . For detailed documentation, see the "Database.Redis" module. . -license: BSD3 +license: BSD-3-Clause license-file: LICENSE author: Falko Peters -maintainer: Kostiantyn Rybnikov +maintainer: Kostiantyn Rybnikov , Alexander Vershilov copyright: Copyright (c) 2011 Falko Peters category: Database -build-type: Simple -cabal-version: >=1.10 homepage: https://github.com/informatikr/hedis bug-reports: https://github.com/informatikr/hedis/issues extra-source-files: CHANGELOG +tested-with: GHC == { 9.6.7, 9.8.4, 9.10.3, 9.12.4, 9.14.1 } + source-repository head type: git location: https://github.com/informatikr/hedis @@ -57,58 +59,66 @@ default: False manual: True +flag cluster + description: enable it to run cluster tests if you have required setup + default: False + manual: True + library default-language: Haskell2010 hs-source-dirs: src - ghc-options: -Wall -fwarn-tabs - if impl(ghc >= 8.6.0) - ghc-options: -Wno-warnings-deprecations + ghc-options: -Wall -Wcompat + if impl(ghc >= 9.8) + ghc-options: -Wno-x-partial if flag(dev) ghc-options: -Werror if flag(dev) ghc-prof-options: -auto-all exposed-modules: Database.Redis - , Database.Redis.Sentinel + , Database.Redis.Cluster + , Database.Redis.Cluster.Command + , Database.Redis.Cluster.HashSlot + , Database.Redis.Commands + , Database.Redis.Connection + , Database.Redis.ConnectionContext + , Database.Redis.Core , Database.Redis.Core.Internal - build-depends: scanner >= 0.2, - async >= 2.1, - base >= 4.8 && < 5, - bytestring >= 0.9, - bytestring-lexing >= 0.5, - exceptions, - unordered-containers, - containers, - text, - deepseq, - mtl >= 2, - network >= 2 && < 3.2, - resource-pool >= 0.2, - stm, - time, - tls >= 1.3, - vector >= 0.9, - HTTP, - errors, - network-uri, - unliftio-core + , Database.Redis.Hooks + , Database.Redis.ManualCommands + , Database.Redis.Protocol + , Database.Redis.ProtocolPipelining + , Database.Redis.PubSub + , Database.Redis.Sentinel + , Database.Redis.Transactions + , Database.Redis.Types + , Database.Redis.URL + build-depends: scanner >= 0.2 && <0.4, + async >= 2.1 && <2.3, + base >= 4.18 && < 5, + bytestring >= 0.9 && <0.13, + bytestring-lexing >= 0.5 && <0.6, + exceptions >= 0.10 && <0.11, + unordered-containers >= 0.2 && <0.3, + containers >= 0.6 && <0.9, + http-types >= 0.12 && <0.13, + text >= 2.0 && <2.2, + deepseq <1.6, + mtl >= 2 && <3, + network >= 2 && < 3.3, + resource-pool >= 0.5 && <0.6, + stm < 2.6, + time < 1.17, + tls >= 1.3 && <2.5, + vector >= 0.9 && <0.14, + HTTP < 4001, + errors < 2.4, + network-uri < 2.7, + unliftio-core < 0.2.2, + hashable <1.6 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.Cluster.Command, - Database.Redis.ProtocolPipelining, - Database.Redis.Protocol, - Database.Redis.PubSub, - Database.Redis.Transactions, - Database.Redis.Types - Database.Redis.Commands, - Database.Redis.ManualCommands, - Database.Redis.URL, - Database.Redis.ConnectionContext other-extensions: StrictData benchmark hedis-benchmark @@ -142,8 +152,10 @@ stm, text, mtl == 2.*, + network, test-framework, test-framework-hunit, + transformers, 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 @@ -152,11 +164,11 @@ if flag(dev) ghc-prof-options: -auto-all -test-suite hedis-test-cluster +test-suite redis7 default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: ClusterMain.hs + main-is: MainRedis7.hs other-modules: PubSubTest Tests build-depends: @@ -168,8 +180,10 @@ stm, text, mtl == 2.*, + network, test-framework, test-framework-hunit, + transformers, 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 @@ -178,11 +192,49 @@ if flag(dev) ghc-prof-options: -auto-all -test-suite doctest +test-suite hedis-test-cluster default-language: Haskell2010 type: exitcode-stdio-1.0 - main-is: DocTest.hs - ghc-options: -O0 -rtsopts + hs-source-dirs: test + main-is: ClusterMain.hs + other-modules: PubSubTest + Tests build-depends: base == 4.*, - doctest + bytestring >= 0.10, + hedis, + HUnit, + async, + stm, + text, + mtl == 2.*, + network, + test-framework, + test-framework-hunit, + time, + transformers + -- 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 + ghc-prof-options: -auto-all + if !flag(cluster) + buildable: False + +test-suite hedis-test-hooks + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: MainHooks.hs + build-depends: + base == 4.*, + hedis, + HUnit, + test-framework, + test-framework-hunit + -- We use -O0 here, since GHC takes *very* long to compile so many constants + ghc-options: -O0 -Wall -rtsopts -fno-warn-unused-do-bind -Wunused-packages + if flag(dev) + ghc-options: -Werror + if flag(dev) + ghc-prof-options: -auto-all diff --git a/src/Database/Redis.hs b/src/Database/Redis.hs --- a/src/Database/Redis.hs +++ b/src/Database/Redis.hs @@ -18,7 +18,7 @@ -- import Data.Default.Class (def) -- (Just certStore) <- readCertificateStore "azure-redis.crt" -- let tlsParams = (defaultParamsClient "foobar.redis.cache.windows.net" "") { clientSupported = def { supportedCiphers = ciphersuite_strong }, clientShared = def { sharedCAStore = certStore } } - -- let redisConnInfo = defaultConnectInfo { connectHost = "foobar.redis.cache.windows.net", connectPort = PortNumber 6380, connectTLSParams = Just tlsParams, connectAuth = Just "Foobar!" } + -- let redisConnInfo = defaultConnectInfo { connectAddr = ConnectAddrHostPort "foobar.redis.cache.windows.net" 6380, connectTLSParams = Just tlsParams, connectAuth = Just "Foobar!" } -- conn <- checkedConnect redisConnInfo -- @ -- @@ -162,10 +162,10 @@ RedisCtx(..), MonadRedis(..), -- * Connection - Connection, ConnectError(..), connect, checkedConnect, disconnect, - withConnect, withCheckedConnect, - ConnectInfo(..), defaultConnectInfo, parseConnectInfo, connectCluster, - PortID(..), + Connection, ConnectError(..), connect, checkedConnect, + ClusterConnectError (..), connectCluster, checkedConnectCluster, + disconnect, withConnect, withCheckedConnect, + ConnectInfo(..), defaultConnectInfo, parseConnectInfo, ConnectAddr(..), -- * Commands module Database.Redis.Commands, @@ -176,9 +176,12 @@ -- * Pub\/Sub module Database.Redis.PubSub, + -- * Hooks + Hooks(..), SendRequestHook, SendPubSubHook, CallbackHook, SendHook, ReceiveHook, defaultHooks, + -- * Low-Level Command API sendRequest, - Reply(..), Status(..), RedisResult(..), ConnectionLostException(..), + Reply(..), Status(..), RedisArg(..), RedisResult(..), ConnectionLostException(..), ConnectTimeout(..), -- |[Solution to Exercise] @@ -197,17 +200,19 @@ import Database.Redis.Core import Database.Redis.Connection ( runRedis - , connectCluster , defaultConnectInfo , ConnectInfo(..) , disconnect , checkedConnect , connect + , checkedConnectCluster + , connectCluster , ConnectError(..) + , ClusterConnectError(..) , Connection(..) , withConnect , withCheckedConnect) -import Database.Redis.ConnectionContext(PortID(..), ConnectionLostException(..), ConnectTimeout(..)) +import Database.Redis.ConnectionContext(ConnectAddr(..), 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 --- a/src/Database/Redis/Cluster.hs +++ b/src/Database/Redis/Cluster.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module Database.Redis.Cluster @@ -12,30 +13,37 @@ , HashSlot , Shard(..) , connect + , connectWith , disconnect , requestPipelined , nodes + , hooks + , requestMasterNodes + , masterNodes + , getRandomConnection ) where import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as Char8 import qualified Data.IORef as IOR import Data.List(nub, sortBy, find) +import Data.Maybe(mapMaybe, fromMaybe) import Data.Map(fromListWith, assocs) import Data.Function(on) -import Control.Exception(Exception, throwIO, BlockedIndefinitelyOnMVar(..), catches, Handler(..)) +import Control.Exception(Exception, throwIO, BlockedIndefinitelyOnMVar(..), catches, Handler(..), bracketOnError) import Control.Concurrent.MVar(MVar, newMVar, readMVar, modifyMVar, modifyMVar_) -import Control.Monad(zipWithM, when, replicateM) +import Control.Monad(zipWithM, when, replicateM, forM_) 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 Scanner import System.IO.Unsafe(unsafeInterleaveIO) -import Database.Redis.Protocol(Reply(Error), renderRequest, reply) +import Database.Redis.Protocol(Reply(..), renderRequest, reply) import qualified Database.Redis.Cluster.Command as CMD +import Database.Redis.Hooks (Hooks) +import Network.TLS (ClientParams (..)) -- This module implements a clustered connection whilst maintaining -- compatibility with the original Hedis codebase. In particular it still @@ -46,18 +54,28 @@ -- 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 +data Connection = Connection + { connectionNodes :: HM.HashMap NodeID NodeConnection + , connectionPipeline :: MVar Pipeline + , connectionShardMap :: MVar ShardMap + , connectionInfoMap :: CMD.InfoMap + , connectionHooks :: Hooks + } -- | A connection to a single node in the cluster, similar to 'ProtocolPipelining.Connection' -data NodeConnection = NodeConnection CC.ConnectionContext (IOR.IORef (Maybe B.ByteString)) NodeID +data NodeConnection = NodeConnection + { nodeConnectionContext :: CC.ConnectionContext + , nodeConnectionLastRecvRef :: IOR.IORef (Maybe B.ByteString) + , nodeConnectionNodeId :: NodeID + } instance Eq NodeConnection where - (NodeConnection _ _ id1) == (NodeConnection _ _ id2) = id1 == id2 + NodeConnection{nodeConnectionNodeId=id1} == NodeConnection{nodeConnectionNodeId=id2} = id1 == id2 instance Ord NodeConnection where - compare (NodeConnection _ _ id1) (NodeConnection _ _ id2) = compare id1 id2 + compare NodeConnection{nodeConnectionNodeId=id1} NodeConnection{nodeConnectionNodeId=id2} = compare id1 id2 data PipelineState = -- Nothing in the pipeline has been evaluated yet so nothing has been @@ -83,47 +101,88 @@ type Host = String type Port = Int type NodeID = B.ByteString -data Node = Node NodeID NodeRole Host Port deriving (Show, Eq, Ord) +-- | 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 :: NodeID + , nodeRole :: NodeRole + , nodeHost :: Host + , nodePort :: Port + } deriving (Show, Eq, Ord) + type MasterNode = Node type SlaveNode = Node -data Shard = Shard MasterNode [SlaveNode] deriving (Show, Eq, Ord) +-- | 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 + { shardMaster :: MasterNode + , shardSlaves :: [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) +newtype MissingNodeException = MissingNodeException [B.ByteString] deriving (Show) instance Exception MissingNodeException -newtype UnsupportedClusterCommandException = UnsupportedClusterCommandException [B.ByteString] deriving (Show, Typeable) +newtype UnsupportedClusterCommandException = UnsupportedClusterCommandException [B.ByteString] deriving (Show) instance Exception UnsupportedClusterCommandException -newtype CrossSlotException = CrossSlotException [[B.ByteString]] deriving (Show, Typeable) +newtype CrossSlotException = CrossSlotException [[B.ByteString]] deriving (Show) instance Exception CrossSlotException -connect :: [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> IO Connection -connect commandInfos shardMapVar timeoutOpt = do +data ClusterAuthError = ClusterAuthError Host Port Reply deriving (Show) +instance Exception ClusterAuthError + +-- | Backwards compatible version of connect that can't provide authentication or TLS parameters. +{-# DEPRECATED connect "Use connectWith instead, passing Nothing for the parameters you don't need." #-} +connect :: [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> Hooks -> IO Connection +connect = connectWith Nothing Nothing Nothing + +-- | Connects to cluster. +connectWith :: Maybe B.ByteString -> Maybe B.ByteString -> Maybe ClientParams -> [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> Hooks -> IO Connection +connectWith mUsername mPassword mTlsParams commandInfos shardMapVar timeoutOpt hooks' = 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) hooks' 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 + nodeConnections shardMap = HM.fromList <$> connectNodes (nub $ nodes shardMap) + connectNodes :: [Node] -> IO [(NodeID, NodeConnection)] + connectNodes [] = return [] + connectNodes (z@Node{nodeHost = host, nodePort = port}:ns) = do + bracketOnError + (CC.connect (CC.ConnectAddrHostPort host $ toEnum port) timeoutOpt mTlsParams) + (CC.disconnect) $ \ctx0 -> do + nodeConn <- connectNode z ctx0 + rest <- connectNodes ns + return $ nodeConn : rest + connectNode :: Node -> CC.ConnectionContext -> IO (NodeID, NodeConnection) + connectNode Node{nodeId = n, nodeHost = host, nodePort = port} ctx0 = do ref <- IOR.newIORef Nothing - return (n, NodeConnection ctx ref n) + let nodeConn = NodeConnection ctx0 ref n + forM_ mPassword $ \password -> do + let reqOpts = maybe [password] (:[password]) mUsername + authReply <- requestNode1 nodeConn ( ["AUTH"] <> reqOpts ) + case authReply of + SingleLine "OK" -> pure () + _ -> throwIO $ ClusterAuthError host port authReply + return (n, nodeConn) disconnect :: Connection -> IO () -disconnect (Connection nodeConnMap _ _ _) = mapM_ disconnectNode (HM.elems nodeConnMap) where +disconnect Connection{connectionNodes=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{connectionPipeline=pipelineVar, connectionShardMap=shardMapVar} nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do (newStateVar, repliesIndex) <- hasLocked $ modifyMVar stateVar $ \case Pending requests | isMulti nextRequest -> do replies <- evaluatePipeline shardMapVar refreshAction conn requests @@ -228,7 +287,7 @@ -- there is one. case last replies of (Error errString) | B.isPrefixOf "MOVED" errString -> do - let (Connection _ _ _ infoMap) = conn + let Connection{connectionInfoMap=infoMap} = conn keys <- mconcat <$> mapM (requestKeys infoMap) requests hashSlot <- hashSlotForKeys (CrossSlotException requests) keys nodeConn <- nodeConnForHashSlot shardMapVar conn (MissingNodeException (head requests)) hashSlot @@ -250,7 +309,7 @@ evaluateTransactionPipeline :: MVar ShardMap -> IO ShardMap -> Connection -> [[B.ByteString]] -> IO [Reply] evaluateTransactionPipeline shardMapVar refreshShardmapAction conn requests' = do let requests = reverse requests' - let (Connection _ _ _ infoMap) = conn + let Connection{connectionInfoMap=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. @@ -296,12 +355,12 @@ nodeConnForHashSlot :: Exception e => MVar ShardMap -> Connection -> e -> HashSlot -> IO NodeConnection nodeConnForHashSlot shardMapVar conn exception hashSlot = do - let (Connection nodeConns _ _ _) = conn + let Connection{connectionNodes=nodeConns} = conn (ShardMap shardMap) <- hasLocked $ readMVar shardMapVar node <- case IntMap.lookup (fromEnum hashSlot) shardMap of Nothing -> throwIO exception - Just (Shard master _) -> return master + Just Shard{shardMaster = master} -> return master case HM.lookup (nodeId node) nodeConns of Nothing -> throwIO exception Just nodeConn' -> return nodeConn' @@ -339,12 +398,12 @@ nodeConnWithHostAndPort :: ShardMap -> Connection -> Host -> Port -> Maybe NodeConnection -nodeConnWithHostAndPort shardMap (Connection nodeConns _ _ _) host port = do +nodeConnWithHostAndPort shardMap Connection{connectionNodes=nodeConns} host port = do node <- nodeWithHostAndPort shardMap host port HM.lookup (nodeId node) nodeConns nodeConnectionForCommand :: Connection -> ShardMap -> [B.ByteString] -> IO [NodeConnection] -nodeConnectionForCommand conn@(Connection nodeConns _ _ infoMap) (ShardMap shardMap) request = +nodeConnectionForCommand conn@Connection{connectionNodes=nodeConns, connectionInfoMap=infoMap} (ShardMap shardMap) request = case request of ("FLUSHALL" : _) -> allNodes ("FLUSHDB" : _) -> allNodes @@ -355,7 +414,7 @@ hashSlot <- hashSlotForKeys (CrossSlotException [request]) keys node <- case IntMap.lookup (fromEnum hashSlot) shardMap of Nothing -> throwIO $ MissingNodeException request - Just (Shard master _) -> return master + Just Shard{shardMaster = master} -> return master maybe (throwIO $ MissingNodeException request) (return . return) (HM.lookup (nodeId node) nodeConns) where allNodes = @@ -364,49 +423,77 @@ Just allNodes' -> return allNodes' allMasterNodes :: Connection -> ShardMap -> Maybe [NodeConnection] -allMasterNodes (Connection nodeConns _ _ _) (ShardMap shardMap) = - mapM (flip HM.lookup nodeConns . nodeId) masterNodes +allMasterNodes Connection{connectionNodes=nodeConns} (ShardMap shardMap) = + mapM (flip HM.lookup nodeConns . nodeId) masters where - masterNodes = (\(Shard master _) -> master) <$> nub (IntMap.elems shardMap) + masters = shardMaster <$> nub (IntMap.elems shardMap) requestNode :: NodeConnection -> [[B.ByteString]] -> IO [Reply] -requestNode (NodeConnection ctx lastRecvRef _) requests = do +requestNode nodeConn@(NodeConnection ctx _ _) requests = do mapM_ (sendNode . renderRequest) requests _ <- CC.flush ctx - replicateM (length requests) recvNode + replicateM (length requests) $ recvNode nodeConn 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 +requestNode1 :: NodeConnection -> [B.ByteString] -> IO Reply +requestNode1 nodeConn@NodeConnection{nodeConnectionContext=ctx} request = do + CC.send ctx $ renderRequest request + _ <- CC.flush ctx + recvNode nodeConn +recvNode :: NodeConnection -> IO Reply +recvNode NodeConnection{nodeConnectionContext = ctx, nodeConnectionLastRecvRef = lastRecvRef} = 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 + nodes :: ShardMap -> [Node] nodes (ShardMap shardMap) = concatMap snd $ IntMap.toList $ fmap shardNodes shardMap where shardNodes :: Shard -> [Node] - shardNodes (Shard master slaves) = master:slaves + shardNodes Shard{..} = shardMaster:shardSlaves nodeWithHostAndPort :: ShardMap -> Host -> Port -> Maybe Node -nodeWithHostAndPort shardMap host port = find (\(Node _ _ nodeHost nodePort) -> port == nodePort && host == nodeHost) (nodes shardMap) - -nodeId :: Node -> NodeID -nodeId (Node theId _ _ _) = theId +nodeWithHostAndPort shardMap host port = find (\Node{nodeHost = h, nodePort = p} -> port == p && host == h) (nodes shardMap) hasLocked :: IO a -> IO a hasLocked action = action `catches` [ Handler $ \exc@BlockedIndefinitelyOnMVar -> throwIO exc ] + +hooks :: Connection -> Hooks +hooks = connectionHooks + +-- | Send a request to all master nodes in the cluster. This is useful for commands that need to be sent to all master nodes, such as `FLUSHALL` or `CONFIG SET`. +requestMasterNodes :: Connection -> [B.ByteString] -> IO [Reply] +requestMasterNodes conn req = do + masterNodeConns <- masterNodes conn + concat <$> mapM (`requestNode` [req]) masterNodeConns + +-- | Get connection to a master nodes in the cluster. +-- This is useful for commands that need to be sent to all master nodes, such as `FLUSHALL` or `CONFIG SET`. +masterNodes :: Connection -> IO [NodeConnection] +masterNodes (Connection nodeConns _ shardMapVar _ _) = do + (ShardMap shardMap) <- readMVar shardMapVar + let masters = map shardMaster $ nub $ IntMap.elems shardMap + let masterNodeIds = map nodeId masters + return $ mapMaybe (`HM.lookup` nodeConns) masterNodeIds + +-- | Get connection to a random node in the cluster that is not the same as the provided connection. +getRandomConnection :: NodeConnection -> Connection -> NodeConnection +getRandomConnection nc Connection{connectionNodes = hmn} = + let conns = HM.elems hmn + in fromMaybe (head conns) $ find (nc /= ) conns diff --git a/src/Database/Redis/Cluster/Command.hs b/src/Database/Redis/Cluster/Command.hs --- a/src/Database/Redis/Cluster/Command.hs +++ b/src/Database/Redis/Cluster/Command.hs @@ -97,6 +97,20 @@ , MultiBulk _ -- ACL categories ])) = decode (MultiBulk (Just [name, arity, flags, firstPos, lastPos, step])) + -- since redis 7.0 + 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 _ -- Subcommands + ])) = + decode (MultiBulk (Just [name, arity, flags, firstPos, lastPos, step])) decode e = Left e @@ -111,6 +125,14 @@ keysForRequest _ ["QUIT"] = -- The `QUIT` command is not listed in the `COMMAND` output. Just [] +keysForRequest _ ["OBJECT", "refcount", key] = + Just [key] +keysForRequest _ ["OBJECT", "encoding", key] = + Just [key] +keysForRequest _ ["OBJECT", "idletime", key] = + Just [key] +keysForRequest _ ("XINFO":_:key:_) = + Just [key] keysForRequest (InfoMap infoMap) request@(command:_) = do info <- HM.lookup (map toLower $ Char8.unpack command) infoMap keysForRequest' info request @@ -150,9 +172,9 @@ readXreadKeys _ = Nothing readXreadgroupKeys :: [BS.ByteString] -> Maybe [BS.ByteString] -readXreadgroupKeys ("COUNT":_:rest) = readXreadKeys rest -readXreadgroupKeys ("BLOCK":_:rest) = readXreadKeys rest -readXreadgroupKeys ("NOACK":rest) = readXreadKeys rest +readXreadgroupKeys ("COUNT":_:rest) = readXreadgroupKeys rest +readXreadgroupKeys ("BLOCK":_:rest) = readXreadgroupKeys rest +readXreadgroupKeys ("NOACK":rest) = readXreadgroupKeys rest readXreadgroupKeys ("STREAMS":rest) = Just $ take (length rest `div` 2) rest readXreadgroupKeys _ = Nothing diff --git a/src/Database/Redis/Cluster/HashSlot.hs b/src/Database/Redis/Cluster/HashSlot.hs --- a/src/Database/Redis/Cluster/HashSlot.hs +++ b/src/Database/Redis/Cluster/HashSlot.hs @@ -5,24 +5,43 @@ import Data.Bits((.&.), xor, shiftL) import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString as BS +import Data.Maybe (fromMaybe) import Data.Word(Word8, Word16) +-- $setup +-- >>> :set -XOverloadedStrings + newtype HashSlot = HashSlot Word16 deriving (Num, Eq, Ord, Real, Enum, Integral, Show) numHashSlots :: Word16 numHashSlots = 16384 -- | Compute the hashslot associated with a key +-- +-- >>> keyToSlot "123" +-- HashSlot 5970 +-- >>> keyToSlot "{123" +-- HashSlot 2872 +-- >>> keyToSlot "{123}" +-- HashSlot 5970 +-- >>> keyToSlot "{}123" +-- HashSlot 7640 +-- >>> keyToSlot "{123}1{abc}" +-- HashSlot 5970 +-- >>> keyToSlot "\00\01" +-- HashSlot 4129 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 +findSubKey key = fromMaybe key (go key) where + go bs = case Char8.break (=='{') bs of + (_, "") -> Nothing + (_, xs) -> case Char8.break (=='}') (Char8.tail xs) of + ("", _) -> go (Char8.tail xs) + (_, "") -> Nothing + (subKey, _) -> Just subKey crc16 :: BS.ByteString -> Word16 crc16 = BS.foldl (crc16Update 0x1021) 0 diff --git a/src/Database/Redis/Commands.hs b/src/Database/Redis/Commands.hs --- a/src/Database/Redis/Commands.hs +++ b/src/Database/Redis/Commands.hs @@ -1,1095 +1,1556 @@ --- Generated by GenCmds.hs. DO NOT EDIT. - -{-# LANGUAGE OverloadedStrings, FlexibleContexts #-} - -module Database.Redis.Commands ( - --- ** Connection -auth, -- |Authenticate to the server (). Since Redis 1.0.0 -echo, -- |Echo the given string (). Since Redis 1.0.0 -ping, -- |Ping the server (). Since Redis 1.0.0 -quit, -- |Close the connection (). Since Redis 1.0.0 -select, -- |Change the selected database for the current connection (). Since Redis 1.0.0 - --- ** Keys -del, -- |Delete a key (). Since Redis 1.0.0 -dump, -- |Return a serialized version of the value stored at the specified key (). Since Redis 2.6.0 -exists, -- |Determine if a key exists (). Since Redis 1.0.0 -expire, -- |Set a key's time to live in seconds (). Since Redis 1.0.0 -expireat, -- |Set the expiration for a key as a UNIX timestamp (). Since Redis 1.2.0 -keys, -- |Find all keys matching the given pattern (). Since Redis 1.0.0 -MigrateOpts(..), -defaultMigrateOpts, -migrate, -- |Atomically transfer a key from a Redis instance to another one (). The Redis command @MIGRATE@ is split up into 'migrate', 'migrateMultiple'. Since Redis 2.6.0 -migrateMultiple, -- |Atomically transfer a key from a Redis instance to another one (). The Redis command @MIGRATE@ is split up into 'migrate', 'migrateMultiple'. Since Redis 2.6.0 -move, -- |Move a key to another database (). Since Redis 1.0.0 -objectRefcount, -- |Inspect the internals of Redis objects (). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3 -objectEncoding, -- |Inspect the internals of Redis objects (). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3 -objectIdletime, -- |Inspect the internals of Redis objects (). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3 -persist, -- |Remove the expiration from a key (). Since Redis 2.2.0 -pexpire, -- |Set a key's time to live in milliseconds (). Since Redis 2.6.0 -pexpireat, -- |Set the expiration for a key as a UNIX timestamp specified in milliseconds (). Since Redis 2.6.0 -pttl, -- |Get the time to live for a key in milliseconds (). Since Redis 2.6.0 -randomkey, -- |Return a random key from the keyspace (). Since Redis 1.0.0 -rename, -- |Rename a key (). Since Redis 1.0.0 -renamenx, -- |Rename a key, only if the new key does not exist (). Since Redis 1.0.0 -restore, -- |Create a key using the provided serialized value, previously obtained using DUMP (). The Redis command @RESTORE@ is split up into 'restore', 'restoreReplace'. Since Redis 2.6.0 -restoreReplace, -- |Create a key using the provided serialized value, previously obtained using DUMP (). The Redis command @RESTORE@ is split up into 'restore', 'restoreReplace'. Since Redis 2.6.0 -Cursor, -cursor0, -ScanOpts(..), -defaultScanOpts, -scan, -- |Incrementally iterate the keys space (). The Redis command @SCAN@ is split up into 'scan', 'scanOpts'. Since Redis 2.8.0 -scanOpts, -- |Incrementally iterate the keys space (). The Redis command @SCAN@ is split up into 'scan', 'scanOpts'. Since Redis 2.8.0 -SortOpts(..), -defaultSortOpts, -SortOrder(..), -sort, -- |Sort the elements in a list, set or sorted set (). The Redis command @SORT@ is split up into 'sort', 'sortStore'. Since Redis 1.0.0 -sortStore, -- |Sort the elements in a list, set or sorted set (). The Redis command @SORT@ is split up into 'sort', 'sortStore'. Since Redis 1.0.0 -ttl, -- |Get the time to live for a key (). Since Redis 1.0.0 -RedisType(..), -getType, -- |Determine the type stored at key (). Since Redis 1.0.0 -wait, -- |Wait for the synchronous replication of all the write commands sent in the context of the current connection (). Since Redis 3.0.0 - --- ** Hashes -hdel, -- |Delete one or more hash fields (). Since Redis 2.0.0 -hexists, -- |Determine if a hash field exists (). Since Redis 2.0.0 -hget, -- |Get the value of a hash field (). Since Redis 2.0.0 -hgetall, -- |Get all the fields and values in a hash (). Since Redis 2.0.0 -hincrby, -- |Increment the integer value of a hash field by the given number (). Since Redis 2.0.0 -hincrbyfloat, -- |Increment the float value of a hash field by the given amount (). Since Redis 2.6.0 -hkeys, -- |Get all the fields in a hash (). Since Redis 2.0.0 -hlen, -- |Get the number of fields in a hash (). Since Redis 2.0.0 -hmget, -- |Get the values of all the given hash fields (). Since Redis 2.0.0 -hmset, -- |Set multiple hash fields to multiple values (). Since Redis 2.0.0 -hscan, -- |Incrementally iterate hash fields and associated values (). The Redis command @HSCAN@ is split up into 'hscan', 'hscanOpts'. Since Redis 2.8.0 -hscanOpts, -- |Incrementally iterate hash fields and associated values (). The Redis command @HSCAN@ is split up into 'hscan', 'hscanOpts'. Since Redis 2.8.0 -hset, -- |Set the string value of a hash field (). Since Redis 2.0.0 -hsetnx, -- |Set the value of a hash field, only if the field does not exist (). Since Redis 2.0.0 -hstrlen, -- |Get the length of the value of a hash field (). Since Redis 3.2.0 -hvals, -- |Get all the values in a hash (). Since Redis 2.0.0 - --- ** HyperLogLogs -pfadd, -- |Adds all the elements arguments to the HyperLogLog data structure stored at the variable name specified as first argument (). Since Redis 2.8.9 -pfcount, -- |Return the approximated cardinality of the set(s) observed by the HyperLogLog at key(s) (). Since Redis 2.8.9 -pfmerge, -- |Merge N different HyperLogLogs into a single one (). Since Redis 2.8.9 - --- ** Lists -blpop, -- |Remove and get the first element in a list, or block until one is available (). Since Redis 2.0.0 -brpop, -- |Remove and get the last element in a list, or block until one is available (). Since Redis 2.0.0 -brpoplpush, -- |Pop a value from a list, push it to another list and return it; or block until one is available (). Since Redis 2.2.0 -lindex, -- |Get an element from a list by its index (). Since Redis 1.0.0 -linsertBefore, -- |Insert an element before or after another element in a list (). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'. Since Redis 2.2.0 -linsertAfter, -- |Insert an element before or after another element in a list (). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'. Since Redis 2.2.0 -llen, -- |Get the length of a list (). Since Redis 1.0.0 -lpop, -- |Remove and get the first element in a list (). Since Redis 1.0.0 -lpush, -- |Prepend one or multiple values to a list (). Since Redis 1.0.0 -lpushx, -- |Prepend a value to a list, only if the list exists (). Since Redis 2.2.0 -lrange, -- |Get a range of elements from a list (). Since Redis 1.0.0 -lrem, -- |Remove elements from a list (). Since Redis 1.0.0 -lset, -- |Set the value of an element in a list by its index (). Since Redis 1.0.0 -ltrim, -- |Trim a list to the specified range (). Since Redis 1.0.0 -rpop, -- |Remove and get the last element in a list (). Since Redis 1.0.0 -rpoplpush, -- |Remove the last element in a list, prepend it to another list and return it (). Since Redis 1.2.0 -rpush, -- |Append one or multiple values to a list (). Since Redis 1.0.0 -rpushx, -- |Append a value to a list, only if the list exists (). Since Redis 2.2.0 - --- ** Scripting -eval, -- |Execute a Lua script server side (). Since Redis 2.6.0 -evalsha, -- |Execute a Lua script server side (). Since Redis 2.6.0 -DebugMode, -scriptDebug, -- |Set the debug mode for executed scripts (). Since Redis 3.2.0 -scriptExists, -- |Check existence of scripts in the script cache (). Since Redis 2.6.0 -scriptFlush, -- |Remove all the scripts from the script cache (). Since Redis 2.6.0 -scriptKill, -- |Kill the script currently in execution (). Since Redis 2.6.0 -scriptLoad, -- |Load the specified Lua script into the script cache (). Since Redis 2.6.0 - --- ** Server -bgrewriteaof, -- |Asynchronously rewrite the append-only file (). Since Redis 1.0.0 -bgsave, -- |Asynchronously save the dataset to disk (). Since Redis 1.0.0 -clientGetname, -- |Get the current connection name (). Since Redis 2.6.9 -clientList, -- |Get the list of client connections (). Since Redis 2.4.0 -clientPause, -- |Stop processing commands from clients for some time (). Since Redis 2.9.50 -ReplyMode, -clientReply, -- |Instruct the server whether to reply to commands (). Since Redis 3.2 -clientSetname, -- |Set the current connection name (). Since Redis 2.6.9 -commandCount, -- |Get total number of Redis commands (). Since Redis 2.8.13 -commandInfo, -- |Get array of specific Redis command details (). Since Redis 2.8.13 -configGet, -- |Get the value of a configuration parameter (). Since Redis 2.0.0 -configResetstat, -- |Reset the stats returned by INFO (). Since Redis 2.0.0 -configRewrite, -- |Rewrite the configuration file with the in memory configuration (). Since Redis 2.8.0 -configSet, -- |Set a configuration parameter to the given value (). Since Redis 2.0.0 -dbsize, -- |Return the number of keys in the selected database (). Since Redis 1.0.0 -debugObject, -- |Get debugging information about a key (). Since Redis 1.0.0 -flushall, -- |Remove all keys from all databases (). Since Redis 1.0.0 -flushdb, -- |Remove all keys from the current database (). Since Redis 1.0.0 -info, -- |Get information and statistics about the server (). The Redis command @INFO@ is split up into 'info', 'infoSection'. Since Redis 1.0.0 -infoSection, -- |Get information and statistics about the server (). The Redis command @INFO@ is split up into 'info', 'infoSection'. Since Redis 1.0.0 -lastsave, -- |Get the UNIX time stamp of the last successful save to disk (). Since Redis 1.0.0 -save, -- |Synchronously save the dataset to disk (). Since Redis 1.0.0 -slaveof, -- |Make the server a slave of another instance, or promote it as master (). Since Redis 1.0.0 -Slowlog(..), -slowlogGet, -- |Manages the Redis slow queries log (). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12 -slowlogLen, -- |Manages the Redis slow queries log (). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12 -slowlogReset, -- |Manages the Redis slow queries log (). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12 -time, -- |Return the current server time (). Since Redis 2.6.0 - --- ** Sets -sadd, -- |Add one or more members to a set (). Since Redis 1.0.0 -scard, -- |Get the number of members in a set (). Since Redis 1.0.0 -sdiff, -- |Subtract multiple sets (). Since Redis 1.0.0 -sdiffstore, -- |Subtract multiple sets and store the resulting set in a key (). Since Redis 1.0.0 -sinter, -- |Intersect multiple sets (). Since Redis 1.0.0 -sinterstore, -- |Intersect multiple sets and store the resulting set in a key (). Since Redis 1.0.0 -sismember, -- |Determine if a given value is a member of a set (). Since Redis 1.0.0 -smembers, -- |Get all the members in a set (). Since Redis 1.0.0 -smove, -- |Move a member from one set to another (). Since Redis 1.0.0 -spop, -- |Remove and return one or multiple random members from a set (). The Redis command @SPOP@ is split up into 'spop', 'spopN'. Since Redis 1.0.0 -spopN, -- |Remove and return one or multiple random members from a set (). The Redis command @SPOP@ is split up into 'spop', 'spopN'. Since Redis 1.0.0 -srandmember, -- |Get one or multiple random members from a set (). The Redis command @SRANDMEMBER@ is split up into 'srandmember', 'srandmemberN'. Since Redis 1.0.0 -srandmemberN, -- |Get one or multiple random members from a set (). The Redis command @SRANDMEMBER@ is split up into 'srandmember', 'srandmemberN'. Since Redis 1.0.0 -srem, -- |Remove one or more members from a set (). Since Redis 1.0.0 -sscan, -- |Incrementally iterate Set elements (). The Redis command @SSCAN@ is split up into 'sscan', 'sscanOpts'. Since Redis 2.8.0 -sscanOpts, -- |Incrementally iterate Set elements (). The Redis command @SSCAN@ is split up into 'sscan', 'sscanOpts'. Since Redis 2.8.0 -sunion, -- |Add multiple sets (). Since Redis 1.0.0 -sunionstore, -- |Add multiple sets and store the resulting set in a key (). Since Redis 1.0.0 - --- ** Sorted Sets -ZaddOpts(..), -defaultZaddOpts, -zadd, -- |Add one or more members to a sorted set, or update its score if it already exists (). The Redis command @ZADD@ is split up into 'zadd', 'zaddOpts'. Since Redis 1.2.0 -zaddOpts, -- |Add one or more members to a sorted set, or update its score if it already exists (). The Redis command @ZADD@ is split up into 'zadd', 'zaddOpts'. Since Redis 1.2.0 -zcard, -- |Get the number of members in a sorted set (). Since Redis 1.2.0 -zcount, -- |Count the members in a sorted set with scores within the given values (). Since Redis 2.0.0 -zincrby, -- |Increment the score of a member in a sorted set (). Since Redis 1.2.0 -Aggregate(..), -zinterstore, -- |Intersect multiple sorted sets and store the resulting sorted set in a new key (). The Redis command @ZINTERSTORE@ is split up into 'zinterstore', 'zinterstoreWeights'. Since Redis 2.0.0 -zinterstoreWeights, -- |Intersect multiple sorted sets and store the resulting sorted set in a new key (). The Redis command @ZINTERSTORE@ is split up into 'zinterstore', 'zinterstoreWeights'. Since Redis 2.0.0 -zlexcount, -- |Count the number of members in a sorted set between a given lexicographical range (). Since Redis 2.8.9 -zrange, -- |Return a range of members in a sorted set, by index (). The Redis command @ZRANGE@ is split up into 'zrange', 'zrangeWithscores'. Since Redis 1.2.0 -zrangeWithscores, -- |Return a range of members in a sorted set, by index (). The Redis command @ZRANGE@ is split up into 'zrange', 'zrangeWithscores'. Since Redis 1.2.0 -RangeLex(..), -zrangebylex, zrangebylexLimit, -- |Return a range of members in a sorted set, by lexicographical range (). Since Redis 2.8.9 -zrangebyscore, -- |Return a range of members in a sorted set, by score (). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5 -zrangebyscoreWithscores, -- |Return a range of members in a sorted set, by score (). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5 -zrangebyscoreLimit, -- |Return a range of members in a sorted set, by score (). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5 -zrangebyscoreWithscoresLimit, -- |Return a range of members in a sorted set, by score (). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5 -zrank, -- |Determine the index of a member in a sorted set (). Since Redis 2.0.0 -zrem, -- |Remove one or more members from a sorted set (). Since Redis 1.2.0 -zremrangebylex, -- |Remove all members in a sorted set between the given lexicographical range (). Since Redis 2.8.9 -zremrangebyrank, -- |Remove all members in a sorted set within the given indexes (). Since Redis 2.0.0 -zremrangebyscore, -- |Remove all members in a sorted set within the given scores (). Since Redis 1.2.0 -zrevrange, -- |Return a range of members in a sorted set, by index, with scores ordered from high to low (). The Redis command @ZREVRANGE@ is split up into 'zrevrange', 'zrevrangeWithscores'. Since Redis 1.2.0 -zrevrangeWithscores, -- |Return a range of members in a sorted set, by index, with scores ordered from high to low (). The Redis command @ZREVRANGE@ is split up into 'zrevrange', 'zrevrangeWithscores'. Since Redis 1.2.0 -zrevrangebyscore, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0 -zrevrangebyscoreWithscores, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0 -zrevrangebyscoreLimit, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0 -zrevrangebyscoreWithscoresLimit, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0 -zrevrank, -- |Determine the index of a member in a sorted set, with scores ordered from high to low (). Since Redis 2.0.0 -zscan, -- |Incrementally iterate sorted sets elements and associated scores (). The Redis command @ZSCAN@ is split up into 'zscan', 'zscanOpts'. Since Redis 2.8.0 -zscanOpts, -- |Incrementally iterate sorted sets elements and associated scores (). The Redis command @ZSCAN@ is split up into 'zscan', 'zscanOpts'. Since Redis 2.8.0 -zscore, -- |Get the score associated with the given member in a sorted set (). Since Redis 1.2.0 -zunionstore, -- |Add multiple sorted sets and store the resulting sorted set in a new key (). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'. Since Redis 2.0.0 -zunionstoreWeights, -- |Add multiple sorted sets and store the resulting sorted set in a new key (). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'. Since Redis 2.0.0 - --- ** Strings -append, -- |Append a value to a key (). Since Redis 2.0.0 -bitcount, -- |Count set bits in a string (). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'. Since Redis 2.6.0 -bitcountRange, -- |Count set bits in a string (). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'. Since Redis 2.6.0 -bitopAnd, -- |Perform bitwise operations between strings (). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0 -bitopOr, -- |Perform bitwise operations between strings (). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0 -bitopXor, -- |Perform bitwise operations between strings (). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0 -bitopNot, -- |Perform bitwise operations between strings (). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0 -bitpos, -- |Find first bit set or clear in a string (). Since Redis 2.8.7 -decr, -- |Decrement the integer value of a key by one (). Since Redis 1.0.0 -decrby, -- |Decrement the integer value of a key by the given number (). Since Redis 1.0.0 -get, -- |Get the value of a key (). Since Redis 1.0.0 -getbit, -- |Returns the bit value at offset in the string value stored at key (). Since Redis 2.2.0 -getrange, -- |Get a substring of the string stored at a key (). Since Redis 2.4.0 -getset, -- |Set the string value of a key and return its old value (). Since Redis 1.0.0 -incr, -- |Increment the integer value of a key by one (). Since Redis 1.0.0 -incrby, -- |Increment the integer value of a key by the given amount (). Since Redis 1.0.0 -incrbyfloat, -- |Increment the float value of a key by the given amount (). Since Redis 2.6.0 -mget, -- |Get the values of all the given keys (). Since Redis 1.0.0 -mset, -- |Set multiple keys to multiple values (). Since Redis 1.0.1 -msetnx, -- |Set multiple keys to multiple values, only if none of the keys exist (). Since Redis 1.0.1 -psetex, -- |Set the value and expiration in milliseconds of a key (). Since Redis 2.6.0 -Condition(..), -SetOpts(..), -set, -- |Set the string value of a key (). The Redis command @SET@ is split up into 'set', 'setOpts'. Since Redis 1.0.0 -setOpts, -- |Set the string value of a key (). The Redis command @SET@ is split up into 'set', 'setOpts'. Since Redis 1.0.0 -setbit, -- |Sets or clears the bit at offset in the string value stored at key (). Since Redis 2.2.0 -setex, -- |Set the value and expiration of a key (). Since Redis 2.0.0 -setnx, -- |Set the value of a key, only if the key does not exist (). Since Redis 1.0.0 -setrange, -- |Overwrite part of a string at key starting at the specified offset (). Since Redis 2.2.0 -strlen, -- |Get the length of the value stored in a key (). Since Redis 2.2.0 - --- ** Streams -XReadOpts(..), -defaultXreadOpts, -XReadResponse(..), -StreamsRecord(..), -TrimOpts(..), -xadd, -- |Add a value to a stream (). Since Redis 5.0.0 -xaddOpts, -- |Add a value to a stream (). The Redis command @XADD@ is split up into 'xadd', 'xaddOpts'. Since Redis 5.0.0 -xread, -- |Read values from a stream (). The Redis command @XREAD@ is split up into 'xread', 'xreadOpts'. Since Redis 5.0.0 -xreadOpts, -- |Read values from a stream (). The Redis command @XREAD@ is split up into 'xread', 'xreadOpts'. Since Redis 5.0.0 -xreadGroup, -- |Read values from a stream as part of a consumer group (https://redis.io/commands/xreadgroup). The redis command @XREADGROUP@ is split up into 'xreadGroup' and 'xreadGroupOpts'. Since Redis 5.0.0 -xreadGroupOpts, -- |Read values from a stream as part of a consumer group (https://redis.io/commands/xreadgroup). The redis command @XREADGROUP@ is split up into 'xreadGroup' and 'xreadGroupOpts'. Since Redis 5.0.0 -xack, -- |Acknowledge receipt of a message as part of a consumer group. Since Redis 5.0.0 -xgroupCreate, -- |Create a consumer group. The redis command @XGROUP@ is split up into 'xgroupCreate', 'xgroupSetId', 'xgroupDestroy', and 'xgroupDelConsumer'. Since Redis 5.0.0 -xgroupSetId, -- |Set the id for a consumer group. The redis command @XGROUP@ is split up into 'xgroupCreate', 'xgroupSetId', 'xgroupDestroy', and 'xgroupDelConsumer'. Since Redis 5.0.0 -xgroupDestroy, -- |Destroy a consumer group. The redis command @XGROUP@ is split up into 'xgroupCreate', 'xgroupSetId', 'xgroupDestroy', and 'xgroupDelConsumer'. Since Redis 5.0.0 -xgroupDelConsumer, -- |Delete a consumer. The redis command @XGROUP@ is split up into 'xgroupCreate', 'xgroupSetId', 'xgroupDestroy', and 'xgroupDelConsumer'. Since Redis 5.0.0 -xrange, -- |Read values from a stream within a range (https://redis.io/commands/xrange). Since Redis 5.0.0 -xrevRange, -- |Read values from a stream within a range in reverse order (https://redis.io/commands/xrevrange). Since Redis 5.0.0 -xlen, -- |Get the number of entries in a stream (https://redis.io/commands/xlen). Since Redis 5.0.0 -XPendingSummaryResponse(..), -xpendingSummary, -- |Get information about pending messages (https://redis.io/commands/xpending). The Redis @XPENDING@ command is split into 'xpendingSummary' and 'xpendingDetail'. Since Redis 5.0.0 -XPendingDetailRecord(..), -xpendingDetail, -- |Get detailed information about pending messages (https://redis.io/commands/xpending). The Redis @XPENDING@ command is split into 'xpendingSummary' and 'xpendingDetail'. Since Redis 5.0.0 -XClaimOpts(..), -defaultXClaimOpts, -xclaim, -- |Change ownership of some messages to the given consumer, returning the updated messages. The Redis @XCLAIM@ command is split into 'xclaim' and 'xclaimJustIds'. Since Redis 5.0.0 -xclaimJustIds, -- |Change ownership of some messages to the given consumer, returning only the changed message IDs. The Redis @XCLAIM@ command is split into 'xclaim' and 'xclaimJustIds'. Since Redis 5.0.0 -XInfoConsumersResponse(..), -xinfoConsumers, -- |Get info about consumers in a group. The Redis command @XINFO@ is split into 'xinfoConsumers', 'xinfoGroups', and 'xinfoStream'. Since Redis 5.0.0 -XInfoGroupsResponse(..), -xinfoGroups, -- |Get info about groups consuming from a stream. The Redis command @XINFO@ is split into 'xinfoConsumers', 'xinfoGroups', and 'xinfoStream'. Since Redis 5.0.0 -XInfoStreamResponse(..), -xinfoStream, -- |Get info about a stream. The Redis command @XINFO@ is split into 'xinfoConsumers', 'xinfoGroups', and 'xinfoStream'. Since Redis 5.0.0 -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, -command --- * Unimplemented Commands --- |These commands are not implemented, as of now. Library --- users can implement these or other commands from --- experimental Redis versions by using the 'sendRequest' --- function. --- --- * COMMAND () --- --- --- * COMMAND GETKEYS () --- --- --- * ROLE () --- --- --- * CLIENT KILL () --- --- --- * ZREVRANGEBYLEX () --- --- --- * ZRANGEBYSCORE () --- --- --- * ZREVRANGEBYSCORE () --- --- --- * MONITOR () --- --- --- * SYNC () --- --- --- * SHUTDOWN () --- --- --- * DEBUG SEGFAULT () --- -) where - -import Prelude hiding (min,max) -import Data.ByteString (ByteString) -import Database.Redis.ManualCommands -import Database.Redis.Types -import Database.Redis.Core(sendRequest, RedisCtx) - -ttl - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f Integer) -ttl key = sendRequest (["TTL"] ++ [encode key] ) - -setnx - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ value - -> m (f Bool) -setnx key value = sendRequest (["SETNX"] ++ [encode key] ++ [encode value] ) - -pttl - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f Integer) -pttl key = sendRequest (["PTTL"] ++ [encode key] ) - -commandCount - :: (RedisCtx m f) - => m (f Integer) -commandCount = sendRequest (["COMMAND","COUNT"] ) - -clientSetname - :: (RedisCtx m f) - => ByteString -- ^ connectionName - -> m (f ByteString) -clientSetname connectionName = sendRequest (["CLIENT","SETNAME"] ++ [encode connectionName] ) - -zrank - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ member - -> m (f (Maybe Integer)) -zrank key member = sendRequest (["ZRANK"] ++ [encode key] ++ [encode member] ) - -zremrangebyscore - :: (RedisCtx m f) - => ByteString -- ^ key - -> Double -- ^ min - -> Double -- ^ max - -> m (f Integer) -zremrangebyscore key min max = sendRequest (["ZREMRANGEBYSCORE"] ++ [encode key] ++ [encode min] ++ [encode max] ) - -hkeys - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f [ByteString]) -hkeys key = sendRequest (["HKEYS"] ++ [encode key] ) - -slaveof - :: (RedisCtx m f) - => ByteString -- ^ host - -> ByteString -- ^ port - -> m (f Status) -slaveof host port = sendRequest (["SLAVEOF"] ++ [encode host] ++ [encode port] ) - -rpushx - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ value - -> m (f Integer) -rpushx key value = sendRequest (["RPUSHX"] ++ [encode key] ++ [encode value] ) - -debugObject - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f ByteString) -debugObject key = sendRequest (["DEBUG","OBJECT"] ++ [encode key] ) - -bgsave - :: (RedisCtx m f) - => m (f Status) -bgsave = sendRequest (["BGSAVE"] ) - -hlen - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f Integer) -hlen key = sendRequest (["HLEN"] ++ [encode key] ) - -rpoplpush - :: (RedisCtx m f) - => ByteString -- ^ source - -> ByteString -- ^ destination - -> m (f (Maybe ByteString)) -rpoplpush source destination = sendRequest (["RPOPLPUSH"] ++ [encode source] ++ [encode destination] ) - -brpop - :: (RedisCtx m f) - => [ByteString] -- ^ key - -> Integer -- ^ timeout - -> m (f (Maybe (ByteString,ByteString))) -brpop key timeout = sendRequest (["BRPOP"] ++ map encode key ++ [encode timeout] ) - -bgrewriteaof - :: (RedisCtx m f) - => m (f Status) -bgrewriteaof = sendRequest (["BGREWRITEAOF"] ) - -zincrby - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ increment - -> ByteString -- ^ member - -> m (f Double) -zincrby key increment member = sendRequest (["ZINCRBY"] ++ [encode key] ++ [encode increment] ++ [encode member] ) - -hgetall - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f [(ByteString,ByteString)]) -hgetall key = sendRequest (["HGETALL"] ++ [encode key] ) - -hmset - :: (RedisCtx m f) - => ByteString -- ^ key - -> [(ByteString,ByteString)] -- ^ fieldValue - -> m (f Status) -hmset key fieldValue = sendRequest (["HMSET"] ++ [encode key] ++ concatMap (\(x,y) -> [encode x,encode y])fieldValue ) - -sinter - :: (RedisCtx m f) - => [ByteString] -- ^ key - -> m (f [ByteString]) -sinter key = sendRequest (["SINTER"] ++ map encode key ) - -pfadd - :: (RedisCtx m f) - => ByteString -- ^ key - -> [ByteString] -- ^ value - -> m (f Integer) -pfadd key value = sendRequest (["PFADD"] ++ [encode key] ++ map encode value ) - -zremrangebyrank - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ start - -> Integer -- ^ stop - -> m (f Integer) -zremrangebyrank key start stop = sendRequest (["ZREMRANGEBYRANK"] ++ [encode key] ++ [encode start] ++ [encode stop] ) - -flushdb - :: (RedisCtx m f) - => m (f Status) -flushdb = sendRequest (["FLUSHDB"] ) - -sadd - :: (RedisCtx m f) - => ByteString -- ^ key - -> [ByteString] -- ^ member - -> m (f Integer) -sadd key member = sendRequest (["SADD"] ++ [encode key] ++ map encode member ) - -lindex - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ index - -> m (f (Maybe ByteString)) -lindex key index = sendRequest (["LINDEX"] ++ [encode key] ++ [encode index] ) - -lpush - :: (RedisCtx m f) - => ByteString -- ^ key - -> [ByteString] -- ^ value - -> m (f Integer) -lpush key value = sendRequest (["LPUSH"] ++ [encode key] ++ map encode value ) - -hstrlen - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ field - -> m (f Integer) -hstrlen key field = sendRequest (["HSTRLEN"] ++ [encode key] ++ [encode field] ) - -smove - :: (RedisCtx m f) - => ByteString -- ^ source - -> ByteString -- ^ destination - -> ByteString -- ^ member - -> m (f Bool) -smove source destination member = sendRequest (["SMOVE"] ++ [encode source] ++ [encode destination] ++ [encode member] ) - -zscore - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ member - -> m (f (Maybe Double)) -zscore key member = sendRequest (["ZSCORE"] ++ [encode key] ++ [encode member] ) - -configResetstat - :: (RedisCtx m f) - => m (f Status) -configResetstat = sendRequest (["CONFIG","RESETSTAT"] ) - -pfcount - :: (RedisCtx m f) - => [ByteString] -- ^ key - -> m (f Integer) -pfcount key = sendRequest (["PFCOUNT"] ++ map encode key ) - -hdel - :: (RedisCtx m f) - => ByteString -- ^ key - -> [ByteString] -- ^ field - -> m (f Integer) -hdel key field = sendRequest (["HDEL"] ++ [encode key] ++ map encode field ) - -incrbyfloat - :: (RedisCtx m f) - => ByteString -- ^ key - -> Double -- ^ increment - -> m (f Double) -incrbyfloat key increment = sendRequest (["INCRBYFLOAT"] ++ [encode key] ++ [encode increment] ) - -setbit - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ offset - -> ByteString -- ^ value - -> m (f Integer) -setbit key offset value = sendRequest (["SETBIT"] ++ [encode key] ++ [encode offset] ++ [encode value] ) - -flushall - :: (RedisCtx m f) - => m (f Status) -flushall = sendRequest (["FLUSHALL"] ) - -incrby - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ increment - -> m (f Integer) -incrby key increment = sendRequest (["INCRBY"] ++ [encode key] ++ [encode increment] ) - -time - :: (RedisCtx m f) - => m (f (Integer,Integer)) -time = sendRequest (["TIME"] ) - -smembers - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f [ByteString]) -smembers key = sendRequest (["SMEMBERS"] ++ [encode key] ) - -zlexcount - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ min - -> ByteString -- ^ max - -> m (f Integer) -zlexcount key min max = sendRequest (["ZLEXCOUNT"] ++ [encode key] ++ [encode min] ++ [encode max] ) - -sunion - :: (RedisCtx m f) - => [ByteString] -- ^ key - -> m (f [ByteString]) -sunion key = sendRequest (["SUNION"] ++ map encode key ) - -sinterstore - :: (RedisCtx m f) - => ByteString -- ^ destination - -> [ByteString] -- ^ key - -> m (f Integer) -sinterstore destination key = sendRequest (["SINTERSTORE"] ++ [encode destination] ++ map encode key ) - -hvals - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f [ByteString]) -hvals key = sendRequest (["HVALS"] ++ [encode key] ) - -configSet - :: (RedisCtx m f) - => ByteString -- ^ parameter - -> ByteString -- ^ value - -> m (f Status) -configSet parameter value = sendRequest (["CONFIG","SET"] ++ [encode parameter] ++ [encode value] ) - -scriptFlush - :: (RedisCtx m f) - => m (f Status) -scriptFlush = sendRequest (["SCRIPT","FLUSH"] ) - -dbsize - :: (RedisCtx m f) - => m (f Integer) -dbsize = sendRequest (["DBSIZE"] ) - -wait - :: (RedisCtx m f) - => Integer -- ^ numslaves - -> Integer -- ^ timeout - -> m (f Integer) -wait numslaves timeout = sendRequest (["WAIT"] ++ [encode numslaves] ++ [encode timeout] ) - -lpop - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f (Maybe ByteString)) -lpop key = sendRequest (["LPOP"] ++ [encode key] ) - -clientPause - :: (RedisCtx m f) - => Integer -- ^ timeout - -> m (f Status) -clientPause timeout = sendRequest (["CLIENT","PAUSE"] ++ [encode timeout] ) - -expire - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ seconds - -> m (f Bool) -expire key seconds = sendRequest (["EXPIRE"] ++ [encode key] ++ [encode seconds] ) - -mget - :: (RedisCtx m f) - => [ByteString] -- ^ key - -> m (f [Maybe ByteString]) -mget key = sendRequest (["MGET"] ++ map encode key ) - -bitpos - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ bit - -> Integer -- ^ start - -> Integer -- ^ end - -> m (f Integer) -bitpos key bit start end = sendRequest (["BITPOS"] ++ [encode key] ++ [encode bit] ++ [encode start] ++ [encode end] ) - -lastsave - :: (RedisCtx m f) - => m (f Integer) -lastsave = sendRequest (["LASTSAVE"] ) - -pexpire - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ milliseconds - -> m (f Bool) -pexpire key milliseconds = sendRequest (["PEXPIRE"] ++ [encode key] ++ [encode milliseconds] ) - -clientList - :: (RedisCtx m f) - => m (f [ByteString]) -clientList = sendRequest (["CLIENT","LIST"] ) - -renamenx - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ newkey - -> m (f Bool) -renamenx key newkey = sendRequest (["RENAMENX"] ++ [encode key] ++ [encode newkey] ) - -pfmerge - :: (RedisCtx m f) - => ByteString -- ^ destkey - -> [ByteString] -- ^ sourcekey - -> m (f ByteString) -pfmerge destkey sourcekey = sendRequest (["PFMERGE"] ++ [encode destkey] ++ map encode sourcekey ) - -lrem - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ count - -> ByteString -- ^ value - -> m (f Integer) -lrem key count value = sendRequest (["LREM"] ++ [encode key] ++ [encode count] ++ [encode value] ) - -sdiff - :: (RedisCtx m f) - => [ByteString] -- ^ key - -> m (f [ByteString]) -sdiff key = sendRequest (["SDIFF"] ++ map encode key ) - -get - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f (Maybe ByteString)) -get key = sendRequest (["GET"] ++ [encode key] ) - -getrange - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ start - -> Integer -- ^ end - -> m (f ByteString) -getrange key start end = sendRequest (["GETRANGE"] ++ [encode key] ++ [encode start] ++ [encode end] ) - -sdiffstore - :: (RedisCtx m f) - => ByteString -- ^ destination - -> [ByteString] -- ^ key - -> m (f Integer) -sdiffstore destination key = sendRequest (["SDIFFSTORE"] ++ [encode destination] ++ map encode key ) - -zcount - :: (RedisCtx m f) - => ByteString -- ^ key - -> Double -- ^ min - -> Double -- ^ max - -> m (f Integer) -zcount key min max = sendRequest (["ZCOUNT"] ++ [encode key] ++ [encode min] ++ [encode max] ) - -scriptLoad - :: (RedisCtx m f) - => ByteString -- ^ script - -> m (f ByteString) -scriptLoad script = sendRequest (["SCRIPT","LOAD"] ++ [encode script] ) - -getset - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ value - -> m (f (Maybe ByteString)) -getset key value = sendRequest (["GETSET"] ++ [encode key] ++ [encode value] ) - -dump - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f ByteString) -dump key = sendRequest (["DUMP"] ++ [encode key] ) - -keys - :: (RedisCtx m f) - => ByteString -- ^ pattern - -> m (f [ByteString]) -keys pattern = sendRequest (["KEYS"] ++ [encode pattern] ) - -configGet - :: (RedisCtx m f) - => ByteString -- ^ parameter - -> m (f [(ByteString,ByteString)]) -configGet parameter = sendRequest (["CONFIG","GET"] ++ [encode parameter] ) - -rpush - :: (RedisCtx m f) - => ByteString -- ^ key - -> [ByteString] -- ^ value - -> m (f Integer) -rpush key value = sendRequest (["RPUSH"] ++ [encode key] ++ map encode value ) - -randomkey - :: (RedisCtx m f) - => m (f (Maybe ByteString)) -randomkey = sendRequest (["RANDOMKEY"] ) - -hsetnx - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ field - -> ByteString -- ^ value - -> m (f Bool) -hsetnx key field value = sendRequest (["HSETNX"] ++ [encode key] ++ [encode field] ++ [encode value] ) - -mset - :: (RedisCtx m f) - => [(ByteString,ByteString)] -- ^ keyValue - -> m (f Status) -mset keyValue = sendRequest (["MSET"] ++ concatMap (\(x,y) -> [encode x,encode y])keyValue ) - -setex - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ seconds - -> ByteString -- ^ value - -> m (f Status) -setex key seconds value = sendRequest (["SETEX"] ++ [encode key] ++ [encode seconds] ++ [encode value] ) - -psetex - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ milliseconds - -> ByteString -- ^ value - -> m (f Status) -psetex key milliseconds value = sendRequest (["PSETEX"] ++ [encode key] ++ [encode milliseconds] ++ [encode value] ) - -scard - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f Integer) -scard key = sendRequest (["SCARD"] ++ [encode key] ) - -scriptExists - :: (RedisCtx m f) - => [ByteString] -- ^ script - -> m (f [Bool]) -scriptExists script = sendRequest (["SCRIPT","EXISTS"] ++ map encode script ) - -sunionstore - :: (RedisCtx m f) - => ByteString -- ^ destination - -> [ByteString] -- ^ key - -> m (f Integer) -sunionstore destination key = sendRequest (["SUNIONSTORE"] ++ [encode destination] ++ map encode key ) - -persist - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f Bool) -persist key = sendRequest (["PERSIST"] ++ [encode key] ) - -strlen - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f Integer) -strlen key = sendRequest (["STRLEN"] ++ [encode key] ) - -lpushx - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ value - -> m (f Integer) -lpushx key value = sendRequest (["LPUSHX"] ++ [encode key] ++ [encode value] ) - -hset - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ field - -> ByteString -- ^ value - -> m (f Integer) -hset key field value = sendRequest (["HSET"] ++ [encode key] ++ [encode field] ++ [encode value] ) - -brpoplpush - :: (RedisCtx m f) - => ByteString -- ^ source - -> ByteString -- ^ destination - -> Integer -- ^ timeout - -> m (f (Maybe ByteString)) -brpoplpush source destination timeout = sendRequest (["BRPOPLPUSH"] ++ [encode source] ++ [encode destination] ++ [encode timeout] ) - -zrevrank - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ member - -> m (f (Maybe Integer)) -zrevrank key member = sendRequest (["ZREVRANK"] ++ [encode key] ++ [encode member] ) - -scriptKill - :: (RedisCtx m f) - => m (f Status) -scriptKill = sendRequest (["SCRIPT","KILL"] ) - -setrange - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ offset - -> ByteString -- ^ value - -> m (f Integer) -setrange key offset value = sendRequest (["SETRANGE"] ++ [encode key] ++ [encode offset] ++ [encode value] ) - -del - :: (RedisCtx m f) - => [ByteString] -- ^ key - -> m (f Integer) -del key = sendRequest (["DEL"] ++ map encode key ) - -hincrbyfloat - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ field - -> Double -- ^ increment - -> m (f Double) -hincrbyfloat key field increment = sendRequest (["HINCRBYFLOAT"] ++ [encode key] ++ [encode field] ++ [encode increment] ) - -hincrby - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ field - -> Integer -- ^ increment - -> m (f Integer) -hincrby key field increment = sendRequest (["HINCRBY"] ++ [encode key] ++ [encode field] ++ [encode increment] ) - -zremrangebylex - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ min - -> ByteString -- ^ max - -> m (f Integer) -zremrangebylex key min max = sendRequest (["ZREMRANGEBYLEX"] ++ [encode key] ++ [encode min] ++ [encode max] ) - -rpop - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f (Maybe ByteString)) -rpop key = sendRequest (["RPOP"] ++ [encode key] ) - -rename - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ newkey - -> m (f Status) -rename key newkey = sendRequest (["RENAME"] ++ [encode key] ++ [encode newkey] ) - -zrem - :: (RedisCtx m f) - => ByteString -- ^ key - -> [ByteString] -- ^ member - -> m (f Integer) -zrem key member = sendRequest (["ZREM"] ++ [encode key] ++ map encode member ) - -hexists - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ field - -> m (f Bool) -hexists key field = sendRequest (["HEXISTS"] ++ [encode key] ++ [encode field] ) - -clientGetname - :: (RedisCtx m f) - => m (f Status) -clientGetname = sendRequest (["CLIENT","GETNAME"] ) - -configRewrite - :: (RedisCtx m f) - => m (f Status) -configRewrite = sendRequest (["CONFIG","REWRITE"] ) - -decr - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f Integer) -decr key = sendRequest (["DECR"] ++ [encode key] ) - -hmget - :: (RedisCtx m f) - => ByteString -- ^ key - -> [ByteString] -- ^ field - -> m (f [Maybe ByteString]) -hmget key field = sendRequest (["HMGET"] ++ [encode key] ++ map encode field ) - -lrange - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ start - -> Integer -- ^ stop - -> m (f [ByteString]) -lrange key start stop = sendRequest (["LRANGE"] ++ [encode key] ++ [encode start] ++ [encode stop] ) - -decrby - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ decrement - -> m (f Integer) -decrby key decrement = sendRequest (["DECRBY"] ++ [encode key] ++ [encode decrement] ) - -llen - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f Integer) -llen key = sendRequest (["LLEN"] ++ [encode key] ) - -append - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ value - -> m (f Integer) -append key value = sendRequest (["APPEND"] ++ [encode key] ++ [encode value] ) - -incr - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f Integer) -incr key = sendRequest (["INCR"] ++ [encode key] ) - -hget - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ field - -> m (f (Maybe ByteString)) -hget key field = sendRequest (["HGET"] ++ [encode key] ++ [encode field] ) - -pexpireat - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ millisecondsTimestamp - -> m (f Bool) -pexpireat key millisecondsTimestamp = sendRequest (["PEXPIREAT"] ++ [encode key] ++ [encode millisecondsTimestamp] ) - -ltrim - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ start - -> Integer -- ^ stop - -> m (f Status) -ltrim key start stop = sendRequest (["LTRIM"] ++ [encode key] ++ [encode start] ++ [encode stop] ) - -zcard - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f Integer) -zcard key = sendRequest (["ZCARD"] ++ [encode key] ) - -lset - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ index - -> ByteString -- ^ value - -> m (f Status) -lset key index value = sendRequest (["LSET"] ++ [encode key] ++ [encode index] ++ [encode value] ) - -expireat - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ timestamp - -> m (f Bool) -expireat key timestamp = sendRequest (["EXPIREAT"] ++ [encode key] ++ [encode timestamp] ) - -save - :: (RedisCtx m f) - => m (f Status) -save = sendRequest (["SAVE"] ) - -move - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ db - -> m (f Bool) -move key db = sendRequest (["MOVE"] ++ [encode key] ++ [encode db] ) - -getbit - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ offset - -> m (f Integer) -getbit key offset = sendRequest (["GETBIT"] ++ [encode key] ++ [encode offset] ) - -msetnx - :: (RedisCtx m f) - => [(ByteString,ByteString)] -- ^ keyValue - -> m (f Bool) -msetnx keyValue = sendRequest (["MSETNX"] ++ concatMap (\(x,y) -> [encode x,encode y])keyValue ) - -commandInfo - :: (RedisCtx m f) - => [ByteString] -- ^ commandName - -> m (f [ByteString]) -commandInfo commandName = sendRequest (["COMMAND","INFO"] ++ map encode commandName ) - -quit - :: (RedisCtx m f) - => m (f Status) -quit = sendRequest (["QUIT"] ) - -blpop - :: (RedisCtx m f) - => [ByteString] -- ^ key - -> Integer -- ^ timeout - -> m (f (Maybe (ByteString,ByteString))) -blpop key timeout = sendRequest (["BLPOP"] ++ map encode key ++ [encode timeout] ) - -srem - :: (RedisCtx m f) - => ByteString -- ^ key - -> [ByteString] -- ^ member - -> m (f Integer) -srem key member = sendRequest (["SREM"] ++ [encode key] ++ map encode member ) - -echo - :: (RedisCtx m f) - => ByteString -- ^ message - -> m (f ByteString) -echo message = sendRequest (["ECHO"] ++ [encode message] ) - -sismember - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ member - -> m (f Bool) -sismember key member = sendRequest (["SISMEMBER"] ++ [encode key] ++ [encode member] ) +{-# LANGUAGE OverloadedStrings, FlexibleContexts, OverloadedLists #-} + +module Database.Redis.Commands ( + +-- ** Connection + +-- *** auth +-- $auth +auth, +authOpts, +AuthOpts(..), +defaultAuthOpts, +-- *** Other commands +echo, +ping, +quit, +select, + +-- ** Keys +del, +dump, +exists, +expire, +ExpireOpts(..), +expireOpts, +expireat, +expireatOpts, +keys, +MigrateOpts(..), +defaultMigrateOpts, +migrate, +migrateMultiple, +move, +objectRefcount, +objectEncoding, +objectIdletime, +persist, +pexpire, +pexpireat, +pexpireatOpts, +pttl, +randomkey, +rename, +renamenx, +restore, +restoreReplace, +Cursor, +cursor0, +ScanOpts(..), +defaultScanOpts, +scan, +scanOpts, +SortOpts(..), +defaultSortOpts, +SortOrder(..), +sort, +sortStore, +ttl, +RedisType(..), +getType, +wait, + +-- ** Hashes +hdel, +hexists, +hget, +hgetall, +hincrby, +hincrbyfloat, +hkeys, +hlen, +hmget, +hmset, +hscan, +hscanOpts, +hset, +hsetnx, +hstrlen, +hvals, + +-- ** HyperLogLogs +pfadd, +pfcount, +pfmerge, + +-- ** Lists +blpop, +blpopFloat, +brpop, +brpopFloat, +brpoplpush, +lindex, +linsertBefore, +linsertAfter, +llen, +lpop, +lpopCount, +lpush, +lpushx, +lrange, +lrem, +lset, +ltrim, +rpop, +rpopCount, +rpoplpush, +rpush, +rpushx, + +-- ** Scripting +eval, +evalsha, +DebugMode, +scriptDebug, +scriptExists, +scriptFlush, +scriptKill, +scriptLoad, + +-- ** Server +bgrewriteaof, +bgsave, +bgsaveSchedule, +clientGetname, +clientId, +clientList, +clientPause, +ReplyMode, +clientReply, +clientSetname, +commandCount, +commandInfo, +configGet, +configResetstat, +configRewrite, +configSet, +dbsize, +debugObject, +flushall, +flushallOpts, +FlushOpts(..), +flushdb, +flushdbOpts, +info, -- |Get information and statistics about the server (). The Redis command @INFO@ is split up into 'info', 'infoSection'. Since Redis 1.0.0 +infoSection, -- |Get information and statistics about the server (). The Redis command @INFO@ is split up into 'info', 'infoSection'. Since Redis 1.0.0 +lastsave, -- |Get the UNIX time stamp of the last successful save to disk (). Since Redis 1.0.0 +save, +slaveof, +Slowlog(..), +slowlogGet, -- |Manages the Redis slow queries log (). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12 +slowlogLen, -- |Manages the Redis slow queries log (). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12 +slowlogReset, -- |Manages the Redis slow queries log (). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12 +time, + +-- ** Sets +sadd, +scard, +sdiff, +sdiffstore, +sinter, +sinterstore, +sismember, +smembers, +smove, +spop, +spopN, +srandmember, +srandmemberN, +srem, +sscan, +sscanOpts, +sunion, +sunionstore, + +-- ** Sorted Sets +ZaddOpts(..), +defaultZaddOpts, +zadd, +zaddOpts, +SizeCondition(..), +zcard, +zcount, +zincrby, +Aggregate(..), +zinterstore, +zinterstoreWeights, +zlexcount, +zrange, +zrangeWithscores, +RangeLex(..), +zrangebylex, zrangebylexLimit, +zrangebyscore, -- |Return a range of members in a sorted set, by score (). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5 +zrangebyscoreWithscores, -- |Return a range of members in a sorted set, by score (). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5 +zrangebyscoreLimit, -- |Return a range of members in a sorted set, by score (). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5 +zrangebyscoreWithscoresLimit, -- |Return a range of members in a sorted set, by score (). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5 +zrank, +zrankWithScore, +zrem, +zremrangebylex, +zremrangebyrank, +zremrangebyscore, +zrevrange, -- |Return a range of members in a sorted set, by index, with scores ordered from high to low (). The Redis command @ZREVRANGE@ is split up into 'zrevrange', 'zrevrangeWithscores'. Since Redis 1.2.0 +zrevrangeWithscores, -- |Return a range of members in a sorted set, by index, with scores ordered from high to low (). The Redis command @ZREVRANGE@ is split up into 'zrevrange', 'zrevrangeWithscores'. Since Redis 1.2.0 +zrevrangebyscore, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0 +zrevrangebyscoreWithscores, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0 +zrevrangebyscoreLimit, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0 +zrevrangebyscoreWithscoresLimit, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0 +zrevrank, +zrevrankWithScore, +zscan, -- |Incrementally iterate sorted sets elements and associated scores (). The Redis command @ZSCAN@ is split up into 'zscan', 'zscanOpts'. Since Redis 2.8.0 +zscanOpts, -- |Incrementally iterate sorted sets elements and associated scores (). The Redis command @ZSCAN@ is split up into 'zscan', 'zscanOpts'. Since Redis 2.8.0 +zscore, +zunionstore, -- |Add multiple sorted sets and store the resulting sorted set in a new key (). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'. Since Redis 2.0.0 +zunionstoreWeights, -- |Add multiple sorted sets and store the resulting sorted set in a new key (). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'. Since Redis 2.0.0 + +-- ** Strings +append, +bitcount, -- |Count set bits in a string (). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'. Since Redis 2.6.0 +bitcountRange, -- |Count set bits in a string (). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'. Since Redis 2.6.0 +bitopAnd, -- |Perform bitwise operations between strings (). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0 +bitopOr, -- |Perform bitwise operations between strings (). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0 +bitopXor, -- |Perform bitwise operations between strings (). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0 +bitopNot, -- |Perform bitwise operations between strings (). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0 +bitpos, +bitposOpts, +BitposOpts(..), +BitposType(..), +decr, +decrby, +get, +getbit, +getrange, +getset, +incr, +incrby, +incrbyfloat, +mget, +mset, +msetnx, +psetex, +Condition(..), +SetOpts(..), +set, -- |Set the string value of a key (). The Redis command @SET@ is split up into 'set', 'setOpts', 'setGet', 'setGetOpts'. Since Redis 1.0.0 +setOpts, -- |Set the string value of a key (). The Redis command @SET@ is split up into 'set', 'setOpts', 'setGet', 'setGetOpts'. Since Redis 1.0.0 +setGet, -- |Set the string value of a key (). The Redis command @SET@ is split up into 'set', 'setOpts', 'setGet', 'setGetOpts'. Since Redis 1.0.0 +setGetOpts, -- |Set the string value of a key (). The Redis command @SET@ is split up into 'set', 'setOpts', 'setGet', 'setGetOpts'. Since Redis 1.0.0 +setbit, +setex, +setnx, +setrange, +strlen, + + +-- ** Streams +XReadOpts(..), +defaultXreadOpts, +XReadResponse(..), +StreamsRecord(..), +xadd, +xaddOpts, +XAddOpts(..), +defaultXAddOpts, +TrimStrategy(..), +TrimType(..), +trimOpts, +xread, -- |Read values from a stream (). The Redis command @XREAD@ is split up into 'xread', 'xreadOpts'. Since Redis 5.0.0 +xreadOpts, -- |Read values from a stream (). The Redis command @XREAD@ is split up into 'xread', 'xreadOpts'. Since Redis 5.0.0 +xreadGroup, -- |Read values from a stream as part of a consumer group (https://redis.io/commands/xreadgroup). The redis command @XREADGROUP@ is split up into 'xreadGroup' and 'xreadGroupOpts'. Since Redis 5.0.0 +XReadGroupOpts(..), +defaultXReadGroupOpts, +xreadGroupOpts, -- |Read values from a stream as part of a consumer group (https://redis.io/commands/xreadgroup). The redis command @XREADGROUP@ is split up into 'xreadGroup' and 'xreadGroupOpts'. Since Redis 5.0.0 +xack, -- |Acknowledge receipt of a message as part of a consumer group. Since Redis 5.0.0 + +-- *** XGROUP CREATE +-- $xgroupCreate +xgroupCreate, +xgroupCreateOpts, +XGroupCreateOpts(..), +defaultXGroupCreateOpts, + +-- *** XGROUP CREATECONSUMER +xgroupCreateConsumer, + +-- *** XGROUP SETID +-- $xgroupSetId +xgroupSetId, +xgroupSetIdOpts, +XGroupSetIdOpts(..), +defaultXGroupSetIdOpts, + +-- *** XGROUP DESTROY +xgroupDestroy, + +-- *** XGROUP DELCONSUMER +xgroupDelConsumer, + +xrange, -- |Read values from a stream within a range (https://redis.io/commands/xrange). Since Redis 5.0.0 +xrevRange, -- |Read values from a stream within a range in reverse order (https://redis.io/commands/xrevrange). Since Redis 5.0.0 +xlen, -- |Get the number of entries in a stream (https://redis.io/commands/xlen). Since Redis 5.0.0 + +-- *** XPENDING +-- $xpending +xpendingSummary, +XPendingSummaryResponse(..), +XPendingDetailOpts(..), +defaultXPendingDetailOpts, +XPendingDetailRecord(..), +xpendingDetail, + +XClaimOpts(..), +defaultXClaimOpts, +xclaim, -- |Change ownership of some messages to the given consumer, returning the updated messages. The Redis @XCLAIM@ command is split into 'xclaim' and 'xclaimJustIds'. Since Redis 5.0.0 +xclaimJustIds, -- |Change ownership of some messages to the given consumer, returning only the changed message IDs. The Redis @XCLAIM@ command is split into 'xclaim' and 'xclaimJustIds'. Since Redis 5.0.0 + +-- *** Autoclaim +-- $autoclaim +xautoclaim, +xautoclaimOpts, +XAutoclaimOpts(..), +XAutoclaimStreamsResult, +XAutoclaimResult(..), +xautoclaimJustIds, +xautoclaimJustIdsOpts, +XAutoclaimJustIdsResult, +XInfoConsumersResponse(..), +xinfoConsumers, +XInfoGroupsResponse(..), +xinfoGroups, +XInfoStreamResponse(..), +xinfoStream, +xdel, +xtrim, +inf, +ClusterInfoResponse (..), +ClusterInfoResponseState (..), +clusterInfo, +ClusterNodesResponse(..), +ClusterNodesResponseEntry(..), +ClusterNodesResponseSlotSpec(..), +clusterNodes, +ClusterSlotsResponse(..), +ClusterSlotsResponseEntry(..), +ClusterSlotsNode(..), +clusterSlots, +clusterSetSlotNode, +clusterSetSlotStable, +clusterSetSlotImporting, +clusterSetSlotMigrating, +clusterGetKeysInSlot, +command +-- * Unimplemented Commands +-- |These commands are not implemented, as of now. Library +-- users can implement these or other commands from +-- experimental Redis versions by using the 'sendRequest' +-- function. +-- +-- * COMMAND () +-- +-- +-- * COMMAND GETKEYS () +-- +-- +-- * ROLE () +-- +-- +-- * CLIENT KILL () +-- +-- +-- * ZREVRANGEBYLEX () +-- +-- +-- * ZRANGEBYSCORE () +-- +-- +-- * ZREVRANGEBYSCORE () +-- +-- +-- * MONITOR () +-- +-- +-- * SYNC () +-- +-- +-- * SHUTDOWN () +-- +-- +-- * DEBUG SEGFAULT () +-- +) where + +import Prelude hiding (min,max) +import Data.Int +import Data.ByteString (ByteString) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import Database.Redis.ManualCommands +import Database.Redis.Types +import Database.Redis.Core(sendRequest, RedisCtx) + +-- | /O(1)/ +-- Get the time to live for a key (). +-- Since Redis 1.0.0 +-- +-- This command returns: +-- * -2 if the key does not exist +-- * -1 if the key exists but has no associated value +-- +ttl + :: (RedisCtx m f) + => ByteString -- ^ Key to check. + -> m (f Integer) +ttl key = sendRequest ["TTL", encode key] + +-- | /O(1)/ +-- Sets the value of a key, only if the key does not exist (). +-- +-- Returns a result if a value was set. +-- +-- Since Redis 1.0.0 +setnx + :: (RedisCtx m f) + => ByteString -- ^ Key to set. + -> ByteString -- ^ Value to set. + -> m (f Bool) +setnx key value = sendRequest ["SETNX", encode key, encode value] + +-- | /O(1)/ +-- Get the time to live for a key in milliseconds (). +-- Since Redis 2.6.0 +-- +-- This command returns @-2@ if the key does not exist. +-- This command returns @-1@ if the key exists but has no associated value +pttl + :: (RedisCtx m f) + => ByteString -- ^ Key. + -> m (f Integer) +pttl key = sendRequest ["PTTL", encode key] + +-- | /O(1)/ +-- Get total number of Redis commands (). +-- Since Redis 2.8.13 +commandCount + :: (RedisCtx m f) + => m (f Integer) +commandCount = sendRequest ["COMMAND","COUNT"] + +-- | Set the current connection name (). +-- Since Redis 2.6.9 +clientSetname + :: (RedisCtx m f) + => ByteString -- ^ Connection Name. + -> m (f Status) +clientSetname connectionName = sendRequest ["CLIENT","SETNAME",encode connectionName] + +-- | Determine the index of a member in a sorted set (). +-- +-- Since Redis 2.0.0 +zrank + :: (RedisCtx m f) + => ByteString -- ^ Key.of the set. + -> ByteString -- ^ Member + -> m (f (Maybe Integer)) +zrank key member = sendRequest ["ZRANK", encode key, encode member] + +-- | +-- Since Redis 7.2.0: fails on earlier versions +zrankWithScore + :: (RedisCtx m f) + => ByteString -- ^ Key of the set. + -> ByteString -- ^ Member. + -> m (f (Maybe (Integer,Double))) +zrankWithScore key member = sendRequest ["ZRANK", encode key, encode member, "WITHSCORE"] + +-- | /O(log(N)+M)/ with @N@ number of elements in the set, @M@ number of elements to be removed. +-- +-- Remove all members in a sorted set within the given scores (). +-- +-- Returns a number of elements that were removed. +-- +-- Since Redis 1.2.0 +zremrangebyscore + :: (RedisCtx m f) + => ByteString -- ^ key + -> Double -- ^ min + -> Double -- ^ max + -> m (f Integer) +zremrangebyscore key min max = + sendRequest ["ZREMRANGEBYSCORE",encode key,encode min,encode max] + +-- | /O(N)/ where @N@ is size of the hash. +-- Get all the fields in a hash (). +-- Since Redis 2.0.0 +hkeys + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f [ByteString]) +hkeys key = sendRequest ["HKEYS",encode key] + +-- |Make the server a slave of another instance, or promote it as master (). +-- Deprecated in Redis, can be replaced by replicaif since redis 5.0 +-- Since Redis 1.0.0 +slaveof + :: (RedisCtx m f) + => ByteString -- ^ host + -> ByteString -- ^ port + -> m (f Status) +slaveof host port = sendRequest ["SLAVEOF",encode host,encode port] + +-- | /O(1)/ for each element added. +-- Append a value to a list, only if the list exists (). +-- Since Redis 2.2.0 +rpushx + :: (RedisCtx m f) + => ByteString -- ^ key + -> NonEmpty ByteString -- ^ value + -> m (f Integer) +rpushx key (value:|values) = sendRequest ("RPUSHX":encode key:value:values) + +-- |Get debugging information about a key (). Since Redis 1.0.0 +debugObject + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f ByteString) +debugObject key = sendRequest ["DEBUG","OBJECT",encode key] + +-- |Asynchronously save the dataset to disk (). +-- +-- Since Redis 1.0.0 +bgsave + :: (RedisCtx m f) + => m (f Status) +bgsave = sendRequest ["BGSAVE"] + +-- |Asynchronously save the dataset to disk (). +-- +-- Immediately returns OK when an AOF rewrite is in progress and schedule the background save +-- to run at the next opportunity. +-- +-- A client may bee able to check if the operation succeeded using the 'lastsave' command +-- +-- Since Redis 3.2.2 +bgsaveSchedule + :: (RedisCtx m f) + => m (f Status) +bgsaveSchedule = sendRequest ["BGSAVE", "SCHEDULE"] + + +-- | /O(1)/ Get the number of fields in a hash (). +-- +-- Since Redis 2.0.0 +hlen + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f Integer) +hlen key = sendRequest ["HLEN", key] + +-- |Remove the last element in a list, prepend it to another list and return that +-- element f it existed (). +-- Since Redis 1.2.0 +rpoplpush + :: (RedisCtx m f) + => ByteString -- ^ source + -> ByteString -- ^ destination + -> m (f (Maybe ByteString)) +rpoplpush source destination = sendRequest ["RPOPLPUSH",encode source,encode destination] + +-- | /O(N)/ +-- Remove and get the last element in a list, or block until one is available (). +-- +-- Since Redis 2.0.0 +brpop + :: (RedisCtx m f) + => NonEmpty ByteString -- ^ key + -> Integer -- ^ timeout + -> m (f (Maybe (ByteString,ByteString))) +brpop (key:|rest) timeout = sendRequest (("BRPOP":key:rest) ++ [encode timeout]) + +-- | /O(N)/ +-- Remove and get the last element in a list, or block until one is available (). +-- +-- Since Redis 2.0.0 +brpopFloat + :: (RedisCtx m f) + => [ByteString] -- ^ key + -> Double -- ^ timeout + -> m (f (Maybe (ByteString,ByteString))) +brpopFloat key timeout = sendRequest (["BRPOP"] ++ map encode key ++ [encode timeout]) + +-- |Asynchronously rewrite the append-only file (). Since Redis 1.0.0 +bgrewriteaof + :: (RedisCtx m f) + => m (f Status) +bgrewriteaof = sendRequest ["BGREWRITEAOF"] + +-- | /O(log(N))/ +-- +-- Increment the score of a member in a sorted set (). +-- +-- Returns new score of the element. +-- +-- Since Redis 1.2.0 +zincrby + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ increment + -> ByteString -- ^ member + -> m (f Double) +zincrby key increment member = sendRequest ["ZINCRBY",encode key,encode increment,encode member] + +-- | Get all the fields and values in a hash (). +-- +-- Since Redis 2.0.0. +hgetall + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f [(ByteString,ByteString)]) +hgetall key = sendRequest ["HGETALL", encode key] + + +-- | Set multiple hash fields to multiple values (). +-- +-- Deprecated by Redis, consider using 'hset' with multiple field-value pairs. +-- +-- Since Redis 2.0.0 +hmset + :: (RedisCtx m f) + => ByteString -- ^ key + -> NonEmpty (ByteString,ByteString) -- ^ fieldValue + -> m (f Status) +hmset key ((field,value):|fieldValues) = + sendRequest ("HMSET":key:field:value: concatMap (\(x,y) -> [x,y]) fieldValues) + +-- |Intersect multiple sets (). +-- Since Redis 1.0.0 +sinter + :: (RedisCtx m f) + => NonEmpty ByteString -- ^ Keys. + -> m (f [ByteString]) +sinter (key:|keys_) = sendRequest ("SINTER":key:keys_) + +-- | /O(1)/ +-- Adds all the elements arguments to the HyperLogLog data structure stored at the variable name specified as first argument (). +-- Since Redis 2.8.9 +pfadd + :: (RedisCtx m f) + => ByteString -- ^ Key. + -> NonEmpty ByteString -- ^ Value. + -> m (f Integer) +pfadd key (value:|values) = sendRequest ("PFADD":key:value:values) + +-- | /O(log(N)+M/ with @N@ being the number of elements in the sorted set and @M@ the number of elemnts removed by the operation. +-- +-- Remove all members in a sorted set within the given indexes (). +-- +-- Returns a number of elements that were removed. +-- +-- Since Redis 2.0.0 +zremrangebyrank + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ start + -> Integer -- ^ stop + -> m (f Integer) +zremrangebyrank key start stop = + sendRequest ["ZREMRANGEBYRANK",encode key,encode start,encode stop] + +-- |Remove all keys from the current database (). +-- Since Redis 1.0.0 +flushdb + :: (RedisCtx m f) + => m (f Status) +flushdb = sendRequest ["FLUSHDB"] + +-- | /O(1)/ for each element added. +-- Add one or more members to a set (). +-- Since Redis 1.0.0 +sadd + :: (RedisCtx m f) + => ByteString -- ^ Key where set is stored. + -> NonEmpty ByteString -- ^ Member to add to the set. + -> m (f Integer) +sadd key member = sendRequest ("SADD":encode key:NE.toList (fmap encode member)) + +-- |Get an element from a list by its index (). +-- Since Redis 1.0.0 +lindex + :: (RedisCtx m f) + => ByteString -- ^ Key. + -> Integer -- ^ Index + -> m (f (Maybe ByteString)) +lindex key index = sendRequest ["LINDEX",encode key,encode index] + +-- | Prepend one or multiple values to a list (). +-- Since Redis 1.0.0 +lpush + :: (RedisCtx m f) + => ByteString -- ^ Key + -> NonEmpty ByteString -- ^ Value + -> m (f Integer) +lpush key (value:|values) = sendRequest ("LPUSH":key:value:values) + +-- |Get the length of the value of a hash field (). +-- Since Redis 3.2.0 +hstrlen + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ field + -> m (f Integer) +hstrlen key field = sendRequest ["HSTRLEN", key, field] + +-- | +-- Move a member from one set to another (). +-- Since Redis 1.0.0 +smove + :: (RedisCtx m f) + => ByteString -- ^ source + -> ByteString -- ^ destination + -> ByteString -- ^ member + -> m (f Bool) +smove source destination member = + sendRequest ["SMOVE", source, destination, member] + +-- |Get the score associated with the given member in a sorted set (). +-- Since Redis 1.2.0 +zscore + :: (RedisCtx m f) + => ByteString -- ^ Key. + -> ByteString -- ^ Member. + -> m (f (Maybe Double)) +zscore key member = sendRequest ["ZSCORE",encode key,encode member] + +-- |Reset the stats returned by INFO (). +-- Since Redis 2.0.0 +configResetstat + :: (RedisCtx m f) + => m (f Status) +configResetstat = sendRequest ["CONFIG","RESETSTAT"] + +-- | +-- Return the approximated cardinality of the set(s) observed by the HyperLogLog at key(s) (). +-- Since Redis 2.8.9 +pfcount + :: (RedisCtx m f) + => NonEmpty ByteString -- ^ key + -> m (f Integer) +pfcount (key:|keys_) = sendRequest ("PFCOUNT": key: keys_) + +-- | Delete one or more hash fields (). +-- Since Redis 2.0.0 +hdel + :: (RedisCtx m f) + => ByteString -- ^ key + -> NonEmpty ByteString -- ^ field + -> m (f Integer) +hdel key (field:|fields) = sendRequest ("HDEL":key:field:fields) + +-- |Increment the float value of a key by the given amount (). +-- Since Redis 2.6.0 +incrbyfloat + :: (RedisCtx m f) + => ByteString -- ^ Key. + -> Double -- ^ Increment. + -> m (f Double) +incrbyfloat key increment = sendRequest ["INCRBYFLOAT", key, encode increment] + +-- |Sets or clears the bit at offset in the string value stored at key (). +-- Since Redis 2.2.0 +setbit + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ offset + -> ByteString -- ^ value + -> m (f Integer) +setbit key offset value = sendRequest ["SETBIT", key, encode offset, value] + +-- | Remove all keys from all databases (). Since Redis 1.0.0 +flushall + :: (RedisCtx m f) + => m (f Status) +flushall = sendRequest ["FLUSHALL"] + +-- |Increment the integer value of a key by the given amount (). +-- Since Redis 1.0.0 +incrby + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ increment + -> m (f Integer) +incrby key increment = sendRequest ["INCRBY", key, encode increment] + +-- | Return the current server time (). +-- Since Redis 2.6.0 +time + :: (RedisCtx m f) + => m (f (Integer,Integer)) +time = sendRequest ["TIME"] + +-- |Get all the members in a set (). Since Redis 1.0.0 +smembers + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f [ByteString]) +smembers key = sendRequest ["SMEMBERS", key] + +-- |Count the number of members in a sorted set between a given lexicographical range (). +-- Since Redis 2.8.9 +zlexcount + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ min + -> ByteString -- ^ max + -> m (f Integer) +zlexcount key min max = sendRequest ["ZLEXCOUNT", key, min, max] + +-- |Add multiple sets (). +-- Since Redis 1.0.0 +sunion + :: (RedisCtx m f) + => NonEmpty ByteString -- ^ key + -> m (f [ByteString]) +sunion (key:|keys_) = sendRequest ("SUNION":key:keys_) + +-- |Intersect multiple sets and store the resulting set in a key (). +-- Since Redis 1.0.0 +sinterstore + :: (RedisCtx m f) + => ByteString -- ^ destination + -> NonEmpty ByteString -- ^ key + -> m (f Integer) +sinterstore destination (key:|keys_) = + sendRequest ("SINTERSTORE":destination:key:keys_) + +-- | Get all the values in a hash (). +-- Since Redis 2.0.0 +hvals + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f [ByteString]) +hvals key = sendRequest ["HVALS", key] + +-- |Set a configuration parameter to the given value (). +-- Since Redis 2.0.0 +configSet + :: (RedisCtx m f) + => ByteString -- ^ parameter + -> ByteString -- ^ value + -> m (f Status) +configSet parameter value = sendRequest ["CONFIG","SET", parameter, value] + +-- |Remove all the scripts from the script cache (). +-- Since Redis 2.6.0 +scriptFlush + :: (RedisCtx m f) + => m (f Status) +scriptFlush = sendRequest ["SCRIPT","FLUSH"] + +-- |Return the number of keys in the selected database (). +-- Since Redis 1.0.0 +dbsize + :: (RedisCtx m f) + => m (f Integer) +dbsize = sendRequest ["DBSIZE"] + +-- |Wait for the synchronous replication of all the write commands sent in the context of the current connection (). +-- Since Redis 3.0.0 +wait + :: (RedisCtx m f) + => Integer -- ^ numslaves + -> Integer -- ^ timeout + -> m (f Integer) +wait numslaves timeout = sendRequest ["WAIT", encode numslaves, encode timeout] + +-- |Remove and get the first element in a list (). Since Redis 1.0.0 +lpop + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f (Maybe ByteString)) +lpop key = sendRequest ["LPOP", encode key] + +-- | +-- Remove and get the first element in a list (). +-- The reply will consist of up to count elements, depending on the list's length. +-- Since Redis 1.0.0 +lpopCount + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer + -> m (f [ByteString]) +lpopCount key count = sendRequest ["LPOP", key, encode count] + +-- |Stop processing commands from clients for some time (). +-- Since Redis 2.9.50 +clientPause + :: (RedisCtx m f) + => Integer -- ^ timeout + -> m (f Status) +clientPause timeout = sendRequest ["CLIENT","PAUSE", encode timeout] + +-- |Set a key's time to live in seconds (). Since Redis 1.0.0 +expire + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ seconds + -> m (f Bool) +expire key seconds = sendRequest ["EXPIRE", key, encode seconds] + +-- |Get the values of all the given keys (). +-- Since Redis 1.0.0 +mget + :: (RedisCtx m f) + => NonEmpty ByteString -- ^ key + -> m (f [Maybe ByteString]) +mget (key:|keys_) = sendRequest ("MGET":key:keys_) + +-- | +-- Find first bit set or clear in a string (). +-- Since Redis 2.8.7 +bitpos + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ bit + -> Integer -- ^ start + -> Integer -- ^ end + -> m (f Integer) +bitpos key bit start end = sendRequest ["BITPOS", key, encode bit, encode start, encode end] + +lastsave + :: (RedisCtx m f) + => m (f Integer) +lastsave = sendRequest (["LASTSAVE"] ) + +-- | Set a key's time to live in milliseconds (). +-- Since Redis 2.6.0 +pexpire + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ milliseconds + -> m (f Bool) +pexpire key milliseconds = sendRequest ["PEXPIRE", key, encode milliseconds] + +-- |Get the list of client connections (). Since Redis 2.4.0 +clientList + :: (RedisCtx m f) + => m (f [ByteString]) +clientList = sendRequest (["CLIENT","LIST"] ) + +-- |Rename a key, only if the new key does not exist (). Since Redis 1.0.0 +renamenx + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ newkey + -> m (f Bool) +renamenx key newkey = sendRequest ["RENAMENX", key, newkey] + +-- |Merge N different HyperLogLogs into a single one (). Since Redis 2.8.9 +pfmerge + :: (RedisCtx m f) + => ByteString -- ^ destkey + -> [ByteString] -- ^ sourcekey + -> m (f ByteString) +pfmerge destkey sourcekey = sendRequest ("PFMERGE": destkey: sourcekey) + +-- | Remove elements from a list (). Since Redis 1.0.0 +lrem + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ count + -> ByteString -- ^ value + -> m (f Integer) +lrem key count value = sendRequest ["LREM", key, encode count, value] + +-- |Subtract multiple sets (). Since Redis 1.0.0 +sdiff + :: (RedisCtx m f) + => NonEmpty ByteString -- ^ key + -> m (f [ByteString]) +sdiff (key_:|keys_) = sendRequest ("SDIFF":key_:keys_) + +-- |Get the value of a key (). Since Redis 1.0.0 +get + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f (Maybe ByteString)) +get key = sendRequest (["GET"] ++ [encode key] ) + +-- |Get a substring of the string stored at a key (). +-- Since Redis 2.4.0 +getrange + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ start + -> Integer -- ^ end + -> m (f ByteString) +getrange key start end = sendRequest ["GETRANGE", key, encode start, encode end] + +-- |Subtract multiple sets and store the resulting set in a key (). Since Redis 1.0.0 +sdiffstore + :: (RedisCtx m f) + => ByteString -- ^ destination + -> NonEmpty ByteString -- ^ key + -> m (f Integer) +sdiffstore destination (key_:|keys_) = sendRequest ("SDIFFSTORE": destination: key_: keys_) + +-- |Count the members in a sorted set with scores within the given values (). Since Redis 2.0.0 +zcount + :: (RedisCtx m f) + => ByteString -- ^ key + -> Double -- ^ min + -> Double -- ^ max + -> m (f Integer) +zcount key min max = sendRequest ["ZCOUNT", key, encode min, encode max] + +-- |Load the specified Lua script into the script cache (). Since Redis 2.6.0 +scriptLoad + :: (RedisCtx m f) + => ByteString -- ^ script + -> m (f ByteString) +scriptLoad script = sendRequest ["SCRIPT","LOAD", encode script] + +-- |Set the string value of a key and return its old value (). Since Redis 1.0.0 +getset + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ value + -> m (f (Maybe ByteString)) +getset key value = sendRequest ["GETSET", key, value] + +-- |Return a serialized version of the value stored at the specified key (). Since Redis 2.6.0 +dump + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f ByteString) +dump key = sendRequest ["DUMP", key] + +-- |Find all keys matching the given pattern (). Since Redis 1.0.0 +keys + :: (RedisCtx m f) + => ByteString -- ^ pattern + -> m (f [ByteString]) +keys pattern = sendRequest ["KEYS", pattern] + +-- |Get the value of a configuration parameter (). Since Redis 2.0.0 +configGet + :: (RedisCtx m f) + => NonEmpty ByteString -- ^ parameter + -> m (f [(ByteString,ByteString)]) +configGet (parameter:|parameters) = sendRequest ("CONFIG":"GET":parameter:parameters) + +-- |Append one or multiple values to a list (). Since Redis 1.0.0 +rpush + :: (RedisCtx m f) + => ByteString -- ^ key + -> NonEmpty ByteString -- ^ value + -> m (f Integer) +rpush key (value:|values) = sendRequest ("RPUSH": encode key:value:values) + +-- |Return a random key from the keyspace (). Since Redis 1.0.0 +randomkey + :: (RedisCtx m f) + => m (f (Maybe ByteString)) +randomkey = sendRequest ["RANDOMKEY"] + +-- |Set the value of a hash field, only if the field does not exist (). Since Redis 2.0.0 +hsetnx + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ field + -> ByteString -- ^ value + -> m (f Bool) +hsetnx key field value = sendRequest ["HSETNX", key, field, value] + +-- |Set multiple keys to multiple values (). Since Redis 1.0.1 +mset + :: (RedisCtx m f) + => NonEmpty (ByteString,ByteString) -- ^ keyValue + -> m (f Status) +mset ((key_,value):|keyValue) = + sendRequest ("MSET":key_:value: concatMap (\(x,y) -> [encode x,encode y]) keyValue) + +-- |Set the value and expiration of a key (). +-- Regarded as deprected since 2.6 as it can be replaced by SET with the EX argument when +-- migrating or writing new code. +-- Since Redis 2.0.0 +setex + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ seconds + -> ByteString -- ^ value + -> m (f Status) +setex key seconds value = sendRequest ["SETEX", key, encode seconds, value] + +-- |Set the value and expiration in milliseconds of a key (). +-- Condidered deprecated since it can be replaced by SET with the PX argument when migrating or writing new code +-- Since Redis 2.6.0 +psetex + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ milliseconds + -> ByteString -- ^ value + -> m (f Status) +psetex key milliseconds value = sendRequest ["PSETEX", key, encode milliseconds, value] + +-- |Get the number of members in a set (). Since Redis 1.0.0 +scard + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f Integer) +scard key = sendRequest ["SCARD", key] + +-- |Check existence of scripts in the script cache (). Since Redis 2.6.0 +scriptExists + :: (RedisCtx m f) + => NonEmpty ByteString -- ^ script + -> m (f [Bool]) +scriptExists (script:|scripts) = sendRequest ("SCRIPT":"EXISTS":script:scripts) + +-- |Add multiple sets and store the resulting set in a key (). Since Redis 1.0.0 +sunionstore + :: (RedisCtx m f) + => ByteString -- ^ destination + -> NonEmpty ByteString -- ^ key + -> m (f Integer) +sunionstore destination (key_:|keys_) = + sendRequest ("SUNIONSTORE":destination:key_:keys_) + +-- |Remove the expiration from a key (). Since Redis 2.2.0 +persist + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f Bool) +persist key = sendRequest ["PERSIST", key] + +-- |Get the length of the value stored in a key (). Since Redis 2.2.0 +strlen + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f Integer) +strlen key = sendRequest ["STRLEN", encode key] + +-- |Prepend a value to a list, only if the list exists (). Since Redis 2.2.0 +lpushx + :: (RedisCtx m f) + => ByteString -- ^ key + -> NonEmpty ByteString -- ^ value + -> m (f Integer) +lpushx key (value:|values) = sendRequest ("LPUSHX":key:value:values) + +-- |Set the string value of a hash field (). +-- +-- This command oveerides keys if they exist in the hash. +-- +-- Since Redis 2.0.0 +hset + :: (RedisCtx m f) + => ByteString -- ^ key + -> NonEmpty (ByteString, ByteString) -- ^ Values. + -> m (f Integer) +hset key ((field,value):|fieldValues) = + sendRequest ("HSET":encode key:encode field:encode value:concatMap (\(f,v) ->[f,v]) fieldValues) + +-- |Pop a value from a list, push it to another list and return it; or block until one is available (). +-- +-- Since Redis 6.0 this command considered deprecated: it can be replaced by BLMOVE with the RIGHT and LEFT arguments when migrating or writing new code. +-- +-- Since Redis 2.2.0 +brpoplpush + :: (RedisCtx m f) + => ByteString -- ^ source + -> ByteString -- ^ destination + -> Integer -- ^ timeout + -> m (f (Maybe ByteString)) +brpoplpush source destination timeout = + sendRequest ["BRPOPLPUSH", source, destination, encode timeout] + +-- |Determine the index of a member in a sorted set, with scores ordered from high to low (). +-- Since Redis 2.0.0 +zrevrank + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ member + -> m (f (Maybe Integer)) +zrevrank key member = sendRequest ["ZREVRANK", key, member] + +zrevrankWithScore + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ member + -> m (f (Maybe (Integer, Double))) +zrevrankWithScore key member = sendRequest ["ZREVRANK", key, member] + +-- |Kill the script currently in execution (). Since Redis 2.6.0 +scriptKill + :: (RedisCtx m f) + => m (f Status) +scriptKill = sendRequest ["SCRIPT","KILL"] + +-- |Overwrite part of a string at key starting at the specified offset (). +-- +-- Returns the lenght of the string after it was modified. +-- +-- Since Redis 2.2.0 +setrange + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ offset + -> ByteString -- ^ value + -> m (f Integer) +setrange key offset value = sendRequest ["SETRANGE", key, encode offset, value] + +-- | Delete a key (). +-- Returns a number of keys that were removed. +-- Since Redis 1.0.0 +del + :: (RedisCtx m f) + => NonEmpty ByteString -- ^ List of keys to delete. + -> m (f Integer) +del (key:|rest) = sendRequest ("DEL":key:rest) + +-- |Increment the float value of a hash field by the given amount (). +-- Since Redis 2.6.0 +hincrbyfloat + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ field + -> Double -- ^ increment + -> m (f Double) +hincrbyfloat key field increment = sendRequest ["HINCRBYFLOAT", key, field, encode increment] + +-- | Increment the integer value of a hash field by the given number (). Since Redis 2.0.0 +hincrby + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ field + -> Int64 -- ^ increment + -> m (f Int64) +hincrby key field increment = sendRequest ["HINCRBY", encode key, encode field, encode increment] + +-- | O(log(N)+M) with @N@ being thee number of elements in thee sorted set and @M@ the number +-- of elements removed by the operation. +-- +-- Remove all members in a sorted set between the given lexicographical range (). +-- +-- Returns number of elements that were removed. +-- +-- Since Redis 2.8.9 +zremrangebylex + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ min + -> ByteString -- ^ max + -> m (f Integer) +zremrangebylex key min max = sendRequest (["ZREMRANGEBYLEX"] ++ [encode key] ++ [encode min] ++ [encode max] ) + +-- |Remove and get the last element in a list (). +-- Since Redis 1.0.0 +rpop + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f (Maybe ByteString)) +rpop key = sendRequest ["RPOP", encode key] + +-- |Remove and get the last element in a list (). +-- The reply will consist of up to count elements, depending on the list's length. +-- Result will have no more than @N@ arguments. +-- +-- Since Redis 1.0.0 +rpopCount + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer + -> m (f [ByteString]) +rpopCount key count = sendRequest (["RPOP",key, encode count] ) + +-- |Rename a key (). Since Redis 1.0.0 +-- +-- Does not return a error even if newkey existed. +rename + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ newkey + -> m (f Status) +rename key newkey = sendRequest ["RENAME", encode key, encode newkey] + +-- | /O(M*log(N))/ with @N@ number of elements in the sorted set, @M@ number of elements to be +-- removed. +-- +-- Removes one or more members from a sorted set (). +-- +-- Since Redis 1.2.0 +zrem + :: (RedisCtx m f) + => ByteString -- ^ key + -> NonEmpty ByteString -- ^ member + -> m (f Integer) +zrem key (member:|members) = sendRequest ("ZREM":encode key:encode member:members) + +-- |Determine if a hash field exists (). +-- Since Redis 2.0.0 +hexists + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ field + -> m (f Bool) +hexists key field = sendRequest ["HEXISTS", key, field] + +-- |Get the current connection ID (). Since Redis 5.0.0 +clientId + :: (RedisCtx m f) + => m (f Integer) +clientId = sendRequest ["CLIENT","ID"] + +-- |Get the current connection name (). Since Redis 2.6.9 +clientGetname + :: (RedisCtx m f) + => m (f (Maybe ByteString)) +clientGetname = sendRequest ["CLIENT","GETNAME"] + +-- |Rewrite the configuration file with the in memory configuration (). Since Redis 2.8.0 +configRewrite + :: (RedisCtx m f) + => m (f Status) +configRewrite = sendRequest ["CONFIG","REWRITE"] + +-- |Decrement the integer value of a key by one (). +-- Since Redis 1.0.0 +decr + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f Integer) +decr key = sendRequest ["DECR", key] + +-- |Get the values of all the given hash fields (). +-- Since Redis 2.0.0 +hmget + :: (RedisCtx m f) + => ByteString -- ^ key + -> NonEmpty ByteString -- ^ field + -> m (f [Maybe ByteString]) +hmget key (field:|fields) = sendRequest ("HMGET":key:field:fields) + +-- |Get a range of elements from a list (). Since Redis 1.0.0 +lrange + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ start + -> Integer -- ^ stop + -> m (f [ByteString]) +lrange key start stop = sendRequest ["LRANGE", key, encode start, encode stop] + +-- |Decrement the integer value of a key by the given number (). +-- Since Redis 1.0.0 +decrby + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ decrement + -> m (f Integer) +decrby key decrement = sendRequest ["DECRBY",key, encode decrement] + +-- |Get the length of a list (). Since Redis 1.0.0 +llen + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f Integer) +llen key = sendRequest ["LLEN", encode key] + +-- | /O(1)/ Append a value to a key (). Since Redis 2.0.0 +append + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ value + -> m (f Integer) +append key value = sendRequest ["APPEND", key, value] + +-- |Increment the integer value of a key by one (). Since Redis 1.0.0 +incr + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f Integer) +incr key = sendRequest ["INCR", key] + +-- |Get the value of a hash field (). Since Redis 2.0.0 +hget + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ field + -> m (f (Maybe ByteString)) +hget key field = sendRequest ["HGET",key,field] + +-- |Set the expiration for a key as a UNIX timestamp specified in milliseconds (). Since Redis 2.6.0 +pexpireat + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ millisecondsTimestamp + -> m (f Bool) +pexpireat key millisecondsTimestamp = sendRequest ["PEXPIREAT", key, encode millisecondsTimestamp] + +-- | Trim a list to the specified range (). +-- Since Redis 1.0.0 +ltrim + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ start + -> Integer -- ^ stop + -> m (f Status) +ltrim key start stop = sendRequest ["LTRIM", key, encode start, encode stop] + +-- | /O(1)/ +-- Get the number of members in a sorted set (). +-- Since Redis 1.2.0 +zcard + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f Integer) +zcard key = sendRequest ["ZCARD", key] + +-- | Set the value of an element in a list by its index (). +-- Since Redis 1.0.0 +lset + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ index + -> ByteString -- ^ value + -> m (f Status) +lset key index value = sendRequest ["LSET", key, encode index, value] + +-- | Set the expiration for a key as a UNIX timestamp (). +-- Since Redis 1.2.0 +expireat + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ timestamp + -> m (f Bool) +expireat key timestamp = sendRequest ["EXPIREAT", key, encode timestamp] + +-- | Synchronously save the dataset to disk (). +-- Since Redis 1.0.0 +save + :: (RedisCtx m f) + => m (f Status) +save = sendRequest ["SAVE"] + +-- | +-- Move a key to another database (). +-- Since Redis 1.0.0 +move + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ db + -> m (f Bool) +move key db = sendRequest ["MOVE", key, encode db] + +-- | +-- Returns the bit value at offset in the string value stored at key (). Since Redis 2.2.0 +getbit + :: (RedisCtx m f) + => ByteString -- ^ Key. + -> Integer -- ^ Offset. + -> m (f Integer) +getbit key offset = sendRequest ["GETBIT", key, encode offset] + +-- |Set multiple keys to multiple values, only if none of the keys exist (). +-- Since Redis 1.0.1 +msetnx + :: (RedisCtx m f) + => NonEmpty (ByteString,ByteString) -- ^ keyValue + -> m (f Bool) +msetnx ((key,value):|keysValues) = + sendRequest ("MSETNX":key:value:concatMap (\(x,y) -> [encode x,encode y]) keysValues) + +-- |Get array of specific Redis command details (). +-- Since Redis 2.8.13 +commandInfo + :: (RedisCtx m f) + => [ByteString] -- ^ commandName + -> m (f [ByteString]) +commandInfo commandName = sendRequest ("COMMAND":"INFO":map encode commandName ) + +-- | Close the connection (). Since Redis 1.0.0 +quit + :: (RedisCtx m f) + => m (f Status) +quit = sendRequest ["QUIT"] + +-- |Remove and get the first element in a list, or block until one is available (). Since Redis 2.0.0 +blpop + :: (RedisCtx m f) + => [ByteString] -- ^ key + -> Integer -- ^ timeout + -> m (f (Maybe (ByteString,ByteString))) +blpop keys_ timeout = sendRequest ("BLPOP":keys_ ++ [encode timeout] ) + +-- |Remove and get the first element in a list, or block until one is available (). Since Redis 6.0.0 +blpopFloat + :: (RedisCtx m f) + => [ByteString] -- ^ key + -> Integer -- ^ timeout + -> m (f (Maybe (ByteString,ByteString))) +blpopFloat keys_ timeout = sendRequest ("BLPOP":keys_ ++ [encode timeout] ) + +-- | /O(N)/ where @N@ is the number of members to be removed. +-- Remove one or more members from a set (). +-- +-- Returns the number of members that were removed from the seet, not including non +-- existing elements. +-- +-- Since Redis 1.0.0 +srem + :: (RedisCtx m f) + => ByteString -- ^ Key of the set. + -> NonEmpty ByteString -- ^ List of members to be removed. + -> m (f Integer) +srem key (member:|members) = sendRequest ("SREM":key:member:members) + +-- |Echo the given string (). Since Redis 1.0.0 +echo + :: (RedisCtx m f) + => ByteString -- ^ message + -> m (f ByteString) +echo message = sendRequest ["ECHO", encode message] + +-- |Determine if a given value is a member of a set (). +-- Since Redis 1.0.0 +sismember + :: (RedisCtx m f) + => ByteString -- ^ Key. + -> ByteString -- ^ member + -> m (f Bool) +sismember key member = sendRequest ["SISMEMBER",key, member] + +-- $autoclaim +-- +-- Family of the commands related to the autoclaim command in redis, they provide an +-- ability to claim messages that are not processed for a long time. +-- +-- Transfers ownership of pending stream entries that match +-- the specified criteria. The message should be pending for more than \ +-- milliseconds and ID should be greater than \. +-- +-- Redis @xautoclaim@ command is split info `xautoclaim`, `xautoclaimOpts`, `xautoclaimJustIds` +-- `xautoclaimJustIdsOpt` functions. +-- +-- All commands are available since Redis 7.0 + +-- $xpending +-- The Redis @XPENDING@ command is split into 'xpendingSummary' and 'xpendingDetail'. + +-- $xgroupCreate +-- Create a consumer group. The redis command @XGROUP CREATE@ is split up into 'xgroupCreate', 'xgroupCreateOpts'. + +-- $xgroupSetId +-- Sets last delivered ID for a consumer group. The redis command @XGROUP SETID@ is split up into 'xgroupSetId' and 'xgroupSetIdOpts' methods. + + +-- $auth +-- Authenticate to the server (). Since Redis 1.0.0 + diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs --- a/src/Database/Redis/Connection.hs +++ b/src/Database/Redis/Connection.hs @@ -6,32 +6,35 @@ import Control.Exception import qualified Control.Monad.Catch as Catch import Control.Monad.IO.Class(liftIO, MonadIO) -import Control.Monad(when) +import Control.Monad(when, forM_) 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 Data.Pool 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 Data.Text as T import qualified Database.Redis.ProtocolPipelining as PP -import Database.Redis.Core(Redis, runRedisInternal, runRedisClusteredInternal) +import Database.Redis.Core(Redis, Hooks, runRedisInternal, runRedisClusteredInternal, defaultHooks) 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 - , auth + , authOpts + , defaultAuthOpts + , AuthOpts(..) + , clusterInfo , clusterSlots , command + , ClusterInfoResponseState (..) + , ClusterInfoResponse (..) , ClusterSlotsResponse(..) , ClusterSlotsResponseEntry(..) , ClusterSlotsNode(..)) @@ -59,18 +62,20 @@ -- @ -- data ConnectInfo = ConnInfo - { connectHost :: NS.HostName - -- ^ Ignored when 'connectPort' is a 'UnixSocket' - , connectPort :: CC.PortID + { connectAddr :: CC.ConnectAddr , 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. + , connectUsername :: Maybe B.ByteString + -- ^ When ACL is used set 'connectUsername' as the user. , 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. + , connectNumStripes :: Maybe Int + -- ^ Number of stripes in the connection pool. , 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 @@ -82,58 +87,63 @@ -- get connected in this interval of time. , connectTLSParams :: Maybe ClientParams -- ^ Optional TLS parameters. TLS will be enabled if this is provided. + , connectHooks :: Hooks + -- ^ Connection hooks. + , connectPoolLabel :: T.Text + -- ^ Label of the connection pool for instrumentation. } deriving Show data ConnectError = ConnectAuthError Reply | ConnectSelectError Reply - deriving (Eq, Show, Typeable) + deriving (Eq, Show) instance Exception ConnectError -- |Default information for connecting: -- -- @ --- connectHost = \"localhost\" --- connectPort = PortNumber 6379 -- Redis default port +-- connectAddr = ConnectAddrHostPort \"localhost\" 6379 -- Redis default port -- connectAuth = Nothing -- No password +-- connectUsername = Nothing -- No user -- connectDatabase = 0 -- SELECT database 0 -- connectMaxConnections = 50 -- Up to 50 connections +-- connectNumStripes = Just 1 -- A single stripe -- connectMaxIdleTime = 30 -- Keep open for 30 seconds -- connectTimeout = Nothing -- Don't add timeout logic -- connectTLSParams = Nothing -- Do not use TLS +-- connectHooks = defaultHooks -- Do nothing +-- connectPoolLabel = "" -- no label -- @ -- defaultConnectInfo :: ConnectInfo defaultConnectInfo = ConnInfo - { connectHost = "localhost" - , connectPort = CC.PortNumber 6379 + { connectAddr = CC.ConnectAddrHostPort "localhost" 6379 , connectAuth = Nothing + , connectUsername = Nothing , connectDatabase = 0 , connectMaxConnections = 50 + , connectNumStripes = Just 1 , connectMaxIdleTime = 30 , connectTimeout = Nothing , connectTLSParams = Nothing + , connectHooks = defaultHooks + , connectPoolLabel = "" } 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 + conn' <- PP.connectWithHooks connectAddr timeoutOptUs connectTLSParams connectHooks 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 () + forM_ connectAuth $ \pass -> do + resp <- authOpts pass defaultAuthOpts{ authOptsUsername = connectUsername} + case resp of + Left r -> liftIO $ throwIO $ ConnectAuthError r + _ -> return () -- SELECT when (connectDatabase /= 0) $ do resp <- select connectDatabase @@ -147,7 +157,7 @@ -- until the first call to the server. connect :: ConnectInfo -> IO Connection connect cInfo@ConnInfo{..} = NonClusteredConnection <$> - createPool (createConnection cInfo) PP.disconnect 1 connectMaxIdleTime connectMaxConnections + newPool (setPoolLabel connectPoolLabel . setNumStripes connectNumStripes $ defaultPoolConfig (createConnection cInfo) PP.disconnect (realToFrac connectMaxIdleTime) connectMaxConnections) -- |Constructs a 'Connection' pool to a Redis server designated by the -- given 'ConnectInfo', then tests if the server is actually there. @@ -159,6 +169,25 @@ runRedis conn $ void ping return conn +-- |Constructs a 'Connection' pool to a Redis cluster 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. +checkedConnectCluster :: ConnectInfo -> IO Connection +checkedConnectCluster connInfo = do + conn <- connectCluster connInfo + res <- runRedis conn clusterInfo + case res of + Right r -> case clusterInfoResponseState r of + OK -> pure conn + Down -> throwIO $ ClusterDownError r + Left e -> throwIO $ ClusterConnectError e + +newtype ClusterDownError = ClusterDownError ClusterInfoResponse + deriving (Eq, Show) + +instance Exception ClusterDownError + -- |Destroy all idle resources in the pool. disconnect :: Connection -> IO () disconnect (NonClusteredConnection pool) = destroyAllResources pool @@ -179,12 +208,12 @@ -- 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 + withResource pool $ \conn -> runRedisInternal conn redis runRedis (ClusteredConnection _ pool) redis = withResource pool $ \conn -> runRedisClusteredInternal conn (refreshShardMap conn) redis newtype ClusterConnectError = ClusterConnectError Reply - deriving (Eq, Show, Typeable) + deriving (Eq, Show) instance Exception ClusterConnectError @@ -198,19 +227,32 @@ -- - PUBLISH, SUBSCRIBE, PSUBSCRIBE, UNSUBSCRIBE, PUNSUBSCRIBE, RESET connectCluster :: ConnectInfo -> IO Connection connectCluster bootstrapConnInfo = do - conn <- createConnection bootstrapConnInfo - slotsResponse <- runRedisInternal conn clusterSlots - shardMapVar <- case slotsResponse of - Left e -> throwIO $ ClusterConnectError e - Right slots -> do - shardMap <- shardMapFromClusterSlotsResponse slots - 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 + bracket (createConnection bootstrapConnInfo) PP.disconnect $ \conn -> do + slotsResponse <- runRedisInternal conn clusterSlots + shardMapVar <- case slotsResponse of + Left e -> throwIO $ ClusterConnectError e + Right slots -> do + shardMap <- shardMapFromClusterSlotsResponse slots + newMVar shardMap + commandInfos <- runRedisInternal conn command + let timeoutOptUs = + round . (1000000 *) <$> connectTimeout bootstrapConnInfo + case commandInfos of + Left e -> throwIO $ ClusterConnectError e + Right infos -> do + pool <- newPool (setPoolLabel (connectPoolLabel bootstrapConnInfo) + $ setNumStripes (connectNumStripes bootstrapConnInfo) + $ defaultPoolConfig + (Cluster.connectWith + (connectUsername bootstrapConnInfo) + (connectAuth bootstrapConnInfo) + (connectTLSParams bootstrapConnInfo) + infos shardMapVar timeoutOptUs + $ connectHooks bootstrapConnInfo) + Cluster.disconnect + (realToFrac $ connectMaxIdleTime bootstrapConnInfo) + (connectMaxConnections bootstrapConnInfo)) + return $ ClusteredConnection shardMapVar pool shardMapFromClusterSlotsResponse :: ClusterSlotsResponse -> IO ShardMap shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr mkShardMap (pure IntMap.empty) clusterSlotsResponseEntries where @@ -230,8 +272,8 @@ 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{connectionNodes=nodeConns} = do + let Cluster.NodeConnection{nodeConnectionContext=ctx} = head $ HM.elems nodeConns pipelineConn <- PP.fromCtx ctx _ <- PP.beginReceiving pipelineConn slotsResponse <- runRedisInternal pipelineConn clusterSlots diff --git a/src/Database/Redis/ConnectionContext.hs b/src/Database/Redis/ConnectionContext.hs --- a/src/Database/Redis/ConnectionContext.hs +++ b/src/Database/Redis/ConnectionContext.hs @@ -6,7 +6,7 @@ ConnectionContext(..) , ConnectTimeout(..) , ConnectionLostException(..) - , PortID(..) + , ConnectAddr(..) , connect , disconnect , send @@ -17,26 +17,25 @@ , 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.Char8 as Char8 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 Control.Exception(bracketOnError, Exception, throwIO, try, finally, mask_) 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) +import System.Timeout (timeout) -data ConnectionContext = NormalHandle Handle | TLSContext TLS.Context +data ConnectionContext = NormalHandle Handle | TLSContext TLS.Context Handle instance Show ConnectionContext where show (NormalHandle _) = "NormalHandle" - show (TLSContext _) = "TLSContext" + show (TLSContext _ _) = "TLSContext" data Connection = Connection { ctx :: ConnectionContext @@ -52,22 +51,33 @@ deriving (Show) newtype ConnectTimeout = ConnectTimeout ConnectPhase - deriving (Show, Typeable) + deriving (Show) instance Exception ConnectTimeout data ConnectionLostException = ConnectionLost deriving Show instance Exception ConnectionLostException -data PortID = PortNumber NS.PortNumber - | UnixSocket String - deriving (Eq, Show) +data ConnectAddr + = ConnectAddrHostPort NS.HostName NS.PortNumber + | ConnectAddrUnixSocket String + deriving (Eq, Show) -connect :: NS.HostName -> PortID -> Maybe Int -> IO ConnectionContext -connect hostName portId timeoutOpt = +connect :: ConnectAddr -> Maybe Int -> Maybe TLS.ClientParams -> IO ConnectionContext +connect connectAddr timeoutOpt mTlsParams = bracketOnError hConnect hClose $ \h -> do hSetBinaryMode h True - return $ NormalHandle h + case (mTlsParams, connectAddr) of + (Just defaultTlsParams, ConnectAddrHostPort host port) -> do + -- The defaultTlsParams are used to connect to the first + -- host in the cluster, other hosts have different + -- hostnames and so require a different server + -- identification params + let tlsParams = defaultTlsParams { + TLS.clientServerIdentification = (host, Char8.pack $ show port) + } + enableTLS tlsParams (NormalHandle h) + _ -> return $ NormalHandle h where hConnect = do phaseMVar <- newMVar PhaseUnknown @@ -75,10 +85,10 @@ case timeoutOpt of Nothing -> doConnect Just micros -> do - result <- race doConnect (threadDelay micros) + result <- timeout micros doConnect case result of - Left h -> return h - Right () -> do + Just h -> return h + Nothing -> do phase <- readMVar phaseMVar errConnectTimeout phase hConnect' mvar = bracketOnError createSock NS.close $ \sock -> do @@ -87,18 +97,17 @@ void $ swapMVar mvar PhaseOpenSocket NS.socketToHandle sock ReadWriteMode where - createSock = case portId of - PortNumber portNumber -> do + createSock = case connectAddr of + ConnectAddrHostPort hostName portNumber -> do addrInfo <- getHostAddrInfo hostName portNumber connectSocket addrInfo - UnixSocket addr -> bracketOnError + ConnectAddrUnixSocket 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) +getHostAddrInfo hostname port = NS.getAddrInfo (Just hints) (Just hostname) (Just $ show port) where hints = NS.defaultHints { NS.addrSocketType = NS.Stream } @@ -126,13 +135,13 @@ 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)) + 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 +recv (TLSContext ctx _) = TLS.recvData ctx ioErrorToConnLost :: IO a -> IO a @@ -146,17 +155,17 @@ enableTLS tlsParams (NormalHandle h) = do ctx <- TLS.contextNew h tlsParams TLS.handshake ctx - return $ TLSContext ctx -enableTLS _ c@(TLSContext _) = return c + return $! TLSContext ctx h +enableTLS _ c@(TLSContext _ _) = return c + disconnect :: ConnectionContext -> IO () -disconnect (NormalHandle h) = do +disconnect (NormalHandle h) = mask_ $ do open <- hIsOpen h when open $ hClose h -disconnect (TLSContext ctx) = do - TLS.bye ctx - TLS.contextClose ctx +disconnect (TLSContext ctx h) = + TLS.bye ctx `finally` TLS.contextClose ctx `finally` (hIsOpen h >>= \open -> when open $ hClose h) flush :: ConnectionContext -> IO () flush (NormalHandle h) = hFlush h -flush (TLSContext c) = TLS.contextFlush c +flush (TLSContext ctx _) = TLS.contextFlush ctx diff --git a/src/Database/Redis/Core.hs b/src/Database/Redis/Core.hs --- a/src/Database/Redis/Core.hs +++ b/src/Database/Redis/Core.hs @@ -1,13 +1,15 @@ {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, RecordWildCards, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, CPP, - DeriveDataTypeable, StandaloneDeriving #-} + DeriveDataTypeable, StandaloneDeriving, UndecidableInstances #-} module Database.Redis.Core ( Redis(), unRedis, reRedis, RedisCtx(..), MonadRedis(..), + Hooks(..), SendRequestHook, SendPubSubHook, CallbackHook, SendHook, ReceiveHook, send, recv, sendRequest, runRedisInternal, runRedisClusteredInternal, + defaultHooks, RedisEnv(..), ) where @@ -24,6 +26,7 @@ import Database.Redis.Types import Database.Redis.Cluster(ShardMap) import qualified Database.Redis.Cluster as Cluster +import Database.Redis.Hooks -------------------------------------------------------------------------------- -- The Redis Monad @@ -40,6 +43,12 @@ class (Monad m) => MonadRedis m where liftRedis :: Redis a -> m a +instance {-# OVERLAPPABLE #-} + ( MonadTrans t + , MonadRedis m + , Monad (t m) + ) => MonadRedis (t m) where + liftRedis = lift . liftRedis instance RedisCtx Redis (Either Reply) where returnDecode = return . decode @@ -74,9 +83,9 @@ 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 + ref <- newIORef (SingleLine "no reply yet") + r <- runReaderT redis (ClusteredEnv refreshShardmapAction connection ref) + r `seq` return r setLastReply :: Reply -> ReaderT RedisEnv IO () setLastReply r = do @@ -112,8 +121,11 @@ env <- ask case env of NonClusteredEnv{..} -> do - r <- liftIO $ PP.request envConn (renderRequest req) + r <- liftIO $ sendRequestHook (PP.hooks envConn) (PP.request envConn . renderRequest) req setLastReply r return r - ClusteredEnv{..} -> liftIO $ Cluster.requestPipelined refreshAction connection req + ClusteredEnv{..} -> do + r <- liftIO $ sendRequestHook (Cluster.hooks connection) (Cluster.requestPipelined refreshAction connection) req + setLastReply r + return r returnDecode r' diff --git a/src/Database/Redis/Core/Internal.hs b/src/Database/Redis/Core/Internal.hs --- a/src/Database/Redis/Core/Internal.hs +++ b/src/Database/Redis/Core/Internal.hs @@ -1,11 +1,13 @@ {-# 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.Catch import Control.Monad.Reader import Data.IORef import Database.Redis.Protocol @@ -20,13 +22,18 @@ -- possibility of Redis returning an 'Error' reply. newtype Redis a = Redis (ReaderT RedisEnv IO a) - deriving (Monad, MonadIO, Functor, Applicative, MonadUnliftIO) + deriving (Monad, MonadIO, Functor, Applicative, MonadUnliftIO, MonadThrow, MonadCatch, MonadMask) #if __GLASGOW_HASKELL__ > 711 deriving instance MonadFail Redis #endif data RedisEnv - = NonClusteredEnv { envConn :: PP.Connection, envLastReply :: IORef Reply } + = 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/Hooks.hs b/src/Database/Redis/Hooks.hs new file mode 100644 --- /dev/null +++ b/src/Database/Redis/Hooks.hs @@ -0,0 +1,44 @@ +module Database.Redis.Hooks where + +import Data.ByteString (ByteString) +import Database.Redis.Protocol (Reply) +import {-# SOURCE #-} Database.Redis.PubSub (Message, PubSub) + +data Hooks = + Hooks + { sendRequestHook :: SendRequestHook + , sendPubSubHook :: SendPubSubHook + , callbackHook :: CallbackHook + , sendHook :: SendHook + , receiveHook :: ReceiveHook + } + +-- | A hook for sending commands to the server and receiving replys from the server. +type SendRequestHook = ([ByteString] -> IO Reply) -> [ByteString] -> IO Reply + +-- | A hook for sending pub/sub messages to the server. +type SendPubSubHook = ([ByteString] -> IO ()) -> [ByteString] -> IO () + +-- | A hook for invoking callbacks with pub/sub messages. +type CallbackHook = (Message -> IO PubSub) -> Message -> IO PubSub + +-- | A hook for just sending raw data to the server. +type SendHook = (ByteString -> IO ()) -> ByteString -> IO () + +-- | A hook for receiving raw data from the server. +type ReceiveHook = IO Reply -> IO Reply + +-- | The default hooks. +-- Every hook is the identity function. +defaultHooks :: Hooks +defaultHooks = + Hooks + { sendRequestHook = id + , sendPubSubHook = id + , callbackHook = id + , sendHook = id + , receiveHook = id + } + +instance Show Hooks where + show _ = "Hooks {sendRequestHook = _, sendPubSubHook = _, callbackHook = _, sendHook = _, receiveHook = _}" diff --git a/src/Database/Redis/ManualCommands.hs b/src/Database/Redis/ManualCommands.hs --- a/src/Database/Redis/ManualCommands.hs +++ b/src/Database/Redis/ManualCommands.hs @@ -6,1422 +6,2245 @@ 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 -import qualified Database.Redis.Cluster.Command as CMD - - -objectRefcount - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f Integer) -objectRefcount key = sendRequest ["OBJECT", "refcount", encode key] - -objectIdletime - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f Integer) -objectIdletime key = sendRequest ["OBJECT", "idletime", encode key] - -objectEncoding - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f ByteString) -objectEncoding key = sendRequest ["OBJECT", "encoding", encode key] - -linsertBefore - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ pivot - -> ByteString -- ^ value - -> m (f Integer) -linsertBefore key pivot value = - sendRequest ["LINSERT", encode key, "BEFORE", encode pivot, encode value] - -linsertAfter - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ pivot - -> ByteString -- ^ value - -> m (f Integer) -linsertAfter key pivot value = - sendRequest ["LINSERT", encode key, "AFTER", encode pivot, encode value] - -getType - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f RedisType) -getType key = sendRequest ["TYPE", encode key] - --- |A single entry from the slowlog. -data Slowlog = Slowlog - { slowlogId :: Integer - -- ^ A unique progressive identifier for every slow log entry. - , slowlogTimestamp :: Integer - -- ^ The unix timestamp at which the logged command was processed. - , slowlogMicros :: Integer - -- ^ The amount of time needed for its execution, in microseconds. - , slowlogCmd :: [ByteString] - -- ^ The command and it's arguments. - , slowlogClientIpAndPort :: Maybe ByteString - , slowlogClientName :: Maybe ByteString - } deriving (Show, Eq) - -instance RedisResult Slowlog where - decode (MultiBulk (Just [logId,timestamp,micros,cmd])) = do - slowlogId <- decode logId - slowlogTimestamp <- decode timestamp - slowlogMicros <- decode micros - slowlogCmd <- decode cmd - let slowlogClientIpAndPort = Nothing - slowlogClientName = Nothing - return Slowlog{..} - decode (MultiBulk (Just [logId,timestamp,micros,cmd,ip,cname])) = do - slowlogId <- decode logId - slowlogTimestamp <- decode timestamp - slowlogMicros <- decode micros - slowlogCmd <- decode cmd - slowlogClientIpAndPort <- Just <$> decode ip - slowlogClientName <- Just <$> decode cname - return Slowlog{..} - decode r = Left r - -slowlogGet - :: (RedisCtx m f) - => Integer -- ^ cnt - -> m (f [Slowlog]) -slowlogGet n = sendRequest ["SLOWLOG", "GET", encode n] - -slowlogLen :: (RedisCtx m f) => m (f Integer) -slowlogLen = sendRequest ["SLOWLOG", "LEN"] - -slowlogReset :: (RedisCtx m f) => m (f Status) -slowlogReset = sendRequest ["SLOWLOG", "RESET"] - -zrange - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ start - -> Integer -- ^ stop - -> m (f [ByteString]) -zrange key start stop = - sendRequest ["ZRANGE", encode key, encode start, encode stop] - -zrangeWithscores - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ start - -> Integer -- ^ stop - -> m (f [(ByteString, Double)]) -zrangeWithscores key start stop = - sendRequest ["ZRANGE", encode key, encode start, encode stop, "WITHSCORES"] - -zrevrange - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ start - -> Integer -- ^ stop - -> m (f [ByteString]) -zrevrange key start stop = - sendRequest ["ZREVRANGE", encode key, encode start, encode stop] - -zrevrangeWithscores - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ start - -> Integer -- ^ stop - -> m (f [(ByteString, Double)]) -zrevrangeWithscores key start stop = - sendRequest ["ZREVRANGE", encode key, encode start, encode stop - ,"WITHSCORES"] - -zrangebyscore - :: (RedisCtx m f) - => ByteString -- ^ key - -> Double -- ^ min - -> Double -- ^ max - -> m (f [ByteString]) -zrangebyscore key min max = - sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max] - -zrangebyscoreWithscores - :: (RedisCtx m f) - => ByteString -- ^ key - -> Double -- ^ min - -> Double -- ^ max - -> m (f [(ByteString, Double)]) -zrangebyscoreWithscores key min max = - sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max - ,"WITHSCORES"] - -zrangebyscoreLimit - :: (RedisCtx m f) - => ByteString -- ^ key - -> Double -- ^ min - -> Double -- ^ max - -> Integer -- ^ offset - -> Integer -- ^ count - -> m (f [ByteString]) -zrangebyscoreLimit key min max offset count = - sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max - ,"LIMIT", encode offset, encode count] - -zrangebyscoreWithscoresLimit - :: (RedisCtx m f) - => ByteString -- ^ key - -> Double -- ^ min - -> Double -- ^ max - -> Integer -- ^ offset - -> Integer -- ^ count - -> m (f [(ByteString, Double)]) -zrangebyscoreWithscoresLimit key min max offset count = - sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max - ,"WITHSCORES","LIMIT", encode offset, encode count] - -zrevrangebyscore - :: (RedisCtx m f) - => ByteString -- ^ key - -> Double -- ^ max - -> Double -- ^ min - -> m (f [ByteString]) -zrevrangebyscore key min max = - sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max] - -zrevrangebyscoreWithscores - :: (RedisCtx m f) - => ByteString -- ^ key - -> Double -- ^ max - -> Double -- ^ min - -> m (f [(ByteString, Double)]) -zrevrangebyscoreWithscores key min max = - sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max - ,"WITHSCORES"] - -zrevrangebyscoreLimit - :: (RedisCtx m f) - => ByteString -- ^ key - -> Double -- ^ max - -> Double -- ^ min - -> Integer -- ^ offset - -> Integer -- ^ count - -> m (f [ByteString]) -zrevrangebyscoreLimit key min max offset count = - sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max - ,"LIMIT", encode offset, encode count] - -zrevrangebyscoreWithscoresLimit - :: (RedisCtx m f) - => ByteString -- ^ key - -> Double -- ^ max - -> Double -- ^ min - -> Integer -- ^ offset - -> Integer -- ^ count - -> m (f [(ByteString, Double)]) -zrevrangebyscoreWithscoresLimit key min max offset count = - sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max - ,"WITHSCORES","LIMIT", encode offset, encode count] - --- |Options for the 'sort' command. -data SortOpts = SortOpts - { sortBy :: Maybe ByteString - , sortLimit :: (Integer,Integer) - , sortGet :: [ByteString] - , sortOrder :: SortOrder - , sortAlpha :: Bool - } deriving (Show, Eq) - --- |Redis default 'SortOpts'. Equivalent to omitting all optional parameters. --- --- @ --- SortOpts --- { sortBy = Nothing -- omit the BY option --- , sortLimit = (0,-1) -- return entire collection --- , sortGet = [] -- omit the GET option --- , sortOrder = Asc -- sort in ascending order --- , sortAlpha = False -- sort numerically, not lexicographically --- } --- @ --- -defaultSortOpts :: SortOpts -defaultSortOpts = SortOpts - { sortBy = Nothing - , sortLimit = (0,-1) - , sortGet = [] - , sortOrder = Asc - , sortAlpha = False - } - -data SortOrder = Asc | Desc deriving (Show, Eq) - -sortStore - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ destination - -> SortOpts - -> m (f Integer) -sortStore key dest = sortInternal key (Just dest) - -sort - :: (RedisCtx m f) - => ByteString -- ^ key - -> SortOpts - -> m (f [ByteString]) -sort key = sortInternal key Nothing - -sortInternal - :: (RedisResult a, RedisCtx m f) - => ByteString -- ^ key - -> Maybe ByteString -- ^ destination - -> SortOpts - -> m (f a) -sortInternal key destination SortOpts{..} = sendRequest $ - concat [["SORT", encode key], by, limit, get, order, alpha, store] - where - by = maybe [] (\pattern -> ["BY", pattern]) sortBy - limit = let (off,cnt) = sortLimit in ["LIMIT", encode off, encode cnt] - get = concatMap (\pattern -> ["GET", pattern]) sortGet - order = case sortOrder of Desc -> ["DESC"]; Asc -> ["ASC"] - alpha = ["ALPHA" | sortAlpha] - store = maybe [] (\dest -> ["STORE", dest]) destination - - -data Aggregate = Sum | Min | Max deriving (Show,Eq) - -zunionstore - :: (RedisCtx m f) - => ByteString -- ^ destination - -> [ByteString] -- ^ keys - -> Aggregate - -> m (f Integer) -zunionstore dest keys = - zstoreInternal "ZUNIONSTORE" dest keys [] - -zunionstoreWeights - :: (RedisCtx m f) - => ByteString -- ^ destination - -> [(ByteString,Double)] -- ^ weighted keys - -> Aggregate - -> m (f Integer) -zunionstoreWeights dest kws = - let (keys,weights) = unzip kws - in zstoreInternal "ZUNIONSTORE" dest keys weights - -zinterstore - :: (RedisCtx m f) - => ByteString -- ^ destination - -> [ByteString] -- ^ keys - -> Aggregate - -> m (f Integer) -zinterstore dest keys = - zstoreInternal "ZINTERSTORE" dest keys [] - -zinterstoreWeights - :: (RedisCtx m f) - => ByteString -- ^ destination - -> [(ByteString,Double)] -- ^ weighted keys - -> Aggregate - -> m (f Integer) -zinterstoreWeights dest kws = - let (keys,weights) = unzip kws - in zstoreInternal "ZINTERSTORE" dest keys weights - -zstoreInternal - :: (RedisCtx m f) - => ByteString -- ^ cmd - -> ByteString -- ^ destination - -> [ByteString] -- ^ keys - -> [Double] -- ^ weights - -> Aggregate - -> m (f Integer) -zstoreInternal cmd dest keys weights aggregate = sendRequest $ - concat [ [cmd, dest, encode . toInteger $ length keys], keys - , if null weights then [] else "WEIGHTS" : map encode weights - , ["AGGREGATE", aggregate'] - ] - where - aggregate' = case aggregate of - Sum -> "SUM" - Min -> "MIN" - Max -> "MAX" - -eval - :: (RedisCtx m f, RedisResult a) - => ByteString -- ^ script - -> [ByteString] -- ^ keys - -> [ByteString] -- ^ args - -> m (f a) -eval script keys args = - sendRequest $ ["EVAL", script, encode numkeys] ++ 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 -- ^ base16-encoded sha1 hash of the script - -> [ByteString] -- ^ keys - -> [ByteString] -- ^ args - -> m (f a) -evalsha script keys args = - sendRequest $ ["EVALSHA", script, encode numkeys] ++ keys ++ args - where - numkeys = toInteger (length keys) - -bitcount - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f Integer) -bitcount key = sendRequest ["BITCOUNT", key] - -bitcountRange - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ start - -> Integer -- ^ end - -> m (f Integer) -bitcountRange key start end = - sendRequest ["BITCOUNT", key, encode start, encode end] - -bitopAnd - :: (RedisCtx m f) - => ByteString -- ^ destkey - -> [ByteString] -- ^ srckeys - -> m (f Integer) -bitopAnd dst srcs = bitop "AND" (dst:srcs) - -bitopOr - :: (RedisCtx m f) - => ByteString -- ^ destkey - -> [ByteString] -- ^ srckeys - -> m (f Integer) -bitopOr dst srcs = bitop "OR" (dst:srcs) - -bitopXor - :: (RedisCtx m f) - => ByteString -- ^ destkey - -> [ByteString] -- ^ srckeys - -> m (f Integer) -bitopXor dst srcs = bitop "XOR" (dst:srcs) - -bitopNot - :: (RedisCtx m f) - => ByteString -- ^ destkey - -> ByteString -- ^ srckey - -> m (f Integer) -bitopNot dst src = bitop "NOT" [dst, src] - -bitop - :: (RedisCtx m f) - => ByteString -- ^ operation - -> [ByteString] -- ^ keys - -> m (f Integer) -bitop op ks = sendRequest $ "BITOP" : op : ks - --- setRange --- :: --- setRange = sendRequest (["SET"] ++ [encode key] ++ [encode value] ++ ) - -migrate - :: (RedisCtx m f) - => ByteString -- ^ host - -> ByteString -- ^ port - -> ByteString -- ^ key - -> Integer -- ^ destinationDb - -> Integer -- ^ timeout - -> m (f Status) -migrate host port key destinationDb timeout = - sendRequest ["MIGRATE", host, port, key, encode destinationDb, encode timeout] - - --- |Options for the 'migrate' command. -data MigrateOpts = MigrateOpts - { migrateCopy :: Bool - , migrateReplace :: Bool - } deriving (Show, Eq) - --- |Redis default 'MigrateOpts'. Equivalent to omitting all optional parameters. --- --- @ --- MigrateOpts --- { migrateCopy = False -- remove the key from the local instance --- , migrateReplace = False -- don't replace existing key on the remote instance --- } --- @ --- -defaultMigrateOpts :: MigrateOpts -defaultMigrateOpts = MigrateOpts - { migrateCopy = False - , migrateReplace = False - } - -migrateMultiple - :: (RedisCtx m f) - => ByteString -- ^ host - -> ByteString -- ^ port - -> Integer -- ^ destinationDb - -> Integer -- ^ timeout - -> MigrateOpts - -> [ByteString] -- ^ keys - -> m (f Status) -migrateMultiple host port destinationDb timeout MigrateOpts{..} keys = - sendRequest $ - concat [["MIGRATE", host, port, empty, encode destinationDb, encode timeout], - copy, replace, keys] - where - copy = ["COPY" | migrateCopy] - replace = ["REPLACE" | migrateReplace] - - -restore - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ timeToLive - -> ByteString -- ^ serializedValue - -> m (f Status) -restore key timeToLive serializedValue = - sendRequest ["RESTORE", key, encode timeToLive, serializedValue] - - -restoreReplace - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ timeToLive - -> ByteString -- ^ serializedValue - -> m (f Status) -restoreReplace key timeToLive serializedValue = - sendRequest ["RESTORE", key, encode timeToLive, serializedValue, "REPLACE"] - - -set - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ value - -> m (f Status) -set key value = sendRequest ["SET", key, value] - - -data Condition = Nx | Xx deriving (Show, Eq) - - -instance RedisArg Condition where - encode Nx = "NX" - encode Xx = "XX" - - -data SetOpts = SetOpts - { setSeconds :: Maybe Integer - , setMilliseconds :: Maybe Integer - , setCondition :: Maybe Condition - } deriving (Show, Eq) - - -setOpts - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ value - -> SetOpts - -> m (f Status) -setOpts key value SetOpts{..} = - sendRequest $ concat [["SET", key, value], ex, px, condition] - where - ex = maybe [] (\s -> ["EX", encode s]) setSeconds - px = maybe [] (\s -> ["PX", encode s]) setMilliseconds - condition = map encode $ maybeToList setCondition - - -data DebugMode = Yes | Sync | No deriving (Show, Eq) - - -instance RedisArg DebugMode where - encode Yes = "YES" - encode Sync = "SYNC" - encode No = "NO" - - -scriptDebug - :: (RedisCtx m f) - => DebugMode - -> m (f Bool) -scriptDebug mode = - sendRequest ["SCRIPT DEBUG", encode mode] - - -zadd - :: (RedisCtx m f) - => ByteString -- ^ key - -> [(Double,ByteString)] -- ^ scoreMember - -> m (f Integer) -zadd key scoreMembers = - zaddOpts key scoreMembers defaultZaddOpts - - -data ZaddOpts = ZaddOpts - { zaddCondition :: Maybe Condition - , zaddChange :: Bool - , zaddIncrement :: Bool - } deriving (Show, Eq) - - --- |Redis default 'ZaddOpts'. Equivalent to omitting all optional parameters. --- --- @ --- ZaddOpts --- { zaddCondition = Nothing -- omit NX and XX options --- , zaddChange = False -- don't modify the return value from the number of new elements added, to the total number of elements changed --- , zaddIncrement = False -- don't add like ZINCRBY --- } --- @ --- -defaultZaddOpts :: ZaddOpts -defaultZaddOpts = ZaddOpts - { zaddCondition = Nothing - , zaddChange = False - , zaddIncrement = False - } - - -zaddOpts - :: (RedisCtx m f) - => ByteString -- ^ key - -> [(Double,ByteString)] -- ^ scoreMember - -> ZaddOpts -- ^ options - -> m (f Integer) -zaddOpts key scoreMembers ZaddOpts{..} = - sendRequest $ concat [["ZADD", key], condition, change, increment, scores] - where - scores = concatMap (\(x,y) -> [encode x,encode y]) scoreMembers - condition = map encode $ maybeToList zaddCondition - change = ["CH" | zaddChange] - increment = ["INCR" | zaddIncrement] - - -data ReplyMode = On | Off | Skip deriving (Show, Eq) - - -instance RedisArg ReplyMode where - encode On = "ON" - encode Off = "OFF" - encode Skip = "SKIP" - - -clientReply - :: (RedisCtx m f) - => ReplyMode - -> m (f Bool) -clientReply mode = - sendRequest ["CLIENT REPLY", encode mode] - - -srandmember - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f (Maybe ByteString)) -srandmember key = sendRequest ["SRANDMEMBER", key] - - -srandmemberN - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ count - -> m (f [ByteString]) -srandmemberN key count = sendRequest ["SRANDMEMBER", key, encode count] - - -spop - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f (Maybe ByteString)) -spop key = sendRequest ["SPOP", key] - - -spopN - :: (RedisCtx m f) - => ByteString -- ^ key - -> Integer -- ^ count - -> m (f [ByteString]) -spopN key count = sendRequest ["SPOP", key, encode count] - - -info - :: (RedisCtx m f) - => m (f ByteString) -info = sendRequest ["INFO"] - - -infoSection - :: (RedisCtx m f) - => ByteString -- ^ section - -> m (f ByteString) -infoSection section = sendRequest ["INFO", section] - - -exists - :: (RedisCtx m f) - => ByteString -- ^ key - -> m (f Bool) -exists key = sendRequest ["EXISTS", key] - -newtype Cursor = Cursor ByteString deriving (Show, Eq) - - -instance RedisArg Cursor where - encode (Cursor c) = encode c - - -instance RedisResult Cursor where - decode (Bulk (Just s)) = Right $ Cursor s - decode r = Left r - - -cursor0 :: Cursor -cursor0 = Cursor "0" - - -scan - :: (RedisCtx m f) - => Cursor - -> m (f (Cursor, [ByteString])) -- ^ next cursor and values -scan cursor = scanOpts cursor defaultScanOpts - - -data ScanOpts = ScanOpts - { scanMatch :: Maybe ByteString - , scanCount :: Maybe Integer - } deriving (Show, Eq) - - --- |Redis default 'ScanOpts'. Equivalent to omitting all optional parameters. --- --- @ --- ScanOpts --- { scanMatch = Nothing -- don't match any pattern --- , scanCount = Nothing -- don't set any requirements on number elements returned (works like value @COUNT 10@) --- } --- @ --- -defaultScanOpts :: ScanOpts -defaultScanOpts = ScanOpts - { scanMatch = Nothing - , scanCount = Nothing - } - - -scanOpts - :: (RedisCtx m f) - => Cursor - -> ScanOpts - -> m (f (Cursor, [ByteString])) -- ^ next cursor and values -scanOpts cursor opts = sendRequest $ addScanOpts ["SCAN", encode cursor] opts - - -addScanOpts - :: [ByteString] -- ^ main part of scan command - -> ScanOpts - -> [ByteString] -addScanOpts cmd ScanOpts{..} = - concat [cmd, match, count] - where - prepend x y = [x, y] - match = maybe [] (prepend "MATCH") scanMatch - count = maybe [] ((prepend "COUNT").encode) scanCount - -sscan - :: (RedisCtx m f) - => ByteString -- ^ key - -> Cursor - -> m (f (Cursor, [ByteString])) -- ^ next cursor and values -sscan key cursor = sscanOpts key cursor defaultScanOpts - - -sscanOpts - :: (RedisCtx m f) - => ByteString -- ^ key - -> Cursor - -> ScanOpts - -> m (f (Cursor, [ByteString])) -- ^ next cursor and values -sscanOpts key cursor opts = sendRequest $ addScanOpts ["SSCAN", key, encode cursor] opts - - -hscan - :: (RedisCtx m f) - => ByteString -- ^ key - -> Cursor - -> m (f (Cursor, [(ByteString, ByteString)])) -- ^ next cursor and values -hscan key cursor = hscanOpts key cursor defaultScanOpts - - -hscanOpts - :: (RedisCtx m f) - => ByteString -- ^ key - -> Cursor - -> ScanOpts - -> m (f (Cursor, [(ByteString, ByteString)])) -- ^ next cursor and values -hscanOpts key cursor opts = sendRequest $ addScanOpts ["HSCAN", key, encode cursor] opts - - -zscan - :: (RedisCtx m f) - => ByteString -- ^ key - -> Cursor - -> m (f (Cursor, [(ByteString, Double)])) -- ^ next cursor and values -zscan key cursor = zscanOpts key cursor defaultScanOpts - - -zscanOpts - :: (RedisCtx m f) - => ByteString -- ^ key - -> Cursor - -> ScanOpts - -> m (f (Cursor, [(ByteString, Double)])) -- ^ next cursor and values -zscanOpts key cursor opts = sendRequest $ addScanOpts ["ZSCAN", key, encode cursor] opts - -data RangeLex a = Incl a | Excl a | Minr | Maxr - -instance RedisArg a => RedisArg (RangeLex a) where - encode (Incl bs) = "[" `append` encode bs - encode (Excl bs) = "(" `append` encode bs - encode Minr = "-" - encode Maxr = "+" - -zrangebylex::(RedisCtx m f) => - ByteString -- ^ key - -> RangeLex ByteString -- ^ min - -> RangeLex ByteString -- ^ max - -> m (f [ByteString]) -zrangebylex key min max = - sendRequest ["ZRANGEBYLEX", encode key, encode min, encode max] - -zrangebylexLimit - ::(RedisCtx m f) - => ByteString -- ^ key - -> RangeLex ByteString -- ^ min - -> RangeLex ByteString -- ^ max - -> Integer -- ^ offset - -> Integer -- ^ count - -> m (f [ByteString]) -zrangebylexLimit key min max offset count = - sendRequest ["ZRANGEBYLEX", encode key, encode min, encode max, - "LIMIT", encode offset, encode count] - -data TrimOpts = NoArgs | Maxlen Integer | ApproxMaxlen Integer - -xaddOpts - :: (RedisCtx m f) - => ByteString -- ^ key - -> ByteString -- ^ id - -> [(ByteString, ByteString)] -- ^ (field, value) - -> TrimOpts - -> m (f ByteString) -xaddOpts key entryId fieldValues opts = sendRequest $ - ["XADD", key] ++ optArgs ++ [entryId] ++ fieldArgs - where - fieldArgs = concatMap (\(x,y) -> [x,y]) fieldValues - optArgs = case opts of - NoArgs -> [] - Maxlen max -> ["MAXLEN", encode max] - ApproxMaxlen max -> ["MAXLEN", "~", encode max] - -xadd - :: (RedisCtx m f) - => ByteString -- ^ stream - -> ByteString -- ^ id - -> [(ByteString, ByteString)] -- ^ (field, value) - -> m (f ByteString) -xadd key entryId fieldValues = xaddOpts key entryId fieldValues NoArgs - -data StreamsRecord = StreamsRecord - { recordId :: ByteString - , keyValues :: [(ByteString, ByteString)] - } deriving (Show, Eq) - -instance RedisResult StreamsRecord where - decode (MultiBulk (Just [Bulk (Just recordId), MultiBulk (Just rawKeyValues)])) = do - keyValuesList <- mapM decode rawKeyValues - let keyValues = decodeKeyValues keyValuesList - return StreamsRecord{..} - where - decodeKeyValues :: [ByteString] -> [(ByteString, ByteString)] - decodeKeyValues bs = map (\[x,y] -> (x,y)) $ chunksOfTwo bs - chunksOfTwo (x:y:rest) = [x,y]:chunksOfTwo rest - chunksOfTwo _ = [] - decode a = Left a - -data XReadOpts = XReadOpts - { block :: Maybe Integer - , recordCount :: Maybe Integer - } 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 --- } --- @ --- -defaultXreadOpts :: XReadOpts -defaultXreadOpts = XReadOpts { block = Nothing, recordCount = Nothing } - -data XReadResponse = XReadResponse - { stream :: ByteString - , records :: [StreamsRecord] - } deriving (Show, Eq) - -instance RedisResult XReadResponse where - decode (MultiBulk (Just [Bulk (Just stream), MultiBulk (Just rawRecords)])) = do - records <- mapM decode rawRecords - return XReadResponse{..} - decode a = Left a - -xreadOpts - :: (RedisCtx m f) - => [(ByteString, ByteString)] -- ^ (stream, id) pairs - -> XReadOpts -- ^ Options - -> m (f (Maybe [XReadResponse])) -xreadOpts streamsAndIds opts = sendRequest $ - ["XREAD"] ++ (internalXreadArgs streamsAndIds opts) - -internalXreadArgs :: [(ByteString, ByteString)] -> XReadOpts -> [ByteString] -internalXreadArgs streamsAndIds XReadOpts{..} = - concat [blockArgs, countArgs, ["STREAMS"], streams, recordIds] - where - blockArgs = maybe [] (\blockMillis -> ["BLOCK", encode blockMillis]) block - countArgs = maybe [] (\countRecords -> ["COUNT", encode countRecords]) recordCount - streams = map (\(stream, _) -> stream) streamsAndIds - recordIds = map (\(_, recordId) -> recordId) streamsAndIds - - -xread - :: (RedisCtx m f) - => [(ByteString, ByteString)] -- ^ (stream, id) pairs - -> m( f (Maybe [XReadResponse])) -xread streamsAndIds = xreadOpts streamsAndIds defaultXreadOpts - -xreadGroupOpts - :: (RedisCtx m f) - => ByteString -- ^ group name - -> ByteString -- ^ consumer name - -> [(ByteString, ByteString)] -- ^ (stream, id) pairs - -> XReadOpts -- ^ Options - -> m (f (Maybe [XReadResponse])) -xreadGroupOpts groupName consumerName streamsAndIds opts = sendRequest $ - ["XREADGROUP", "GROUP", groupName, consumerName] ++ (internalXreadArgs streamsAndIds opts) - -xreadGroup - :: (RedisCtx m f) - => ByteString -- ^ group name - -> ByteString -- ^ consumer name - -> [(ByteString, ByteString)] -- ^ (stream, id) pairs - -> m (f (Maybe [XReadResponse])) -xreadGroup groupName consumerName streamsAndIds = xreadGroupOpts groupName consumerName streamsAndIds defaultXreadOpts - -xgroupCreate - :: (RedisCtx m f) - => ByteString -- ^ stream - -> ByteString -- ^ group name - -> ByteString -- ^ start ID - -> m (f Status) -xgroupCreate stream groupName startId = sendRequest $ ["XGROUP", "CREATE", stream, groupName, startId] - -xgroupSetId - :: (RedisCtx m f) - => ByteString -- ^ stream - -> ByteString -- ^ group - -> ByteString -- ^ id - -> m (f Status) -xgroupSetId stream group messageId = sendRequest ["XGROUP", "SETID", stream, group, messageId] - -xgroupDelConsumer - :: (RedisCtx m f) - => ByteString -- ^ stream - -> ByteString -- ^ group - -> ByteString -- ^ consumer - -> m (f Integer) -xgroupDelConsumer stream group consumer = sendRequest ["XGROUP", "DELCONSUMER", stream, group, consumer] - -xgroupDestroy - :: (RedisCtx m f) - => ByteString -- ^ stream - -> ByteString -- ^ group - -> m (f Bool) -xgroupDestroy stream group = sendRequest ["XGROUP", "DESTROY", stream, group] - -xack - :: (RedisCtx m f) - => ByteString -- ^ stream - -> ByteString -- ^ group name - -> [ByteString] -- ^ message IDs - -> m (f Integer) -xack stream groupName messageIds = sendRequest $ ["XACK", stream, groupName] ++ messageIds - -xrange - :: (RedisCtx m f) - => ByteString -- ^ stream - -> ByteString -- ^ start - -> ByteString -- ^ end - -> Maybe Integer -- ^ COUNT - -> m (f [StreamsRecord]) -xrange stream start end count = sendRequest $ ["XRANGE", stream, start, end] ++ countArgs - where countArgs = maybe [] (\c -> ["COUNT", encode c]) count - -xrevRange - :: (RedisCtx m f) - => ByteString -- ^ stream - -> ByteString -- ^ end - -> ByteString -- ^ start - -> Maybe Integer -- ^ COUNT - -> m (f [StreamsRecord]) -xrevRange stream end start count = sendRequest $ ["XREVRANGE", stream, end, start] ++ countArgs - where countArgs = maybe [] (\c -> ["COUNT", encode c]) count - -xlen - :: (RedisCtx m f) - => ByteString -- ^ stream - -> m (f Integer) -xlen stream = sendRequest ["XLEN", stream] - -data XPendingSummaryResponse = XPendingSummaryResponse - { numPendingMessages :: Integer - , smallestPendingMessageId :: ByteString - , largestPendingMessageId :: ByteString - , numPendingMessagesByconsumer :: [(ByteString, Integer)] - } deriving (Show, Eq) - -instance RedisResult XPendingSummaryResponse where - decode (MultiBulk (Just [ - Integer numPendingMessages, - Bulk (Just smallestPendingMessageId), - Bulk (Just largestPendingMessageId), - MultiBulk (Just [MultiBulk (Just rawGroupsAndCounts)])])) = do - let groupsAndCounts = chunksOfTwo rawGroupsAndCounts - numPendingMessagesByconsumer <- decodeGroupsAndCounts groupsAndCounts - return XPendingSummaryResponse{..} - where - decodeGroupsAndCounts :: [(Reply, Reply)] -> Either Reply [(ByteString, Integer)] - decodeGroupsAndCounts bs = sequence $ map decodeGroupCount bs - decodeGroupCount :: (Reply, Reply) -> Either Reply (ByteString, Integer) - decodeGroupCount (x, y) = do - decodedX <- decode x - decodedY <- decode y - return (decodedX, decodedY) - chunksOfTwo (x:y:rest) = (x,y):chunksOfTwo rest - chunksOfTwo _ = [] - decode a = Left a - -xpendingSummary - :: (RedisCtx m f) - => ByteString -- ^ stream - -> ByteString -- ^ group - -> Maybe ByteString -- ^ consumer - -> m (f XPendingSummaryResponse) -xpendingSummary stream group consumer = sendRequest $ ["XPENDING", stream, group] ++ consumerArg - where consumerArg = maybe [] (\c -> [c]) consumer - -data XPendingDetailRecord = XPendingDetailRecord - { messageId :: ByteString - , consumer :: ByteString - , millisSinceLastDelivered :: Integer - , numTimesDelivered :: Integer - } deriving (Show, Eq) - -instance RedisResult XPendingDetailRecord where - decode (MultiBulk (Just [ - Bulk (Just messageId) , - Bulk (Just consumer), - Integer millisSinceLastDelivered, - Integer numTimesDelivered])) = Right XPendingDetailRecord{..} - decode a = Left a - -xpendingDetail - :: (RedisCtx m f) - => ByteString -- ^ stream - -> ByteString -- ^ group - -> ByteString -- ^ startId - -> ByteString -- ^ endId - -> Integer -- ^ count - -> Maybe ByteString -- ^ consumer - -> m (f [XPendingDetailRecord]) -xpendingDetail stream group startId endId count consumer = sendRequest $ - ["XPENDING", stream, group, startId, endId, encode count] ++ consumerArg - where consumerArg = maybe [] (\c -> [c]) consumer - -data XClaimOpts = XClaimOpts - { xclaimIdle :: Maybe Integer - , xclaimTime :: Maybe Integer - , xclaimRetryCount :: Maybe Integer - , xclaimForce :: Bool - } deriving (Show, Eq) - -defaultXClaimOpts :: XClaimOpts -defaultXClaimOpts = XClaimOpts - { xclaimIdle = Nothing - , xclaimTime = Nothing - , xclaimRetryCount = Nothing - , xclaimForce = False - } - - --- |Format a request for XCLAIM. -xclaimRequest - :: ByteString -- ^ stream - -> ByteString -- ^ group - -> ByteString -- ^ consumer - -> Integer -- ^ min idle time - -> XClaimOpts -- ^ optional arguments - -> [ByteString] -- ^ message IDs - -> [ByteString] -xclaimRequest stream group consumer minIdleTime XClaimOpts{..} messageIds = - ["XCLAIM", stream, group, consumer, encode minIdleTime] ++ ( map encode messageIds ) ++ optArgs - where optArgs = idleArg ++ timeArg ++ retryCountArg ++ forceArg - idleArg = optArg "IDLE" xclaimIdle - timeArg = optArg "TIME" xclaimTime - retryCountArg = optArg "RETRYCOUNT" xclaimRetryCount - forceArg = if xclaimForce then ["FORCE"] else [] - optArg name maybeArg = maybe [] (\x -> [name, encode x]) maybeArg - -xclaim - :: (RedisCtx m f) - => ByteString -- ^ stream - -> ByteString -- ^ group - -> ByteString -- ^ consumer - -> Integer -- ^ min idle time - -> XClaimOpts -- ^ optional arguments - -> [ByteString] -- ^ message IDs - -> m (f [StreamsRecord]) -xclaim stream group consumer minIdleTime opts messageIds = sendRequest $ - xclaimRequest stream group consumer minIdleTime opts messageIds - -xclaimJustIds - :: (RedisCtx m f) - => ByteString -- ^ stream - -> ByteString -- ^ group - -> ByteString -- ^ consumer - -> Integer -- ^ min idle time - -> XClaimOpts -- ^ optional arguments - -> [ByteString] -- ^ message IDs - -> m (f [ByteString]) -xclaimJustIds stream group consumer minIdleTime opts messageIds = sendRequest $ - (xclaimRequest stream group consumer minIdleTime opts messageIds) ++ ["JUSTID"] - -data XInfoConsumersResponse = XInfoConsumersResponse - { xinfoConsumerName :: ByteString - , xinfoConsumerNumPendingMessages :: Integer - , xinfoConsumerIdleTime :: Integer - } deriving (Show, Eq) - -instance RedisResult XInfoConsumersResponse where - decode (MultiBulk (Just [ - Bulk (Just "name"), - Bulk (Just xinfoConsumerName), - Bulk (Just "pending"), - Integer xinfoConsumerNumPendingMessages, - Bulk (Just "idle"), - Integer xinfoConsumerIdleTime])) = Right XInfoConsumersResponse{..} - decode a = Left a - -xinfoConsumers - :: (RedisCtx m f) - => ByteString -- ^ stream - -> ByteString -- ^ group - -> m (f [XInfoConsumersResponse]) -xinfoConsumers stream group = sendRequest $ ["XINFO", "CONSUMERS", stream, group] - -data XInfoGroupsResponse = XInfoGroupsResponse - { xinfoGroupsGroupName :: ByteString - , xinfoGroupsNumConsumers :: Integer - , xinfoGroupsNumPendingMessages :: Integer - , xinfoGroupsLastDeliveredMessageId :: ByteString - } deriving (Show, Eq) - -instance RedisResult XInfoGroupsResponse where - decode (MultiBulk (Just [ - Bulk (Just "name"),Bulk (Just xinfoGroupsGroupName), - Bulk (Just "consumers"),Integer xinfoGroupsNumConsumers, - Bulk (Just "pending"),Integer xinfoGroupsNumPendingMessages, - Bulk (Just "last-delivered-id"),Bulk (Just xinfoGroupsLastDeliveredMessageId)])) = Right XInfoGroupsResponse{..} - decode a = Left a - -xinfoGroups - :: (RedisCtx m f) - => ByteString -- ^ stream - -> m (f [XInfoGroupsResponse]) -xinfoGroups stream = sendRequest ["XINFO", "GROUPS", stream] - -data XInfoStreamResponse - = XInfoStreamResponse - { xinfoStreamLength :: Integer - , xinfoStreamRadixTreeKeys :: Integer - , xinfoStreamRadixTreeNodes :: Integer - , xinfoStreamNumGroups :: Integer - , xinfoStreamLastEntryId :: ByteString - , xinfoStreamFirstEntry :: StreamsRecord - , xinfoStreamLastEntry :: StreamsRecord - } - | 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, - 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) - => ByteString -- ^ stream - -> m (f XInfoStreamResponse) -xinfoStream stream = sendRequest ["XINFO", "STREAM", stream] - -xdel - :: (RedisCtx m f) - => ByteString -- ^ stream - -> [ByteString] -- ^ message IDs - -> m (f Integer) -xdel stream messageIds = sendRequest $ ["XDEL", stream] ++ messageIds - -xtrim - :: (RedisCtx m f) - => ByteString -- ^ stream - -> TrimOpts - -> m (f Integer) -xtrim stream opts = sendRequest $ ["XTRIM", stream] ++ optArgs - where - optArgs = case opts of - NoArgs -> [] - Maxlen max -> ["MAXLEN", encode max] - ApproxMaxlen max -> ["MAXLEN", "~", encode max] - -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)] - -command :: (RedisCtx m f) => m (f [CMD.CommandInfo]) -command = sendRequest ["COMMAND"] +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (maybeToList, catMaybes, fromMaybe) +#if __GLASGOW_HASKELL__ < 808 +import Data.Semigroup ((<>)) +#endif + + + +import Database.Redis.Core +import Database.Redis.Protocol +import Database.Redis.Types +import qualified Database.Redis.Cluster.Command as CMD + +-- |Inspect the internals of Redis objects (). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3 +objectRefcount + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f Integer) +objectRefcount key = sendRequest ["OBJECT", "refcount", key] + +objectIdletime + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f Integer) +objectIdletime key = sendRequest ["OBJECT", "idletime", key] + +-- |Inspect the internals of Redis objects (). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3 +objectEncoding + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f ByteString) +objectEncoding key = sendRequest ["OBJECT", "encoding", key] + +-- |Insert an element before or after another element in a list (). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'. Since Redis 2.2.0 +linsertBefore + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ pivot + -> ByteString -- ^ value + -> m (f Integer) +linsertBefore key pivot value = + sendRequest ["LINSERT", key, "BEFORE", pivot, value] + +-- |Insert an element before or after another element in a list (). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'. Since Redis 2.2.0 +linsertAfter + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ pivot + -> ByteString -- ^ value + -> m (f Integer) +linsertAfter key pivot value = + sendRequest ["LINSERT", encode key, "AFTER", encode pivot, encode value] + +-- |Determine the type stored at key (). Since Redis 1.0.0 +getType + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f RedisType) +getType key = sendRequest ["TYPE", key] + +-- |A single entry from the slowlog. +data Slowlog = Slowlog + { slowlogId :: Integer + -- ^ A unique progressive identifier for every slow log entry. + , slowlogTimestamp :: Integer + -- ^ The unix timestamp at which the logged command was processed. + , slowlogMicros :: Integer + -- ^ The amount of time needed for its execution, in microseconds. + , slowlogCmd :: [ByteString] + -- ^ The command and it's arguments. + , slowlogClientIpAndPort :: Maybe ByteString + , slowlogClientName :: Maybe ByteString + } deriving (Show, Eq) + +instance RedisResult Slowlog where + decode (MultiBulk (Just [logId,timestamp,micros,cmd])) = do + slowlogId <- decode logId + slowlogTimestamp <- decode timestamp + slowlogMicros <- decode micros + slowlogCmd <- decode cmd + let slowlogClientIpAndPort = Nothing + slowlogClientName = Nothing + return Slowlog{..} + decode (MultiBulk (Just [logId,timestamp,micros,cmd,ip,cname])) = do + slowlogId <- decode logId + slowlogTimestamp <- decode timestamp + slowlogMicros <- decode micros + slowlogCmd <- decode cmd + slowlogClientIpAndPort <- Just <$> decode ip + slowlogClientName <- Just <$> decode cname + return Slowlog{..} + decode r = Left r + +slowlogGet + :: (RedisCtx m f) + => Integer -- ^ cnt + -> m (f [Slowlog]) +slowlogGet n = sendRequest ["SLOWLOG", "GET", encode n] + +slowlogLen :: (RedisCtx m f) => m (f Integer) +slowlogLen = sendRequest ["SLOWLOG", "LEN"] + +slowlogReset :: (RedisCtx m f) => m (f Status) +slowlogReset = sendRequest ["SLOWLOG", "RESET"] + +-- |Return a range of members in a sorted set, by index (). The Redis command @ZRANGE@ is split up into 'zrange', 'zrangeWithscores'. Since Redis 1.2.0 +zrange + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ start + -> Integer -- ^ stop + -> m (f [ByteString]) +zrange key start stop = + sendRequest ["ZRANGE", encode key, encode start, encode stop] + +-- |Return a range of members in a sorted set, by index (). The Redis command @ZRANGE@ is split up into 'zrange', 'zrangeWithscores'. Since Redis 1.2.0 +zrangeWithscores + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ start + -> Integer -- ^ stop + -> m (f [(ByteString, Double)]) +zrangeWithscores key start stop = + sendRequest ["ZRANGE", encode key, encode start, encode stop, "WITHSCORES"] + +zrevrange + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ start + -> Integer -- ^ stop + -> m (f [ByteString]) +zrevrange key start stop = + sendRequest ["ZREVRANGE", encode key, encode start, encode stop] + +zrevrangeWithscores + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ start + -> Integer -- ^ stop + -> m (f [(ByteString, Double)]) +zrevrangeWithscores key start stop = + sendRequest ["ZREVRANGE", encode key, encode start, encode stop + ,"WITHSCORES"] + +zrangebyscore + :: (RedisCtx m f) + => ByteString -- ^ key + -> Double -- ^ min + -> Double -- ^ max + -> m (f [ByteString]) +zrangebyscore key min max = + sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max] + +zrangebyscoreWithscores + :: (RedisCtx m f) + => ByteString -- ^ key + -> Double -- ^ min + -> Double -- ^ max + -> m (f [(ByteString, Double)]) +zrangebyscoreWithscores key min max = + sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max + ,"WITHSCORES"] + +zrangebyscoreLimit + :: (RedisCtx m f) + => ByteString -- ^ key + -> Double -- ^ min + -> Double -- ^ max + -> Integer -- ^ offset + -> Integer -- ^ count + -> m (f [ByteString]) +zrangebyscoreLimit key min max offset count = + sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max + ,"LIMIT", encode offset, encode count] + +zrangebyscoreWithscoresLimit + :: (RedisCtx m f) + => ByteString -- ^ key + -> Double -- ^ min + -> Double -- ^ max + -> Integer -- ^ offset + -> Integer -- ^ count + -> m (f [(ByteString, Double)]) +zrangebyscoreWithscoresLimit key min max offset count = + sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max + ,"WITHSCORES","LIMIT", encode offset, encode count] + +zrevrangebyscore + :: (RedisCtx m f) + => ByteString -- ^ key + -> Double -- ^ max + -> Double -- ^ min + -> m (f [ByteString]) +zrevrangebyscore key min max = + sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max] + +zrevrangebyscoreWithscores + :: (RedisCtx m f) + => ByteString -- ^ key + -> Double -- ^ max + -> Double -- ^ min + -> m (f [(ByteString, Double)]) +zrevrangebyscoreWithscores key min max = + sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max + ,"WITHSCORES"] + +zrevrangebyscoreLimit + :: (RedisCtx m f) + => ByteString -- ^ key + -> Double -- ^ max + -> Double -- ^ min + -> Integer -- ^ offset + -> Integer -- ^ count + -> m (f [ByteString]) +zrevrangebyscoreLimit key min max offset count = + sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max + ,"LIMIT", encode offset, encode count] + +zrevrangebyscoreWithscoresLimit + :: (RedisCtx m f) + => ByteString -- ^ key + -> Double -- ^ max + -> Double -- ^ min + -> Integer -- ^ offset + -> Integer -- ^ count + -> m (f [(ByteString, Double)]) +zrevrangebyscoreWithscoresLimit key min max offset count = + sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max + ,"WITHSCORES","LIMIT", encode offset, encode count] + +-- |Options for the 'sort' command. +data SortOpts = SortOpts + { sortBy :: Maybe ByteString + , sortLimit :: (Integer,Integer) + , sortGet :: [ByteString] + , sortOrder :: SortOrder + , sortAlpha :: Bool + } deriving (Show, Eq) + +-- |Redis default 'SortOpts'. Equivalent to omitting all optional parameters. +-- +-- @ +-- SortOpts +-- { sortBy = Nothing -- omit the BY option +-- , sortLimit = (0,-1) -- return entire collection +-- , sortGet = [] -- omit the GET option +-- , sortOrder = Asc -- sort in ascending order +-- , sortAlpha = False -- sort numerically, not lexicographically +-- } +-- @ +-- +defaultSortOpts :: SortOpts +defaultSortOpts = SortOpts + { sortBy = Nothing + , sortLimit = (0,-1) + , sortGet = [] + , sortOrder = Asc + , sortAlpha = False + } + +data SortOrder = Asc | Desc deriving (Show, Eq) + +-- |Sort the elements in a list, set or sorted set (). The Redis command @SORT@ is split up into 'sort', 'sortStore'. Since Redis 1.0.0 +sortStore + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ destination + -> SortOpts + -> m (f Integer) +sortStore key dest = sortInternal key (Just dest) + +-- |Sort the elements in a list, set or sorted set (). The Redis command @SORT@ is split up into 'sort', 'sortStore'. Since Redis 1.0.0 +sort + :: (RedisCtx m f) + => ByteString -- ^ key + -> SortOpts + -> m (f [ByteString]) +sort key = sortInternal key Nothing + +sortInternal + :: (RedisResult a, RedisCtx m f) + => ByteString -- ^ key + -> Maybe ByteString -- ^ destination + -> SortOpts + -> m (f a) +sortInternal key destination SortOpts{..} = sendRequest $ + concat [["SORT", encode key], by, limit, get, order, alpha, store] + where + by = maybe [] (\pattern -> ["BY", pattern]) sortBy + limit = let (off,cnt) = sortLimit in ["LIMIT", encode off, encode cnt] + get = concatMap (\pattern -> ["GET", pattern]) sortGet + order = case sortOrder of Desc -> ["DESC"]; Asc -> ["ASC"] + alpha = ["ALPHA" | sortAlpha] + store = maybe [] (\dest -> ["STORE", dest]) destination + + +data Aggregate = Sum | Min | Max deriving (Show,Eq) + +zunionstore + :: (RedisCtx m f) + => ByteString -- ^ destination + -> [ByteString] -- ^ keys + -> Aggregate + -> m (f Integer) +zunionstore dest keys = + zstoreInternal "ZUNIONSTORE" dest keys [] + +zunionstoreWeights + :: (RedisCtx m f) + => ByteString -- ^ destination + -> [(ByteString,Double)] -- ^ weighted keys + -> Aggregate + -> m (f Integer) +zunionstoreWeights dest kws = + let (keys,weights) = unzip kws + in zstoreInternal "ZUNIONSTORE" dest keys weights + +-- |Intersect multiple sorted sets and store the resulting sorted set in a new key (). The Redis command @ZINTERSTORE@ is split up into 'zinterstore', 'zinterstoreWeights'. Since Redis 2.0.0 +zinterstore + :: (RedisCtx m f) + => ByteString -- ^ destination + -> NonEmpty ByteString -- ^ keys + -> Aggregate + -> m (f Integer) +zinterstore dest (key_:|keys_) = + zstoreInternal "ZINTERSTORE" dest (key_:keys_) [] + +-- |Intersect multiple sorted sets and store the resulting sorted set in a new key (). The Redis command @ZINTERSTORE@ is split up into 'zinterstore', 'zinterstoreWeights'. Since Redis 2.0.0 +zinterstoreWeights + :: (RedisCtx m f) + => ByteString -- ^ destination + -> NonEmpty (ByteString,Double) -- ^ weighted keys + -> Aggregate + -> m (f Integer) +zinterstoreWeights dest kws = + let (keys,weights) = unzip (NE.toList kws) + in zstoreInternal "ZINTERSTORE" dest keys weights + +zstoreInternal + :: (RedisCtx m f) + => ByteString -- ^ cmd + -> ByteString -- ^ destination + -> [ByteString] -- ^ keys + -> [Double] -- ^ weights + -> Aggregate + -> m (f Integer) +zstoreInternal cmd dest keys weights aggregate = sendRequest $ + concat [ [cmd, dest, encode . toInteger $ length keys ], keys + , if null weights then [] else "WEIGHTS" : map encode weights + , ["AGGREGATE", aggregate'] + ] + where + aggregate' = case aggregate of + Sum -> "SUM" + Min -> "MIN" + Max -> "MAX" + +-- |Execute a Lua script server side (). Since Redis 2.6.0 +eval + :: (RedisCtx m f, RedisResult a) + => ByteString -- ^ script + -> [ByteString] -- ^ keys + -> [ByteString] -- ^ args + -> m (f a) +eval script keys args = + sendRequest $ ["EVAL", script, encode numkeys] ++ 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 -- ^ base16-encoded sha1 hash of the script + -> [ByteString] -- ^ keys + -> [ByteString] -- ^ args + -> m (f a) +evalsha script keys args = + sendRequest $ ["EVALSHA", script, encode numkeys] ++ keys ++ args + where + numkeys = toInteger (length keys) + +bitcount + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f Integer) +bitcount key = sendRequest ["BITCOUNT", key] + +bitcountRange + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ start + -> Integer -- ^ end + -> m (f Integer) +bitcountRange key start end = + sendRequest ["BITCOUNT", key, encode start, encode end] + +bitopAnd + :: (RedisCtx m f) + => ByteString -- ^ destkey + -> [ByteString] -- ^ srckeys + -> m (f Integer) +bitopAnd dst srcs = bitop "AND" (dst:srcs) + +bitopOr + :: (RedisCtx m f) + => ByteString -- ^ destkey + -> [ByteString] -- ^ srckeys + -> m (f Integer) +bitopOr dst srcs = bitop "OR" (dst:srcs) + +bitopXor + :: (RedisCtx m f) + => ByteString -- ^ destkey + -> [ByteString] -- ^ srckeys + -> m (f Integer) +bitopXor dst srcs = bitop "XOR" (dst:srcs) + +bitopNot + :: (RedisCtx m f) + => ByteString -- ^ destkey + -> ByteString -- ^ srckey + -> m (f Integer) +bitopNot dst src = bitop "NOT" [dst, src] + +bitop + :: (RedisCtx m f) + => ByteString -- ^ operation + -> [ByteString] -- ^ keys + -> m (f Integer) +bitop op ks = sendRequest $ "BITOP" : op : ks + +-- |Atomically transfer a key from a Redis instance to another one (). The Redis command @MIGRATE@ is split up into 'migrate', 'migrateMultiple'. Since Redis 2.6.0 +migrate + :: (RedisCtx m f) + => ByteString -- ^ host + -> ByteString -- ^ port + -> ByteString -- ^ key + -> Integer -- ^ destinationDb + -> Integer -- ^ timeout + -> m (f Status) +migrate host port key destinationDb timeout = + sendRequest ["MIGRATE", host, port, key, encode destinationDb, encode timeout] + +data MigrateAuth + = MigrateAuth ByteString + | MigrateAuth2 ByteString ByteString + deriving (Show, Eq) + +-- |Options for the 'migrate' command. +data MigrateOpts = MigrateOpts + { migrateCopy :: Bool + , migrateReplace :: Bool + , migrateAuth :: Maybe MigrateAuth + } deriving (Show, Eq) + +-- |Redis default 'MigrateOpts'. Equivalent to omitting all optional parameters. +-- +-- @ +-- MigrateOpts +-- { migrateCopy = False -- remove the key from the local instance +-- , migrateReplace = False -- don't replace existing key on the remote instance +-- , migrateAuth = Nothing +-- } +-- @ +-- +defaultMigrateOpts :: MigrateOpts +defaultMigrateOpts = MigrateOpts + { migrateCopy = False + , migrateReplace = False + , migrateAuth = Nothing + } + +-- |Atomically transfer a key from a Redis instance to another one (). The Redis command @MIGRATE@ is split up into 'migrate', 'migrateMultiple'. Since Redis 2.6.0 +migrateMultiple + :: (RedisCtx m f) + => ByteString -- ^ host + -> ByteString -- ^ port + -> Integer -- ^ destinationDb + -> Integer -- ^ timeout + -> MigrateOpts + -> [ByteString] -- ^ keys + -> m (f Status) +migrateMultiple host port destinationDb timeout MigrateOpts{..} keys = + sendRequest $ + concat [["MIGRATE", host, port, empty, encode destinationDb, encode timeout], + auth_, copy, replace, keys] + where + copy = ["COPY" | migrateCopy] + replace = ["REPLACE" | migrateReplace] + auth_ = case migrateAuth of + Nothing -> [] + Just (MigrateAuth pass) -> ["AUTH", pass] + Just (MigrateAuth2 user pass) -> ["AUTH2", user, pass] + + +-- |Create a key using the provided serialized value, previously obtained using DUMP (). The Redis command @RESTORE@ is split up into 'restore', 'restoreReplace'. Since Redis 2.6.0 +restore + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ timeToLive + -> ByteString -- ^ serializedValue + -> m (f Status) +restore key timeToLive serializedValue = + sendRequest ["RESTORE", key, encode timeToLive, serializedValue] + +data RestoreOpts = RestoreOpts + { restoreOptsReplace :: Bool + , restoreOptsAbsTTL :: Bool + , restoreOptsIdle :: Maybe Integer + , restoreOptsFreq :: Maybe Integer + } + +-- |Create a key using the provided serialized value, previously obtained using DUMP (). The Redis command @RESTORE@ is split up into 'restore', 'restoreReplace'. Since Redis 2.6.0 +restoreOpts + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ timeToLive + -> ByteString -- ^ serializedValue + -> RestoreOpts -- ^ restore options + -> m (f Status) +restoreOpts key timeToLive serializedValue RestoreOpts{..} = + sendRequest ("RESTORE": key: encode timeToLive: serializedValue:rest) where + rest = replace <> absttl <> idle <> freq + replace = ["REPLACE" | restoreOptsReplace] + absttl = ["ABSTTL" | restoreOptsAbsTTL] + idle = maybe [] (\i -> ["IDLE", encode i]) restoreOptsIdle + freq = maybe [] (\f -> ["FREQ", encode f]) restoreOptsFreq + +-- |Create a key using the provided serialized value, previously obtained using DUMP (). The Redis command @RESTORE@ is split up into 'restore', 'restoreReplace'. Since Redis 2.6.0 + +restoreReplace + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ timeToLive + -> ByteString -- ^ serializedValue + -> m (f Status) +restoreReplace key timeToLive serializedValue = + sendRequest ["RESTORE", key, encode timeToLive, serializedValue, "REPLACE"] + + +set + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ value + -> m (f Status) +set key value = sendRequest ["SET", key, value] + + +data Condition = + Nx | -- ^ Only set the key if it does not already exist. + Xx -- ^ Only set the key if it already exists. + deriving (Show, Eq) + + +instance RedisArg Condition where + encode Nx = "NX" + encode Xx = "XX" + + +data SetOpts = SetOpts + { setSeconds :: Maybe Integer -- ^ Set the specified expire time, in seconds. + , setMilliseconds :: Maybe Integer -- ^ Set the specified expire time, in milliseconds. + , setUnixSeconds :: Maybe Integer + {- ^ Set the specified Unix time at which the key will expire, in seconds. + + Since Redis 6.2 + -} + , setUnixMilliseconds :: Maybe Integer + {- ^ Set the specified Unix time at which the key will expire, in milliseconds. + -} + , setCondition :: Maybe Condition -- ^ Set the key on condition + , setKeepTTL :: Bool + {- ^ Retain the time to live associated with the key. + + Since Redis 6.0 + -} + } deriving (Show, Eq) + +internalSetOptsToArgs :: SetOpts -> [ByteString] +internalSetOptsToArgs SetOpts{..} = concat [ex, px, exat, pxat, keepttl, condition] + where + ex = maybe [] (\s -> ["EX", encode s]) setSeconds + px = maybe [] (\s -> ["PX", encode s]) setMilliseconds + exat = maybe [] (\s -> ["EXAT", encode s]) setUnixSeconds + pxat = maybe [] (\s -> ["PXAT", encode s]) setUnixMilliseconds + keepttl = ["KEEPTTL" | setKeepTTL] + condition = map encode $ maybeToList setCondition + +setOpts + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ value + -> SetOpts + -> m (f Status) +setOpts key value opts = sendRequest $ ["SET", key, value] ++ internalSetOptsToArgs opts + +setGet + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ value + -> m (f ByteString) +setGet key value = sendRequest ["SET", key, value, "GET"] + +setGetOpts + :: (RedisCtx m f) + => ByteString -- ^ key + -> ByteString -- ^ value + -> SetOpts + -> m (f ByteString) +setGetOpts key value opts = sendRequest $ ["SET", key, value, "GET"] ++ internalSetOptsToArgs opts + + +data DebugMode = Yes | Sync | No deriving (Show, Eq) + + +instance RedisArg DebugMode where + encode Yes = "YES" + encode Sync = "SYNC" + encode No = "NO" + +-- |Set the debug mode for executed scripts (). Since Redis 3.2.0 +scriptDebug + :: (RedisCtx m f) + => DebugMode + -> m (f Bool) +scriptDebug mode = + sendRequest ["SCRIPT DEBUG", encode mode] + +-- |Add one or more members to a sorted set, or update its score if it already exists (). The Redis command @ZADD@ is split up into 'zadd', 'zaddOpts'. Since Redis 1.2.0 +zadd + :: (RedisCtx m f) + => ByteString -- ^ key + -> [(Double,ByteString)] -- ^ scoreMember + -> m (f Integer) +zadd key scoreMembers = + zaddOpts key scoreMembers defaultZaddOpts + + +data SizeCondition = + CGT | -- ^ Only update existing elements if the new score is greater than the current score. This flag doesn't prevent adding new elements. + CLT -- ^ Only update existing elements if the new score is less than the current score. This flag doesn't prevent adding new elements. + deriving (Show, Eq) + +instance RedisArg SizeCondition where + encode CGT = "GT" + encode CLT = "LT" + +-- |Add one or more members to a sorted set, or update its score if it already exists (). The Redis command @ZADD@ is split up into 'zadd', 'zaddOpts'. Since Redis 1.2.0 +data ZaddOpts = ZaddOpts + { zaddCondition :: Maybe Condition -- ^ Add on condition + , zaddSizeCondition :: Maybe SizeCondition + {- ^ Only update existing elements on condition + + Since Redis 6.2 + -} + , zaddChange :: Bool -- ^ Modify the return value from the number of new elements added, to the total number of elements changed + , zaddIncrement :: Bool -- ^ When this option is specified ZADD acts like ZINCRBY. Only one score-element pair can be specified in this mode. + } deriving (Show, Eq) + + +-- |Redis default 'ZaddOpts'. Equivalent to omitting all optional parameters. +-- +-- @ +-- ZaddOpts +-- { zaddCondition = Nothing -- omit NX and XX options +-- , zaddChange = False -- don't modify the return value from the number of new elements added, to the total number of elements changed +-- , zaddIncrement = False -- don't add like ZINCRBY +-- } +-- @ +-- +defaultZaddOpts :: ZaddOpts +defaultZaddOpts = ZaddOpts + { zaddCondition = Nothing + , zaddChange = False + , zaddIncrement = False + , zaddSizeCondition = Nothing + } + + +zaddOpts + :: (RedisCtx m f) + => ByteString -- ^ key + -> [(Double,ByteString)] -- ^ scoreMember + -> ZaddOpts -- ^ options + -> m (f Integer) +zaddOpts key scoreMembers ZaddOpts{..} = + sendRequest $ concat [["ZADD", key], condition, sizeCondition, change, increment, scores] + where + scores = concatMap (\(x,y) -> [encode x,encode y]) scoreMembers + condition = map encode $ maybeToList zaddCondition + sizeCondition = map encode $ maybeToList zaddSizeCondition + change = ["CH" | zaddChange] + increment = ["INCR" | zaddIncrement] + + +data ReplyMode = On | Off | Skip deriving (Show, Eq) + + +instance RedisArg ReplyMode where + encode On = "ON" + encode Off = "OFF" + encode Skip = "SKIP" + +-- |Instruct the server whether to reply to commands (). Since Redis 3.2 +clientReply + :: (RedisCtx m f) + => ReplyMode + -> m (f Bool) +clientReply mode = + sendRequest ["CLIENT REPLY", encode mode] + +-- |Get one or multiple random members from a set (). The Redis command @SRANDMEMBER@ is split up into 'srandmember', 'srandmemberN'. Since Redis 1.0.0 +srandmember + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f (Maybe ByteString)) +srandmember key = sendRequest ["SRANDMEMBER", key] + + +-- |Get one or multiple random members from a set (). The Redis command @SRANDMEMBER@ is split up into 'srandmember', 'srandmemberN'. Since Redis 1.0.0 +srandmemberN + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ count + -> m (f [ByteString]) +srandmemberN key count = sendRequest ["SRANDMEMBER", key, encode count] + +-- |Remove and return one or multiple random members from a set (). The Redis command @SPOP@ is split up into 'spop', 'spopN'. Since Redis 1.0.0 +spop + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f (Maybe ByteString)) +spop key = sendRequest ["SPOP", key] + +-- |Remove and return one or multiple random members from a set (). The Redis command @SPOP@ is split up into 'spop', 'spopN'. Since Redis 1.0.0 +spopN + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ count + -> m (f [ByteString]) +spopN key count = sendRequest ["SPOP", key, encode count] + + +info + :: (RedisCtx m f) + => m (f ByteString) +info = sendRequest ["INFO"] + + +infoSection + :: (RedisCtx m f) + => ByteString -- ^ section + -> m (f ByteString) +infoSection section = sendRequest ["INFO", section] + +-- |Determine if a key exists (). Since Redis 1.0.0 +exists + :: (RedisCtx m f) + => ByteString -- ^ key + -> m (f Bool) +exists key = sendRequest ["EXISTS", key] + +newtype Cursor = Cursor ByteString deriving (Show, Eq) + + +instance RedisArg Cursor where + encode (Cursor c) = encode c + + +instance RedisResult Cursor where + decode (Bulk (Just s)) = Right $ Cursor s + decode r = Left r + + +cursor0 :: Cursor +cursor0 = Cursor "0" + +-- |Incrementally iterate the keys space (). The Redis command @SCAN@ is split up into 'scan', 'scanOpts'. Since Redis 2.8.0 +scan + :: (RedisCtx m f) + => Cursor + -> m (f (Cursor, [ByteString])) -- ^ next cursor and values +scan cursor = scanOpts cursor defaultScanOpts Nothing + + +data ScanOpts = ScanOpts + { scanMatch :: Maybe ByteString + , scanCount :: Maybe Integer + } deriving (Show, Eq) + + +-- |Redis default 'ScanOpts'. Equivalent to omitting all optional parameters. +-- +-- @ +-- ScanOpts +-- { scanMatch = Nothing -- don't match any pattern +-- , scanCount = Nothing -- don't set any requirements on number elements returned (works like value @COUNT 10@) +-- } +-- @ +-- +defaultScanOpts :: ScanOpts +defaultScanOpts = ScanOpts + { scanMatch = Nothing + , scanCount = Nothing + } + +-- | Incrementally iterate the keys space (). The Redis command @SCAN@ is split up into 'scan', 'scanOpts'. Since Redis 2.8.0 +scanOpts + :: (RedisCtx m f) + => Cursor + -> ScanOpts + -> Maybe ByteString -- ^ types of the object to scan + -> m (f (Cursor, [ByteString])) -- ^ next cursor and values +scanOpts cursor opts mtype_ = sendRequest $ addScanOpts ["SCAN", encode cursor] opts + ++ maybe [] (\type_ -> ["TYPE", type_]) mtype_ + + +addScanOpts + :: [ByteString] -- ^ main part of scan command + -> ScanOpts + -> [ByteString] +addScanOpts cmd ScanOpts{..} = + concat [cmd, match, count] + where + prepend x y = [x, y] + match = maybe [] (prepend "MATCH") scanMatch + count = maybe [] ((prepend "COUNT").encode) scanCount + +-- |Incrementally iterate Set elements (). The Redis command @SSCAN@ is split up into 'sscan', 'sscanOpts'. Since Redis 2.8.0 +sscan + :: (RedisCtx m f) + => ByteString -- ^ key + -> Cursor + -> m (f (Cursor, [ByteString])) -- ^ next cursor and values +sscan key cursor = sscanOpts key cursor defaultScanOpts + +-- |Incrementally iterate Set elements (). The Redis command @SSCAN@ is split up into 'sscan', 'sscanOpts'. Since Redis 2.8.0 +sscanOpts + :: (RedisCtx m f) + => ByteString -- ^ key + -> Cursor + -> ScanOpts + -> m (f (Cursor, [ByteString])) -- ^ next cursor and values +sscanOpts key cursor opts = sendRequest $ addScanOpts ["SSCAN", key, encode cursor] opts + +-- |Incrementally iterate hash fields and associated values (). The Redis command @HSCAN@ is split up into 'hscan', 'hscanOpts'. Since Redis 2.8.0 +hscan + :: (RedisCtx m f) + => ByteString -- ^ key + -> Cursor + -> m (f (Cursor, [(ByteString, ByteString)])) -- ^ next cursor and values +hscan key cursor = hscanOpts key cursor defaultScanOpts + +-- |Incrementally iterate hash fields and associated values (). The Redis command @HSCAN@ is split up into 'hscan', 'hscanOpts'. Since Redis 2.8.0 +hscanOpts + :: (RedisCtx m f) + => ByteString -- ^ key + -> Cursor + -> ScanOpts + -> m (f (Cursor, [(ByteString, ByteString)])) -- ^ next cursor and values +hscanOpts key cursor opts = sendRequest $ addScanOpts ["HSCAN", key, encode cursor] opts + + +zscan + :: (RedisCtx m f) + => ByteString -- ^ key + -> Cursor + -> m (f (Cursor, [(ByteString, Double)])) -- ^ next cursor and values +zscan key cursor = zscanOpts key cursor defaultScanOpts + + +zscanOpts + :: (RedisCtx m f) + => ByteString -- ^ key + -> Cursor + -> ScanOpts + -> m (f (Cursor, [(ByteString, Double)])) -- ^ next cursor and values +zscanOpts key cursor opts = sendRequest $ addScanOpts ["ZSCAN", key, encode cursor] opts + +data RangeLex a = Incl a | Excl a | Minr | Maxr + +instance RedisArg a => RedisArg (RangeLex a) where + encode (Incl bs) = "[" `append` encode bs + encode (Excl bs) = "(" `append` encode bs + encode Minr = "-" + encode Maxr = "+" + +-- |Return a range of members in a sorted set, by lexicographical range (). Since Redis 2.8.9 +zrangebylex::(RedisCtx m f) => + ByteString -- ^ key + -> RangeLex ByteString -- ^ min + -> RangeLex ByteString -- ^ max + -> m (f [ByteString]) +zrangebylex key min max = + sendRequest ["ZRANGEBYLEX", encode key, encode min, encode max] + +zrangebylexLimit + ::(RedisCtx m f) + => ByteString -- ^ key + -> RangeLex ByteString -- ^ min + -> RangeLex ByteString -- ^ max + -> Integer -- ^ offset + -> Integer -- ^ count + -> m (f [ByteString]) +zrangebylexLimit key min max offset count = + sendRequest ["ZRANGEBYLEX", encode key, encode min, encode max, + "LIMIT", encode offset, encode count] + +-- | Trimming strategy. +-- +-- @since 0.16.0 +data TrimStrategy + = TrimMaxlen Integer + -- ^ Evicts entries as long as the stream's length exceeds the specified threshold, where threshold is a positive integer. + | TrimMinId ByteString + {- ^ Evicts entries with IDs lower than threshold, where threshold is a stream ID. + + Since Redis 6.2: will fail if used on ealier versions. + -} + +-- | Type of the trimming. +-- +-- @since 0.16.0 +data TrimType + = TrimExact {- ^ Exact trimming -} + | TrimApprox (Maybe Integer) {- ^ Approximate trimming. Is faster, but may leave slightly more + elements in the stream if they can't be immediately deleted. + + Additional parameter Specifies the maximal count of entries that will be evicted. When LIMIT and count aren't specified, the default value of 100 * the number of entries in a macro node will be implicitly used as the count, @Just 0@ removes the limit entirely. + -} + +data TrimOpts = TrimOpts + { trimOptsStrategy :: TrimStrategy + , trimOptsType :: TrimType + } + +-- | Converts trim options to the low level parameters +internalTrimArgToList :: TrimOpts -> [ByteString] +internalTrimArgToList TrimOpts{..} = trimArg ++ limitArg + where trimArg = case trimOptsStrategy of + TrimMaxlen max -> ("MAXLEN":approxArg:encode max:[]) + TrimMinId i -> ("MINID":approxArg:i:[]) + (approxArg, limitArg) = case trimOptsType of + TrimExact -> ("=", []) + TrimApprox limit -> ("~", maybe [] (("LIMIT":) . (:[]) . encode) limit) + +trimOpts :: TrimStrategy -> TrimType -> TrimOpts +trimOpts = TrimOpts + +data XAddOpts = XAddOpts { + xAddTrimOpts :: Maybe TrimOpts, -- ^ Call XTRIM right after XADD + xAddnoMkStream :: Bool + {- ^ Don't create a new stream if it doesn't exist + + @since Redis 6.2 + -} +} + +defaultXAddOpts :: XAddOpts +defaultXAddOpts = XAddOpts { + xAddTrimOpts = Nothing, + xAddnoMkStream = False +} + +-- |Add a value to a stream (). The Redis command @XADD@ is split up into 'xadd', 'xaddOpts'. Since Redis 5.0.0 +xaddOpts + :: (RedisCtx m f) + => ByteString -- ^ Stream name. + -> ByteString -- ^ Message ID + -> [(ByteString, ByteString)] -- ^ Message data (field, value) + -> XAddOpts -- ^ Additional parameteers + -> m (f ByteString) -- ^ ID of the added entry. +xaddOpts key entryId fieldValues opts = sendRequest $ + ["XADD", key] ++ noMkStreamArgs ++ trimArgs ++ [entryId] ++ fieldArgs + where + fieldArgs = concatMap (\(x,y) -> [x,y]) fieldValues + noMkStreamArgs = ["NOMKSTREAM" | xAddnoMkStream opts] + trimArgs = maybe [] (internalTrimArgToList) (xAddTrimOpts opts) + +-- | /O(1)/ Adds a value to a stream (). Since Redis 5.0.0 +xadd + :: (RedisCtx m f) + => ByteString -- ^ Stream name + -> ByteString -- ^ Message id + -> [(ByteString, ByteString)] -- ^ Message data (field, value) + -> m (f ByteString) +xadd key entryId fieldValues = xaddOpts key entryId fieldValues defaultXAddOpts + +-- | Additional parameters. +newtype XAutoclaimOpts = XAutoclaimOpts { + xAutoclaimCount :: Maybe Integer -- ^ The upper limit of the number of entries that the command attempts to claim (default: 100). +} + +-- | Default 'XAutoclaimOpts' value. +-- +-- Prefer to use this function over direct use of constructor to preserve +-- backwards compatibility. +-- +-- Defaults to @[Count 100)@ +defaultXAutoclaimOpts :: XAutoclaimOpts +defaultXAutoclaimOpts = XAutoclaimOpts { + xAutoclaimCount = Nothing +} + +-- | Result of the 'xautoclaim' family of calls +data XAutoclaimResult resultFormat = XAutoclaimResult { + xAutoclaimResultId :: ByteString, + -- ^ ID of message that should be used in the next 'xautoclaim' call as a start parameter. + xAutoclaimClaimedMessages :: [resultFormat], + -- ^ List of succesfully claimed messages. + xAutoclaimDeletedMessages :: [ByteString] + -- ^ List of the messages that are available in the PEL but already deleted from the stream. +} deriving (Show, Eq) + +instance RedisResult a => RedisResult (XAutoclaimResult a) where + decode (MultiBulk (Just [ + Bulk (Just xAutoclaimResultId) , + claimedMsg, + deletedMsg])) = do + xAutoclaimClaimedMessages <- decode claimedMsg + xAutoclaimDeletedMessages <- decode deletedMsg + Right XAutoclaimResult{..} + decode (MultiBulk (Just [ + Bulk (Just xAutoclaimResultId) , + MultiBulk (Just []) + ])) = do + let xAutoclaimClaimedMessages = [] + let xAutoclaimDeletedMessages = [] + Right XAutoclaimResult{..} + decode a = Left a + +-- | Version of the autoclaim result that contains data of the messages. +type XAutoclaimStreamsResult = XAutoclaimResult StreamsRecord +-- | Version of the autoclaim result that contains only IDs. +type XAutoclaimJustIdsResult = XAutoclaimResult ByteString + +-- | /O(1)/ Transfers ownership of pending stream entries that match +-- the specified criteria. The message should be pending for more than \ +-- milliseconds and ID should be greater than \. +-- +-- @XAUTOCLAIM \ \ \ \@ +-- +-- This version of function claims no more than 100 mesages, use 'xautoclaimOpt' to +-- override this behavior. +-- +-- Since Redis 7.0: fails on ealier versions. +xautoclaim + :: (RedisCtx m f) + => ByteString -- ^ Stream name. + -> ByteString -- ^ Consumer group name. + -> ByteString -- ^ Consumer name. + -> Integer -- ^ Min idle time (ms). + -> ByteString -- ^ ID of the message to start. + -> m (f XAutoclaimStreamsResult) +xautoclaim key group consumer min_idle_time start = xautoclaimOpts key group consumer min_idle_time start defaultXAutoclaimOpts + +-- | /O(1) if count is small/. Transfers ownership of pending stream entries that match +-- the specified criteria. See 'xautoclaim' for details. +-- +-- Allows to pass additional optional parameters to set limit. +-- +-- @XAUTOCLAIM \ \ \ \ COUNT \@ +-- +-- Since Redis 7.0: fails on the ealier versions. +xautoclaimOpts + :: (RedisCtx m f) + => ByteString -- ^ Stream name. + -> ByteString -- ^ Consumer group name. + -> ByteString -- ^ Consumer name. + -> Integer -- ^ min idle time (ms). + -> ByteString -- ^ start ID. + -> XAutoclaimOpts -- ^ Additional parameters. + -> m (f XAutoclaimStreamsResult) +xautoclaimOpts key group consumer min_idle_time start opts = sendRequest $ + ["XAUTOCLAIM", key, group, consumer, encode min_idle_time, start] ++ count + where count = maybe [] (("COUNT":) . (:[]) . encode) (xAutoclaimCount opts) + +-- | /O(1)/ Transfers ownership of pending stream entries that match +-- the specified criteria. See 'xautoclaim' for more details about criteria. +-- +-- This variant returns only id of the messages without data. This method +-- claims no more than 100 messages, see 'xautoclaimJustIdsOpts' for changing +-- this default. +-- +-- @XAUTOCLAIM \ \ \ \ JUSTID@ +-- +-- Since Redis 7.0: fails on the ealier versions. +xautoclaimJustIds + :: (RedisCtx m f) + => ByteString -- ^ Stream name. + -> ByteString -- ^ Consumer group name. + -> ByteString -- ^ Consumer name. + -> Integer -- ^ Min idle time (ms). + -> ByteString -- ^ start ID. + -> m (f XAutoclaimJustIdsResult) +xautoclaimJustIds key group consumer min_idle_time start = + xautoclaimJustIdsOpts key group consumer min_idle_time start defaultXAutoclaimOpts + +-- | /O(1) if count is small/ Transfers ownership of pending stream entries that match +-- the specified criteria. See 'xautoclaim' for more details about criteria. +-- +-- This variant returns only id of the messages without data and allows to set the maximum +-- number of messages to be claimed. +-- +-- @XAUTOCLAIM \ \ \ \ COUNT \ JUSTID@ +-- +-- Since Redis 7.0: fails on the ealier versions. +xautoclaimJustIdsOpts + :: (RedisCtx m f) + => ByteString -- ^ Stream name. + -> ByteString -- ^ Consumers group name. + -> ByteString -- ^ Consumer namee. + -> Integer -- ^ min idle time (ms). + -> ByteString -- ^ Start ID. + -> XAutoclaimOpts -- ^ Additional parametres. + -> m (f XAutoclaimJustIdsResult) +xautoclaimJustIdsOpts key group consumer min_idle_time start opts = sendRequest $ + ["XAUTOCLAIM", key, group, consumer, encode min_idle_time, start] ++ count ++ ["JUSTID"] + where count = maybe [] (("COUNT":) . (:[]) . encode) (xAutoclaimCount opts) + +data StreamsRecord = StreamsRecord + { recordId :: ByteString + , keyValues :: [(ByteString, ByteString)] + } deriving (Show, Eq) + +instance RedisResult StreamsRecord where + decode (MultiBulk (Just [Bulk (Just recordId), MultiBulk (Just rawKeyValues)])) = do + keyValuesList <- mapM decode rawKeyValues + let keyValues = decodeKeyValues keyValuesList + return StreamsRecord{..} + where + decodeKeyValues :: [ByteString] -> [(ByteString, ByteString)] + decodeKeyValues (x:y:rest) = (x,y):decodeKeyValues rest + decodeKeyValues _ = [] + decode a = Left a + +data XReadOpts = XReadOpts + { block :: Maybe Integer + , recordCount :: Maybe Integer + } 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 +-- } +-- @ +-- +defaultXreadOpts :: XReadOpts +defaultXreadOpts = XReadOpts { block = Nothing, recordCount = Nothing } + +data XReadResponse = XReadResponse + { stream :: ByteString + , records :: [StreamsRecord] + } deriving (Show, Eq) + +instance RedisResult XReadResponse where + decode (MultiBulk (Just [Bulk (Just stream), MultiBulk (Just rawRecords)])) = do + records <- mapM decode rawRecords + return XReadResponse{..} + decode a = Left a + +xreadOpts + :: (RedisCtx m f) + => [(ByteString, ByteString)] -- ^ (stream, id) pairs + -> XReadOpts -- ^ Options + -> m (f (Maybe [XReadResponse])) +xreadOpts streamsAndIds opts = sendRequest $ + ["XREAD"] ++ (internalXreadArgs streamsAndIds opts) + +internalXreadArgs :: [(ByteString, ByteString)] -> XReadOpts -> [ByteString] +internalXreadArgs streamsAndIds XReadOpts{..} = + concat [blockArgs, countArgs, ["STREAMS"], streams, recordIds] + where + blockArgs = maybe [] (\blockMillis -> ["BLOCK", encode blockMillis]) block + countArgs = maybe [] (\countRecords -> ["COUNT", encode countRecords]) recordCount + streams = map (\(stream, _) -> stream) streamsAndIds + recordIds = map (\(_, recordId) -> recordId) streamsAndIds + + +xread + :: (RedisCtx m f) + => [(ByteString, ByteString)] -- ^ (stream, id) pairs + -> m( f (Maybe [XReadResponse])) +xread streamsAndIds = xreadOpts streamsAndIds defaultXreadOpts + +data XReadGroupOpts = XReadGroupOpts + { xReadGroupBlock :: Maybe Integer + , xReadGroupCount :: Maybe Integer + , xReadGroupNoAck :: Bool + } deriving (Show, Eq) + +defaultXReadGroupOpts :: XReadGroupOpts +defaultXReadGroupOpts = XReadGroupOpts + { xReadGroupBlock = Nothing + , xReadGroupCount = Nothing + , xReadGroupNoAck = False + } + +xreadGroupOpts + :: (RedisCtx m f) + => ByteString -- ^ group name + -> ByteString -- ^ consumer name + -> [(ByteString, ByteString)] -- ^ (stream, id) pairs + -> XReadGroupOpts -- ^ Options + -> m (f (Maybe [XReadResponse])) +xreadGroupOpts groupName consumerName streamsAndIds XReadGroupOpts{..} = sendRequest $ + ["XREADGROUP", "GROUP", groupName, consumerName] ++ internalXreadGroupArgs + where + internalXreadGroupArgs = concat [countArgs, blockArgs, noAckArgs, ["STREAMS"], streams, recordIds] + blockArgs = maybe [] (\blockMillis -> ["BLOCK", encode blockMillis]) xReadGroupBlock + countArgs = maybe [] (\countRecords -> ["COUNT", encode countRecords]) xReadGroupCount + noAckArgs = ["NOACK" | xReadGroupNoAck] + streams = map (\(stream, _) -> stream) streamsAndIds + recordIds = map (\(_, recordId) -> recordId) streamsAndIds + +xreadGroup + :: (RedisCtx m f) + => ByteString -- ^ group name + -> ByteString -- ^ consumer name + -> [(ByteString, ByteString)] -- ^ (stream, id) pairs + -> m (f (Maybe [XReadResponse])) +xreadGroup groupName consumerName streamsAndIds = xreadGroupOpts groupName consumerName streamsAndIds defaultXReadGroupOpts + +-- | Additional parameters of the XGroupCreate +data XGroupCreateOpts = XGroupCreateOpts + { xGroupCreateMkStream :: Bool -- ^ If a stream does not exist, create it automatically with length of 0 + , xGroupCreateEntriesRead :: Maybe ByteString + {- ^ Enable consumer group lag tracking, specify an arbitrary ID. + An arbitrary ID is any ID that isn't the ID of the stream's first entry, + last entry, or zero (@"0-0"@) ID. Use it to find out how many entries + are between the arbitrary ID (excluding it) and the stream's last entry. + + Since Redis 7.0, fails if set on the ealier versions. + -} + } deriving (Show, Eq) + +-- | Specifies default group opts. +-- +-- Prefer using this method over use of constructor to preserve backwards compatibility. +defaultXGroupCreateOpts :: XGroupCreateOpts +defaultXGroupCreateOpts = XGroupCreateOpts{ + xGroupCreateEntriesRead = Nothing, + xGroupCreateMkStream = False +} + +-- | /O(1)/ Creates consumer group. +-- +-- Fails if called on with the stream name that does not exist, use 'xgroupCreateOpts' +-- to override this behavior. +xgroupCreate + :: (RedisCtx m f) + => ByteString -- ^ Stream name. + -> ByteString -- ^ Consumer group name. + -> ByteString -- ^ ID of the message to start reading with. + -> m (f Status) +xgroupCreate stream groupName startId = xgroupCreateOpts stream groupName startId defaultXGroupCreateOpts + +-- | /O(1)/ Creates consumer group, accepts additional parameters. +xgroupCreateOpts + :: (RedisCtx m f) + => ByteString -- ^ Stream name. + -> ByteString -- ^ Consumer group name. + -> ByteString -- ^ ID of the message to start reading with. + -> XGroupCreateOpts -- ^ Additional parameters. + -> m (f Status) +xgroupCreateOpts stream groupName startId opts = sendRequest $ ["XGROUP", "CREATE", stream, groupName, startId] ++ args + where args = mkstream ++ entriesRead + mkstream = ["MKSTREAM" | xGroupCreateMkStream opts] + entriesRead = maybe [] (("ENTRIESREAD":) . (:[])) (xGroupCreateEntriesRead opts) + +-- | /O(1)/ Creates new consumer in the consumers group. +-- +-- Since redis 6.2.0: fails on the ealier versions. +xgroupCreateConsumer + :: (RedisCtx m f) + => ByteString -- ^ Stream name. + -> ByteString -- ^ Consumer group name. + -> ByteString -- ^ Consumer name. + -> m (f Bool) -- ^ Returns if the consumer was created or not. +xgroupCreateConsumer key group consumer = sendRequest ["XGROUP", "CREATECONSUMER", key, group, consumer] + +-- | /O(1)/ Sets last delivered id for a consumer group. +xgroupSetId + :: (RedisCtx m f) + => ByteString -- ^ Stream name. + -> ByteString -- ^ Consumr group name. + -> ByteString -- ^ Message ID or @$@ + -> m (f Status) +xgroupSetId stream group messageId = xgroupSetIdOpts stream group messageId defaultXGroupSetIdOpts + +-- | Additional parameters for the 'xgroupSetId' method +newtype XGroupSetIdOpts = XGroupSetIdOpts { + xGroupSetIdEntriesRead :: Maybe ByteString + {- ^ Enable consumer group lag tracking for an arbitrary ID. An arbitrary ID is any ID that isn't the ID of the stream's first entry, its last entry or the zero (@"0-0"@) ID + + @since Redis 7.0, fails if set to Just on ealier versions. + -} +} + +-- | Default value for the 'XGroupSetIdOpts'. +-- +-- Prefer use this method over the raw constructor in order to preserve +-- backwards compatibility. +defaultXGroupSetIdOpts :: XGroupSetIdOpts +defaultXGroupSetIdOpts = XGroupSetIdOpts {xGroupSetIdEntriesRead = Nothing} + +-- | /O(1)/ a variant of the 'xgroupSetId' that allowes to pass additional parameters. +xgroupSetIdOpts + :: (RedisCtx m f) + => ByteString -- ^ Stream name. + -> ByteString -- ^ Consumer group name. + -> ByteString -- ^ Message id or @$S + -> XGroupSetIdOpts -- ^ Additional parameters. + -> m (f Status) +xgroupSetIdOpts stream group messageId opts = sendRequest $ ["XGROUP", "SETID", stream, group, messageId] ++ entriesRead + where entriesRead = maybe [] (("ENTRIESREAD":) . (:[])) (xGroupSetIdEntriesRead opts) + +-- | /O(1)/ Delete consumer. +xgroupDelConsumer + :: (RedisCtx m f) + => ByteString -- ^ Stream name. + -> ByteString -- ^ Consumer group name. + -> ByteString -- ^ Consumer name. + -> m (f Integer) -- ^ The number of pending messages owned by the consumer. +xgroupDelConsumer stream group consumer = sendRequest ["XGROUP", "DELCONSUMER", stream, group, consumer] + +-- | /O(1)/ destroys a group. +xgroupDestroy + :: (RedisCtx m f) + => ByteString -- ^ Stream name. + -> ByteString -- ^ Consumer group name. + -> m (f Bool) -- ^ Tells if the group was destroyed or not. +xgroupDestroy stream group = sendRequest ["XGROUP", "DESTROY", stream, group] + +xack + :: (RedisCtx m f) + => ByteString -- ^ stream + -> ByteString -- ^ group name + -> [ByteString] -- ^ message IDs + -> m (f Integer) +xack stream groupName messageIds = sendRequest $ ["XACK", stream, groupName] ++ messageIds + +xrange + :: (RedisCtx m f) + => ByteString -- ^ stream + -> ByteString -- ^ start + -> ByteString -- ^ end + -> Maybe Integer -- ^ COUNT + -> m (f [StreamsRecord]) +xrange stream start end count = sendRequest $ ["XRANGE", stream, start, end] ++ countArgs + where countArgs = maybe [] (\c -> ["COUNT", encode c]) count + +xrevRange + :: (RedisCtx m f) + => ByteString -- ^ stream + -> ByteString -- ^ end + -> ByteString -- ^ start + -> Maybe Integer -- ^ COUNT + -> m (f [StreamsRecord]) +xrevRange stream end start count = sendRequest $ ["XREVRANGE", stream, end, start] ++ countArgs + where countArgs = maybe [] (\c -> ["COUNT", encode c]) count + +xlen + :: (RedisCtx m f) + => ByteString -- ^ stream + -> m (f Integer) +xlen stream = sendRequest ["XLEN", stream] + +data XPendingSummaryResponse = XPendingSummaryResponse + { numPendingMessages :: Integer + , smallestPendingMessageId :: ByteString + , largestPendingMessageId :: ByteString + , numPendingMessagesByconsumer :: [(ByteString, Integer)] + } deriving (Show, Eq) + +instance RedisResult XPendingSummaryResponse where + decode (MultiBulk (Just [ + Integer numPendingMessages, + Bulk (Just smallestPendingMessageId), + Bulk (Just largestPendingMessageId), + MultiBulk (Just [MultiBulk (Just rawGroupsAndCounts)])])) = do + let groupsAndCounts = chunksOfTwo rawGroupsAndCounts + numPendingMessagesByconsumer <- decodeGroupsAndCounts groupsAndCounts + return XPendingSummaryResponse{..} + where + decodeGroupsAndCounts :: [(Reply, Reply)] -> Either Reply [(ByteString, Integer)] + decodeGroupsAndCounts bs = sequence $ map decodeGroupCount bs + decodeGroupCount :: (Reply, Reply) -> Either Reply (ByteString, Integer) + decodeGroupCount (x, y) = do + decodedX <- decode x + decodedY <- decode y + return (decodedX, decodedY) + chunksOfTwo (x:y:rest) = (x,y):chunksOfTwo rest + chunksOfTwo _ = [] + decode a = Left a + +-- | /O(N)/ N - number of message beign returned. +-- +-- Get information about pending messages (https://redis.io/commands/xpending). +-- +-- Since Redis 5.0. +xpendingSummary + :: (RedisCtx m f) + => ByteString -- ^ Stream name. + -> ByteString -- ^ Stream consumer group. + -> m (f XPendingSummaryResponse) +xpendingSummary stream group = sendRequest $ ["XPENDING", stream, group] + +-- | Details about message returned by the 'xpendingDetails' +data XPendingDetailRecord = XPendingDetailRecord + { messageId :: ByteString + , consumer :: ByteString + , millisSinceLastDelivered :: Integer + , numTimesDelivered :: Integer + } deriving (Show, Eq) + +instance RedisResult XPendingDetailRecord where + decode (MultiBulk (Just [ + Bulk (Just messageId) , + Bulk (Just consumer), + Integer millisSinceLastDelivered, + Integer numTimesDelivered])) = Right XPendingDetailRecord{..} + decode a = Left a + +-- | Additional parameters of the xpending call family +data XPendingDetailOpts = XPendingDetailOpts + { + xPendingDetailConsumer :: Maybe ByteString, -- ^ Fetch the messages having a specific owner. + xPendingDetailIdle :: Maybe Integer + {- ^ Filter pending stream entries by their idle-time, ms + + Since Redis 6.2: Just values will fail + -} + } + +-- | Default 'XPendingOpts' values. +-- +-- Prefer this method over use of the constructor in order to preserve +-- backwards compatibility. +defaultXPendingDetailOpts :: XPendingDetailOpts +defaultXPendingDetailOpts = XPendingDetailOpts { + xPendingDetailConsumer = Nothing, + xPendingDetailIdle = Nothing +} + +-- | /O(N)/ N - number of messages returned. +-- +-- Get detailed information about pending messages (https://redis.io/commands/xpending). +xpendingDetail + :: (RedisCtx m f) + => ByteString -- ^ Stream name. + -> ByteString -- ^ Consumer group name. + -> ByteString -- ^ ID of the first interesting message. + -> ByteString -- ^ ID of the last intersting message. + -> Integer -- ^ Limits the numbere of messages returned from the call. + -> XPendingDetailOpts + -> m (f [XPendingDetailRecord]) +xpendingDetail stream group startId endId count opts = sendRequest $ + ["XPENDING", stream, group] ++ idleArg ++ [startId, endId, encode count] ++ consumerArg + where consumerArg = maybeToList (xPendingDetailConsumer opts) + idleArg = maybe [] (("IDLE":) . (:[]) . encode) (xPendingDetailIdle opts) + +data XClaimOpts = XClaimOpts + { xclaimIdle :: Maybe Integer + , xclaimTime :: Maybe Integer + , xclaimRetryCount :: Maybe Integer + , xclaimForce :: Bool + } deriving (Show, Eq) + +defaultXClaimOpts :: XClaimOpts +defaultXClaimOpts = XClaimOpts + { xclaimIdle = Nothing + , xclaimTime = Nothing + , xclaimRetryCount = Nothing + , xclaimForce = False + } + + +-- |Format a request for XCLAIM. +xclaimRequest + :: ByteString -- ^ stream + -> ByteString -- ^ group + -> ByteString -- ^ consumer + -> Integer -- ^ min idle time + -> XClaimOpts -- ^ optional arguments + -> [ByteString] -- ^ message IDs + -> [ByteString] +xclaimRequest stream group consumer minIdleTime XClaimOpts{..} messageIds = + ["XCLAIM", stream, group, consumer, encode minIdleTime] ++ ( map encode messageIds ) ++ optArgs + where optArgs = idleArg ++ timeArg ++ retryCountArg ++ forceArg + idleArg = optArg "IDLE" xclaimIdle + timeArg = optArg "TIME" xclaimTime + retryCountArg = optArg "RETRYCOUNT" xclaimRetryCount + forceArg = if xclaimForce then ["FORCE"] else [] + optArg name maybeArg = maybe [] (\x -> [name, encode x]) maybeArg + +xclaim + :: (RedisCtx m f) + => ByteString -- ^ stream + -> ByteString -- ^ group + -> ByteString -- ^ consumer + -> Integer -- ^ min idle time + -> XClaimOpts -- ^ optional arguments + -> [ByteString] -- ^ message IDs + -> m (f [StreamsRecord]) +xclaim stream group consumer minIdleTime opts messageIds = sendRequest $ + xclaimRequest stream group consumer minIdleTime opts messageIds + +xclaimJustIds + :: (RedisCtx m f) + => ByteString -- ^ stream + -> ByteString -- ^ group + -> ByteString -- ^ consumer + -> Integer -- ^ min idle time + -> XClaimOpts -- ^ optional arguments + -> [ByteString] -- ^ message IDs + -> m (f [ByteString]) +xclaimJustIds stream group consumer minIdleTime opts messageIds = sendRequest $ + (xclaimRequest stream group consumer minIdleTime opts messageIds) ++ ["JUSTID"] + +-- | Data structure that is returned as a result of 'xinfoConsumers' +data XInfoConsumersResponse = XInfoConsumersResponse + { xinfoConsumerName :: ByteString -- ^ The name of the consumer. + , xinfoConsumerNumPendingMessages :: Integer -- ^ The number of entries in the PEL (pending elemeent list): pending messages for the consumer, which are messages that were delivered but are yet to be acknowledged + , xinfoConsumerIdleTime :: Integer -- ^ The number of milliseconds that have passed since the consumer's last attempted interaction (Examples: 'xreadGroup', 'xclam', 'xautoclaim') + , xinfoConsumerInactive :: Maybe Integer + {- ^ The number of milliseconds that have passed since the consumer's last successful interaction (Examples: 'xreadGroup' that actually read some entries into the PEL, 'xclaim'/'xautoclaim' that actually claimed some entries) + + @since Redis 7.0: always @Nothing@ for previous versions. + -} + } deriving (Show, Eq) + +instance RedisResult XInfoConsumersResponse where + decode = decodeRedis6 <> decodeRedis7 + where decodeRedis6 (MultiBulk (Just [ + Bulk (Just "name"), + Bulk (Just xinfoConsumerName), + Bulk (Just "pending"), + Integer xinfoConsumerNumPendingMessages, + Bulk (Just "idle"), + Integer xinfoConsumerIdleTime])) = Right XInfoConsumersResponse{xinfoConsumerInactive = Nothing, ..} + decodeRedis6 a = Left a + + decodeRedis7 (MultiBulk (Just [ + Bulk (Just "name"), + Bulk (Just xinfoConsumerName), + Bulk (Just "pending"), + Integer xinfoConsumerNumPendingMessages, + Bulk (Just "idle"), + Integer xinfoConsumerIdleTime, + Bulk (Just "inactive"), + Integer xinfoConsumerInactive])) = Right XInfoConsumersResponse{xinfoConsumerInactive = Just xinfoConsumerInactive, ..} + decodeRedis7 a = Left a + +-- | /O(1)/ +-- Returns information about the list of the consumers beloging to the consumer group. +-- +-- Available since Redis 5.0.0 +-- +-- Wrapper over @XINFO CONSUMERS \ \@ +xinfoConsumers + :: (RedisCtx m f) + => ByteString -- ^ Stream name. + -> ByteString -- ^ Group name. + -> m (f [XInfoConsumersResponse]) +xinfoConsumers stream group = sendRequest $ ["XINFO", "CONSUMERS", stream, group] + +-- | Result of the 'xinfoGroups' call. +data XInfoGroupsResponse = XInfoGroupsResponse + { xinfoGroupsGroupName :: ByteString -- ^ Name of the consumer group. + , xinfoGroupsNumConsumers :: Integer -- ^ The number of consumers in the group. + , xinfoGroupsNumPendingMessages :: Integer -- ^ The length of the group's pending entries list (PEL), which are messages that were delivered but are yet to be acknowledged. + , xinfoGroupsLastDeliveredMessageId :: ByteString -- ^ The ID of the last entry delivered to the group's consumers. + , xinfoGroupsEntriesRead :: Maybe Integer + {- ^ The logical "read counter" of the last entry delivered to group's consumers. + + Since Redis 7.0: always @Nothing@ on the previous versions. + -} + , xinfoGroupsLag :: Maybe Integer + {- ^ the number of entries in the stream that are still waiting to be delivered to the group's consumers, or a Nothing when that number can't be determined. + + Since Redis 7.0: always @Nothing@ on the previous versions. + -} + } deriving (Show, Eq) + +instance RedisResult XInfoGroupsResponse where + decode = decodeRedis6 <> decodeRedis7 + where decodeRedis6 (MultiBulk (Just [ + Bulk (Just "name"), Bulk (Just xinfoGroupsGroupName), + Bulk (Just "consumers"), Integer xinfoGroupsNumConsumers, + Bulk (Just "pending"), Integer xinfoGroupsNumPendingMessages, + Bulk (Just "last-delivered-id"), + Bulk (Just xinfoGroupsLastDeliveredMessageId)])) = + Right XInfoGroupsResponse{ + xinfoGroupsEntriesRead = Nothing + , xinfoGroupsLag = Nothing + , ..} + decodeRedis6 a = Left a + + decodeRedis7 (MultiBulk (Just [ + Bulk (Just "name"), Bulk (Just xinfoGroupsGroupName), + Bulk (Just "consumers"), Integer xinfoGroupsNumConsumers, + Bulk (Just "pending"), Integer xinfoGroupsNumPendingMessages, + Bulk (Just "last-delivered-id"), Bulk (Just xinfoGroupsLastDeliveredMessageId), + Bulk (Just "entries-read"), Integer xinfoGroupsEntriesRead, + Bulk (Just "lag"), Integer xinfoGroupsLag])) = + Right XInfoGroupsResponse{ + xinfoGroupsEntriesRead = Just xinfoGroupsEntriesRead + , xinfoGroupsLag = Just xinfoGroupsLag + , ..} + decodeRedis7 a = Left a + +-- | /O(1)/ Returns information about the groups. +-- +-- Available since: Redis 5.0.0 +-- +-- Wrapper around @XINFO GROUPS \@ call. +xinfoGroups + :: (RedisCtx m f) + => ByteString -- ^ Stream name. + -> m (f [XInfoGroupsResponse]) +xinfoGroups stream = sendRequest ["XINFO", "GROUPS", stream] + +data XInfoStreamResponse + = XInfoStreamResponse + { xinfoStreamLength :: Integer -- ^ The number of entries in the stream. + , xinfoStreamRadixTreeKeys :: Integer -- ^ The number of keys in the underlying radix data structure. + , xinfoStreamRadixTreeNodes :: Integer -- ^ The number of nodes in the underlying radix data structure. + , xinfoMaxDeletedEntryId :: Maybe ByteString + {- ^ The maximal entry ID that was deleted from the stream + + Since Redis 7.0: always returns @Nothing@ on the previous versions. + -} + , xinfoEntriesAdded :: Maybe Integer + {- ^ The count of all entries added to the stream during its lifetime + + Since Redis 7.0: always returns @Nothing@ on the previous versions. + -} + , xinfoRecordedFirstEntryId :: Maybe ByteString + {- ^ ID of first recorded entry. + + Since Redis 7.0: always returns @Nothing@ on the previous versions. + -} + , xinfoStreamNumGroups :: Integer -- ^ The number of consumer groups defined for the stream. + , xinfoStreamLastEntryId :: ByteString -- ^ ID of the last entry in the stream. + , xinfoStreamFirstEntry :: StreamsRecord -- ^ ID and field-value tuples of the first entry in the stream. + , xinfoStreamLastEntry :: StreamsRecord -- ^ ID and field-value tuples of the last entry in the stream. + } + | XInfoStreamEmptyResponse + { xinfoStreamLength :: Integer -- ^ The number of entries in the stream. + , xinfoStreamRadixTreeKeys :: Integer -- ^ The number of keys in the underlying radix data structure. + , xinfoStreamRadixTreeNodes :: Integer -- ^ The number of nodes in the underlying radix data structure. + , xinfoMaxDeletedEntryId :: Maybe ByteString + {- ^ The maximal entry ID that was deleted from the stream. + + Since Redis 7.0: always returns @Nothing@ on the previous versions. + -} + , xinfoEntriesAdded :: Maybe Integer + {- ^ The count of all entries added to the stream during its lifetime + + Since Redis 7.0: always returns @Nothing@ on the previous versions. + -} + , xinfoRecordedFirstEntryId :: Maybe ByteString + {- ^ ID of first recorded entry. + + Since Redis 7.0: always returns @Nothing@ on the previous versions. + -} + , xinfoStreamNumGroups :: Integer -- ^ The number of consumer groups defined for the stream. + , xinfoStreamLastEntryId :: ByteString -- ^ The ID of the last entry in the stream. + } + deriving (Show, Eq) + +instance RedisResult XInfoStreamResponse where + decode = decodeRedis5 <> decodeRedis6 <> decodeRedis7 + 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{ + xinfoMaxDeletedEntryId = Nothing + , xinfoEntriesAdded = Nothing + , xinfoRecordedFirstEntryId = Nothing + , ..} + 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{ + xinfoMaxDeletedEntryId = Nothing + , xinfoEntriesAdded = Nothing + , xinfoRecordedFirstEntryId = Nothing + , ..} + 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{ + xinfoMaxDeletedEntryId = Nothing + , xinfoEntriesAdded = Nothing + , xinfoRecordedFirstEntryId = Nothing + , ..} + 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{ + xinfoMaxDeletedEntryId = Nothing + , xinfoEntriesAdded = Nothing + , xinfoRecordedFirstEntryId = Nothing + , ..} + decodeRedis6 a = Left a + + decodeRedis7 (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 "max-deleted-entry-id"), Bulk (Just xinfoMaxDeletedEntryId), + Bulk (Just "entries-added"), Integer xinfoEntriesAdded, + Bulk (Just "recorded-first-entry-id"), Bulk (Just xinfoRecordedFirstEntryId), + Bulk (Just "groups"), Integer xinfoStreamNumGroups, + Bulk (Just "first-entry"), Bulk Nothing , + Bulk (Just "last-entry"), Bulk Nothing ])) = do + return XInfoStreamEmptyResponse{ + xinfoMaxDeletedEntryId = Just xinfoMaxDeletedEntryId + , xinfoEntriesAdded = Just xinfoEntriesAdded + , xinfoRecordedFirstEntryId = Just xinfoRecordedFirstEntryId + , ..} + + decodeRedis7 (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 "max-deleted-entry-id"), Bulk (Just xinfoMaxDeletedEntryId), + Bulk (Just "entries-added"), Integer xinfoEntriesAdded, + Bulk (Just "recorded-first-entry-id"), Bulk (Just xinfoRecordedFirstEntryId), + Bulk (Just "groups"), Integer xinfoStreamNumGroups, + Bulk (Just "first-entry"), rawFirstEntry , + Bulk (Just "last-entry"), rawLastEntry ])) = do + xinfoStreamFirstEntry <- decode rawFirstEntry + xinfoStreamLastEntry <- decode rawLastEntry + return XInfoStreamResponse{ + xinfoMaxDeletedEntryId = Just xinfoMaxDeletedEntryId + , xinfoEntriesAdded = Just xinfoEntriesAdded + , xinfoRecordedFirstEntryId = Just xinfoRecordedFirstEntryId + , ..} + decodeRedis7 a = Left a + +-- | Get info about a stream. The Redis command @XINFO@ is split into 'xinfoConsumers', 'xinfoGroups', and 'xinfoStream'. +-- Since Redis 5.0.0 +xinfoStream + :: (RedisCtx m f) + => ByteString -- ^ stream + -> m (f XInfoStreamResponse) +xinfoStream stream = sendRequest ["XINFO", "STREAM", stream] + +-- | Delete messages from a stream. +-- Since Redis 5.0.0 +xdel + :: (RedisCtx m f) + => ByteString -- ^ stream + -> NonEmpty ByteString -- ^ message IDs + -> m (f Integer) +xdel stream (messageId:|messageIds) = sendRequest ("XDEL":stream:messageId: messageIds) + +-- |Set the upper bound for number of messages in a stream. Since Redis 5.0.0 +xtrim + :: (RedisCtx m f) + => ByteString -- ^ stream + -> TrimOpts + -> m (f Integer) +xtrim stream opts = sendRequest ("XTRIM":stream:internalTrimArgToList opts) + +-- |Constructor for `inf` Redis argument values +inf :: RealFloat a => a +inf = 1 / 0 + +-- | Additional parameters for the auth command. +data AuthOpts = AuthOpts + { authOptsUsername + :: Maybe ByteString + {- ^ Username. + + Since Redis 6.0: fails on earlier + -} + } + deriving Show + +-- | Default options for AuthOpts +-- +-- >>> defaultAuthOpts +-- AuthOpts {authOptsUsername = Nothing} +defaultAuthOpts :: AuthOpts +defaultAuthOpts = AuthOpts + { authOptsUsername = Nothing + } + +-- | /O(N)/ where N is the number of passwords defined for the user. +-- +-- Authenticates client to the server. +auth + :: RedisCtx m f + => ByteString -- ^ Password. + -> m (f Status) +auth password = authOpts password defaultAuthOpts + +-- | /O(N)/ where N is the number of passwords defined for the user. +-- +-- Authenticates client to the server. +-- +-- This method allows passing additional options. +authOpts + :: RedisCtx m f + => ByteString -- ^ Password. + -> AuthOpts -- ^ Additional options. + -> m (f Status) +authOpts password AuthOpts{..} = sendRequest $ + ["AUTH"] <> maybe [] (:[]) authOptsUsername <> [password] + +-- |Change the selected database for the current connection (). Since Redis 1.0.0 +select + :: RedisCtx m f + => Integer -- ^ index + -> m (f Status) +select ix = sendRequest ["SELECT", encode ix] + +-- |Ping the server (). Since Redis 1.0.0 +ping + :: (RedisCtx m f) + => m (f Status) +ping = sendRequest (["PING"] ) + +-- https://redis.io/commands/cluster-info/ +data ClusterInfoResponse = ClusterInfoResponse + { clusterInfoResponseState :: ClusterInfoResponseState, + clusterInfoResponseSlotsAssigned :: Integer, + clusterInfoResponseSlotsOK :: Integer, + clusterInfoResponseSlotsPfail :: Integer, + clusterInfoResponseSlotsFail :: Integer, + clusterInfoResponseKnownNodes :: Integer, + clusterInfoResponseSize :: Integer, + clusterInfoResponseCurrentEpoch :: Integer, + clusterInfoResponseMyEpoch :: Integer, + clusterInfoResponseStatsMessagesSent :: Integer, + clusterInfoResponseStatsMessagesReceived :: Integer, + clusterInfoResponseTotalLinksBufferLimitExceeded :: Integer, + clusterInfoResponseStatsMessagesPingSent :: Maybe Integer, + clusterInfoResponseStatsMessagesPingReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesPongSent :: Maybe Integer, + clusterInfoResponseStatsMessagesPongReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesMeetSent :: Maybe Integer, + clusterInfoResponseStatsMessagesMeetReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesFailSent :: Maybe Integer, + clusterInfoResponseStatsMessagesFailReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesPublishSent :: Maybe Integer, + clusterInfoResponseStatsMessagesPublishReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesAuthReqSent :: Maybe Integer, + clusterInfoResponseStatsMessagesAuthReqReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesAuthAckSent :: Maybe Integer, + clusterInfoResponseStatsMessagesAuthAckReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesUpdateSent :: Maybe Integer, + clusterInfoResponseStatsMessagesUpdateReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesMfstartSent :: Maybe Integer, + clusterInfoResponseStatsMessagesMfstartReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesModuleSent :: Maybe Integer, + clusterInfoResponseStatsMessagesModuleReceived :: Maybe Integer, + clusterInfoResponseStatsMessagesPublishshardSent :: Maybe Integer, + clusterInfoResponseStatsMessagesPublishshardReceived :: Maybe Integer + } + deriving (Show, Eq) + +data ClusterInfoResponseState + = OK + | Down + deriving (Show, Eq) + +defClusterInfoResponse :: ClusterInfoResponse +defClusterInfoResponse = + ClusterInfoResponse + { clusterInfoResponseState = Down, + clusterInfoResponseSlotsAssigned = 0, + clusterInfoResponseSlotsOK = 0, + clusterInfoResponseSlotsPfail = 0, + clusterInfoResponseSlotsFail = 0, + clusterInfoResponseKnownNodes = 0, + clusterInfoResponseSize = 0, + clusterInfoResponseCurrentEpoch = 0, + clusterInfoResponseMyEpoch = 0, + clusterInfoResponseStatsMessagesSent = 0, + clusterInfoResponseStatsMessagesReceived = 0, + clusterInfoResponseTotalLinksBufferLimitExceeded = 0, + clusterInfoResponseStatsMessagesPingSent = Nothing, + clusterInfoResponseStatsMessagesPingReceived = Nothing, + clusterInfoResponseStatsMessagesPongSent = Nothing, + clusterInfoResponseStatsMessagesPongReceived = Nothing, + clusterInfoResponseStatsMessagesMeetSent = Nothing, + clusterInfoResponseStatsMessagesMeetReceived = Nothing, + clusterInfoResponseStatsMessagesFailSent = Nothing, + clusterInfoResponseStatsMessagesFailReceived = Nothing, + clusterInfoResponseStatsMessagesPublishSent = Nothing, + clusterInfoResponseStatsMessagesPublishReceived = Nothing, + clusterInfoResponseStatsMessagesAuthReqSent = Nothing, + clusterInfoResponseStatsMessagesAuthReqReceived = Nothing, + clusterInfoResponseStatsMessagesAuthAckSent = Nothing, + clusterInfoResponseStatsMessagesAuthAckReceived = Nothing, + clusterInfoResponseStatsMessagesUpdateSent = Nothing, + clusterInfoResponseStatsMessagesUpdateReceived = Nothing, + clusterInfoResponseStatsMessagesMfstartSent = Nothing, + clusterInfoResponseStatsMessagesMfstartReceived = Nothing, + clusterInfoResponseStatsMessagesModuleSent = Nothing, + clusterInfoResponseStatsMessagesModuleReceived = Nothing, + clusterInfoResponseStatsMessagesPublishshardSent = Nothing, + clusterInfoResponseStatsMessagesPublishshardReceived = Nothing + } + +parseClusterInfoResponse :: [[ByteString]] -> ClusterInfoResponse -> Maybe ClusterInfoResponse +parseClusterInfoResponse fields resp = case fields of + [] -> pure resp + (["cluster_state", state] : fs) -> parseState state >>= \s -> parseClusterInfoResponse fs $ resp {clusterInfoResponseState = s} + (["cluster_slots_assigned", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseSlotsAssigned = v} + (["cluster_slots_ok", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseSlotsOK = v} + (["cluster_slots_pfail", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseSlotsPfail = v} + (["cluster_slots_fail", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseSlotsFail = v} + (["cluster_known_nodes", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseKnownNodes = v} + (["cluster_size", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseSize = v} + (["cluster_current_epoch", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseCurrentEpoch = v} + (["cluster_my_epoch", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseMyEpoch = v} + (["cluster_stats_messages_sent", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesSent = v} + (["cluster_stats_messages_received", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesReceived = v} + (["total_cluster_links_buffer_limit_exceeded", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseTotalLinksBufferLimitExceeded = fromMaybe 0 $ parseInteger value} -- this value should be mandatory according to the spec, but isn't necessarily set in Redis 6 + (["cluster_stats_messages_ping_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPingSent = parseInteger value} + (["cluster_stats_messages_ping_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPingReceived = parseInteger value} + (["cluster_stats_messages_pong_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPongSent = parseInteger value} + (["cluster_stats_messages_pong_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPongReceived = parseInteger value} + (["cluster_stats_messages_meet_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesMeetSent = parseInteger value} + (["cluster_stats_messages_meet_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesMeetReceived = parseInteger value} + (["cluster_stats_messages_fail_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesFailSent = parseInteger value} + (["cluster_stats_messages_fail_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesFailReceived = parseInteger value} + (["cluster_stats_messages_publish_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPublishSent = parseInteger value} + (["cluster_stats_messages_publish_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPublishReceived = parseInteger value} + (["cluster_stats_messages_auth_req_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesAuthReqSent = parseInteger value} + (["cluster_stats_messages_auth_req_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesAuthReqReceived = parseInteger value} + (["cluster_stats_messages_auth_ack_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesAuthAckSent = parseInteger value} + (["cluster_stats_messages_auth_ack_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesAuthAckReceived = parseInteger value} + (["cluster_stats_messages_update_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesUpdateSent = parseInteger value} + (["cluster_stats_messages_update_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesUpdateReceived = parseInteger value} + (["cluster_stats_messages_mfstart_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesMfstartSent = parseInteger value} + (["cluster_stats_messages_mfstart_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesMfstartReceived = parseInteger value} + (["cluster_stats_messages_module_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesModuleSent = parseInteger value} + (["cluster_stats_messages_module_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesModuleReceived = parseInteger value} + (["cluster_stats_messages_publishshard_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPublishshardSent = parseInteger value} + (["cluster_stats_messages_publishshard_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPublishshardReceived = parseInteger value} + (_ : fs) -> parseClusterInfoResponse fs resp + where + parseState bs = case bs of + "ok" -> Just OK + "fail" -> Just Down + _ -> Nothing + parseInteger = fmap fst . Char8.readInteger + +instance RedisResult ClusterInfoResponse where + decode r@(Bulk (Just bulkData)) = + maybe (Left r) Right + . flip parseClusterInfoResponse defClusterInfoResponse + . map (Char8.split ':' . Char8.takeWhile (/= '\r')) + $ Char8.lines bulkData + decode r = Left r + +clusterInfo :: RedisCtx m f => m (f ClusterInfoResponse) +clusterInfo = sendRequest ["CLUSTER", "INFO"] + +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)] + +command :: (RedisCtx m f) => m (f [CMD.CommandInfo]) +command = sendRequest ["COMMAND"] + + +data ExpireOpts + = ExpireOptsTime Condition + | ExpireOptsValue SizeCondition + +instance RedisArg ExpireOpts where + encode (ExpireOptsTime c) = encode c + encode (ExpireOptsValue c) = encode c + +-- |Set the expiration for a key as a UNIX timestamp specified in milliseconds (). +-- Since Redis 7.0 +pexpireatOpts + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ millisecondsTimestamp + -> ExpireOpts + -> m (f Bool) +pexpireatOpts key millisecondsTimestamp opts = + sendRequest ["PEXPIREAT", key, encode millisecondsTimestamp, encode opts] + +expireOpts + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ seconds + -> ExpireOpts + -> m (f Bool) +expireOpts key seconds opts = sendRequest ["EXPIRE", key, encode seconds, encode opts] + +-- | Set the expiration for a key as a UNIX timestamp (). +-- Since Redis 1.2.0 +expireatOpts + :: (RedisCtx m f) + => ByteString -- ^ key + -> Integer -- ^ timestamp + -> ExpireOpts + -> m (f Bool) +expireatOpts key timestamp opts = sendRequest ["EXPIREAT", key, encode timestamp, encode opts] + +data FlushOpts + = FlushOptsSync + | FlushOptsAsync + +instance RedisArg FlushOpts where + encode FlushOptsSync = "SYNC" + encode FlushOptsAsync = "ASYNC" + +-- |Remove all keys from the current database (). +-- Since Redis 6.2 +flushdbOpts + :: (RedisCtx m f) + => FlushOpts + -> m (f Status) +flushdbOpts opts = sendRequest ["FLUSHDB", encode opts] + +-- |Remove all keys from the current database (). +-- Since Redis 6.2 +flushallOpts + :: (RedisCtx m f) + => FlushOpts + -> m (f Status) +flushallOpts opts = sendRequest ["FLUSHALL", encode opts] + +data BitposType = Byte | Bit + +instance RedisArg BitposType where + encode Byte = "BYTE" + encode Bit = "BIT" + +data BitposOpts + = BitposOptsStart Integer + | BitposOptsStartEnd Integer Integer (Maybe BitposType) + +bitposOpts + :: (RedisCtx m f) + => ByteString + -> Integer + -> BitposOpts + -> m (f Integer) +bitposOpts key_ bit opts = sendRequest ("BITPOS": key_:encode bit: rest) where + rest = case opts of + BitposOptsStart s -> [encode s] + BitposOptsStartEnd start end bits -> + [encode start, encode end] ++ [ encode bits_ | Just bits_ <- pure bits] diff --git a/src/Database/Redis/ProtocolPipelining.hs b/src/Database/Redis/ProtocolPipelining.hs --- a/src/Database/Redis/ProtocolPipelining.hs +++ b/src/Database/Redis/ProtocolPipelining.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -- |A module for automatic, optimal protocol pipelining. @@ -16,7 +17,7 @@ -- module Database.Redis.ProtocolPipelining ( Connection, - connect, enableTLS, beginReceiving, disconnect, request, send, recv, flush, fromCtx + connect, connectWithHooks, beginReceiving, disconnect, request, send, recv, flush, fromCtx, hooks ) where import Prelude @@ -24,12 +25,12 @@ import qualified Scanner import qualified Data.ByteString as S import Data.IORef -import qualified Network.Socket as NS import qualified Network.TLS as TLS import System.IO.Unsafe import Database.Redis.Protocol import qualified Database.Redis.ConnectionContext as CC +import Database.Redis.Hooks data Connection = Conn { connCtx :: CC.ConnectionContext -- ^ Connection socket-handle. @@ -41,25 +42,24 @@ -- ^ Number of pending replies and thus the difference length between -- 'connReplies' and 'connPending'. -- length connPending - pendingCount = length connReplies + , hooks :: Hooks } fromCtx :: CC.ConnectionContext -> IO Connection -fromCtx ctx = Conn ctx <$> newIORef [] <*> newIORef [] <*> newIORef 0 +fromCtx ctx = Conn ctx <$> newIORef [] <*> newIORef [] <*> newIORef 0 <*> pure defaultHooks -connect :: NS.HostName -> CC.PortID -> Maybe Int -> IO Connection -connect hostName portId timeoutOpt = do - connCtx <- CC.connect hostName portId timeoutOpt +connect :: CC.ConnectAddr -> Maybe Int -> Maybe TLS.ClientParams -> IO Connection +connect connectAddr timeoutOpt mTlsParams = connectWithHooks connectAddr timeoutOpt mTlsParams defaultHooks + +connectWithHooks :: CC.ConnectAddr -> Maybe Int -> Maybe TLS.ClientParams -> Hooks -> IO Connection +connectWithHooks connectAddr timeoutOpt mTlsParams hooks = do + connCtx <- CC.connect connectAddr timeoutOpt mTlsParams connReplies <- newIORef [] connPending <- newIORef [] connPendingCnt <- newIORef 0 return Conn{..} -enableTLS :: TLS.ClientParams -> Connection -> IO Connection -enableTLS tlsParams conn@Conn{..} = do - newCtx <- CC.enableTLS tlsParams connCtx - return conn{connCtx = newCtx} - beginReceiving :: Connection -> IO () beginReceiving conn = do rs <- connGetReplies conn @@ -73,7 +73,7 @@ -- The 'Handle' is 'hFlush'ed when reading replies from the 'connCtx'. send :: Connection -> S.ByteString -> IO () send Conn{..} s = do - CC.send connCtx s + sendHook hooks (CC.send connCtx) s -- Signal that we expect one more reply from Redis. n <- atomicModifyIORef' connPendingCnt $ \n -> let n' = n+1 in (n', n') @@ -87,10 +87,11 @@ -- |Take a reply-thunk from the list of future replies. recv :: Connection -> IO Reply -recv Conn{..} = do - (r:rs) <- readIORef connReplies - writeIORef connReplies rs - return r +recv Conn{..} = + receiveHook hooks $ do + (r:rs) <- readIORef connReplies + writeIORef connReplies rs + return r -- | Flush the socket. Normally, the socket is flushed in 'recv' (actually 'conGetReplies'), but -- for the multithreaded pub/sub code, the sending thread needs to explicitly flush the subscription @@ -129,7 +130,9 @@ Scanner.Done rest' r -> do -- r is the same as 'head' of 'connPending'. Since we just -- received r, we remove it from the pending list. - atomicModifyIORef' connPending $ \(_:rs) -> (rs, ()) + atomicModifyIORef' connPending $ \case + (_:rs) -> (rs, ()) + [] -> error "Hedis: impossible happened parseWith missing value that it just received" -- We now expect one less reply from Redis. We don't count to -- negative, which would otherwise occur during pubsub. atomicModifyIORef' connPendingCnt $ \n -> (max 0 (n-1), ()) diff --git a/src/Database/Redis/PubSub.hs b/src/Database/Redis/PubSub.hs --- a/src/Database/Redis/PubSub.hs +++ b/src/Database/Redis/PubSub.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, EmptyDataDecls, FlexibleInstances, FlexibleContexts, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables, TupleSections, ConstraintKinds #-} module Database.Redis.PubSub ( publish, @@ -17,31 +18,38 @@ RedisChannel, RedisPChannel, MessageCallback, PMessageCallback, PubSubController, newPubSubController, currentChannels, currentPChannels, addChannels, addChannelsAndWait, removeChannels, removeChannelsAndWait, - UnregisterCallbacksAction + UnregisterCallbacksAction, + pendingChannels, pendingPatternChannels ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative import Data.Monoid hiding (<>) #endif +import Control.Arrow (second) import Control.Concurrent.Async (withAsync, waitEitherCatch, waitEitherCatchSTM) import Control.Concurrent.STM import Control.Exception (throwIO) import Control.Monad +import Control.Monad.Reader (asks) import Control.Monad.State import Data.ByteString.Char8 (ByteString) -import Data.List (foldl') +import qualified Data.List as L import Data.Maybe (isJust) import Data.Pool #if __GLASGOW_HASKELL__ < 808 import Data.Semigroup (Semigroup(..)) #endif +import Data.Hashable (Hashable) import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS 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 +import Control.Monad.IO.Unlift (MonadUnliftIO(withRunInIO)) +import Data.Functor (($>)) -- |While in PubSub mode, we keep track of the number of current subscriptions -- (as reported by Redis replies) and the number of messages we expect to @@ -111,20 +119,17 @@ sendCmd :: (Command (Cmd a b)) => Cmd a b -> StateT PubSubState Core.Redis () sendCmd DoNothing = return () sendCmd cmd = do - lift $ Core.send (redisCmd cmd : changes cmd) - modifyPending (updatePending cmd) - -cmdCount :: Cmd a b -> Int -cmdCount DoNothing = 0 -cmdCount (Cmd c) = length c - -totalPendingChanges :: PubSub -> Int -totalPendingChanges (PubSub{..}) = - cmdCount subs + cmdCount unsubs + cmdCount psubs + cmdCount punsubs + conn <- lift $ Core.reRedis $ asks Core.envConn + let hook = Core.sendPubSubHook $ PP.hooks conn + lift $ withRunInIO $ \runInIO -> hook (runInIO . Core.send) (redisCmd cmd : changes cmd) + modifyPending (updatePending cmd) rawSendCmd :: (Command (Cmd a b)) => PP.Connection -> Cmd a b -> IO () rawSendCmd _ DoNothing = return () -rawSendCmd conn cmd = PP.send conn $ renderRequest $ redisCmd cmd : changes cmd +rawSendCmd conn cmd = + let hook = Core.sendPubSubHook $ PP.hooks conn + msg = redisCmd cmd : changes cmd + in hook (PP.send conn . renderRequest) msg plusChangeCnt :: Cmd a b -> Int -> Int plusChangeCnt DoNothing = id @@ -151,7 +156,12 @@ | PMessage { msgPattern, msgChannel, msgMessage :: ByteString} deriving (Show) -data PubSubReply = Subscribed | Unsubscribed Int | Msg Message +data PubSubReply + = Subscribed RedisChannel + | PSubscribed RedisPChannel + | Unsubscribed RedisChannel Int + | PUnsubscribed RedisPChannel Int + | Msg Message ------------------------------------------------------------------------------ @@ -172,7 +182,7 @@ subscribe :: [ByteString] -- ^ channel -> PubSub -subscribe [] = mempty +subscribe [] = mempty subscribe cs = mempty{ subs = Cmd cs } -- |Stop listening for messages posted to the given channels @@ -182,12 +192,21 @@ -> PubSub unsubscribe cs = mempty{ unsubs = Cmd cs } +-- |Stop listening for messages posted to the given channels. +-- It works like 'unsubscribe', except it does not unsubscribe from +-- all channels when no channel is passed +unsubscribe1 + :: [ByteString] -- ^ channel + -> PubSub +unsubscribe1 [] = mempty +unsubscribe1 cs = mempty{ unsubs = Cmd cs } + -- |Listen for messages published to channels matching the given patterns -- (). psubscribe :: [ByteString] -- ^ pattern -> PubSub -psubscribe [] = mempty +psubscribe [] = mempty psubscribe ps = mempty{ psubs = Cmd ps } -- |Stop listening for messages posted to channels matching the given patterns @@ -197,6 +216,15 @@ -> PubSub punsubscribe ps = mempty{ punsubs = Cmd ps } +-- |Stop listening for messages posted to channels matching the given patterns. +-- It works like 'punsubscribe', except it does not unsubscribe from all channels +-- in case when the list is empty. +punsubscribe1 + :: [ByteString] -- ^ pattern + -> PubSub +punsubscribe1 [] = mempty +punsubscribe1 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 . @@ -246,15 +274,21 @@ recv :: StateT PubSubState Core.Redis () recv = do + hook <- lift $ Core.reRedis $ asks $ Core.callbackHook . PP.hooks . Core.envConn reply <- lift Core.recv case decodeMsg reply of - Msg msg -> liftIO (callback msg) >>= send - Subscribed -> modifyPending (subtract 1) >> recv - Unsubscribed n -> do - putSubCnt n - PubSubState{..} <- get - unless (subCnt == 0 && pending == 0) recv + Msg msg -> liftIO (hook callback msg) >>= send + Subscribed _ -> modifyPending (subtract 1) >> recv + PSubscribed _ -> modifyPending (subtract 1) >> recv + PUnsubscribed _ n -> onUnsubscribe n + Unsubscribed _ n -> onUnsubscribe n + onUnsubscribe :: Int -> StateT PubSubState Core.Redis () + onUnsubscribe n = do + putSubCnt n + PubSubState{..} <- get + unless (subCnt == 0 && pending == 0) recv + -- | A Redis channel name type RedisChannel = ByteString @@ -298,6 +332,15 @@ newtype UnregisterHandle = UnregisterHandle Integer deriving (Eq, Show, Num) +-- | Stores channels subscribed, pending subscription, and pending removal +-- by type, where type can be a normal channel, or a pattern channel. +data ChannelData channel callback + = ChannelData + { cdSubscribedChannels :: !(TVar (HM.HashMap channel [(UnregisterHandle, callback)])) + , cdChannelsPendingSubscription :: !(TVar (HS.HashSet channel)) + , cdChannelsPendingRemoval :: !(TVar (HS.HashSet channel)) + } + -- | A controller that stores a set of channels, pattern channels, and callbacks. -- It allows you to manage Pub/Sub subscriptions and pattern subscriptions and alter them at -- any time throughout the life of your program. @@ -305,48 +348,74 @@ -- through the life of your program, using 'addChannels' and 'removeChannels' to update the -- current subscriptions. data PubSubController = PubSubController - { callbacks :: TVar (HM.HashMap RedisChannel [(UnregisterHandle, MessageCallback)]) - , pcallbacks :: TVar (HM.HashMap RedisPChannel [(UnregisterHandle, PMessageCallback)]) - , sendChanges :: TBQueue PubSub - , pendingCnt :: TVar Int + { sendChanges :: TBQueue PubSub + , pscChannelData :: ChannelData RedisChannel MessageCallback + , pscPChannelData :: ChannelData RedisPChannel PMessageCallback , lastUsedCallbackId :: TVar UnregisterHandle } +newChannelData :: Hashable channel => [(channel, callback)] -> STM (ChannelData channel callback) +newChannelData initialSubs + = ChannelData + <$> newTVar (HM.fromListWith (++) $ map (second $ pure . (0,)) initialSubs) + <*> newTVar mempty + <*> newTVar mempty + -- | Create a new 'PubSubController'. Note that this does not subscribe to any channels, it just -- creates the controller. The subscriptions will happen once 'pubSubForever' is called. newPubSubController :: MonadIO m => [(RedisChannel, MessageCallback)] -- ^ the initial subscriptions -> [(RedisPChannel, PMessageCallback)] -- ^ the initial pattern subscriptions -> m PubSubController -newPubSubController x y = liftIO $ do - cbs <- newTVarIO (HM.map (\z -> [(0,z)]) $ HM.fromList x) - pcbs <- newTVarIO (HM.map (\z -> [(0,z)]) $ HM.fromList y) - c <- newTBQueueIO 10 - pending <- newTVarIO 0 - lastId <- newTVarIO 0 - return $ PubSubController cbs pcbs c pending lastId +newPubSubController initialSubs initialPSubs = liftIO $ atomically $ do + c <- newTBQueue 10 + lastId <- newTVar 0 + channelData' <- newChannelData initialSubs + pchannelData' <- newChannelData initialPSubs + return $ PubSubController c channelData' pchannelData' lastId +#if __GLASGOW_HASKELL__ < 710 +type FunctorMonadIO m = (MonadIO m, Functor m) +#else +type FunctorMonadIO m = MonadIO m +#endif + -- | Get the list of current channels in the 'PubSubController'. WARNING! This might not -- exactly reflect the subscribed channels in the Redis server, because there is a delay -- between adding or removing a channel in the 'PubSubController' and when Redis receives -- and processes the subscription change request. -#if __GLASGOW_HASKELL__ < 710 -currentChannels :: (MonadIO m, Functor m) => PubSubController -> m [RedisChannel] -#else -currentChannels :: MonadIO m => PubSubController -> m [RedisChannel] -#endif -currentChannels ctrl = HM.keys <$> (liftIO $ atomically $ readTVar $ callbacks ctrl) +currentChannels :: FunctorMonadIO m => PubSubController -> m [RedisChannel] +currentChannels ctrl = HM.keys <$> (liftIO $ atomically $ readTVar $ cdSubscribedChannels $ pscChannelData ctrl) -- | Get the list of current pattern channels in the 'PubSubController'. WARNING! This might not -- exactly reflect the subscribed channels in the Redis server, because there is a delay -- between adding or removing a channel in the 'PubSubController' and when Redis receives -- and processes the subscription change request. -#if __GLASGOW_HASKELL__ < 710 -currentPChannels :: (MonadIO m, Functor m) => PubSubController -> m [RedisPChannel] -#else -currentPChannels :: MonadIO m => PubSubController -> m [RedisPChannel] -#endif -currentPChannels ctrl = HM.keys <$> (liftIO $ atomically $ readTVar $ pcallbacks ctrl) +currentPChannels :: FunctorMonadIO m => PubSubController -> m [RedisPChannel] +currentPChannels ctrl = HM.keys <$> (liftIO $ atomically $ readTVar $ cdSubscribedChannels $ pscPChannelData ctrl) +pendingChannels :: MonadIO m => PubSubController -> m (HS.HashSet RedisChannel) +pendingChannels ctrl = liftIO $ readTVarIO $ cdChannelsPendingSubscription $ pscChannelData ctrl + +pendingPatternChannels :: MonadIO m => PubSubController -> m (HS.HashSet RedisPChannel) +pendingPatternChannels ctrl = liftIO $ readTVarIO $ cdChannelsPendingSubscription $ pscPChannelData ctrl + +-- type CallbackMap a = HM.HashMap ByteString [(UnregisterHandle, a)] + +-- | Helper for `addChannels`. Can take either normal or pattern channels. +addChannelsOfType + :: Hashable channel + => UnregisterHandle + -> [(channel, callback)] + -> ChannelData channel callback + -> STM [channel] +addChannelsOfType ident newChans channelData = do + callbacks <- readTVar $ cdSubscribedChannels channelData + pendingCallbacks <- readTVar $ cdChannelsPendingSubscription channelData + let newChans' = filter (not . memberMapOrSet callbacks pendingCallbacks) $ fst <$> newChans + writeTVar (cdSubscribedChannels channelData) (HM.unionWith (++) callbacks $ (\z -> [(ident,z)]) <$> HM.fromList newChans) + writeTVar (cdChannelsPendingSubscription channelData) $ HS.union pendingCallbacks $ HS.fromList newChans' + pure newChans' + -- | Add channels into the 'PubSubController', and if there is an active 'pubSubForever', send the subscribe -- and psubscribe commands to Redis. The 'addChannels' function is thread-safe. This function -- does not wait for Redis to acknowledge that the channels have actually been subscribed; use @@ -366,24 +435,19 @@ ident <- atomically $ do modifyTVar (lastUsedCallbackId ctrl) (+1) ident <- readTVar $ lastUsedCallbackId ctrl - cm <- readTVar $ callbacks ctrl - pm <- readTVar $ pcallbacks ctrl - let newChans' = [ n | (n,_) <- newChans, not $ HM.member n cm] - newPChans' = [ n | (n, _) <- newPChans, not $ HM.member n pm] - ps = subscribe newChans' `mappend` psubscribe newPChans' + newChannels <- addChannelsOfType ident newChans $ pscChannelData ctrl + newPChannels <- addChannelsOfType ident newPChans $ pscPChannelData ctrl + let ps = subscribe newChannels `mappend` psubscribe newPChannels writeTBQueue (sendChanges ctrl) ps - writeTVar (callbacks ctrl) (HM.unionWith (++) cm (fmap (\z -> [(ident,z)]) $ HM.fromList newChans)) - writeTVar (pcallbacks ctrl) (HM.unionWith (++) pm (fmap (\z -> [(ident,z)]) $ HM.fromList newPChans)) - modifyTVar (pendingCnt ctrl) (+ totalPendingChanges ps) return ident return $ unsubChannels ctrl (map fst newChans) (map fst newPChans) ident + -- | Call 'addChannels' and then wait for Redis to acknowledge that the channels are actually subscribed. -- --- Note that this function waits for all pending subscription change requests, so if you for example call --- 'addChannelsAndWait' from multiple threads simultaneously, they all will wait for all pending --- subscription changes to be acknowledged by Redis (this is due to the fact that we just track the total --- number of pending change requests sent to Redis and just wait until that count reaches zero). +-- Note that this function waits for requested subscription change requests, so if you for example call +-- 'addChannelsAndWait' from multiple threads simultaneously, they will all wait their pending +-- subscription changes to be acknowledged by Redis. -- -- This also correctly waits if the network connection dies during the subscription change. Say that the -- network connection dies right after we send a subscription change to Redis. 'pubSubForever' will throw @@ -399,11 +463,21 @@ addChannelsAndWait _ [] [] = return $ return () addChannelsAndWait ctrl newChans newPChans = do unreg <- addChannels ctrl newChans newPChans - liftIO $ atomically $ do - r <- readTVar (pendingCnt ctrl) - when (r > 0) retry + liftIO $ + waitUntilAbsent + [ (cdChannelsPendingSubscription $ pscChannelData ctrl, fst <$> newChans) + , (cdChannelsPendingSubscription $ pscPChannelData ctrl, fst <$> newPChans) + ] return unreg +-- | Wait until all interesting channels are instantiated. +waitUntilAbsent :: Hashable channel => [(TVar (HS.HashSet channel), [channel])] -> IO () +waitUntilAbsent pending = atomically $ do + forM_ pending $ \(tPendingChannels, channels) -> do + unless (null channels) $ do + pendingChannels' <- readTVar tPendingChannels + when (any (\ch -> HS.member ch pendingChannels') channels) retry + -- | Remove channels from the 'PubSubController', and if there is an active 'pubSubForever', send the -- unsubscribe commands to Redis. Note that as soon as this function returns, no more callbacks will be -- executed even if more messages arrive during the period when we request to unsubscribe from the channel @@ -419,55 +493,78 @@ -> m () removeChannels _ [] [] = return () removeChannels ctrl remChans remPChans = liftIO $ atomically $ do - cm <- readTVar $ callbacks ctrl - pm <- readTVar $ pcallbacks ctrl - let remChans' = filter (\n -> HM.member n cm) remChans - remPChans' = filter (\n -> HM.member n pm) remPChans - ps = (if null remChans' then mempty else unsubscribe remChans') - `mappend` (if null remPChans' then mempty else punsubscribe remPChans') - writeTBQueue (sendChanges ctrl) ps - writeTVar (callbacks ctrl) (foldl' (flip HM.delete) cm remChans') - writeTVar (pcallbacks ctrl) (foldl' (flip HM.delete) pm remPChans') - modifyTVar (pendingCnt ctrl) (+ totalPendingChanges ps) + remChans' <- removeChannels' (pscChannelData ctrl) remChans + remPChans' <- removeChannels' (pscPChannelData ctrl) remPChans + writeTBQueue (sendChanges ctrl) $ unsubscribe1 remChans' `mappend` punsubscribe1 remPChans' --- | Internal function to unsubscribe only from those channels matching the given handle. -unsubChannels :: PubSubController -> [RedisChannel] -> [RedisPChannel] -> UnregisterHandle -> IO () -unsubChannels ctrl chans pchans h = liftIO $ atomically $ do - cm <- readTVar $ callbacks ctrl - pm <- readTVar $ pcallbacks ctrl +#if !(MIN_VERSION_stm(2,3,0)) +-- | Strict version of 'modifyTVar'. +-- +-- @since 2.3 +modifyTVar' :: TVar a -> (a -> a) -> STM () +modifyTVar' var f = do + x <- readTVar var + writeTVar var $! f x +{-# INLINE modifyTVar' #-} +#endif - -- only worry about channels that exist - let remChans = filter (\n -> HM.member n cm) chans - remPChans = filter (\n -> HM.member n pm) pchans +-- Helper for `removeChannels` that works on normal or pattern channels +removeChannels' :: (Hashable channel) => ChannelData channel callback -> [channel] -> STM [channel] +removeChannels' channelData remChannels = do + subbedChannels <- readTVar $ cdSubscribedChannels channelData + pendingChannelSubs <- readTVar $ cdChannelsPendingSubscription channelData + let remChannels' = filter (memberMapOrSet subbedChannels pendingChannelSubs) remChannels + writeTVar (cdSubscribedChannels channelData) (L.foldl' (flip HM.delete) subbedChannels remChannels') + writeTVar (cdChannelsPendingSubscription channelData) (L.foldl' (flip HS.delete) pendingChannelSubs remChannels') + modifyTVar' (cdChannelsPendingRemoval channelData) $ flip (L.foldl' $ flip HS.insert) remChannels' + pure remChannels' +memberMapOrSet :: Hashable k => HM.HashMap k v1 -> HS.HashSet k -> k -> Bool +memberMapOrSet m s k = HM.member k m || HS.member k s + +unregisterHandles + :: forall channel callback. Hashable channel => ChannelData channel callback + -> [channel] + -> UnregisterHandle + -> STM [channel] +unregisterHandles channelData remChansParam h = do + callbacks <- readTVar $ cdSubscribedChannels channelData + let remChans = filter (`HM.member` callbacks) remChansParam + -- helper functions to filter out handlers that match - let filterHandle :: Maybe [(UnregisterHandle,a)] -> Maybe [(UnregisterHandle,a)] + -- returns number of removals, and remaining subscriptions + -- maps after taking out channels matching the handle + let callbacks' = L.foldl' removeHandles callbacks remChans + remChans' = filter (\chan -> HM.member chan callbacks && not (HM.member chan callbacks')) remChans + + writeTVar (cdSubscribedChannels channelData) callbacks' + unless (null remChans') $ modifyTVar (cdChannelsPendingSubscription channelData) (`HS.difference` HS.fromList remChans') + pure remChans' + + where + filterHandle :: Maybe [(UnregisterHandle,a)] -> Maybe [(UnregisterHandle,a)] filterHandle Nothing = Nothing filterHandle (Just lst) = case filter (\x -> fst x /= h) lst of [] -> Nothing xs -> Just xs - let removeHandles :: HM.HashMap ByteString [(UnregisterHandle,a)] - -> ByteString - -> HM.HashMap ByteString [(UnregisterHandle,a)] + + removeHandles :: HM.HashMap channel [(UnregisterHandle,a)] + -> channel + -> HM.HashMap channel [(UnregisterHandle,a)] removeHandles m k = case filterHandle (HM.lookup k m) of -- recent versions of unordered-containers have alter Nothing -> HM.delete k m - Just v -> HM.insert k v m + Just v -> HM.insert k v m - -- maps after taking out channels matching the handle - let cm' = foldl' removeHandles cm remChans - pm' = foldl' removeHandles pm remPChans +-- | Internal function to unsubscribe only from those channels matching the given handle. +unsubChannels :: PubSubController -> [RedisChannel] -> [RedisPChannel] -> UnregisterHandle -> IO () +unsubChannels ctrl chans pchans h = liftIO $ atomically $ do + channelsToDrop <- unregisterHandles (pscChannelData ctrl) chans h + pChannelsToDrop <- unregisterHandles (pscPChannelData ctrl) pchans h - -- the channels to unsubscribe are those that no longer exist in cm' and pm' - let remChans' = filter (\n -> not $ HM.member n cm') remChans - remPChans' = filter (\n -> not $ HM.member n pm') remPChans - ps = (if null remChans' then mempty else unsubscribe remChans') - `mappend` (if null remPChans' then mempty else punsubscribe remPChans') + let commands = unsubscribe1 channelsToDrop `mappend` punsubscribe1 pChannelsToDrop -- do the unsubscribe - writeTBQueue (sendChanges ctrl) ps - writeTVar (callbacks ctrl) cm' - writeTVar (pcallbacks ctrl) pm' - modifyTVar (pendingCnt ctrl) (+ totalPendingChanges ps) + writeTBQueue (sendChanges ctrl) commands return () -- | Call 'removeChannels' and then wait for all pending subscription change requests to be acknowledged @@ -478,12 +575,16 @@ -> [RedisChannel] -> [RedisPChannel] -> m () -removeChannelsAndWait _ [] [] = return () -removeChannelsAndWait ctrl remChans remPChans = do - removeChannels ctrl remChans remPChans - liftIO $ atomically $ do - r <- readTVar (pendingCnt ctrl) - when (r > 0) retry +removeChannelsAndWait ctrl remChannels remPChannels = liftIO $ do + (remChans', remPChans') <- atomically $ do + remChans' <- removeChannels' (pscChannelData ctrl) remChannels + remPChans' <- removeChannels' (pscPChannelData ctrl) remPChannels + writeTBQueue (sendChanges ctrl) $ unsubscribe1 remChans' `mappend` punsubscribe1 remPChans' + pure (remChans', remPChans') + waitUntilAbsent + [ (cdChannelsPendingRemoval $ pscChannelData ctrl, remChans') + , (cdChannelsPendingRemoval $ pscPChannelData ctrl, remPChans') + ] -- | Internal thread which listens for messages and executes callbacks. -- This is the only thread which ever receives data from the underlying @@ -492,20 +593,18 @@ listenThread ctrl rawConn = forever $ do msg <- PP.recv rawConn case decodeMsg msg of - Msg (Message channel msgCt) -> do - cm <- atomically $ readTVar (callbacks ctrl) - case HM.lookup channel cm of - Nothing -> return () - Just c -> mapM_ (\(_,x) -> x msgCt) c - Msg (PMessage pattern channel msgCt) -> do - pm <- atomically $ readTVar (pcallbacks ctrl) - case HM.lookup pattern pm of - Nothing -> return () - Just c -> mapM_ (\(_,x) -> x channel msgCt) c - Subscribed -> atomically $ - modifyTVar (pendingCnt ctrl) (\x -> x - 1) - Unsubscribed _ -> atomically $ - modifyTVar (pendingCnt ctrl) (\x -> x - 1) + Msg message@(Message channel _) -> do + cm <- atomically $ readTVar $ cdSubscribedChannels $ pscChannelData ctrl + forM_ (HM.lookup channel cm) $ \c -> do + void $ Core.callbackHook (PP.hooks rawConn) (\m -> mapM_ (\(_,x) -> x $ msgMessage m) c $> mempty) message + Msg message@(PMessage pattern _ _) -> do + pm <- atomically $ readTVar $ cdSubscribedChannels $ pscPChannelData ctrl + forM_ (HM.lookup pattern pm) $ \c -> do + void $ Core.callbackHook (PP.hooks rawConn) (\m -> mapM_ (\(_,x) -> x (msgChannel m) (msgMessage m)) c $> mempty) message + Subscribed chan -> atomically $ modifyTVar (cdChannelsPendingSubscription $ pscChannelData ctrl) $ HS.delete chan + PSubscribed chan -> atomically $ modifyTVar (cdChannelsPendingSubscription $ pscPChannelData ctrl) $ HS.delete chan + Unsubscribed chan _ -> atomically $ modifyTVar (cdChannelsPendingRemoval $ pscChannelData ctrl) $ HS.delete chan + PUnsubscribed chan _ -> atomically $ modifyTVar (cdChannelsPendingRemoval $ pscPChannelData ctrl) $ HS.delete chan -- | Internal thread which sends subscription change requests. -- This is the only thread which ever sends data on the underlying @@ -575,11 +674,12 @@ let loop = tryReadTBQueue (sendChanges ctrl) >>= \x -> if isJust x then loop else return () loop - cm <- readTVar $ callbacks ctrl - pm <- readTVar $ pcallbacks ctrl - let ps = subscribe (HM.keys cm) `mappend` psubscribe (HM.keys pm) + channels <- fmap HM.keys $ readTVar $ cdSubscribedChannels $ pscChannelData ctrl + patternChannels <- fmap HM.keys $ readTVar $ cdSubscribedChannels $ pscPChannelData ctrl + let ps = subscribe channels `mappend` psubscribe patternChannels writeTBQueue (sendChanges ctrl) ps - writeTVar (pendingCnt ctrl) (totalPendingChanges ps) + writeTVar (cdChannelsPendingSubscription $ pscChannelData ctrl) $ HS.fromList channels + writeTVar (cdChannelsPendingSubscription $ pscPChannelData ctrl) $ HS.fromList patternChannels withAsync (listenThread ctrl rawConn) $ \listenT -> withAsync (sendThread ctrl rawConn) $ \sendT -> do @@ -588,8 +688,11 @@ mret <- atomically $ (Left <$> (waitEitherCatchSTM listenT sendT)) `orElse` - (Right <$> (readTVar (pendingCnt ctrl) >>= - \x -> if x > 0 then retry else return ())) + (Right <$> do + a <- readTVar $ cdChannelsPendingSubscription $ pscChannelData ctrl + unless (HS.null a) retry + b <- readTVar $ cdChannelsPendingSubscription $ pscPChannelData ctrl + unless (HS.null b) retry) case mret of Right () -> onInitialLoad _ -> return () -- if there is an error, waitEitherCatch below will also see it @@ -612,15 +715,16 @@ case kind :: ByteString of "message" -> Msg <$> decodeMessage "pmessage" -> Msg <$> decodePMessage - "subscribe" -> return Subscribed - "psubscribe" -> return Subscribed - "unsubscribe" -> Unsubscribed <$> decodeCnt - "punsubscribe" -> Unsubscribed <$> decodeCnt + "subscribe" -> Subscribed <$> decodeChan + "psubscribe" -> PSubscribed <$> decodeChan + "unsubscribe" -> Unsubscribed <$> decodeChan <*> decodeCnt + "punsubscribe" -> PUnsubscribed <$> decodeChan <*> decodeCnt _ -> errMsg r where decodeMessage = Message <$> decode r1 <*> decode r2 decodePMessage = PMessage <$> decode r1 <*> decode r2 <*> decode (head rs) decodeCnt = fromInteger <$> decode r2 + decodeChan = decode r1 decodeMsg r = errMsg r diff --git a/src/Database/Redis/PubSub.hs-boot b/src/Database/Redis/PubSub.hs-boot new file mode 100644 --- /dev/null +++ b/src/Database/Redis/PubSub.hs-boot @@ -0,0 +1,8 @@ +module Database.Redis.PubSub ( + Message, + PubSub, +) where + +data PubSub + +data Message diff --git a/src/Database/Redis/Sentinel.hs b/src/Database/Redis/Sentinel.hs --- a/src/Database/Redis/Sentinel.hs +++ b/src/Database/Redis/Sentinel.hs @@ -14,7 +14,7 @@ -- Example: -- -- @ --- conn <- 'connect' 'SentinelConnectionInfo' (("localhost", PortNumber 26379) :| []) "mymaster" 'defaultConnectInfo' +-- conn <- 'connect' 'SentinelConnectionInfo' (("localhost", 26379) :| []) "mymaster" 'defaultConnectInfo' -- -- 'runRedis' conn $ do -- 'set' "hello" "world" @@ -44,18 +44,17 @@ import Control.Concurrent import Control.Exception (Exception, IOException, evaluate, throwIO) import Control.Monad -import Control.Monad.Catch (Handler (..), MonadCatch, catches, throwM) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Catch (Handler (..), MonadCatch, catches, throwM, bracket) import Control.Monad.Except -import Control.Monad.IO.Class(MonadIO(liftIO)) 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 qualified Network.Socket as NS import Database.Redis hiding (Connection, connect, runRedis) import qualified Database.Redis as Redis @@ -80,6 +79,7 @@ then return (oldMasterConnectInfo, oldBaseConnection) else do newConn <- Redis.connect newMasterConnectInfo + Redis.disconnect oldBaseConnection return (newMasterConnectInfo, newConn) return @@ -106,7 +106,7 @@ where sameHost :: Redis.ConnectInfo -> Redis.ConnectInfo -> Bool - sameHost l r = connectHost l == connectHost r && connectPort l == connectPort r + sameHost l r = connectAddr l == connectAddr r setCheckSentinel preToken = modifyMVar_ connMVar $ \conn@SentinelConnection'{rcToken} -> if preToken == rcToken @@ -148,28 +148,31 @@ ) Right () -> throwIO $ NoSentinels connectSentinels where - trySentinel :: HostName -> PortID -> ExceptT (Redis.ConnectInfo, (HostName, PortID)) IO () + trySentinel :: NS.HostName -> NS.PortNumber -> ExceptT (Redis.ConnectInfo, (NS.HostName, NS.PortNumber)) 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 + bracket + (Redis.connect $ Redis.defaultConnectInfo + { connectAddr = ConnectAddrHostPort sentinelHost sentinelPort , connectMaxConnections = 1 - } - Redis.runRedis sentinelConn $ sendRequest - ["SENTINEL", "get-master-addr-by-name", connectMasterName] + }) + Redis.disconnect + $ \sentinelConn -> 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) + { connectAddr = + ConnectAddrHostPort + (BS8.unpack host) + (maybe + 26379 + (fromIntegral . fst) $ BS8.readInt port + ) } , (sentinelHost, sentinelPort) ) @@ -203,20 +206,20 @@ -- | Configuration of Sentinel hosts. data SentinelConnectInfo = SentinelConnectInfo - { connectSentinels :: NonEmpty (HostName, PortID) + { connectSentinels :: NonEmpty (NS.HostName, NS.PortNumber) -- ^ 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. + -- but 'Redis.connectAddr' is ignored. } deriving (Show) -- | Exception thrown by "Database.Redis.Sentinel". data RedisSentinelException - = NoSentinels (NonEmpty (HostName, PortID)) + = NoSentinels (NonEmpty (NS.HostName, NS.PortNumber)) -- ^ Thrown if no sentinel can be reached. - deriving (Show, Typeable) + deriving (Show) deriving instance Exception RedisSentinelException diff --git a/src/Database/Redis/Types.hs b/src/Database/Redis/Types.hs --- a/src/Database/Redis/Types.hs +++ b/src/Database/Redis/Types.hs @@ -11,6 +11,7 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif +import Data.Int import Control.DeepSeq import Data.ByteString.Char8 (ByteString, pack) import qualified Data.ByteString.Lex.Fractional as F (readSigned, readExponential) @@ -38,6 +39,9 @@ instance RedisArg Integer where encode = pack . show +instance RedisArg Int64 where + encode = pack . show + instance RedisArg Double where encode a | isInfinite a && a > 0 = "+inf" @@ -65,6 +69,11 @@ instance RedisResult Integer where decode (Integer n) = Right n + decode r = + maybe (Left r) (Right . fst) . I.readSigned I.readDecimal =<< decode r + +instance RedisResult Int64 where + decode (Integer n) = Right (fromInteger n) decode r = maybe (Left r) (Right . fst) . I.readSigned I.readDecimal =<< decode r diff --git a/src/Database/Redis/URL.hs b/src/Database/Redis/URL.hs --- a/src/Database/Redis/URL.hs +++ b/src/Database/Redis/URL.hs @@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module Database.Redis.URL ( parseConnectInfo ) where @@ -6,60 +9,134 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif +import qualified Data.ByteString.Char8 as C8 import Control.Error.Util (note) -import Control.Monad (guard) #if __GLASGOW_HASKELL__ < 808 import Data.Monoid ((<>)) #endif +import Data.String (fromString) import Database.Redis.Connection (ConnectInfo(..), defaultConnectInfo) import qualified Database.Redis.ConnectionContext as CC import Network.HTTP.Base -import Network.URI (parseURI, uriPath, uriScheme) +import Network.URI (parseURI, uriPath, uriScheme, uriQuery, URI) +import Network.TLS (defaultParamsClient) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Network.HTTP.Types (parseSimpleQuery) import Text.Read (readMaybe) -import qualified Data.ByteString.Char8 as C8 --- | Parse a @'ConnectInfo'@ from a URL +-- | Parse a @'ConnectInfo'@ from a URL according to the Rules in Redis client -- --- Username is ignored, path is used to specify the database: +-- Standalone Redis: -- +-- @ +-- redis :// [[username :] password@] host [:port][/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 {connectAddr = ConnectAddrHostPort "host" 42, connectAuth = Just "password", connectUsername = Just "username", connectDatabase = 2, connectMaxConnections = 50, connectNumStripes = Just 1, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing, connectHooks = Hooks {...}, connectPoolLabel = ""}) -- +-- >>> parseConnectInfo "redis://password@host:42/2" +-- Right (ConnInfo {connectAddr = ConnectAddrHostPort "host" 42, connectAuth = Just "password", connectUsername = Nothing, connectDatabase = 2, connectMaxConnections = 50, connectNumStripes = Just 1, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing, connectHooks = Hooks {...}, connectPoolLabel = ""}) +-- +-- TLS-enabled Redis: +-- +-- @ +-- rediss :// [[username :] password@] host [: port][/database] +-- @ +-- +-- Unix socket Redis: +-- +-- @ +-- redis-socket :// [[username :] password@]path [? [&database=database] +-- @ +-- +-- >>> parseConnectInfo "redis-socket://password@/tmp/redis.sock?database=2" +-- Right (ConnInfo {connectAddr = ConnectAddrUnixSocket "/tmp/redis.sock", connectAuth = Just "password", connectUsername = Nothing, connectDatabase = 2, connectMaxConnections = 50, connectNumStripes = Just 1, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing, connectHooks = Hooks {...}, connectPoolLabel = ""}) +-- -- >>> parseConnectInfo "redis://username:password@host:42/db" -- Left "Invalid port: db" -- -- The scheme is validated, to prevent mixing up configurations: -- -- >>> parseConnectInfo "postgres://" --- Left "Wrong scheme" +-- Left "Wrong scheme postgres:" -- -- Beyond that, all values are optional. Omitted values are taken from -- @'defaultConnectInfo'@: -- --- >>> parseConnectInfo "redis://" --- Right (ConnInfo {connectHost = "localhost", connectPort = PortNumber 6379, connectAuth = Nothing, connectDatabase = 0, connectMaxConnections = 50, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing}) +-- >>> parseConnectInfo "rediss://" +-- Right (ConnInfo {connectAddr = ConnectAddrHostPort "localhost" 6379, connectAuth = Nothing, connectUsername = Nothing, connectDatabase = 0, connectMaxConnections = 50, connectNumStripes = Just 1, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Just (ClientParams ...), connectHooks = Hooks {...}, connectPoolLabel = ""}) -- parseConnectInfo :: String -> Either String ConnectInfo parseConnectInfo url = do uri <- note "Invalid URI" $ parseURI url - note "Wrong scheme" $ guard $ uriScheme uri == "redis:" - uriAuth <- note "Missing or invalid Authority" - $ parseURIAuthority - $ uriToAuthorityString uri + let userScheme = uriScheme uri + case userScheme of + "redis:" -> parseSocket False uri + "rediss:" -> parseSocket True uri + "redis-socket:" -> parseUnix uri + x -> Left ("Wrong scheme " ++ x) + where + parseSocket :: Bool -> URI -> Either String ConnectInfo + parseSocket isSecure uri = do + uriAuth <- note "Missing or invalid Authority" + $ parseURIAuthority + $ uriToAuthorityString uri - let h = host uriAuth - dbNumPart = dropWhile (== '/') (uriPath uri) + let h = host uriAuth + dbNumPart = dropWhile (== '/') (uriPath uri) - db <- if null dbNumPart - then return $ connectDatabase defaultConnectInfo - else note ("Invalid port: " <> dbNumPart) $ readMaybe dbNumPart + db <- if null dbNumPart + then return $ connectDatabase defaultConnectInfo + else note ("Invalid port: " <> dbNumPart) $ readMaybe dbNumPart - return defaultConnectInfo - { connectHost = if null h - then connectHost defaultConnectInfo - else h - , connectPort = maybe (connectPort defaultConnectInfo) (CC.PortNumber . fromIntegral) (port uriAuth) - , connectAuth = C8.pack <$> password uriAuth - , connectDatabase = db - } + let finalHost = if null h + then case connectAddr defaultConnectInfo of + CC.ConnectAddrHostPort defaultHost _ -> defaultHost + CC.ConnectAddrUnixSocket _ -> "localhost" + else h + + let (finalUser, finalAuth) = case (T.pack <$> user uriAuth, T.pack <$> password uriAuth) of + (p, Nothing) -> (Nothing, p) + (p, fmap T.strip -> Just "") -> (Nothing, p) + (u, p) -> (u, p) + + return defaultConnectInfo + { connectAddr = + CC.ConnectAddrHostPort + finalHost + (maybe defaultPort fromIntegral (port uriAuth)) + , connectAuth = T.encodeUtf8 <$> finalAuth + , connectUsername = T.encodeUtf8 <$> finalUser + , connectDatabase = db + , connectTLSParams = case isSecure of + False -> Nothing + True -> Just $ defaultParamsClient finalHost "" + } + where + defaultPort = case connectAddr defaultConnectInfo of + CC.ConnectAddrHostPort _ portNum -> portNum + CC.ConnectAddrUnixSocket _ -> 6379 + + parseUnix :: URI -> Either String ConnectInfo + parseUnix uri = do + auth <- note "Missing or invalid Authority" + $ parseURIAuthority + $ uriToAuthorityString uri + db <- case lookup "database" query of + Nothing -> return $ connectDatabase defaultConnectInfo + Just dbNumPart -> + note "Invalid database" $ readMaybe @Integer . T.unpack $ T.decodeUtf8 dbNumPart + return defaultConnectInfo + { connectAddr = CC.ConnectAddrUnixSocket (mkPath auth) + , connectAuth = C8.pack <$> (user auth) + , connectDatabase = (db :: Integer) + } + where + mkPath auth = + case host auth <> uriPath uri of + ('/':_) -> host auth <> uriPath uri + _ -> '/' : host auth <> uriPath uri + query = parseSimpleQuery (T.encodeUtf8 $ fromString $ uriQuery uri) diff --git a/test/ClusterMain.hs b/test/ClusterMain.hs --- a/test/ClusterMain.hs +++ b/test/ClusterMain.hs @@ -1,46 +1,62 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} module Main (main) where import qualified Test.Framework as Test +import Data.ByteString (ByteString) import Database.Redis +import Network.Socket (PortNumber) +import System.Environment (lookupEnv) import Tests +import Text.Read (readMaybe) main :: IO () main = do + + redisPort <- ((readMaybe @PortNumber =<<) <$> lookupEnv "REDIS_PORT") >>= \case + Just port -> return port + _ -> return 6379 + redisHost <- lookupEnv "REDIS_HOST" >>= \case + Just host -> return host + Nothing -> return "localhost" -- 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) + conn <- connectCluster defaultConnectInfo { connectAddr = ConnectAddrHostPort redisHost redisPort } + Test.defaultMain (tests redisHost redisPort conn) -tests :: Connection -> [Test.Test] -tests conn = map ($conn) $ concat +tests :: String -> PortNumber -> Connection -> [Test.Test] +tests host port 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] + , testsConnection host port, testsClient, testsServer, [testSScan, testHScan, testZScan], [testZrangelex] + , [testXAddRead, testXReadGroup, testXRange, testXpending7, testXClaim, testXInfo, testXDel, testXTrim] -- should always be run last as connection gets closed after it , [testQuit] ] +testsClient :: [Test] +testsClient = [testClientId, testClientName] + testsServer :: [Test] testsServer = [testBgrewriteaof, testFlushall, testSlowlog, testDebugObject] -testsConnection :: [Test] -testsConnection = [ testConnectAuthUnexpected, testEcho, testPing - ] +testsConnection :: String -> PortNumber -> [Test] +testsConnection host port = [ testConnectAuthUnexpected host port, testEcho, testPing ] testsKeys :: [Test] testsKeys = [ testKeys, testExpireAt, testSortCluster, testGetType, testObject ] testSortCluster :: Test testSortCluster = testCase "sort" $ do - lpush "{same}ids" ["1","2","3"] >>=? 3 + lpush "{same}ids" ["1"::ByteString,"2","3"] >>=? 3 sort "{same}ids" defaultSortOpts >>=? ["1","2","3"] sortStore "{same}ids" "{same}anotherKey" defaultSortOpts >>=? 3 let opts = defaultSortOpts { sortOrder = Desc, sortAlpha = True diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,34 +1,59 @@ +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} module Main (main) where import qualified Test.Framework as Test import Database.Redis import Tests import PubSubTest +import System.Environment +import Text.Read (readMaybe) +import Network.Socket (PortNumber) main :: IO () main = do - conn <- connect defaultConnectInfo - Test.defaultMain (tests conn) + redisPort <- ((readMaybe @PortNumber =<<) <$> lookupEnv "REDIS_PORT") >>= \case + Just port -> return port + _ -> return 6379 + host <- lookupEnv "REDIS_HOST" >>= \case + Just host -> return host + Nothing -> return "localhost" + conn <- connect defaultConnectInfo { connectAddr = ConnectAddrHostPort host redisPort } + Test.defaultMain (tests host redisPort conn) -tests :: Connection -> [Test.Test] -tests conn = map ($conn) $ concat +tests :: String -> PortNumber -> Connection -> [Test.Test] +tests host port conn = map ($ conn) $ concat [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog] , testsZSets, [testPubSub], [testTransaction], [testScripting] - , testsConnection, testsServer, [testScans, testSScan, testHScan, testZScan], [testZrangelex] + , testsConnection host port + , testsClient, 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] ] + +testsClient :: [Test] +testsClient = [testClientId, testClientName] + testsServer :: [Test] testsServer = [testServer, testBgrewriteaof, testFlushall, testInfo, testConfig ,testSlowlog, testDebugObject] -testsConnection :: [Test] -testsConnection = [ testConnectAuth, testConnectAuthUnexpected, testConnectDb - , testConnectDbUnexisting, testEcho, testPing, testSelect ] +testsConnection :: String -> PortNumber -> [Test] +testsConnection host port = + [ testConnectAuth host port + , testConnectAuthUnexpected host port + , testConnectAuthAcl host port + , testConnectDb host port + , testConnectDbUnexisting host port + , testEcho + , testPing + , testSelect + ] testsKeys :: [Test] testsKeys = [ testKeys, testKeysNoncluster, testExpireAt, testSort, testGetType, testObject ] diff --git a/test/MainHooks.hs b/test/MainHooks.hs new file mode 100644 --- /dev/null +++ b/test/MainHooks.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} + +import qualified Test.Framework.Providers.HUnit as Test (testCase) +import qualified Test.Framework as Test +import Database.Redis +import Data.IORef +import qualified Test.HUnit as HUnit +import Control.Monad.IO.Class (MonadIO(liftIO)) + +main :: IO () +main = Test.defaultMain [testSetGet] + +data Counts = + Counts + { sendRequestCount :: Word + , sendPubSubCount :: Word + , callbackCount :: Word + , sendCount :: Word + , receiveCount :: Word + } + deriving (Show, Eq) + +testCase :: String -> Counts -> Redis () -> Test.Test +testCase name expected r = Test.testCase name $ do + ref <- newIORef $ Counts 0 0 0 0 0 + conn <- connect defaultConnectInfo {connectHooks = hooks ref} + t <- runRedis conn $ flushdb >>=? Ok >> r + actual <- readIORef ref + HUnit.assertEqual "count" expected actual + return t + +hooks :: IORef Counts -> Hooks +hooks ref = + defaultHooks + { sendRequestHook = \f message -> do + modifyIORef ref $ \c -> c {sendRequestCount = succ $ sendRequestCount c} + f message + , sendPubSubHook = \f message -> do + modifyIORef ref $ \c -> c {sendPubSubCount = succ $ sendPubSubCount c} + f message + , callbackHook = \f message -> do + modifyIORef ref $ \c -> c {callbackCount = succ $ callbackCount c} + f message + , sendHook = \f message -> do + modifyIORef ref $ \c -> c {sendCount = succ $ sendCount c} + f message + , receiveHook = \m -> do + modifyIORef ref $ \c -> c {receiveCount = succ $ receiveCount c} + m + } + +(>>=?) :: (Eq a, Show a) => Redis (Either Reply a) -> a -> Redis () +redis >>=? expected = redis >>@? (expected HUnit.@=?) + +(>>@?) :: (Eq a, Show a) => Redis (Either Reply a) -> (a -> HUnit.Assertion) -> Redis () +redis >>@? predicate = do + a <- redis + liftIO $ case a of + Left reply -> HUnit.assertFailure $ "Redis error: " ++ show reply + Right actual -> predicate actual + +testSetGet :: Test.Test +testSetGet = + testCase + "set/get" + (Counts 3 0 0 3 3) $ do + set "{same}key" "value" >>=? Ok + get "{same}key" >>=? Just "value" diff --git a/test/MainRedis7.hs b/test/MainRedis7.hs new file mode 100644 --- /dev/null +++ b/test/MainRedis7.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE LambdaCase #-} +module Main (main) where + +import qualified Test.Framework as Test +import Database.Redis +import System.Environment (lookupEnv) +import Tests + +main :: IO () +main = do + host <- lookupEnv "REDIS_HOST" >>= \case + Just host -> return host + Nothing -> return "localhost" + conn <- connect defaultConnectInfo{ connectAddr = ConnectAddrHostPort host 6379 } + Test.defaultMain (tests conn) + +tests :: Connection -> [Test.Test] +tests conn = map ($ conn) $ [testXCreateGroup7, testXpending7, testXAutoClaim7, testQuit] diff --git a/test/PubSubTest.hs b/test/PubSubTest.hs --- a/test/PubSubTest.hs +++ b/test/PubSubTest.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE CPP, OverloadedStrings, DeriveDataTypeable #-} +{-# LANGUAGE CPP, OverloadedStrings #-} module PubSubTest (testPubSubThreaded) where import Control.Concurrent import Control.Monad import Control.Concurrent.Async import Control.Exception -import Data.Typeable import qualified Data.List -import Data.Text +import Data.Text (Text) +import Data.Typeable import Data.ByteString import Control.Concurrent.STM +import System.Timeout (timeout) import qualified Test.Framework as Test import qualified Test.Framework.Providers.HUnit as Test (testCase) import qualified Test.HUnit as HUnit @@ -17,7 +18,13 @@ import Database.Redis testPubSubThreaded :: [Connection -> Test.Test] -testPubSubThreaded = [removeAllTest, callbackErrorTest, removeFromUnregister] +testPubSubThreaded = + [ removeAllTest + , callbackErrorTest + , removeFromUnregister + , pendingChannelsTrackingTest + , subscribeReplyDecodingTracksPendingSets + ] -- | A handler label to be able to distinguish the handlers from one another -- to help make sure we unregister the correct handler. @@ -100,7 +107,7 @@ waitForPMessage msgVar "InitialBar2" "bar2:aaa" "0987" data TestError = TestError ByteString - deriving (Eq, Show, Typeable) + deriving (Eq, Show) instance Exception TestError -- | Test an error thrown from a message handler @@ -171,3 +178,78 @@ runRedis conn $ publish "def:cccc" "World6" waitForPMessage msgVar "InitialDef" "def:cccc" "World6" + +waitUntilPendingEmpty :: PubSubController -> IO () +waitUntilPendingEmpty ctrl = do + ret <- timeout (5 * 1000 * 1000) loop + case ret of + Nothing -> HUnit.assertFailure "Timed out waiting for pending PubSub channels to be cleared" + Just _ -> return () + where + loop = do + pendingCh <- pendingChannels ctrl + pendingPCh <- pendingPatternChannels ctrl + unless (Prelude.null pendingCh && Prelude.null pendingPCh) $ do + threadDelay (10 * 1000) + loop + +assertDoesNotHappen :: String -> IO a -> IO () +assertDoesNotHappen label action = do + ret <- timeout (700 * 1000) action + case ret of + Nothing -> return () + Just _ -> HUnit.assertFailure $ "Unexpectedly observed: " ++ label + +-- | Verify exported pending sets track add/remove operations before Redis acknowledges requests. +pendingChannelsTrackingTest :: Connection -> Test.Test +pendingChannelsTrackingTest _ = Test.testCase "Multithreaded Pub/Sub - pending channels tracking" $ do + msgVar <- newTVarIO [] + ctrl <- newPubSubController [] [] + + _ <- addChannels ctrl + [("pending:chan", handler "PendingChan" msgVar)] + [("pending:*", phandler "PendingPattern" msgVar)] + + pendingCh <- pendingChannels ctrl + pendingPCh <- pendingPatternChannels ctrl + HUnit.assertBool "channel should be marked pending" ("pending:chan" `Prelude.elem` pendingCh) + HUnit.assertBool "pattern channel should be marked pending" ("pending:*" `Prelude.elem` pendingPCh) + + removeChannels ctrl ["pending:chan"] ["pending:*"] + + pendingCh2 <- pendingChannels ctrl + pendingPCh2 <- pendingPatternChannels ctrl + HUnit.assertBool "removed channel should no longer be pending" (not $ "pending:chan" `Prelude.elem` pendingCh2) + HUnit.assertBool "removed pattern channel should no longer be pending" (not $ "pending:*" `Prelude.elem` pendingPCh2) + +-- | Exercise subscribe/unsubscribe decoding paths and ensure pending sets are drained per channel type. +subscribeReplyDecodingTracksPendingSets :: Connection -> Test.Test +subscribeReplyDecodingTracksPendingSets conn = Test.testCase "Multithreaded Pub/Sub - decode subscribe/unsubscribe replies" $ do + msgVar <- newTVarIO [] + initialComplete <- newTVarIO False + ctrl <- newPubSubController [] [] + + withAsync (pubSubForever conn ctrl (atomically $ writeTVar initialComplete True)) $ \_ -> do + atomically $ readTVar initialComplete >>= \b -> if b then return () else retry + + _ <- addChannels ctrl + [("decode:chan", handler "DecodeChan" msgVar)] + [("decode:*", phandler "DecodePattern" msgVar)] + + waitUntilPendingEmpty ctrl + + runRedis conn $ publish "decode:chan" "msg-1" + waitForMessage msgVar "DecodeChan" "msg-1" + + runRedis conn $ publish "decode:abc" "msg-2" + waitForPMessage msgVar "DecodePattern" "decode:abc" "msg-2" + + removeChannelsAndWait ctrl ["decode:chan"] ["decode:*"] + + waitUntilPendingEmpty ctrl + + runRedis conn $ publish "decode:chan" "msg-3" + assertDoesNotHappen "channel callback after unsubscribe" $ waitForMessage msgVar "DecodeChan" "msg-3" + + runRedis conn $ publish "decode:def" "msg-4" + assertDoesNotHappen "pattern callback after unsubscribe" $ waitForPMessage msgVar "DecodePattern" "decode:def" "msg-4" diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, LambdaCase #-} +{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, LambdaCase, OverloadedLists, TypeApplications #-} module Tests where + #if __GLASGOW_HASKELL__ < 710 import Control.Applicative import Data.Monoid (mappend) @@ -10,14 +11,21 @@ import Control.Concurrent import Control.Monad import Control.Monad.Trans +import Control.Monad.Trans.Except +import Data.ByteString (ByteString) +import Data.Either (isRight) import qualified Data.List as L +import qualified Data.List.NonEmpty as NE import Data.Time import Data.Time.Clock.POSIX import qualified Test.Framework as Test (Test) import qualified Test.Framework.Providers.HUnit as Test (testCase) import qualified Test.HUnit as HUnit +import qualified Test.HUnit.Lang as HUnit.Lang +import Network.Socket (PortNumber) import Database.Redis +import Data.Either (fromRight) ------------------------------------------------------------------------------ -- helpers @@ -36,12 +44,31 @@ putStrLn $ name ++ ": " ++ show deltaT (>>=?) :: (Eq a, Show a) => Redis (Either Reply a) -> a -> Redis () -redis >>=? expected = do +redis >>=? expected = redis >>@? (expected HUnit.@=?) + +(>>@?) :: (Eq a, Show a) => Redis (Either Reply a) -> (a -> HUnit.Assertion) -> Redis () +redis >>@? predicate = do a <- redis liftIO $ case a of - Left reply -> HUnit.assertFailure $ "Redis error: " ++ show reply - Right actual -> expected HUnit.@=? actual + Left reply -> HUnit.assertFailure $ "Redis error: " ++ show reply + Right actual -> predicate actual +(<|?>) :: HUnit.Assertion -> HUnit.Assertion -> HUnit.Assertion +a <|?> b = do + resultA <- HUnit.Lang.performTestCase a + case resultA of + HUnit.Lang.Success -> a + HUnit.Lang.Failure _ errA -> tryB errA + HUnit.Lang.Error _ errA -> tryB errA + where tryB errA = do + resultB <- HUnit.Lang.performTestCase b + case resultB of + HUnit.Lang.Success -> b + HUnit.Lang.Failure _ errB -> concatErrors errA errB + HUnit.Lang.Error _ errB -> concatErrors errA errB + concatErrors errA errB = HUnit.Lang.assertFailure ("{" ++ errA ++ "\nOR\n" ++ errB ++ "\n}: Failed") + + assert :: Bool -> Redis () assert = liftIO . HUnit.assert @@ -93,12 +120,12 @@ testEvalReplies conn = testCase "eval unused replies" go conn where go = do - _ <- liftIO $ runRedis conn $ set "key" "value" + _ <- liftIO $ runRedis conn $ set "key-12" "value" result <- liftIO $ do threadDelay $ 10 ^ (5 :: Int) mvar <- newEmptyMVar _ <- - (Async.wait =<< Async.async (runRedis conn (get "key"))) >>= putMVar mvar + (Async.wait =<< Async.async (runRedis conn (get "key-12"))) >>= putMVar mvar takeMVar mvar pure result >>=? Just "value" @@ -115,11 +142,11 @@ ttl "{same}key" >>= \case Left _ -> error "error" Right t -> do - assert $ t `elem` [0..1] + assert $ elem @[] t [0..1] pttl "{same}key" >>= \case Left _ -> error "error" Right pt -> do - assert $ pt `elem` [990..1000] + assert $ elem @[] pt [990..1000] persist "{same}key" >>=? True dump "{same}key" >>= \case Left _ -> error "impossible" @@ -127,7 +154,7 @@ restore "{same}key'" 0 s >>=? Ok rename "{same}key" "{same}key'" >>=? Ok renamenx "{same}key'" "{same}key" >>=? True - del ["{same}key"] >>=? 1 + del (NE.fromList ["{same}key"]) >>=? 1 testKeysNoncluster :: Test testKeysNoncluster = testCase "keysNoncluster" $ do @@ -172,13 +199,13 @@ testGetType :: Test testGetType = testCase "getType" $ do getType "key" >>=? None - forM_ ts $ \(setKey, typ) -> do + forM_ @[] ts $ \(setKey, typ) -> do setKey getType "key" >>=? typ - del ["key"] >>=? 1 + del (NE.fromList ["key"]) >>=? 1 where ts = [ (set "key" "value" >>=? Ok, String) - , (hset "key" "field" "value" >>=? 1, Hash) + , (hset "key" [("field"::ByteString, "value"::ByteString)] >>=? 1, Hash) , (lpush "key" ["value"] >>=? 1, List) , (sadd "key" ["member"] >>=? 1, Set) , (zadd "key" [(42,"member"),(12.3,"value")] >>=? 2, ZSet) @@ -189,9 +216,10 @@ set "key" "value" >>=? Ok objectRefcount "key" >>=? 1 objectEncoding "key" >>= \case - Left _ -> error "error" - _ -> return () + Left _ -> error "error" + _ -> return () objectIdletime "key" >>=? 0 + return () ------------------------------------------------------------------------------ -- Strings @@ -217,7 +245,7 @@ incr "key" >>=? 41 incrby "key" 1 >>=? 42 incrbyfloat "key" 1 >>=? 43 - del ["key"] >>=? 1 + del (NE.fromList ["key"]) >>=? 1 setbit "key" 42 "1" >>=? 0 getbit "key" 42 >>=? 1 bitcount "key" >>=? 1 @@ -237,9 +265,9 @@ -- testHashes :: Test testHashes = testCase "hashes" $ do - hset "key" "field" "another" >>=? 1 - hset "key" "field" "another" >>=? 0 - hset "key" "field" "value" >>=? 0 + hset "key" [("field"::ByteString, "another"::ByteString)] >>=? 1 + hset "key" [("field"::ByteString, "another"::ByteString)] >>=? 0 + hset "key" [("field"::ByteString, "value"::ByteString)] >>=? 0 hsetnx "key" "field" "value" >>=? False hexists "key" "field" >>=? True hlen "key" >>=? 1 @@ -262,8 +290,8 @@ testLists :: Test testLists = testCase "lists" $ do - lpushx "notAKey" "-" >>=? 0 - rpushx "notAKey" "-" >>=? 0 + lpushx "notAKey" ["-" :: ByteString] >>=? 0 + rpushx "notAKey" ["-" :: ByteString] >>=? 0 lpush "key" ["value"] >>=? 1 lpop "key" >>=? Just "value" rpush "key" ["value"] >>=? 1 @@ -277,6 +305,17 @@ lrem "key" 0 "v2" >>=? 1 llen "key" >>=? 2 ltrim "key" 0 1 >>=? Ok + del ("key" NE.:| []) + -- keys are pushed sequentially so this will result in a list with value1, value2, value3 + lpush "key" ["value3", "value2", "value1"] >>=? 3 + lpopCount "key" 2 >>=? ["value1", "value2"] + lpush "key" ["value2", "value1"] >>=? 3 + rpopCount "key" 2 >>=? ["value3", "value2"] + del ("key" NE.:| []) + lpush "key" ["value3", "value2", "value1"] >>=? 3 + lpopCount "key" 4 >>=? ["value1", "value2", "value3"] + del ("key" NE.:| []) + return () testBpop :: Test testBpop = testCase "blocking push/pop" $ do @@ -295,22 +334,22 @@ testSets :: Test testSets = testCase "sets" $ do - sadd "set" ["member"] >>=? 1 + sadd "set" (NE.fromList ["member"]) >>=? 1 sismember "set" "member" >>=? True scard "set" >>=? 1 smembers "set" >>=? ["member"] srandmember "set" >>=? Just "member" spop "set" >>=? Just "member" - srem "set" ["member"] >>=? 0 + srem "set" (NE.fromList ["member"]) >>=? 0 smove "{same}set" "{same}set'" "member" >>=? False - _ <- sadd "set" ["member1", "member2"] + _ <- sadd "set" (NE.fromList ["member1", "member2"]) (fmap L.sort <$> spopN "set" 2) >>=? ["member1", "member2"] - _ <- sadd "set" ["member1", "member2"] + _ <- sadd "set" (NE.fromList ["member1", "member2"]) (fmap L.sort <$> srandmemberN "set" 2) >>=? ["member1", "member2"] testSetAlgebra :: Test testSetAlgebra = testCase "set algebra" $ do - sadd "{same}s1" ["member"] >>=? 1 + sadd "{same}s1" (NE.fromList ["member"]) >>=? 1 sdiff ["{same}s1", "{same}s2"] >>=? ["member"] sunion ["{same}s1", "{same}s2"] >>=? ["member"] sinter ["{same}s1", "{same}s2"] >>=? [] @@ -349,10 +388,15 @@ zrevrangebyscoreLimit "key" 2.5 0.5 0 1 >>=? ["v2"] zrevrangebyscoreWithscoresLimit "key" 2.5 0.5 0 1 >>=? [("v2",2)] - zrem "key" ["v2"] >>=? 1 + zrem "key" (NE.fromList ["v2"]) >>=? 1 zremrangebyscore "key" 10 100 >>=? 1 zremrangebyrank "key" 0 0 >>=? 1 +-- testZSets7 :: Test +-- testZSets7 = testCase "sorted sets: redis 7" $ do +-- zadd "key" [(2,"v1"),(0,"v2"),(40,"v3")] >>=? 3 +-- zrankWithScore "key" "v1" >>=? Just (1, 2) + testZStore :: Test testZStore = testCase "zunionstore/zinterstore" $ do zadd "{same}k1" [(1, "v1"), (2, "v2")] >>= \case @@ -450,7 +494,51 @@ return $ (,) <$> foo <*> bar assert $ foobar == TxSuccess (Just "foo", Just "bar") +testSet7 :: Test +testSet7 = testCase "Set" $ do + set "hello" "hi" >>=? Ok + setOpts "hello" "hi" SetOpts{ + setSeconds = Nothing, + setMilliseconds = Nothing, + setUnixSeconds = Just 2000, + setUnixMilliseconds = Nothing, + setCondition = Nothing, + setKeepTTL = False + } >>=? Ok + setOpts "hello" "hi" SetOpts{ + setSeconds = Nothing, + setMilliseconds = Nothing, + setUnixSeconds = Nothing, + setUnixMilliseconds = Just 20000, + setCondition = Nothing, + setKeepTTL = False + } >>=? Ok + setOpts "hello" "hi" SetOpts{ + setSeconds = Nothing, + setMilliseconds = Nothing, + setUnixSeconds = Nothing, + setUnixMilliseconds = Nothing, + setCondition = Nothing, + setKeepTTL = True + } >>=? Ok + setGet "hello" "henlo" >>=? "hi" + setGetOpts "hello" "henlo2" SetOpts{ + setSeconds = Nothing, + setMilliseconds = Nothing, + setUnixSeconds = Nothing, + setUnixMilliseconds = Nothing, + setCondition = Just Nx, + setKeepTTL = False + } >>=? "henlo" + return () +testZAdd7 :: Test +testZAdd7 = testCase "ZADD" $ do + zadd "set" [(42, "2")] >>=? 1 + zaddOpts "set" [(44, "6")] (defaultZaddOpts {zaddSizeCondition = Just CGT}) >>=? 1 + zaddOpts "set" [(46, "7")] (defaultZaddOpts {zaddSizeCondition = Just CLT}) >>=? 1 + return () + ------------------------------------------------------------------------------ -- Scripting -- @@ -487,34 +575,50 @@ ------------------------------------------------------------------------------ -- Connection -- -testConnectAuth :: Test -testConnectAuth = testCase "connect/auth" $ do +testConnectAuth :: String -> PortNumber -> Test +testConnectAuth host port = testCase "connect/auth" $ do configSet "requirepass" "pass" >>=? Ok liftIO $ do - c <- checkedConnect defaultConnectInfo { connectAuth = Just "pass" } + c <- checkedConnect defaultConnectInfo { connectAuth = Just "pass", connectAddr = ConnectAddrHostPort host port } runRedis c (ping >>=? Pong) auth "pass" >>=? Ok configSet "requirepass" "" >>=? Ok -testConnectAuthUnexpected :: Test -testConnectAuthUnexpected = testCase "connect/auth/unexpected" $ do +testConnectAuthUnexpected :: String -> PortNumber -> Test +testConnectAuthUnexpected host port = testCase "connect/auth/unexpected" $ do liftIO $ do res <- try $ void $ checkedConnect connInfo HUnit.assertEqual "" err res - where connInfo = defaultConnectInfo { connectAuth = Just "pass" } + where connInfo = defaultConnectInfo { connectAuth = Just "pass", connectAddr = ConnectAddrHostPort host port } err = Left $ ConnectAuthError $ 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 + +testConnectAuthAcl :: String -> PortNumber -> Test +testConnectAuthAcl host port = testCase "connect/auth/acl" $ do + liftIO $ do + c <- checkedConnect defaultConnectInfo { connectAddr = ConnectAddrHostPort host port } + runRedis c $ sendRequest ["ACL", "SETUSER", "test", "on", ">pass", "~*", "&*", "+@all"] >>=? Ok + liftIO $ do + c <- checkedConnect defaultConnectInfo{connectAuth=Just "pass", connectUsername=Just "test", connectAddr = ConnectAddrHostPort host port} + runRedis c (ping >>=? Pong) + liftIO $ do + res <- try $ void $ checkedConnect defaultConnectInfo{connectAuth=Just "pass", connectUsername=Just "test1", connectAddr = ConnectAddrHostPort host port} + HUnit.assertEqual "" err res + where + err = Left $ ConnectAuthError $ + Error "WRONGPASS invalid username-password pair or user is disabled." + +testConnectDb :: String -> PortNumber -> Test +testConnectDb host port = testCase "connect/db" $ do set "connect" "value" >>=? Ok liftIO $ void $ do - c <- checkedConnect defaultConnectInfo { connectDatabase = 1 } + c <- checkedConnect defaultConnectInfo { connectDatabase = 1, connectAddr = ConnectAddrHostPort host port } runRedis c (get "connect" >>=? Nothing) -testConnectDbUnexisting :: Test -testConnectDbUnexisting = testCase "connect/db/unexisting" $ do +testConnectDbUnexisting :: String -> PortNumber -> Test +testConnectDbUnexisting host port = testCase "connect/db/unexisting" $ do liftIO $ do res <- try $ void $ checkedConnect connInfo case res of @@ -522,7 +626,7 @@ _ -> HUnit.assertFailure $ "Expected ConnectSelectError, got " ++ show res - where connInfo = defaultConnectInfo { connectDatabase = 100 } + where connInfo = defaultConnectInfo { connectDatabase = 100, connectAddr = ConnectAddrHostPort host port } testEcho :: Test testEcho = testCase "echo" $ @@ -541,6 +645,20 @@ ------------------------------------------------------------------------------ +-- Client +-- +testClientId :: Test +testClientId = testCase "client id" $ do + clientId >>= assert . isRight + +testClientName :: Test +testClientName = testCase "client {get,set}name" $ do + clientGetname >>=? Nothing + clientSetname "FooBar" >>=? Ok + clientGetname >>=? Just "FooBar" + + +------------------------------------------------------------------------------ -- Server -- testServer :: Test @@ -566,7 +684,7 @@ testConfig :: Test testConfig = testCase "config/auth" $ do - configGet "requirepass" >>=? [("requirepass", "")] + configGet ["requirepass"] >>=? [("requirepass", "")] configSet "requirepass" "pass" >>=? Ok auth "pass" >>=? Ok configSet "requirepass" "" >>=? Ok @@ -593,32 +711,34 @@ slowlogGet 5 >>=? [] slowlogLen >>=? 0 +-- |Starting with Redis 7.0.0, the DEBUG command is disabled by default and must be enabled manually in the Redis Config file testDebugObject :: Test testDebugObject = testCase "debugObject/debugSegfault" $ do - set "key" "value" >>=? Ok - debugObject "key" >>= \case - Left _ -> error "error" - _ -> return () return () + -- set "key" "value" >>=? Ok + -- debugObject "key" >>= \case + -- Left _ -> error "error" + -- _ -> return () + -- return () testScans :: Test testScans = testCase "scans" $ do set "key" "value" >>=? Ok scan cursor0 >>=? (cursor0, ["key"]) - scanOpts cursor0 sOpts1 >>=? (cursor0, ["key"]) - scanOpts cursor0 sOpts2 >>=? (cursor0, []) + scanOpts cursor0 sOpts1 Nothing >>=? (cursor0, ["key"]) + scanOpts cursor0 sOpts2 Nothing >>=? (cursor0, []) where sOpts1 = defaultScanOpts { scanMatch = Just "k*" } sOpts2 = defaultScanOpts { scanMatch = Just "not*"} testSScan :: Test testSScan = testCase "sscan" $ do - sadd "set" ["1"] >>=? 1 + sadd "set" (NE.fromList ["1"]) >>=? 1 sscan "set" cursor0 >>=? (cursor0, ["1"]) testHScan :: Test testHScan = testCase "hscan" $ do - hset "hash" "k" "v" >>=? 1 - hscan "hash" cursor0 >>=? (cursor0, [("k", "v")]) + hset "hash" [("k"::ByteString, "v"::ByteString)] >>=? 1 + hscan "hash" cursor0 >>=? (cursor0, [("k", "v")]) testZScan :: Test testZScan = testCase "zscan" $ do @@ -638,8 +758,10 @@ testXAddRead = testCase "xadd/xread" $ do 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) + xaddOpts "{same}thirdstream" "*" [("k", "v")] + $ xaddTrimOpt (Just $ trimOpts (TrimMaxlen 1) TrimExact) + xaddOpts "{same}thirdstream" "*" [("k", "v")] + $ xaddTrimOpt (Just $ trimOpts (TrimMaxlen 1) (TrimApprox Nothing)) xread [("{same}somestream", "0"), ("{same}otherstream", "0")] >>=? Just [ XReadResponse { stream = "{same}somestream", @@ -650,22 +772,37 @@ records = [StreamsRecord{recordId = "456-0", keyValues = [("key1", "value1")]}] }] xlen "{same}somestream" >>=? 1 + where xaddTrimOpt a = XAddOpts{ + xAddTrimOpts = a, + xAddnoMkStream = False} testXReadGroup ::Test -testXReadGroup = testCase "XGROUP */xreadgroup/xack" $ do - xadd "somestream" "123" [("key", "value")] - xgroupCreate "somestream" "somegroup" "0" - xreadGroup "somegroup" "consumer1" [("somestream", ">")] >>=? Just [ +testXReadGroup = testCase "XGROUP */xreadgroup/xack" $ void $ runExceptT $ do + ExceptT $ xadd "somestream" "123" [("key", "value")] + ExceptT $ xgroupCreate "somestream" "somegroup" "0" + readResult <- ExceptT $ xreadGroup "somegroup" "consumer1" [("somestream", ">")] + liftIO $ readResult HUnit.@=? Just [ XReadResponse { stream = "somestream", records = [StreamsRecord{recordId = "123-0", keyValues = [("key", "value")]}] }] - xack "somestream" "somegroup" ["123-0"] >>=? 1 - xreadGroup "somegroup" "consumer1" [("somestream", ">")] >>=? Nothing - xgroupSetId "somestream" "somegroup" "0" >>=? Ok - xgroupDelConsumer "somestream" "somegroup" "consumer1" >>=? 0 - xgroupDestroy "somestream" "somegroup" >>=? True + noAcked <- ExceptT $ xack "somestream" "somegroup" ["123-0"] + liftIO $ noAcked HUnit.@=? 1 + groupMessages <- ExceptT $ xreadGroup "somegroup" "consumer1" [("somestream", ">")] + liftIO $ groupMessages HUnit.@=? Nothing + setIdOk <- ExceptT $ xgroupSetId "somestream" "somegroup" "0" + liftIO $ setIdOk HUnit.@=? Ok + itemsLeft <- ExceptT $ xgroupDelConsumer "somestream" "somegroup" "consumer1" + liftIO $ itemsLeft HUnit.@=? 0 + groupDestroyed <- ExceptT (xgroupDestroy "somestream" "somegroup") + liftIO $ groupDestroyed HUnit.@=? True +testXCreateGroup7 ::Test +testXCreateGroup7 = testCase "XGROUP CREATE" $ do + xgroupCreateOpts "somestream" "somegroup" "0" XGroupCreateOpts {xGroupCreateMkStream = True, + xGroupCreateEntriesRead = Just "1234"} >>=? Ok + return () + testXRange ::Test testXRange = testCase "xrange/xrevrange" $ do xadd "somestream" "121" [("key1", "value1")] @@ -689,31 +826,54 @@ xadd "somestream" "124" [("key4", "value4")] xgroupCreate "somestream" "somegroup" "0" xreadGroup "somegroup" "consumer1" [("somestream", ">")] - xpendingSummary "somestream" "somegroup" Nothing >>=? XPendingSummaryResponse { + xpendingSummary "somestream" "somegroup" >>=? XPendingSummaryResponse { numPendingMessages = 4, smallestPendingMessageId = "121-0", largestPendingMessageId = "124-0", numPendingMessagesByconsumer = [("consumer1", 4)] } - detail <- xpendingDetail "somestream" "somegroup" "121" "121" 10 Nothing - liftIO $ case detail of - Left reply -> HUnit.assertFailure $ "Redis error: " ++ show reply - Right [XPendingDetailRecord{..}] -> do - messageId HUnit.@=? "121-0" - Right bad -> HUnit.assertFailure $ "Unexpectedly got " ++ show bad + xpendingDetail "somestream" "somegroup" "121" "121" 10 defaultXPendingDetailOpts >>@? (\case + [XPendingDetailRecord{..}] -> do + messageId HUnit.@=? "121-0" + bad -> HUnit.assertFailure $ "Unexpectedly got " ++ show bad + ) +testXpending7 ::Test +testXpending7 = testCase "xpending7" $ void $ runExceptT $ do + ExceptT $ xadd "somestream" "121" [("key1", "value1")] + ExceptT $ xadd "somestream" "122" [("key2", "value2")] + ExceptT $ xadd "somestream" "123" [("key3", "value3")] + ExceptT $ xadd "somestream" "124" [("key4", "value4")] + ExceptT $ xgroupCreate "somestream" "somegroup" "0" + ExceptT $ xgroupCreate "somestream" "somegroup2" "0" + ExceptT $ xreadGroup "somegroup" "consumer1" [("somestream", ">")] + ExceptT $ xreadGroup "somegroup2" "consumer2" [("somestream", ">")] + ackedCount <- ExceptT $ xack "somestream" "somegroup" ["121", "122", "123"] + liftIO $ ackedCount HUnit.@=? 3 + pendingDetails <- ExceptT $ xpendingDetail "somestream" "somegroup2" "123" "123" 10 XPendingDetailOpts + {xPendingDetailIdle = Just 0, + xPendingDetailConsumer = Just "consumer2" } + + liftIO $ case pendingDetails of + [XPendingDetailRecord{..}] -> do + messageId HUnit.@=? "123-0" + bad -> HUnit.assertFailure $ "Unexpectedly got " ++ show bad + testXClaim ::Test testXClaim = - testCase "xclaim" $ do - xadd "somestream" "121" [("key1", "value1")] >>=? "121-0" - xadd "somestream" "122" [("key2", "value2")] >>=? "122-0" - xgroupCreate "somestream" "somegroup" "0" >>=? Ok - xreadGroupOpts + testCase "xclaim" $ void $ runExceptT $ do + storedKey1 <- ExceptT $ xadd "somestream" "121" [("key1", "value1")] + liftIO $ storedKey1 HUnit.@=? "121-0" + storedKey2 <- ExceptT $ xadd "somestream" "122" [("key2", "value2")] + liftIO $ storedKey2 HUnit.@=? "122-0" + groupCreated <- ExceptT $ xgroupCreate "somestream" "somegroup" "0" + liftIO $ groupCreated HUnit.@=? Ok + readResult <- ExceptT $ xreadGroupOpts "somegroup" "consumer1" [("somestream", ">")] - (defaultXreadOpts {recordCount = Just 2}) >>=? - Just + (defaultXReadGroupOpts {xReadGroupCount = Just 2}) + liftIO $ readResult HUnit.@=? Just [ XReadResponse { stream = "somestream" , records = @@ -724,53 +884,101 @@ ] } ] - xclaim "somestream" "somegroup" "consumer2" 0 defaultXClaimOpts ["121-0"] >>=? - [StreamsRecord {recordId = "121-0", keyValues = [("key1", "value1")]}] - xclaimJustIds + claimed <- ExceptT $ xclaim "somestream" "somegroup" "consumer2" 0 defaultXClaimOpts ["121-0"] + liftIO $ claimed HUnit.@=? [StreamsRecord {recordId = "121-0", keyValues = [("key1", "value1")]}] + claimedJustIds <- ExceptT $ xclaimJustIds "somestream" "somegroup" "consumer2" 0 defaultXClaimOpts - ["122-0"] >>=? ["122-0"] + liftIO $ claimedJustIds HUnit.@=? ["122-0"] +testXAutoClaim7 ::Test +testXAutoClaim7 = + testCase "xautoclaim" $ do + xadd "somestream" "121" [("key1", "value1")] >>=? "121-0" + xadd "somestream" "122" [("key2", "value2")] >>=? "122-0" + xgroupCreate "somestream" "somegroup" "0" >>=? Ok + xreadGroupOpts "somegroup" "consumer1" [("somestream", ">")] defaultXReadGroupOpts { xReadGroupCount = Just 2 } + + let opts = XAutoclaimOpts { + xAutoclaimCount = Just 1 + } + xautoclaimJustIdsOpts "somestream" "somegroup" "consumer2" 0 "0-0" opts >>@? (\case + XAutoclaimResult{..} -> do + xAutoclaimClaimedMessages HUnit.@=? ["121-0"] + xAutoclaimDeletedMessages HUnit.@=? [] + return ()) + + xtrim "somestream" (trimOpts (TrimMaxlen 1) TrimExact) >>=? 1 + xautoclaim "somestream" "somegroup" "consumer2" 0 "0-0" >>@? (\case + XAutoclaimResult{..} -> do + xAutoclaimClaimedMessages HUnit.@=? [StreamsRecord { + recordId = "122-0", + keyValues = [("key2", "value2")] + }] + xAutoclaimDeletedMessages HUnit.@=? ["121-0"] + return () + ) + return () + testXInfo ::Test -testXInfo = testCase "xinfo" $ do - xadd "somestream" "121" [("key1", "value1")] - xadd "somestream" "122" [("key2", "value2")] - xgroupCreate "somestream" "somegroup" "0" - xreadGroupOpts "somegroup" "consumer1" [("somestream", ">")] (defaultXreadOpts { recordCount = Just 2}) - consumerInfos <- xinfoConsumers "somestream" "somegroup" - liftIO $ case consumerInfos of - Left reply -> HUnit.assertFailure $ "Redis error: " ++ show reply - Right [XInfoConsumersResponse{..}] -> do +-- This test does not work with pipelining because it relies on the certaino order of commands execution +-- and fails if commands reach different nodes. +testXInfo = testCase "xinfo" $ void $ runExceptT $ do + _ <- ExceptT $ xadd "somestream" "121" [("key1", "value1")] + _ <- ExceptT $ xadd "somestream" "122" [("key2", "value2")] + _ <- ExceptT $ xgroupCreate "somestream" "somegroup" "0" + _ <- ExceptT $ xreadGroupOpts "somegroup" "consumer1" [("somestream", ">")] defaultXReadGroupOpts { xReadGroupCount = Just 2 } + + z <- ExceptT $ xinfoConsumers "somestream" "somegroup" + liftIO $ case z of + [XInfoConsumersResponse{..}] -> do xinfoConsumerName HUnit.@=? "consumer1" xinfoConsumerNumPendingMessages HUnit.@=? 2 - Right bad -> HUnit.assertFailure $ "Unexpectedly got " ++ show bad - xinfoGroups "somestream" >>=? [ - XInfoGroupsResponse{ - xinfoGroupsGroupName = "somegroup", - xinfoGroupsNumConsumers = 1, - xinfoGroupsNumPendingMessages = 2, - xinfoGroupsLastDeliveredMessageId = "122-0" - }] - xinfoStream "somestream" >>=? XInfoStreamResponse - { xinfoStreamLength = 2 - , xinfoStreamRadixTreeKeys = 1 - , xinfoStreamRadixTreeNodes = 2 - , xinfoStreamNumGroups = 1 - , xinfoStreamLastEntryId = "122-0" - , xinfoStreamFirstEntry = StreamsRecord - { recordId = "121-0" - , keyValues = [("key1", "value1")] - } - , xinfoStreamLastEntry = StreamsRecord - { recordId = "122-0" - , keyValues = [("key2", "value2")] - } - } + bad -> HUnit.assertFailure $ "Unexpectedly got " ++ show bad + + x <- ExceptT $ xinfoGroups "somestream" + liftIO $ case x of + [XInfoGroupsResponse{..}] -> do + xinfoGroupsGroupName HUnit.@=? "somegroup" + xinfoGroupsNumConsumers HUnit.@=? 1 + xinfoGroupsNumPendingMessages HUnit.@=? 2 + xinfoGroupsLastDeliveredMessageId HUnit.@=? "122-0" + + (do xinfoGroupsEntriesRead HUnit.@=? Nothing -- Redis 6 + xinfoGroupsLag HUnit.@=? Nothing) <|?> + (do xinfoGroupsEntriesRead HUnit.@=? Just 2 -- Redis 7 + xinfoGroupsLag HUnit.@=? Just 0) + + bad -> HUnit.assertFailure $ "Unexpectedly got " ++ show bad + + a <- ExceptT $ xinfoStream "somestream" + liftIO $ case a of + XInfoStreamResponse{..} -> do + xinfoStreamLength HUnit.@=? 2 + xinfoStreamRadixTreeKeys HUnit.@=? 1 + xinfoStreamRadixTreeNodes HUnit.@=? 2 + xinfoStreamNumGroups HUnit.@=? 1 + xinfoStreamLastEntryId HUnit.@=? "122-0" + xinfoStreamFirstEntry HUnit.@=? StreamsRecord { + recordId = "121-0" + , keyValues = [("key1", "value1")]} + xinfoStreamLastEntry HUnit.@=? StreamsRecord { + recordId = "122-0" + , keyValues = [("key2", "value2")] } + (do xinfoMaxDeletedEntryId HUnit.@=? Nothing -- Redis 6.0 + xinfoEntriesAdded HUnit.@=? Nothing + xinfoRecordedFirstEntryId HUnit.@=? Nothing) <|?> -- Redis 7.0 + (do xinfoMaxDeletedEntryId HUnit.@=? Just "0-0" + xinfoEntriesAdded HUnit.@=? Just 2 + xinfoRecordedFirstEntryId HUnit.@=? Just "121-0") + bad -> HUnit.assertFailure $ "Unexpectedly got " ++ show bad + return () + testXDel ::Test testXDel = testCase "xdel" $ do xadd "somestream" "121" [("key1", "value1")] @@ -783,6 +991,7 @@ xadd "somestream" "121" [("key1", "value1")] xadd "somestream" "122" [("key2", "value2")] xadd "somestream" "123" [("key3", "value3")] - xadd "somestream" "124" [("key4", "value4")] + streamId <- fromRight "" <$> xadd "somestream" "124" [("key4", "value4")] xadd "somestream" "125" [("key5", "value5")] - xtrim "somestream" (Maxlen 2) >>=? 3 + xtrim "somestream" (trimOpts (TrimMaxlen 3) TrimExact) >>=? 2 + xtrim "somestream" (trimOpts (TrimMinId streamId) TrimExact) >>=? 1