hedis 0.15.2 → 0.16.0
raw patch · 27 files changed
+5315/−3052 lines, 27 filesdep +hashabledep +http-typesdep +transformersdep −doctestdep ~HTTPdep ~asyncdep ~basenew-uploader
Dependencies added: hashable, http-types, transformers
Dependencies removed: doctest
Dependency ranges changed: HTTP, async, base, bytestring, bytestring-lexing, containers, deepseq, errors, exceptions, mtl, network, network-uri, resource-pool, scanner, stm, text, time, tls, unliftio-core, unordered-containers, vector
Files
- CHANGELOG +65/−2
- DocTest.hs +0/−6
- benchmark/Benchmark.hs +3/−2
- hedis.cabal +102/−50
- src/Database/Redis.hs +13/−8
- src/Database/Redis/Cluster.hs +140/−53
- src/Database/Redis/Cluster/Command.hs +25/−3
- src/Database/Redis/Cluster/HashSlot.hs +24/−5
- src/Database/Redis/Commands.hs +1556/−1095
- src/Database/Redis/Connection.hs +86/−44
- src/Database/Redis/ConnectionContext.hs +42/−33
- src/Database/Redis/Core.hs +18/−6
- src/Database/Redis/Core/Internal.hs +9/−2
- src/Database/Redis/Hooks.hs +44/−0
- src/Database/Redis/ManualCommands.hs +2242/−1419
- src/Database/Redis/ProtocolPipelining.hs +20/−17
- src/Database/Redis/PubSub.hs +229/−125
- src/Database/Redis/PubSub.hs-boot +8/−0
- src/Database/Redis/Sentinel.hs +25/−22
- src/Database/Redis/Types.hs +9/−0
- src/Database/Redis/URL.hs +103/−26
- test/ClusterMain.hs +26/−10
- test/Main.hs +33/−8
- test/MainHooks.hs +68/−0
- test/MainRedis7.hs +18/−0
- test/PubSubTest.hs +87/−5
- test/Tests.hs +320/−111
CHANGELOG view
@@ -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
− DocTest.hs
@@ -1,6 +0,0 @@-module Main (main) where--import Test.DocTest--main :: IO ()-main = doctest ["-isrc", "src"]
benchmark/Benchmark.hs view
@@ -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
hedis.cabal view
@@ -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 <falko.peters@gmail.com>-maintainer: Kostiantyn Rybnikov <k-bx@k-bx.com>+maintainer: Kostiantyn Rybnikov <k-bx@k-bx.com>, Alexander Vershilov <alexander.vershilov@gmail.com> 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
src/Database/Redis.hs view
@@ -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
src/Database/Redis/Cluster.hs view
@@ -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
src/Database/Redis/Cluster/Command.hs view
@@ -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
src/Database/Redis/Cluster/HashSlot.hs view
@@ -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
src/Database/Redis/Commands.hs view
@@ -1,1095 +1,1556 @@--- Generated by GenCmds.hs. DO NOT EDIT.--{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}--module Database.Redis.Commands (---- ** Connection-auth, -- |Authenticate to the server (<http://redis.io/commands/auth>). Since Redis 1.0.0-echo, -- |Echo the given string (<http://redis.io/commands/echo>). Since Redis 1.0.0-ping, -- |Ping the server (<http://redis.io/commands/ping>). Since Redis 1.0.0-quit, -- |Close the connection (<http://redis.io/commands/quit>). Since Redis 1.0.0-select, -- |Change the selected database for the current connection (<http://redis.io/commands/select>). Since Redis 1.0.0---- ** Keys-del, -- |Delete a key (<http://redis.io/commands/del>). Since Redis 1.0.0-dump, -- |Return a serialized version of the value stored at the specified key (<http://redis.io/commands/dump>). Since Redis 2.6.0-exists, -- |Determine if a key exists (<http://redis.io/commands/exists>). Since Redis 1.0.0-expire, -- |Set a key's time to live in seconds (<http://redis.io/commands/expire>). Since Redis 1.0.0-expireat, -- |Set the expiration for a key as a UNIX timestamp (<http://redis.io/commands/expireat>). Since Redis 1.2.0-keys, -- |Find all keys matching the given pattern (<http://redis.io/commands/keys>). Since Redis 1.0.0-MigrateOpts(..),-defaultMigrateOpts,-migrate, -- |Atomically transfer a key from a Redis instance to another one (<http://redis.io/commands/migrate>). 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 (<http://redis.io/commands/migrate>). The Redis command @MIGRATE@ is split up into 'migrate', 'migrateMultiple'. Since Redis 2.6.0-move, -- |Move a key to another database (<http://redis.io/commands/move>). Since Redis 1.0.0-objectRefcount, -- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3-objectEncoding, -- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3-objectIdletime, -- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3-persist, -- |Remove the expiration from a key (<http://redis.io/commands/persist>). Since Redis 2.2.0-pexpire, -- |Set a key's time to live in milliseconds (<http://redis.io/commands/pexpire>). Since Redis 2.6.0-pexpireat, -- |Set the expiration for a key as a UNIX timestamp specified in milliseconds (<http://redis.io/commands/pexpireat>). Since Redis 2.6.0-pttl, -- |Get the time to live for a key in milliseconds (<http://redis.io/commands/pttl>). Since Redis 2.6.0-randomkey, -- |Return a random key from the keyspace (<http://redis.io/commands/randomkey>). Since Redis 1.0.0-rename, -- |Rename a key (<http://redis.io/commands/rename>). Since Redis 1.0.0-renamenx, -- |Rename a key, only if the new key does not exist (<http://redis.io/commands/renamenx>). Since Redis 1.0.0-restore, -- |Create a key using the provided serialized value, previously obtained using DUMP (<http://redis.io/commands/restore>). 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 (<http://redis.io/commands/restore>). 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 (<http://redis.io/commands/scan>). The Redis command @SCAN@ is split up into 'scan', 'scanOpts'. Since Redis 2.8.0-scanOpts, -- |Incrementally iterate the keys space (<http://redis.io/commands/scan>). 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 (<http://redis.io/commands/sort>). 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 (<http://redis.io/commands/sort>). The Redis command @SORT@ is split up into 'sort', 'sortStore'. Since Redis 1.0.0-ttl, -- |Get the time to live for a key (<http://redis.io/commands/ttl>). Since Redis 1.0.0-RedisType(..),-getType, -- |Determine the type stored at key (<http://redis.io/commands/type>). Since Redis 1.0.0-wait, -- |Wait for the synchronous replication of all the write commands sent in the context of the current connection (<http://redis.io/commands/wait>). Since Redis 3.0.0---- ** Hashes-hdel, -- |Delete one or more hash fields (<http://redis.io/commands/hdel>). Since Redis 2.0.0-hexists, -- |Determine if a hash field exists (<http://redis.io/commands/hexists>). Since Redis 2.0.0-hget, -- |Get the value of a hash field (<http://redis.io/commands/hget>). Since Redis 2.0.0-hgetall, -- |Get all the fields and values in a hash (<http://redis.io/commands/hgetall>). Since Redis 2.0.0-hincrby, -- |Increment the integer value of a hash field by the given number (<http://redis.io/commands/hincrby>). Since Redis 2.0.0-hincrbyfloat, -- |Increment the float value of a hash field by the given amount (<http://redis.io/commands/hincrbyfloat>). Since Redis 2.6.0-hkeys, -- |Get all the fields in a hash (<http://redis.io/commands/hkeys>). Since Redis 2.0.0-hlen, -- |Get the number of fields in a hash (<http://redis.io/commands/hlen>). Since Redis 2.0.0-hmget, -- |Get the values of all the given hash fields (<http://redis.io/commands/hmget>). Since Redis 2.0.0-hmset, -- |Set multiple hash fields to multiple values (<http://redis.io/commands/hmset>). Since Redis 2.0.0-hscan, -- |Incrementally iterate hash fields and associated values (<http://redis.io/commands/hscan>). The Redis command @HSCAN@ is split up into 'hscan', 'hscanOpts'. Since Redis 2.8.0-hscanOpts, -- |Incrementally iterate hash fields and associated values (<http://redis.io/commands/hscan>). The Redis command @HSCAN@ is split up into 'hscan', 'hscanOpts'. Since Redis 2.8.0-hset, -- |Set the string value of a hash field (<http://redis.io/commands/hset>). Since Redis 2.0.0-hsetnx, -- |Set the value of a hash field, only if the field does not exist (<http://redis.io/commands/hsetnx>). Since Redis 2.0.0-hstrlen, -- |Get the length of the value of a hash field (<http://redis.io/commands/hstrlen>). Since Redis 3.2.0-hvals, -- |Get all the values in a hash (<http://redis.io/commands/hvals>). 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 (<http://redis.io/commands/pfadd>). Since Redis 2.8.9-pfcount, -- |Return the approximated cardinality of the set(s) observed by the HyperLogLog at key(s) (<http://redis.io/commands/pfcount>). Since Redis 2.8.9-pfmerge, -- |Merge N different HyperLogLogs into a single one (<http://redis.io/commands/pfmerge>). Since Redis 2.8.9---- ** Lists-blpop, -- |Remove and get the first element in a list, or block until one is available (<http://redis.io/commands/blpop>). Since Redis 2.0.0-brpop, -- |Remove and get the last element in a list, or block until one is available (<http://redis.io/commands/brpop>). 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 (<http://redis.io/commands/brpoplpush>). Since Redis 2.2.0-lindex, -- |Get an element from a list by its index (<http://redis.io/commands/lindex>). Since Redis 1.0.0-linsertBefore, -- |Insert an element before or after another element in a list (<http://redis.io/commands/linsert>). 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 (<http://redis.io/commands/linsert>). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'. Since Redis 2.2.0-llen, -- |Get the length of a list (<http://redis.io/commands/llen>). Since Redis 1.0.0-lpop, -- |Remove and get the first element in a list (<http://redis.io/commands/lpop>). Since Redis 1.0.0-lpush, -- |Prepend one or multiple values to a list (<http://redis.io/commands/lpush>). Since Redis 1.0.0-lpushx, -- |Prepend a value to a list, only if the list exists (<http://redis.io/commands/lpushx>). Since Redis 2.2.0-lrange, -- |Get a range of elements from a list (<http://redis.io/commands/lrange>). Since Redis 1.0.0-lrem, -- |Remove elements from a list (<http://redis.io/commands/lrem>). Since Redis 1.0.0-lset, -- |Set the value of an element in a list by its index (<http://redis.io/commands/lset>). Since Redis 1.0.0-ltrim, -- |Trim a list to the specified range (<http://redis.io/commands/ltrim>). Since Redis 1.0.0-rpop, -- |Remove and get the last element in a list (<http://redis.io/commands/rpop>). Since Redis 1.0.0-rpoplpush, -- |Remove the last element in a list, prepend it to another list and return it (<http://redis.io/commands/rpoplpush>). Since Redis 1.2.0-rpush, -- |Append one or multiple values to a list (<http://redis.io/commands/rpush>). Since Redis 1.0.0-rpushx, -- |Append a value to a list, only if the list exists (<http://redis.io/commands/rpushx>). Since Redis 2.2.0---- ** Scripting-eval, -- |Execute a Lua script server side (<http://redis.io/commands/eval>). Since Redis 2.6.0-evalsha, -- |Execute a Lua script server side (<http://redis.io/commands/evalsha>). Since Redis 2.6.0-DebugMode,-scriptDebug, -- |Set the debug mode for executed scripts (<http://redis.io/commands/script-debug>). Since Redis 3.2.0-scriptExists, -- |Check existence of scripts in the script cache (<http://redis.io/commands/script-exists>). Since Redis 2.6.0-scriptFlush, -- |Remove all the scripts from the script cache (<http://redis.io/commands/script-flush>). Since Redis 2.6.0-scriptKill, -- |Kill the script currently in execution (<http://redis.io/commands/script-kill>). Since Redis 2.6.0-scriptLoad, -- |Load the specified Lua script into the script cache (<http://redis.io/commands/script-load>). Since Redis 2.6.0---- ** Server-bgrewriteaof, -- |Asynchronously rewrite the append-only file (<http://redis.io/commands/bgrewriteaof>). Since Redis 1.0.0-bgsave, -- |Asynchronously save the dataset to disk (<http://redis.io/commands/bgsave>). Since Redis 1.0.0-clientGetname, -- |Get the current connection name (<http://redis.io/commands/client-getname>). Since Redis 2.6.9-clientList, -- |Get the list of client connections (<http://redis.io/commands/client-list>). Since Redis 2.4.0-clientPause, -- |Stop processing commands from clients for some time (<http://redis.io/commands/client-pause>). Since Redis 2.9.50-ReplyMode,-clientReply, -- |Instruct the server whether to reply to commands (<http://redis.io/commands/client-reply>). Since Redis 3.2-clientSetname, -- |Set the current connection name (<http://redis.io/commands/client-setname>). Since Redis 2.6.9-commandCount, -- |Get total number of Redis commands (<http://redis.io/commands/command-count>). Since Redis 2.8.13-commandInfo, -- |Get array of specific Redis command details (<http://redis.io/commands/command-info>). Since Redis 2.8.13-configGet, -- |Get the value of a configuration parameter (<http://redis.io/commands/config-get>). Since Redis 2.0.0-configResetstat, -- |Reset the stats returned by INFO (<http://redis.io/commands/config-resetstat>). Since Redis 2.0.0-configRewrite, -- |Rewrite the configuration file with the in memory configuration (<http://redis.io/commands/config-rewrite>). Since Redis 2.8.0-configSet, -- |Set a configuration parameter to the given value (<http://redis.io/commands/config-set>). Since Redis 2.0.0-dbsize, -- |Return the number of keys in the selected database (<http://redis.io/commands/dbsize>). Since Redis 1.0.0-debugObject, -- |Get debugging information about a key (<http://redis.io/commands/debug-object>). Since Redis 1.0.0-flushall, -- |Remove all keys from all databases (<http://redis.io/commands/flushall>). Since Redis 1.0.0-flushdb, -- |Remove all keys from the current database (<http://redis.io/commands/flushdb>). Since Redis 1.0.0-info, -- |Get information and statistics about the server (<http://redis.io/commands/info>). The Redis command @INFO@ is split up into 'info', 'infoSection'. Since Redis 1.0.0-infoSection, -- |Get information and statistics about the server (<http://redis.io/commands/info>). 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 (<http://redis.io/commands/lastsave>). Since Redis 1.0.0-save, -- |Synchronously save the dataset to disk (<http://redis.io/commands/save>). Since Redis 1.0.0-slaveof, -- |Make the server a slave of another instance, or promote it as master (<http://redis.io/commands/slaveof>). Since Redis 1.0.0-Slowlog(..),-slowlogGet, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12-slowlogLen, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12-slowlogReset, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12-time, -- |Return the current server time (<http://redis.io/commands/time>). Since Redis 2.6.0---- ** Sets-sadd, -- |Add one or more members to a set (<http://redis.io/commands/sadd>). Since Redis 1.0.0-scard, -- |Get the number of members in a set (<http://redis.io/commands/scard>). Since Redis 1.0.0-sdiff, -- |Subtract multiple sets (<http://redis.io/commands/sdiff>). Since Redis 1.0.0-sdiffstore, -- |Subtract multiple sets and store the resulting set in a key (<http://redis.io/commands/sdiffstore>). Since Redis 1.0.0-sinter, -- |Intersect multiple sets (<http://redis.io/commands/sinter>). Since Redis 1.0.0-sinterstore, -- |Intersect multiple sets and store the resulting set in a key (<http://redis.io/commands/sinterstore>). Since Redis 1.0.0-sismember, -- |Determine if a given value is a member of a set (<http://redis.io/commands/sismember>). Since Redis 1.0.0-smembers, -- |Get all the members in a set (<http://redis.io/commands/smembers>). Since Redis 1.0.0-smove, -- |Move a member from one set to another (<http://redis.io/commands/smove>). Since Redis 1.0.0-spop, -- |Remove and return one or multiple random members from a set (<http://redis.io/commands/spop>). 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 (<http://redis.io/commands/spop>). 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 (<http://redis.io/commands/srandmember>). 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 (<http://redis.io/commands/srandmember>). The Redis command @SRANDMEMBER@ is split up into 'srandmember', 'srandmemberN'. Since Redis 1.0.0-srem, -- |Remove one or more members from a set (<http://redis.io/commands/srem>). Since Redis 1.0.0-sscan, -- |Incrementally iterate Set elements (<http://redis.io/commands/sscan>). The Redis command @SSCAN@ is split up into 'sscan', 'sscanOpts'. Since Redis 2.8.0-sscanOpts, -- |Incrementally iterate Set elements (<http://redis.io/commands/sscan>). The Redis command @SSCAN@ is split up into 'sscan', 'sscanOpts'. Since Redis 2.8.0-sunion, -- |Add multiple sets (<http://redis.io/commands/sunion>). Since Redis 1.0.0-sunionstore, -- |Add multiple sets and store the resulting set in a key (<http://redis.io/commands/sunionstore>). 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 (<http://redis.io/commands/zadd>). 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 (<http://redis.io/commands/zadd>). 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 (<http://redis.io/commands/zcard>). Since Redis 1.2.0-zcount, -- |Count the members in a sorted set with scores within the given values (<http://redis.io/commands/zcount>). Since Redis 2.0.0-zincrby, -- |Increment the score of a member in a sorted set (<http://redis.io/commands/zincrby>). Since Redis 1.2.0-Aggregate(..),-zinterstore, -- |Intersect multiple sorted sets and store the resulting sorted set in a new key (<http://redis.io/commands/zinterstore>). 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 (<http://redis.io/commands/zinterstore>). 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 (<http://redis.io/commands/zlexcount>). Since Redis 2.8.9-zrange, -- |Return a range of members in a sorted set, by index (<http://redis.io/commands/zrange>). 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 (<http://redis.io/commands/zrange>). 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 (<http://redis.io/commands/zrangebylex>). Since Redis 2.8.9-zrangebyscore, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). 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 (<http://redis.io/commands/zrangebyscore>). 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 (<http://redis.io/commands/zrangebyscore>). 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 (<http://redis.io/commands/zrangebyscore>). 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 (<http://redis.io/commands/zrank>). Since Redis 2.0.0-zrem, -- |Remove one or more members from a sorted set (<http://redis.io/commands/zrem>). Since Redis 1.2.0-zremrangebylex, -- |Remove all members in a sorted set between the given lexicographical range (<http://redis.io/commands/zremrangebylex>). Since Redis 2.8.9-zremrangebyrank, -- |Remove all members in a sorted set within the given indexes (<http://redis.io/commands/zremrangebyrank>). Since Redis 2.0.0-zremrangebyscore, -- |Remove all members in a sorted set within the given scores (<http://redis.io/commands/zremrangebyscore>). Since Redis 1.2.0-zrevrange, -- |Return a range of members in a sorted set, by index, with scores ordered from high to low (<http://redis.io/commands/zrevrange>). 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 (<http://redis.io/commands/zrevrange>). 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 (<http://redis.io/commands/zrevrangebyscore>). 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 (<http://redis.io/commands/zrevrangebyscore>). 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 (<http://redis.io/commands/zrevrangebyscore>). 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 (<http://redis.io/commands/zrevrangebyscore>). 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 (<http://redis.io/commands/zrevrank>). Since Redis 2.0.0-zscan, -- |Incrementally iterate sorted sets elements and associated scores (<http://redis.io/commands/zscan>). The Redis command @ZSCAN@ is split up into 'zscan', 'zscanOpts'. Since Redis 2.8.0-zscanOpts, -- |Incrementally iterate sorted sets elements and associated scores (<http://redis.io/commands/zscan>). 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 (<http://redis.io/commands/zscore>). Since Redis 1.2.0-zunionstore, -- |Add multiple sorted sets and store the resulting sorted set in a new key (<http://redis.io/commands/zunionstore>). 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 (<http://redis.io/commands/zunionstore>). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'. Since Redis 2.0.0---- ** Strings-append, -- |Append a value to a key (<http://redis.io/commands/append>). Since Redis 2.0.0-bitcount, -- |Count set bits in a string (<http://redis.io/commands/bitcount>). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'. Since Redis 2.6.0-bitcountRange, -- |Count set bits in a string (<http://redis.io/commands/bitcount>). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'. Since Redis 2.6.0-bitopAnd, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0-bitopOr, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0-bitopXor, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0-bitopNot, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). 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 (<http://redis.io/commands/bitpos>). Since Redis 2.8.7-decr, -- |Decrement the integer value of a key by one (<http://redis.io/commands/decr>). Since Redis 1.0.0-decrby, -- |Decrement the integer value of a key by the given number (<http://redis.io/commands/decrby>). Since Redis 1.0.0-get, -- |Get the value of a key (<http://redis.io/commands/get>). Since Redis 1.0.0-getbit, -- |Returns the bit value at offset in the string value stored at key (<http://redis.io/commands/getbit>). Since Redis 2.2.0-getrange, -- |Get a substring of the string stored at a key (<http://redis.io/commands/getrange>). Since Redis 2.4.0-getset, -- |Set the string value of a key and return its old value (<http://redis.io/commands/getset>). Since Redis 1.0.0-incr, -- |Increment the integer value of a key by one (<http://redis.io/commands/incr>). Since Redis 1.0.0-incrby, -- |Increment the integer value of a key by the given amount (<http://redis.io/commands/incrby>). Since Redis 1.0.0-incrbyfloat, -- |Increment the float value of a key by the given amount (<http://redis.io/commands/incrbyfloat>). Since Redis 2.6.0-mget, -- |Get the values of all the given keys (<http://redis.io/commands/mget>). Since Redis 1.0.0-mset, -- |Set multiple keys to multiple values (<http://redis.io/commands/mset>). Since Redis 1.0.1-msetnx, -- |Set multiple keys to multiple values, only if none of the keys exist (<http://redis.io/commands/msetnx>). Since Redis 1.0.1-psetex, -- |Set the value and expiration in milliseconds of a key (<http://redis.io/commands/psetex>). Since Redis 2.6.0-Condition(..),-SetOpts(..),-set, -- |Set the string value of a key (<http://redis.io/commands/set>). The Redis command @SET@ is split up into 'set', 'setOpts'. Since Redis 1.0.0-setOpts, -- |Set the string value of a key (<http://redis.io/commands/set>). 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 (<http://redis.io/commands/setbit>). Since Redis 2.2.0-setex, -- |Set the value and expiration of a key (<http://redis.io/commands/setex>). Since Redis 2.0.0-setnx, -- |Set the value of a key, only if the key does not exist (<http://redis.io/commands/setnx>). Since Redis 1.0.0-setrange, -- |Overwrite part of a string at key starting at the specified offset (<http://redis.io/commands/setrange>). Since Redis 2.2.0-strlen, -- |Get the length of the value stored in a key (<http://redis.io/commands/strlen>). Since Redis 2.2.0---- ** Streams-XReadOpts(..),-defaultXreadOpts,-XReadResponse(..),-StreamsRecord(..),-TrimOpts(..),-xadd, -- |Add a value to a stream (<https://redis.io/commands/xadd>). Since Redis 5.0.0-xaddOpts, -- |Add a value to a stream (<https://redis.io/commands/xadd>). The Redis command @XADD@ is split up into 'xadd', 'xaddOpts'. Since Redis 5.0.0-xread, -- |Read values from a stream (<https://redis.io/commands/xread>). The Redis command @XREAD@ is split up into 'xread', 'xreadOpts'. Since Redis 5.0.0-xreadOpts, -- |Read values from a stream (<https://redis.io/commands/xread>). 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 (<http://redis.io/commands/command>)--------- * COMMAND GETKEYS (<http://redis.io/commands/command-getkeys>)--------- * ROLE (<http://redis.io/commands/role>)--------- * CLIENT KILL (<http://redis.io/commands/client-kill>)--------- * ZREVRANGEBYLEX (<http://redis.io/commands/zrevrangebylex>)--------- * ZRANGEBYSCORE (<http://redis.io/commands/zrangebyscore>)--------- * ZREVRANGEBYSCORE (<http://redis.io/commands/zrevrangebyscore>)--------- * MONITOR (<http://redis.io/commands/monitor>)--------- * SYNC (<http://redis.io/commands/sync>)--------- * SHUTDOWN (<http://redis.io/commands/shutdown>)--------- * DEBUG SEGFAULT (<http://redis.io/commands/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 (<http://redis.io/commands/info>). The Redis command @INFO@ is split up into 'info', 'infoSection'. Since Redis 1.0.0+infoSection, -- |Get information and statistics about the server (<http://redis.io/commands/info>). 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 (<http://redis.io/commands/lastsave>). Since Redis 1.0.0+save,+slaveof,+Slowlog(..),+slowlogGet, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12+slowlogLen, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12+slowlogReset, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). 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 (<http://redis.io/commands/zrangebyscore>). 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 (<http://redis.io/commands/zrangebyscore>). 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 (<http://redis.io/commands/zrangebyscore>). 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 (<http://redis.io/commands/zrangebyscore>). 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 (<http://redis.io/commands/zrevrange>). 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 (<http://redis.io/commands/zrevrange>). 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 (<http://redis.io/commands/zrevrangebyscore>). 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 (<http://redis.io/commands/zrevrangebyscore>). 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 (<http://redis.io/commands/zrevrangebyscore>). 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 (<http://redis.io/commands/zrevrangebyscore>). 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 (<http://redis.io/commands/zscan>). The Redis command @ZSCAN@ is split up into 'zscan', 'zscanOpts'. Since Redis 2.8.0+zscanOpts, -- |Incrementally iterate sorted sets elements and associated scores (<http://redis.io/commands/zscan>). 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 (<http://redis.io/commands/zunionstore>). 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 (<http://redis.io/commands/zunionstore>). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'. Since Redis 2.0.0++-- ** Strings+append,+bitcount, -- |Count set bits in a string (<http://redis.io/commands/bitcount>). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'. Since Redis 2.6.0+bitcountRange, -- |Count set bits in a string (<http://redis.io/commands/bitcount>). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'. Since Redis 2.6.0+bitopAnd, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0+bitopOr, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0+bitopXor, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0+bitopNot, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). 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 (<http://redis.io/commands/set>). 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 (<http://redis.io/commands/set>). 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 (<http://redis.io/commands/set>). 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 (<http://redis.io/commands/set>). 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 (<https://redis.io/commands/xread>). The Redis command @XREAD@ is split up into 'xread', 'xreadOpts'. Since Redis 5.0.0+xreadOpts, -- |Read values from a stream (<https://redis.io/commands/xread>). 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 (<http://redis.io/commands/command>)+--+--+-- * COMMAND GETKEYS (<http://redis.io/commands/command-getkeys>)+--+--+-- * ROLE (<http://redis.io/commands/role>)+--+--+-- * CLIENT KILL (<http://redis.io/commands/client-kill>)+--+--+-- * ZREVRANGEBYLEX (<http://redis.io/commands/zrevrangebylex>)+--+--+-- * ZRANGEBYSCORE (<http://redis.io/commands/zrangebyscore>)+--+--+-- * ZREVRANGEBYSCORE (<http://redis.io/commands/zrevrangebyscore>)+--+--+-- * MONITOR (<http://redis.io/commands/monitor>)+--+--+-- * SYNC (<http://redis.io/commands/sync>)+--+--+-- * SHUTDOWN (<http://redis.io/commands/shutdown>)+--+--+-- * DEBUG SEGFAULT (<http://redis.io/commands/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 (<http://redis.io/commands/ttl>).+-- 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 (<http://redis.io/commands/setnx>).+--+-- 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 (<http://redis.io/commands/pttl>).+-- 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 (<http://redis.io/commands/command-count>).+-- Since Redis 2.8.13+commandCount+ :: (RedisCtx m f)+ => m (f Integer)+commandCount = sendRequest ["COMMAND","COUNT"]++-- | Set the current connection name (<http://redis.io/commands/client-setname>).+-- 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 (<http://redis.io/commands/zrank>).+--+-- 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 (<http://redis.io/commands/zremrangebyscore>).+--+-- 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 (<http://redis.io/commands/hkeys>).+-- 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 (<http://redis.io/commands/slaveof>).+-- 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 (<http://redis.io/commands/rpushx>).+-- 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 (<http://redis.io/commands/debug-object>). 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 (<http://redis.io/commands/bgsave>).+--+-- Since Redis 1.0.0+bgsave+ :: (RedisCtx m f)+ => m (f Status)+bgsave = sendRequest ["BGSAVE"]++-- |Asynchronously save the dataset to disk (<http://redis.io/commands/bgsave>).+--+-- 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 (<http://redis.io/commands/hlen>).+--+-- 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 (<http://redis.io/commands/rpoplpush>).+-- 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 (<http://redis.io/commands/brpop>).+--+-- 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 (<http://redis.io/commands/brpop>).+--+-- 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 (<http://redis.io/commands/bgrewriteaof>). 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 (<http://redis.io/commands/zincrby>).+--+-- 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 (<http://redis.io/commands/hgetall>).+--+-- 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 (<http://redis.io/commands/hmset>).+--+-- 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 (<http://redis.io/commands/sinter>).+-- 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 (<http://redis.io/commands/pfadd>).+-- 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 (<http://redis.io/commands/zremrangebyrank>).+--+-- 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 (<http://redis.io/commands/flushdb>).+-- 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 (<http://redis.io/commands/sadd>).+-- 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 (<http://redis.io/commands/lindex>).+-- 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 (<http://redis.io/commands/lpush>).+-- 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 (<http://redis.io/commands/hstrlen>).+-- 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 (<http://redis.io/commands/smove>).+-- 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 (<http://redis.io/commands/zscore>).+-- 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 (<http://redis.io/commands/config-resetstat>).+-- 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) (<http://redis.io/commands/pfcount>).+-- 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 (<http://redis.io/commands/hdel>).+-- 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 (<http://redis.io/commands/incrbyfloat>).+-- 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 (<http://redis.io/commands/setbit>).+-- 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 (<http://redis.io/commands/flushall>). 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 (<http://redis.io/commands/incrby>).+-- 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 (<http://redis.io/commands/time>).+-- Since Redis 2.6.0+time+ :: (RedisCtx m f)+ => m (f (Integer,Integer))+time = sendRequest ["TIME"]++-- |Get all the members in a set (<http://redis.io/commands/smembers>). 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 (<http://redis.io/commands/zlexcount>).+-- 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 (<http://redis.io/commands/sunion>).+-- 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 (<http://redis.io/commands/sinterstore>).+-- 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 (<http://redis.io/commands/hvals>).+-- 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 (<http://redis.io/commands/config-set>).+-- 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 (<http://redis.io/commands/script-flush>).+-- 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 (<http://redis.io/commands/dbsize>).+-- 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 (<http://redis.io/commands/wait>).+-- 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 (<http://redis.io/commands/lpop>). 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 (<http://redis.io/commands/lpop>).+-- 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 (<http://redis.io/commands/client-pause>).+-- 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 (<http://redis.io/commands/expire>). 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 (<http://redis.io/commands/mget>).+-- 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 (<http://redis.io/commands/bitpos>).+-- 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 (<http://redis.io/commands/pexpire>).+-- 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 (<http://redis.io/commands/client-list>). 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 (<http://redis.io/commands/renamenx>). 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 (<http://redis.io/commands/pfmerge>). 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 (<http://redis.io/commands/lrem>). 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 (<http://redis.io/commands/sdiff>). 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 (<http://redis.io/commands/get>). 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 (<http://redis.io/commands/getrange>).+-- 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 (<http://redis.io/commands/sdiffstore>). 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 (<http://redis.io/commands/zcount>). 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 (<http://redis.io/commands/script-load>). 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 (<http://redis.io/commands/getset>). 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 (<http://redis.io/commands/dump>). 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 (<http://redis.io/commands/keys>). 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 (<http://redis.io/commands/config-get>). 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 (<http://redis.io/commands/rpush>). 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 (<http://redis.io/commands/randomkey>). 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 (<http://redis.io/commands/hsetnx>). 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 (<http://redis.io/commands/mset>). 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 (<http://redis.io/commands/setex>).+-- 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 (<http://redis.io/commands/psetex>).+-- 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 (<http://redis.io/commands/scard>). 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 (<http://redis.io/commands/script-exists>). 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 (<http://redis.io/commands/sunionstore>). 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 (<http://redis.io/commands/persist>). 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 (<http://redis.io/commands/strlen>). 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 (<http://redis.io/commands/lpushx>). 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 (<http://redis.io/commands/hset>).+--+-- 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 (<http://redis.io/commands/brpoplpush>).+--+-- 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 (<http://redis.io/commands/zrevrank>).+-- 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 (<http://redis.io/commands/script-kill>). 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 (<http://redis.io/commands/setrange>).+--+-- 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 (<http://redis.io/commands/del>).+-- 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 (<http://redis.io/commands/hincrbyfloat>).+-- 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 (<http://redis.io/commands/hincrby>). 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 (<http://redis.io/commands/zremrangebylex>).+--+-- 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 (<http://redis.io/commands/rpop>).+-- 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 (<http://redis.io/commands/rpop>).+-- 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 (<http://redis.io/commands/rename>). 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 (<http://redis.io/commands/zrem>).+--+-- 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 (<http://redis.io/commands/hexists>).+-- 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 (<http://redis.io/commands/client-id>). Since Redis 5.0.0+clientId+ :: (RedisCtx m f)+ => m (f Integer)+clientId = sendRequest ["CLIENT","ID"]++-- |Get the current connection name (<http://redis.io/commands/client-getname>). 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 (<http://redis.io/commands/config-rewrite>). 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 (<http://redis.io/commands/decr>).+-- 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 (<http://redis.io/commands/hmget>).+-- 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 (<http://redis.io/commands/lrange>). 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 (<http://redis.io/commands/decrby>).+-- 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 (<http://redis.io/commands/llen>). 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 (<http://redis.io/commands/append>). 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 (<http://redis.io/commands/incr>). 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 (<http://redis.io/commands/hget>). 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 (<http://redis.io/commands/pexpireat>). 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 (<http://redis.io/commands/ltrim>).+-- 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 (<http://redis.io/commands/zcard>).+-- 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 (<http://redis.io/commands/lset>).+-- 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 (<http://redis.io/commands/expireat>).+-- 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 (<http://redis.io/commands/save>).+-- Since Redis 1.0.0+save+ :: (RedisCtx m f)+ => m (f Status)+save = sendRequest ["SAVE"]++-- |+-- Move a key to another database (<http://redis.io/commands/move>).+-- 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 (<http://redis.io/commands/getbit>). 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 (<http://redis.io/commands/msetnx>).+-- 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 (<http://redis.io/commands/command-info>).+-- 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 (<http://redis.io/commands/quit>). 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 (<http://redis.io/commands/blpop>). 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 (<http://redis.io/commands/blpop>). 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 (<http://redis.io/commands/srem>).+--+-- 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 (<http://redis.io/commands/echo>). 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 (<http://redis.io/commands/sismember>).+-- 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 \<min-idle-time\>+-- milliseconds and ID should be greater than \<start\>.+--+-- 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 (<http://redis.io/commands/auth>). Since Redis 1.0.0+
src/Database/Redis/Connection.hs view
@@ -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
src/Database/Redis/ConnectionContext.hs view
@@ -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
src/Database/Redis/Core.hs view
@@ -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'
src/Database/Redis/Core/Internal.hs view
@@ -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
+ src/Database/Redis/Hooks.hs view
@@ -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 = _}"
src/Database/Redis/ManualCommands.hs view
@@ -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 (<http://redis.io/commands/object>). 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 (<http://redis.io/commands/object>). 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 (<http://redis.io/commands/linsert>). 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 (<http://redis.io/commands/linsert>). 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 (<http://redis.io/commands/type>). 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 (<http://redis.io/commands/zrange>). 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 (<http://redis.io/commands/zrange>). 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 (<http://redis.io/commands/sort>). 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 (<http://redis.io/commands/sort>). 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 (<http://redis.io/commands/zinterstore>). 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 (<http://redis.io/commands/zinterstore>). 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 (<http://redis.io/commands/eval>). 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 (<http://redis.io/commands/migrate>). 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 (<http://redis.io/commands/migrate>). 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 (<http://redis.io/commands/restore>). 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 (<http://redis.io/commands/restore>). 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 (<http://redis.io/commands/restore>). 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 (<http://redis.io/commands/script-debug>). 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 (<http://redis.io/commands/zadd>). 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 (<http://redis.io/commands/zadd>). 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 (<http://redis.io/commands/client-reply>). 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 (<http://redis.io/commands/srandmember>). 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 (<http://redis.io/commands/srandmember>). 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 (<http://redis.io/commands/spop>). 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 (<http://redis.io/commands/spop>). 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 (<http://redis.io/commands/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 (<http://redis.io/commands/scan>). 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 (<http://redis.io/commands/scan>). 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 (<http://redis.io/commands/sscan>). 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 (<http://redis.io/commands/sscan>). 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 (<http://redis.io/commands/hscan>). 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 (<http://redis.io/commands/hscan>). 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 (<http://redis.io/commands/zrangebylex>). 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 (<https://redis.io/commands/xadd>). 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 (<https://redis.io/commands/xadd>). 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 \<min-idle-time\>+-- milliseconds and ID should be greater than \<start\>.+--+-- @XAUTOCLAIM \<stream name\> \<consumer group name\> \<min idle time\> \<start\>@+--+-- 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 \<stream name\> \<consumer group name\> \<min idle time\> \<start\> COUNT \<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 \<stream name\> \<consumer group name\> \<min idle time\> \<start\> 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 \<stream name\> \<consumer group name\> \<min idle time\> \<start\> COUNT \<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 \<stream name\> \<group name\>@+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 \<stream name\>@ 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 (<http://redis.io/commands/select>). Since Redis 1.0.0+select+ :: RedisCtx m f+ => Integer -- ^ index+ -> m (f Status)+select ix = sendRequest ["SELECT", encode ix]++-- |Ping the server (<http://redis.io/commands/ping>). 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 (<http://redis.io/commands/pexpireat>).+-- 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 (<http://redis.io/commands/expireat>).+-- 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 (<http://redis.io/commands/flushdb>).+-- 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 (<http://redis.io/commands/flushdb>).+-- 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]
src/Database/Redis/ProtocolPipelining.hs view
@@ -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), ())
src/Database/Redis/PubSub.hs view
@@ -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 -- (<http://redis.io/commands/psubscribe>). 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 <http://redis.io/topics/pubsub>.@@ -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
+ src/Database/Redis/PubSub.hs-boot view
@@ -0,0 +1,8 @@+module Database.Redis.PubSub (+ Message,+ PubSub,+) where++data PubSub++data Message
src/Database/Redis/Sentinel.hs view
@@ -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
src/Database/Redis/Types.hs view
@@ -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
src/Database/Redis/URL.hs view
@@ -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)
test/ClusterMain.hs view
@@ -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
test/Main.hs view
@@ -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 ]
+ test/MainHooks.hs view
@@ -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"
+ test/MainRedis7.hs view
@@ -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]
test/PubSubTest.hs view
@@ -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"
test/Tests.hs view
@@ -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 <password> 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