hedis-0.15.2/0000755000000000000000000000000007346545000011064 5ustar0000000000000000hedis-0.15.2/CHANGELOG0000644000000000000000000001170107346545000012276 0ustar0000000000000000# Changelog for Hedis ## 0.15.2 * PR #189. Document that UnixSocket ignores connectHost * PR #190. mtl version update ## 0.15.1 * PR #181. Add MonadUnliftIO instance ## 0.15.0 * PR #174, Issue #173. Hedis fails to decode xstreamInfo response in case when the stream is empty ## 0.14.3 * PR #171. Support GHC 9 ## 0.14.2 * PR #163. support for redis 6.0 COMMAND format * PR #164. remove invalid tests for Redis Cluster ## 0.14.1 * PR #162. Improved documentation for EVALSHA ## 0.14.0 * PR #157. Clustering support ## 0.13.1 * PR #158. Upgrade to Redis 6.0.9 & Fix auth test * PR #160. Fix GHC 8.0.1 compat ## 0.13.0 * PR #159. Issue #152. Make HSET return integer instead of bool ## 0.12.15 * PR #154. Implement Redis Sentinel support ## 0.12.14 * PR #153. Publicly expose ConnectTimeout exception ## 0.12.13 * PR #150, Issue #143. Leaking sockets when connection fails ## 0.12.12 * PR #149. Make withConnect friendly to transformer stack ## 0.12.11 * Expose `withCheckedConnect`, `withConnect` ## 0.12.9 * Expose the `Database.Redis.Core.Internal` module (see https://github.com/informatikr/hedis/issues/144 ) ## 0.12.8 * PR #140. Added support of +/- inf redis argument ## 0.12.7 * PR #139. fix MonadFail instance ## 0.12.6 * PR #138, Issue #137. Derive MonadFail for the Redis monad ## 0.12.5 Issue #136 fix slowlog parsing ## 0.12.4 * Add upper bound on network package ## 0.12.3 * Issue #135. Upper the base bound ## 0.12.2 * PR #134. Fix some asynchronous exception safety problems ## 0.12.1 * PR #133. Fixes to stream commands ## 0.12.0 * PR #130. Bring back ability to connect via a Unix Socket ## 0.11.1 * PR #129. Fix tests ## 0.11.0 * PR #126. Fixes for network 2.8 and 3.0 ## 0.10.10 * Only disable warnings for GHC 8.6, fix build ## 0.10.9 * Remove deprecation warnings ## 0.10.8 * PR #121. make xgroupCreate return Status ## 0.10.7 * PR #121. Fix streaming on redis 5.0.2 * PR #121. Get rid of slave-thread ## 0.10.6 * PR #120. Add withConnect, withCheckedConnect ## 0.10.5 * PR #XXX Fix CI builds with updated Redis version ## 0.10.4 * PR #112. Implement streams commands ## 0.10.3 * PR #110. Add disconnect which destroys all (idle) resources in the pool ## 0.10.2 * PR #108. Add TLS support ## 0.10.1 * PR #104. Add a Semigroup instance (fix GHC 8.4) ## 0.10.0 * PR #102. Return list from srandmemberN * PR #103. Add spopN * PR #101. Add parseConnectInfo * PR #100, Issue #99. Throw error when AUTH or SELECT fails on connect ## 0.9.12 * PR #98. Added `connectTimeout` option ## 0.9.11 * PR #94. Refactor fix for issue #92 - (Connection to Unix sockets is broken) ## 0.9.10 * PR #93, Issue #92. Connection to Unix sockets is broken ## 0.9.9 * PR #90. set SO_KEEPALIVE option on underlying connection socket ## 0.9.8 * Fix syntax errors from redis when using scanOpts to specify match pattern or count options (see PR #88) ## 0.9.7 * Expose returnDecode method of RedisCtx (see issue #83) ## 0.9.6 * Export Condition constructors (see PR #86) ## 0.9.2 * Added multithreaded pub/sub message processing (see PR #77) ## 0.9.0 * Merge in a fresh commands.json and a set of new commands implemented. See PR #52 for more info ## 0.8.3 * Export MonadRedis methods ## 0.8.1 * Export unRedis/reRedis internalish functions which let you define MonadCatch instance easily (see PR #73) ## 0.8.0 * Major speed improvement by using non-backtracking parser (PR #69) ## 0.7.10 * Improved performance (PR #64) ## 0.7.7 * Close connection handle on error ## 0.7.2 * Improve speed, rewrite internal logic (PR #56) ## 0.7.1 * Add NFData instances ## 0.7.0 * Enforce all replies being recieved in runRedis. Pipelining between runRedis calls doesn't work now. ## 0.6.10 * Add HyperLogLog support ## 0.6.4 * New connection option to automatically SELECT a database. ## 0.5 -> 0.6 * Changed return type of HDEL from Bool to Integer. * Some documentation updates. ## 0.5 -> 0.5.1 * New commands: DUMP, RESTORE, BITOP, BITCOUNT. * Removed the dependency on stm. * Improved performance of Queued in long transactions. * Minor documentation updates. ## 0.4.1 -> 0.5 * Added new Redis 2.6 commands, including Lua scripting support. * A transaction context is now created by using the 'multiExec' function. The functions 'multi', 'exec' and 'discard' are no longer available individually. * Inside of a transaction, commands return their results wrapped in a composable /future/, called 'Queued'. * The 'getType' command (the Redis TYPE command) now has a custom return type 'RedisType'. * Minor improvements and fixes to the documentation. ## 0.3.2 -> 0.4.1 * The following commands got a 'Maybe' added to their return type, to properly handle Redis returning `nil`-replies: `brpoplpush`, `lindex`, `lpop`, `objectEncoding`, `randomkey`, `rpop`, `rpoplpush`, `spop`, `srandmember`, `zrank`, `zrevrank`, `zscore`. * Updated dependencies on `bytestring-lexing` and `stm`. * Minor improvements and fixes to the documentation. hedis-0.15.2/DocTest.hs0000644000000000000000000000013507346545000012764 0ustar0000000000000000module Main (main) where import Test.DocTest main :: IO () main = doctest ["-isrc", "src"] hedis-0.15.2/LICENSE0000644000000000000000000000276107346545000012077 0ustar0000000000000000Copyright (c)2011, Falko Peters All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Falko Peters nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hedis-0.15.2/Setup.hs0000644000000000000000000000005607346545000012521 0ustar0000000000000000import Distribution.Simple main = defaultMain hedis-0.15.2/benchmark/0000755000000000000000000000000007346545000013016 5ustar0000000000000000hedis-0.15.2/benchmark/Benchmark.hs0000644000000000000000000000652007346545000015247 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, LambdaCase #-} module Main where import Control.Concurrent import Control.Monad import Control.Monad.Trans import Data.Time import Database.Redis import Text.Printf nRequests, nClients :: Int nRequests = 100000 nClients = 50 main :: IO () main = do ---------------------------------------------------------------------- -- Preparation -- conn <- connect defaultConnectInfo runRedis conn $ do _ <- flushall mset [ ("k1","v1"), ("k2","v2"), ("k3","v3") , ("k4","v4"), ("k5","v5") ] >>= \case Left _ -> error "error" _ -> return () return () ---------------------------------------------------------------------- -- Spawn clients -- start <- newEmptyMVar done <- newEmptyMVar replicateM_ nClients $ forkIO $ do runRedis conn $ forever $ do action <- liftIO $ takeMVar start action liftIO $ putMVar done () let timeAction name nActions action = do startT <- getCurrentTime -- each clients runs ACTION nRepetitions times let nRepetitions = nRequests `div` nClients `div` nActions replicateM_ nClients $ putMVar start (replicateM_ nRepetitions action) replicateM_ nClients $ takeMVar done stopT <- getCurrentTime let deltaT = realToFrac $ diffUTCTime stopT startT -- the real # of reqs send. We might have lost some due to 'div'. actualReqs = nRepetitions * nActions * nClients rqsPerSec = fromIntegral actualReqs / deltaT :: Double putStrLn $ printf "%-20s %10.2f Req/s" (name :: String) rqsPerSec ---------------------------------------------------------------------- -- Benchmarks -- timeAction "ping" 1 $ do ping >>= \case Right Pong -> return () _ -> error "error" return () timeAction "get" 1 $ do get "key" >>= \case Right Nothing -> return () _ -> error "error" return () timeAction "mget" 1 $ do mget ["k1","k2","k3","k4","k5"] >>= \case Right vs -> do let expected = map Just ["v1","v2","v3","v4","v5"] case vs == expected of True -> return () _ -> error "error" return () _ -> error "error" timeAction "ping (pipelined)" 100 $ do pongs <- replicateM 100 ping let expected = replicate 100 (Right Pong) case pongs == expected of True -> return () _ -> error "error" return () timeAction "multiExec get 1" 1 $ do multiExec (get "foo") >>= \case TxSuccess _ -> return () _ -> error "error" return () timeAction "multiExec get 50" 50 $ do res <- multiExec $ do rs <- replicateM 50 (get "foo") return $ fmap length (sequence rs) case res of TxSuccess 50 -> return () _ -> error "error" return () timeAction "multiExec get 1000" 1000 $ do res <- multiExec $ do rs <- replicateM 1000 (get "foo") return $ fmap length (sequence rs) case res of TxSuccess 1000 -> return () _ -> error "error" return () hedis-0.15.2/hedis.cabal0000644000000000000000000001425007346545000013146 0ustar0000000000000000name: hedis version: 0.15.2 synopsis: Client library for the Redis datastore: supports full command set, pipelining. Description: Redis is an open source, advanced key-value store. It is often referred to as a data structure server since keys can contain strings, hashes, lists, sets and sorted sets. This library is a Haskell client for the Redis datastore. Compared to other Haskell client libraries it has some advantages: . [Compatibility with Latest Stable Redis:] Hedis is intended to be used with the latest stable version of Redis (currently 5.0). Most redis commands () are available as haskell functions, although MONITOR and SYNC are intentionally omitted. Additionally, a low-level API is exposed that makes it easy for the library user to implement further commands, such as new commands from an experimental Redis version. . [Automatic Optimal Pipelining:] Commands are pipelined () as much as possible without any work by the user. See for a technical explanation of automatic optimal pipelining. . [Enforced Pub\/Sub semantics:] When subscribed to the Redis Pub\/Sub server (), clients are not allowed to issue commands other than subscribing to or unsubscribing from channels. This library uses the type system to enforce the correct behavior. . [Connect via TCP or Unix Domain Socket:] TCP sockets are the default way to connect to a Redis server. For connections to a server on the same machine, Unix domain sockets offer higher performance than the standard TCP connection. . For detailed documentation, see the "Database.Redis" module. . license: BSD3 license-file: LICENSE author: Falko Peters maintainer: Kostiantyn Rybnikov 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 source-repository head type: git location: https://github.com/informatikr/hedis flag dev description: enable this for local development -Werror and profiling options 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 if flag(dev) ghc-options: -Werror if flag(dev) ghc-prof-options: -auto-all exposed-modules: Database.Redis , Database.Redis.Sentinel , Database.Redis.Core.Internal build-depends: scanner >= 0.2, async >= 2.1, 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 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 default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: benchmark/Benchmark.hs build-depends: base == 4.*, mtl >= 2.0, hedis, time >= 1.2 ghc-options: -O2 -Wall -rtsopts if flag(dev) ghc-options: -Werror if flag(dev) ghc-prof-options: -auto-all test-suite hedis-test default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs other-modules: PubSubTest Tests build-depends: base == 4.*, bytestring >= 0.10, hedis, HUnit, async, stm, text, mtl == 2.*, test-framework, test-framework-hunit, time -- We use -O0 here, since GHC takes *very* long to compile so many constants ghc-options: -O0 -Wall -rtsopts -fno-warn-unused-do-bind if flag(dev) ghc-options: -Werror if flag(dev) ghc-prof-options: -auto-all test-suite hedis-test-cluster default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test main-is: ClusterMain.hs other-modules: PubSubTest Tests build-depends: base == 4.*, bytestring >= 0.10, hedis, HUnit, async, stm, text, mtl == 2.*, test-framework, test-framework-hunit, time -- We use -O0 here, since GHC takes *very* long to compile so many constants ghc-options: -O0 -Wall -rtsopts -fno-warn-unused-do-bind if flag(dev) ghc-options: -Werror if flag(dev) ghc-prof-options: -auto-all test-suite doctest default-language: Haskell2010 type: exitcode-stdio-1.0 main-is: DocTest.hs ghc-options: -O0 -rtsopts build-depends: base == 4.*, doctest hedis-0.15.2/src/Database/0000755000000000000000000000000007346545000013357 5ustar0000000000000000hedis-0.15.2/src/Database/Redis.hs0000644000000000000000000002035207346545000014763 0ustar0000000000000000module Database.Redis ( -- * How To Use This Module -- | -- Connect to a Redis server: -- -- @ -- -- connects to localhost:6379 -- conn <- 'checkedConnect' 'defaultConnectInfo' -- @ -- -- Connect to a Redis server using TLS: -- -- @ -- -- connects to foobar.redis.cache.windows.net:6380 -- import Network.TLS -- import Network.TLS.Extra.Cipher -- import Data.X509.CertificateStore -- 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!" } -- conn <- checkedConnect redisConnInfo -- @ -- -- Send commands to the server: -- -- @ -- {-\# LANGUAGE OverloadedStrings \#-} -- ... -- 'runRedis' conn $ do -- 'set' \"hello\" \"hello\" -- set \"world\" \"world\" -- hello <- 'get' \"hello\" -- world <- get \"world\" -- liftIO $ print (hello,world) -- @ -- -- disconnect all idle resources in the connection pool: -- -- @ -- 'disconnect' 'conn' -- @ -- ** Command Type Signatures -- |Redis commands behave differently when issued in- or outside of a -- transaction. To make them work in both contexts, most command functions -- have a type signature similar to the following: -- -- @ -- 'echo' :: ('RedisCtx' m f) => ByteString -> m (f ByteString) -- @ -- -- Here is how to interpret this type signature: -- -- * The argument types are independent of the execution context. 'echo' -- always takes a 'ByteString' parameter, whether in- or outside of a -- transaction. This is true for all command functions. -- -- * All Redis commands return their result wrapped in some \"container\". -- The type @f@ of this container depends on the commands execution -- context @m@. The 'ByteString' return type in the example is specific -- to the 'echo' command. For other commands, it will often be another -- type. -- -- * In the \"normal\" context 'Redis', outside of any transactions, -- results are wrapped in an @'Either' 'Reply'@. -- -- * Inside a transaction, in the 'RedisTx' context, results are wrapped in -- a 'Queued'. -- -- In short, you can view any command with a 'RedisCtx' constraint in the -- type signature, to \"have two types\". For example 'echo' \"has both -- types\": -- -- @ -- echo :: ByteString -> Redis (Either Reply ByteString) -- echo :: ByteString -> RedisTx (Queued ByteString) -- @ -- -- [Exercise] What are the types of 'expire' inside a transaction and -- 'lindex' outside of a transaction? The solutions are at the very -- bottom of this page. -- ** Lua Scripting -- |Lua values returned from the 'eval' and 'evalsha' functions will be -- converted to Haskell values by the 'decode' function from the -- 'RedisResult' type class. -- -- @ -- Lua Type | Haskell Type | Conversion Example -- --------------|--------------------|----------------------------- -- Number | Integer | 1.23 => 1 -- String | ByteString, Double | \"1.23\" => \"1.23\" or 1.23 -- Boolean | Bool | false => False -- Table | List | {1,2} => [1,2] -- @ -- -- Additionally, any of the Haskell types from the table above can be -- wrapped in a 'Maybe': -- -- @ -- 42 => Just 42 :: Maybe Integer -- nil => Nothing :: Maybe Integer -- @ -- -- Note that Redis imposes some limitations on the possible conversions: -- -- * Lua numbers can only be converted to Integers. Only Lua strings can be -- interpreted as Doubles. -- -- * Associative Lua tables can not be converted at all. Returned tables -- must be \"arrays\", i.e. indexed only by integers. -- -- The Redis Scripting website () -- documents the exact semantics of the scripting commands and value -- conversion. -- ** Automatic Pipelining -- |Commands are automatically pipelined as much as possible. For example, -- in the above \"hello world\" example, all four commands are pipelined. -- Automatic pipelining makes use of Haskell's laziness. As long as a -- previous reply is not evaluated, subsequent commands can be pipelined. -- -- Automatic pipelining is limited to the scope of 'runRedis' call and -- it is guaranteed that every reply expected as a part of 'runRedis' -- execution gets received after 'runRedis` invocation. -- -- To keep memory usage low, the number of requests \"in the pipeline\" is -- limited (per connection) to 1000. After that number, the next command is -- sent only when at least one reply has been received. That means, command -- functions may block until there are less than 1000 outstanding replies. -- -- ** Error Behavior -- | -- [Operations against keys holding the wrong kind of value:] Outside of a -- transaction, if the Redis server returns an 'Error', command functions -- will return 'Left' the 'Reply'. The library user can inspect the error -- message to gain information on what kind of error occured. -- -- [Connection to the server lost:] In case of a lost connection, command -- functions throw a 'ConnectionLostException'. It can only be caught -- outside of 'runRedis'. -- -- [Trying to connect to an unreachable server:] When trying to connect to -- a server that does not exist or can't be reached, the connection pool -- only starts the first connection when actually executing a call to -- the server. This can lead to discovering very late that the server is -- not available, for example when running a server that logs to Redis. -- To prevent this, run a 'ping' command directly after connecting or -- use the 'checkedConnect' function which encapsulates this behavior. -- -- [Exceptions:] Any exceptions can only be caught /outside/ of 'runRedis'. -- This way the connection pool can properly close the connection, making -- sure it is not left in an unusable state, e.g. closed or inside a -- transaction. -- -- * The Redis Monad Redis(), runRedis, unRedis, reRedis, RedisCtx(..), MonadRedis(..), -- * Connection Connection, ConnectError(..), connect, checkedConnect, disconnect, withConnect, withCheckedConnect, ConnectInfo(..), defaultConnectInfo, parseConnectInfo, connectCluster, PortID(..), -- * Commands module Database.Redis.Commands, -- * Transactions module Database.Redis.Transactions, -- * Pub\/Sub module Database.Redis.PubSub, -- * Low-Level Command API sendRequest, Reply(..), Status(..), RedisResult(..), ConnectionLostException(..), ConnectTimeout(..), -- |[Solution to Exercise] -- -- Type of 'expire' inside a transaction: -- -- > expire :: ByteString -> Integer -> RedisTx (Queued Bool) -- -- Type of 'lindex' outside of a transaction: -- -- > lindex :: ByteString -> Integer -> Redis (Either Reply ByteString) -- HashSlot, keyToSlot ) where import Database.Redis.Core import Database.Redis.Connection ( runRedis , connectCluster , defaultConnectInfo , ConnectInfo(..) , disconnect , checkedConnect , connect , ConnectError(..) , Connection(..) , withConnect , withCheckedConnect) import Database.Redis.ConnectionContext(PortID(..), ConnectionLostException(..), ConnectTimeout(..)) import Database.Redis.PubSub import Database.Redis.Protocol import Database.Redis.Transactions import Database.Redis.Types import Database.Redis.URL import Database.Redis.Commands import Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot) hedis-0.15.2/src/Database/Redis/0000755000000000000000000000000007346545000014425 5ustar0000000000000000hedis-0.15.2/src/Database/Redis/Cluster.hs0000644000000000000000000004671207346545000016414 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module Database.Redis.Cluster ( Connection(..) , NodeRole(..) , NodeConnection(..) , Node(..) , ShardMap(..) , HashSlot , Shard(..) , connect , disconnect , requestPipelined , nodes ) 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.Map(fromListWith, assocs) import Data.Function(on) import Control.Exception(Exception, throwIO, BlockedIndefinitelyOnMVar(..), catches, Handler(..)) import Control.Concurrent.MVar(MVar, newMVar, readMVar, modifyMVar, modifyMVar_) import Control.Monad(zipWithM, when, replicateM) 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 qualified Database.Redis.Cluster.Command as CMD -- This module implements a clustered connection whilst maintaining -- compatibility with the original Hedis codebase. In particular it still -- performs implicit pipelining using `unsafeInterleaveIO` as the single node -- codebase does. To achieve this each connection carries around with it a -- pipeline of commands. Every time `sendRequest` is called the command is -- added to the pipeline and an IO action is returned which will, upon being -- evaluated, execute the entire pipeline. If the pipeline is already executed -- then it just looks up it's response in the executed pipeline. -- | A connection to a redis cluster, it is compoesed of a map from Node IDs to -- | 'NodeConnection's, a 'Pipeline', and a 'ShardMap' data Connection = Connection (HM.HashMap NodeID NodeConnection) (MVar Pipeline) (MVar ShardMap) CMD.InfoMap -- | A connection to a single node in the cluster, similar to 'ProtocolPipelining.Connection' data NodeConnection = NodeConnection CC.ConnectionContext (IOR.IORef (Maybe B.ByteString)) NodeID instance Eq NodeConnection where (NodeConnection _ _ id1) == (NodeConnection _ _ id2) = id1 == id2 instance Ord NodeConnection where compare (NodeConnection _ _ id1) (NodeConnection _ _ id2) = compare id1 id2 data PipelineState = -- Nothing in the pipeline has been evaluated yet so nothing has been -- sent Pending [[B.ByteString]] -- This pipeline has been executed, the replies are contained within it | Executed [Reply] -- We're in a MULTI-EXEC transaction. All commands in the transaction -- should go to the same node, but we won't know what node that is until -- we see a command with a key. We're storing these transactions and will -- send them all together when we see an EXEC. | TransactionPending [[B.ByteString]] -- A pipeline has an MVar for the current state, this state is actually always -- `Pending` because the first thing the implementation does when executing a -- pipeline is to take the current pipeline state out of the MVar and replace -- it with a new `Pending` state. The executed state is held on to by the -- replies within it. newtype Pipeline = Pipeline (MVar PipelineState) data NodeRole = Master | Slave deriving (Show, Eq, Ord) type Host = String type Port = Int type NodeID = B.ByteString data Node = Node NodeID NodeRole Host Port deriving (Show, Eq, Ord) type MasterNode = Node type SlaveNode = Node data Shard = Shard MasterNode [SlaveNode] deriving (Show, Eq, Ord) newtype ShardMap = ShardMap (IntMap.IntMap Shard) deriving (Show) newtype MissingNodeException = MissingNodeException [B.ByteString] deriving (Show, Typeable) instance Exception MissingNodeException newtype UnsupportedClusterCommandException = UnsupportedClusterCommandException [B.ByteString] deriving (Show, Typeable) instance Exception UnsupportedClusterCommandException newtype CrossSlotException = CrossSlotException [[B.ByteString]] deriving (Show, Typeable) instance Exception CrossSlotException connect :: [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> IO Connection connect commandInfos shardMapVar timeoutOpt = do shardMap <- readMVar shardMapVar stateVar <- newMVar $ Pending [] pipelineVar <- newMVar $ Pipeline stateVar nodeConns <- nodeConnections shardMap return $ Connection nodeConns pipelineVar shardMapVar (CMD.newInfoMap commandInfos) where nodeConnections :: ShardMap -> IO (HM.HashMap NodeID NodeConnection) nodeConnections shardMap = HM.fromList <$> mapM connectNode (nub $ nodes shardMap) connectNode :: Node -> IO (NodeID, NodeConnection) connectNode (Node n _ host port) = do ctx <- CC.connect host (CC.PortNumber $ toEnum port) timeoutOpt ref <- IOR.newIORef Nothing return (n, NodeConnection ctx ref n) disconnect :: Connection -> IO () disconnect (Connection nodeConnMap _ _ _) = mapM_ disconnectNode (HM.elems nodeConnMap) where disconnectNode (NodeConnection nodeCtx _ _) = CC.disconnect nodeCtx -- Add a request to the current pipeline for this connection. The pipeline will -- be executed implicitly as soon as any result returned from this function is -- evaluated. requestPipelined :: IO ShardMap -> Connection -> [B.ByteString] -> IO Reply requestPipelined refreshAction conn@(Connection _ pipelineVar shardMapVar _) nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do (newStateVar, repliesIndex) <- hasLocked $ modifyMVar stateVar $ \case Pending requests | isMulti nextRequest -> do replies <- evaluatePipeline shardMapVar refreshAction conn requests s' <- newMVar $ TransactionPending [nextRequest] return (Executed replies, (s', 0)) Pending requests | length requests > 1000 -> do replies <- evaluatePipeline shardMapVar refreshAction conn (nextRequest:requests) return (Executed replies, (stateVar, length requests)) Pending requests -> return (Pending (nextRequest:requests), (stateVar, length requests)) TransactionPending requests -> if isExec nextRequest then do replies <- evaluateTransactionPipeline shardMapVar refreshAction conn (nextRequest:requests) return (Executed replies, (stateVar, length requests)) else return (TransactionPending (nextRequest:requests), (stateVar, length requests)) e@(Executed _) -> do s' <- newMVar $ if isMulti nextRequest then TransactionPending [nextRequest] else Pending [nextRequest] return (e, (s', 0)) evaluateAction <- unsafeInterleaveIO $ do replies <- hasLocked $ modifyMVar newStateVar $ \case Executed replies -> return (Executed replies, replies) Pending requests-> do replies <- evaluatePipeline shardMapVar refreshAction conn requests return (Executed replies, replies) TransactionPending requests-> do replies <- evaluateTransactionPipeline shardMapVar refreshAction conn requests return (Executed replies, replies) return $ replies !! repliesIndex return (Pipeline newStateVar, evaluateAction) isMulti :: [B.ByteString] -> Bool isMulti ("MULTI" : _) = True isMulti _ = False isExec :: [B.ByteString] -> Bool isExec ("EXEC" : _) = True isExec _ = False data PendingRequest = PendingRequest Int [B.ByteString] data CompletedRequest = CompletedRequest Int [B.ByteString] Reply rawRequest :: PendingRequest -> [B.ByteString] rawRequest (PendingRequest _ r) = r responseIndex :: CompletedRequest -> Int responseIndex (CompletedRequest i _ _) = i rawResponse :: CompletedRequest -> Reply rawResponse (CompletedRequest _ _ r) = r -- The approach we take here is similar to that taken by the redis-py-cluster -- library, which is described at https://redis-py-cluster.readthedocs.io/en/master/pipelines.html -- -- Essentially we group all the commands by node (based on the current shardmap) -- and then execute a pipeline for each node (maintaining the order of commands -- on a per node basis but not between nodes). Once we've done this, if any of -- the commands have resulted in a MOVED error we refresh the shard map, then -- we run through all the responses and retry any MOVED or ASK errors. This retry -- step is not pipelined, there is a request per error. This is probably -- acceptable in most cases as these errors should only occur in the case of -- cluster reconfiguration events, which should be rare. evaluatePipeline :: MVar ShardMap -> IO ShardMap -> Connection -> [[B.ByteString]] -> IO [Reply] evaluatePipeline shardMapVar refreshShardmapAction conn requests = do shardMap <- hasLocked $ readMVar shardMapVar requestsByNode <- getRequestsByNode shardMap resps <- concat <$> mapM (uncurry executeRequests) requestsByNode when (any (moved . rawResponse) resps) refreshShardMapVar retriedResps <- mapM (retry 0) resps return $ map rawResponse $ sortBy (on compare responseIndex) retriedResps where getRequestsByNode :: ShardMap -> IO [(NodeConnection, [PendingRequest])] getRequestsByNode shardMap = do commandsWithNodes <- zipWithM (requestWithNodes shardMap) (reverse [0..(length requests - 1)]) requests return $ assocs $ fromListWith (++) (mconcat commandsWithNodes) requestWithNodes :: ShardMap -> Int -> [B.ByteString] -> IO [(NodeConnection, [PendingRequest])] requestWithNodes shardMap index request = do nodeConns <- nodeConnectionForCommand conn shardMap request return $ (, [PendingRequest index request]) <$> nodeConns executeRequests :: NodeConnection -> [PendingRequest] -> IO [CompletedRequest] executeRequests nodeConn nodeRequests = do replies <- requestNode nodeConn $ map rawRequest nodeRequests return $ zipWith (curry (\(PendingRequest i r, rep) -> CompletedRequest i r rep)) nodeRequests replies retry :: Int -> CompletedRequest -> IO CompletedRequest retry retryCount (CompletedRequest index request thisReply) = do retryReply <- head <$> retryBatch shardMapVar refreshShardmapAction conn retryCount [request] [thisReply] return (CompletedRequest index request retryReply) refreshShardMapVar :: IO () refreshShardMapVar = hasLocked $ modifyMVar_ shardMapVar (const refreshShardmapAction) -- Retry a batch of requests if any of the responses is a redirect instruction. -- If multiple requests are passed in they're assumed to be a MULTI..EXEC -- transaction and will all be retried. retryBatch :: MVar ShardMap -> IO ShardMap -> Connection -> Int -> [[B.ByteString]] -> [Reply] -> IO [Reply] retryBatch shardMapVar refreshShardmapAction conn retryCount requests replies = -- The last reply will be the `EXEC` reply containing the redirection, if -- there is one. case last replies of (Error errString) | B.isPrefixOf "MOVED" errString -> do let (Connection _ _ _ infoMap) = conn keys <- mconcat <$> mapM (requestKeys infoMap) requests hashSlot <- hashSlotForKeys (CrossSlotException requests) keys nodeConn <- nodeConnForHashSlot shardMapVar conn (MissingNodeException (head requests)) hashSlot requestNode nodeConn requests (askingRedirection -> Just (host, port)) -> do shardMap <- hasLocked $ readMVar shardMapVar let maybeAskNode = nodeConnWithHostAndPort shardMap conn host port case maybeAskNode of Just askNode -> tail <$> requestNode askNode (["ASKING"] : requests) Nothing -> case retryCount of 0 -> do _ <- hasLocked $ modifyMVar_ shardMapVar (const refreshShardmapAction) retryBatch shardMapVar refreshShardmapAction conn (retryCount + 1) requests replies _ -> throwIO $ MissingNodeException (head requests) _ -> return replies -- Like `evaluateOnPipeline`, except we expect to be able to run all commands -- on a single shard. Failing to meet this expectation is an error. evaluateTransactionPipeline :: MVar ShardMap -> IO ShardMap -> Connection -> [[B.ByteString]] -> IO [Reply] evaluateTransactionPipeline shardMapVar refreshShardmapAction conn requests' = do let requests = reverse requests' let (Connection _ _ _ infoMap) = conn keys <- mconcat <$> mapM (requestKeys infoMap) requests -- In cluster mode Redis expects commands in transactions to all work on the -- same hashslot. We find that hashslot here. -- We could be more permissive and allow transactions that touch multiple -- hashslots, as long as those hashslots are on the same node. This allows -- a new failure case though: if some of the transactions hashslots are -- moved to a different node we could end up in a situation where some of -- the commands in a transaction are applied and some are not. Better to -- fail early. hashSlot <- hashSlotForKeys (CrossSlotException requests) keys nodeConn <- nodeConnForHashSlot shardMapVar conn (MissingNodeException (head requests)) hashSlot resps <- requestNode nodeConn requests -- The Redis documentation has the following to say on the effect of -- resharding on multi-key operations: -- -- Multi-key operations may become unavailable when a resharding of the -- hash slot the keys belong to is in progress. -- -- More specifically, even during a resharding the multi-key operations -- targeting keys that all exist and all still hash to the same slot -- (either the source or destination node) are still available. -- -- Operations on keys that don't exist or are - during the resharding - -- split between the source and destination nodes, will generate a -- -TRYAGAIN error. The client can try the operation after some time, -- or report back the error. -- -- https://redis.io/topics/cluster-spec#multiple-keys-operations -- -- An important take-away here is that MULTI..EXEC transactions can fail -- with a redirect in which case we need to repeat the full transaction on -- the node we're redirected too. -- -- A second important takeway is that MULTI..EXEC transactions might -- temporarily fail during resharding with a -TRYAGAIN error. We can only -- make arbitrary decisions about how long to paus before the retry and how -- often to retry, so instead we'll propagate the error to the library user -- and let them decide how they would like to handle the error. when (any moved resps) (hasLocked $ modifyMVar_ shardMapVar (const refreshShardmapAction)) retriedResps <- retryBatch shardMapVar refreshShardmapAction conn 0 requests resps return retriedResps nodeConnForHashSlot :: Exception e => MVar ShardMap -> Connection -> e -> HashSlot -> IO NodeConnection nodeConnForHashSlot shardMapVar conn exception hashSlot = do let (Connection nodeConns _ _ _) = conn (ShardMap shardMap) <- hasLocked $ readMVar shardMapVar node <- case IntMap.lookup (fromEnum hashSlot) shardMap of Nothing -> throwIO exception Just (Shard master _) -> return master case HM.lookup (nodeId node) nodeConns of Nothing -> throwIO exception Just nodeConn' -> return nodeConn' hashSlotForKeys :: Exception e => e -> [B.ByteString] -> IO HashSlot hashSlotForKeys exception keys = case nub (keyToSlot <$> keys) of -- If none of the commands contain a key we can send them to any -- node. Let's pick the first one. [] -> return 0 [hashSlot] -> return hashSlot _ -> throwIO $ exception requestKeys :: CMD.InfoMap -> [B.ByteString] -> IO [B.ByteString] requestKeys infoMap request = case CMD.keysForRequest infoMap request of Nothing -> throwIO $ UnsupportedClusterCommandException request Just k -> return k askingRedirection :: Reply -> Maybe (Host, Port) askingRedirection (Error errString) = case Char8.words errString of ["ASK", _, hostport] -> case Char8.split ':' hostport of [host, portString] -> case Char8.readInt portString of Just (port,"") -> Just (Char8.unpack host, port) _ -> Nothing _ -> Nothing _ -> Nothing askingRedirection _ = Nothing moved :: Reply -> Bool moved (Error errString) = case Char8.words errString of "MOVED":_ -> True _ -> False moved _ = False nodeConnWithHostAndPort :: ShardMap -> Connection -> Host -> Port -> Maybe NodeConnection nodeConnWithHostAndPort shardMap (Connection nodeConns _ _ _) host port = do node <- nodeWithHostAndPort shardMap host port HM.lookup (nodeId node) nodeConns nodeConnectionForCommand :: Connection -> ShardMap -> [B.ByteString] -> IO [NodeConnection] nodeConnectionForCommand conn@(Connection nodeConns _ _ infoMap) (ShardMap shardMap) request = case request of ("FLUSHALL" : _) -> allNodes ("FLUSHDB" : _) -> allNodes ("QUIT" : _) -> allNodes ("UNWATCH" : _) -> allNodes _ -> do keys <- requestKeys infoMap request hashSlot <- hashSlotForKeys (CrossSlotException [request]) keys node <- case IntMap.lookup (fromEnum hashSlot) shardMap of Nothing -> throwIO $ MissingNodeException request Just (Shard master _) -> return master maybe (throwIO $ MissingNodeException request) (return . return) (HM.lookup (nodeId node) nodeConns) where allNodes = case allMasterNodes conn (ShardMap shardMap) of Nothing -> throwIO $ MissingNodeException request Just allNodes' -> return allNodes' allMasterNodes :: Connection -> ShardMap -> Maybe [NodeConnection] allMasterNodes (Connection nodeConns _ _ _) (ShardMap shardMap) = mapM (flip HM.lookup nodeConns . nodeId) masterNodes where masterNodes = (\(Shard master _) -> master) <$> nub (IntMap.elems shardMap) requestNode :: NodeConnection -> [[B.ByteString]] -> IO [Reply] requestNode (NodeConnection ctx lastRecvRef _) requests = do mapM_ (sendNode . renderRequest) requests _ <- CC.flush ctx replicateM (length requests) recvNode where sendNode :: B.ByteString -> IO () sendNode = CC.send ctx recvNode :: IO Reply recvNode = do maybeLastRecv <- IOR.readIORef lastRecvRef scanResult <- case maybeLastRecv of Just lastRecv -> Scanner.scanWith (CC.recv ctx) reply lastRecv Nothing -> Scanner.scanWith (CC.recv ctx) reply B.empty case scanResult of Scanner.Fail{} -> CC.errConnClosed Scanner.More{} -> error "Hedis: parseWith returned Partial" Scanner.Done rest' r -> do IOR.writeIORef lastRecvRef (Just rest') return r nodes :: ShardMap -> [Node] nodes (ShardMap shardMap) = concatMap snd $ IntMap.toList $ fmap shardNodes shardMap where shardNodes :: Shard -> [Node] shardNodes (Shard master slaves) = master:slaves nodeWithHostAndPort :: ShardMap -> Host -> Port -> Maybe Node nodeWithHostAndPort shardMap host port = find (\(Node _ _ nodeHost nodePort) -> port == nodePort && host == nodeHost) (nodes shardMap) nodeId :: Node -> NodeID nodeId (Node theId _ _ _) = theId hasLocked :: IO a -> IO a hasLocked action = action `catches` [ Handler $ \exc@BlockedIndefinitelyOnMVar -> throwIO exc ] hedis-0.15.2/src/Database/Redis/Cluster/0000755000000000000000000000000007346545000016046 5ustar0000000000000000hedis-0.15.2/src/Database/Redis/Cluster/Command.hs0000644000000000000000000001414507346545000017765 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, RecordWildCards #-} module Database.Redis.Cluster.Command where import Data.Char(toLower) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as Char8 import qualified Data.HashMap.Strict as HM import Database.Redis.Types(RedisResult(decode)) import Database.Redis.Protocol(Reply(..)) data Flag = Write | ReadOnly | DenyOOM | Admin | PubSub | NoScript | Random | SortForScript | Loading | Stale | SkipMonitor | Asking | Fast | MovableKeys | Other BS.ByteString deriving (Show, Eq) data AritySpec = Required Integer | MinimumRequired Integer deriving (Show) data LastKeyPositionSpec = LastKeyPosition Integer | UnlimitedKeys Integer deriving (Show) newtype InfoMap = InfoMap (HM.HashMap String CommandInfo) -- Represents the result of the COMMAND command, which returns information -- about the position of keys in a request data CommandInfo = CommandInfo { name :: BS.ByteString , arity :: AritySpec , flags :: [Flag] , firstKeyPosition :: Integer , lastKeyPosition :: LastKeyPositionSpec , stepCount :: Integer } deriving (Show) instance RedisResult CommandInfo where decode (MultiBulk (Just [ Bulk (Just commandName) , Integer aritySpec , MultiBulk (Just replyFlags) , Integer firstKeyPos , Integer lastKeyPos , Integer replyStepCount])) = do parsedFlags <- mapM parseFlag replyFlags lastKey <- parseLastKeyPos return $ CommandInfo { name = commandName , arity = parseArity aritySpec , flags = parsedFlags , firstKeyPosition = firstKeyPos , lastKeyPosition = lastKey , stepCount = replyStepCount } where parseArity int = case int of i | i >= 0 -> Required i i -> MinimumRequired $ abs i parseFlag :: Reply -> Either Reply Flag parseFlag (SingleLine flag) = return $ case flag of "write" -> Write "readonly" -> ReadOnly "denyoom" -> DenyOOM "admin" -> Admin "pubsub" -> PubSub "noscript" -> NoScript "random" -> Random "sort_for_script" -> SortForScript "loading" -> Loading "stale" -> Stale "skip_monitor" -> SkipMonitor "asking" -> Asking "fast" -> Fast "movablekeys" -> MovableKeys other -> Other other parseFlag bad = Left bad parseLastKeyPos :: Either Reply LastKeyPositionSpec parseLastKeyPos = return $ case lastKeyPos of i | i < 0 -> UnlimitedKeys (-i - 1) i -> LastKeyPosition i -- since redis 6.0 decode (MultiBulk (Just [ name@(Bulk (Just _)) , arity@(Integer _) , flags@(MultiBulk (Just _)) , firstPos@(Integer _) , lastPos@(Integer _) , step@(Integer _) , MultiBulk _ -- ACL categories ])) = decode (MultiBulk (Just [name, arity, flags, firstPos, lastPos, step])) decode e = Left e newInfoMap :: [CommandInfo] -> InfoMap newInfoMap = InfoMap . HM.fromList . map (\c -> (Char8.unpack $ name c, c)) keysForRequest :: InfoMap -> [BS.ByteString] -> Maybe [BS.ByteString] keysForRequest _ ["DEBUG", "OBJECT", key] = -- `COMMAND` output for `DEBUG` would let us believe it doesn't have any -- keys, but the `DEBUG OBJECT` subcommand does. Just [key] keysForRequest _ ["QUIT"] = -- The `QUIT` command is not listed in the `COMMAND` output. Just [] keysForRequest (InfoMap infoMap) request@(command:_) = do info <- HM.lookup (map toLower $ Char8.unpack command) infoMap keysForRequest' info request keysForRequest _ [] = Nothing keysForRequest' :: CommandInfo -> [BS.ByteString] -> Maybe [BS.ByteString] keysForRequest' info request | isMovable info = parseMovable request | stepCount info == 0 = Just [] | otherwise = do let possibleKeys = case lastKeyPosition info of LastKeyPosition end -> take (fromEnum $ 1 + end - firstKeyPosition info) $ drop (fromEnum $ firstKeyPosition info) request UnlimitedKeys end -> drop (fromEnum $ firstKeyPosition info) $ take (length request - fromEnum end) request return $ takeEvery (fromEnum $ stepCount info) possibleKeys isMovable :: CommandInfo -> Bool isMovable CommandInfo{..} = MovableKeys `elem` flags parseMovable :: [BS.ByteString] -> Maybe [BS.ByteString] parseMovable ("SORT":key:_) = Just [key] parseMovable ("EVAL":_:rest) = readNumKeys rest parseMovable ("EVALSHA":_:rest) = readNumKeys rest parseMovable ("ZUNIONSTORE":_:rest) = readNumKeys rest parseMovable ("ZINTERSTORE":_:rest) = readNumKeys rest parseMovable ("XREAD":rest) = readXreadKeys rest parseMovable ("XREADGROUP":"GROUP":_:_:rest) = readXreadgroupKeys rest parseMovable _ = Nothing readXreadKeys :: [BS.ByteString] -> Maybe [BS.ByteString] readXreadKeys ("COUNT":_:rest) = readXreadKeys rest readXreadKeys ("BLOCK":_:rest) = readXreadKeys rest readXreadKeys ("STREAMS":rest) = Just $ take (length rest `div` 2) rest readXreadKeys _ = Nothing readXreadgroupKeys :: [BS.ByteString] -> Maybe [BS.ByteString] readXreadgroupKeys ("COUNT":_:rest) = readXreadKeys rest readXreadgroupKeys ("BLOCK":_:rest) = readXreadKeys rest readXreadgroupKeys ("NOACK":rest) = readXreadKeys rest readXreadgroupKeys ("STREAMS":rest) = Just $ take (length rest `div` 2) rest readXreadgroupKeys _ = Nothing readNumKeys :: [BS.ByteString] -> Maybe [BS.ByteString] readNumKeys (rawNumKeys:rest) = do numKeys <- readMaybe (Char8.unpack rawNumKeys) return $ take numKeys rest readNumKeys _ = Nothing -- takeEvery 1 [1,2,3,4,5] ->[1,2,3,4,5] -- takeEvery 2 [1,2,3,4,5] ->[1,3,5] -- takeEvery 3 [1,2,3,4,5] ->[1,4] takeEvery :: Int -> [a] -> [a] takeEvery _ [] = [] takeEvery n (x:xs) = x : takeEvery n (drop (n-1) xs) readMaybe :: Read a => String -> Maybe a readMaybe s = case reads s of [(val, "")] -> Just val _ -> Nothing hedis-0.15.2/src/Database/Redis/Cluster/HashSlot.hs0000644000000000000000000000256407346545000020136 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot) where import Data.Bits((.&.), xor, shiftL) import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString as BS import Data.Word(Word8, Word16) newtype HashSlot = HashSlot Word16 deriving (Num, Eq, Ord, Real, Enum, Integral, Show) numHashSlots :: Word16 numHashSlots = 16384 -- | Compute the hashslot associated with a key keyToSlot :: BS.ByteString -> HashSlot keyToSlot = HashSlot . (.&.) (numHashSlots - 1) . crc16 . findSubKey -- | Find the section of a key to compute the slot for. findSubKey :: BS.ByteString -> BS.ByteString findSubKey key = case Char8.break (=='{') key of (whole, "") -> whole (_, xs) -> case Char8.break (=='}') (Char8.tail xs) of ("", _) -> key (subKey, _) -> subKey crc16 :: BS.ByteString -> Word16 crc16 = BS.foldl (crc16Update 0x1021) 0 -- Taken from crc16 package crc16Update :: Word16 -- ^ polynomial -> Word16 -- ^ initial crc -> Word8 -- ^ data byte -> Word16 -- ^ new crc crc16Update poly crc b = foldl crc16UpdateBit newCrc [1 :: Int .. 8] where newCrc = crc `xor` shiftL (fromIntegral b :: Word16) 8 crc16UpdateBit crc' _ = if (crc' .&. 0x8000) /= 0x0000 then shiftL crc' 1 `xor` poly else shiftL crc' 1 hedis-0.15.2/src/Database/Redis/Commands.hs0000644000000000000000000014740207346545000016532 0ustar0000000000000000-- Generated by GenCmds.hs. DO NOT EDIT. {-# LANGUAGE OverloadedStrings, FlexibleContexts #-} module Database.Redis.Commands ( -- ** Connection auth, -- |Authenticate to the server (). Since Redis 1.0.0 echo, -- |Echo the given string (). Since Redis 1.0.0 ping, -- |Ping the server (). Since Redis 1.0.0 quit, -- |Close the connection (). Since Redis 1.0.0 select, -- |Change the selected database for the current connection (). Since Redis 1.0.0 -- ** Keys del, -- |Delete a key (). Since Redis 1.0.0 dump, -- |Return a serialized version of the value stored at the specified key (). Since Redis 2.6.0 exists, -- |Determine if a key exists (). Since Redis 1.0.0 expire, -- |Set a key's time to live in seconds (). Since Redis 1.0.0 expireat, -- |Set the expiration for a key as a UNIX timestamp (). Since Redis 1.2.0 keys, -- |Find all keys matching the given pattern (). Since Redis 1.0.0 MigrateOpts(..), defaultMigrateOpts, migrate, -- |Atomically transfer a key from a Redis instance to another one (). The Redis command @MIGRATE@ is split up into 'migrate', 'migrateMultiple'. Since Redis 2.6.0 migrateMultiple, -- |Atomically transfer a key from a Redis instance to another one (). The Redis command @MIGRATE@ is split up into 'migrate', 'migrateMultiple'. Since Redis 2.6.0 move, -- |Move a key to another database (). Since Redis 1.0.0 objectRefcount, -- |Inspect the internals of Redis objects (). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3 objectEncoding, -- |Inspect the internals of Redis objects (). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3 objectIdletime, -- |Inspect the internals of Redis objects (). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3 persist, -- |Remove the expiration from a key (). Since Redis 2.2.0 pexpire, -- |Set a key's time to live in milliseconds (). Since Redis 2.6.0 pexpireat, -- |Set the expiration for a key as a UNIX timestamp specified in milliseconds (). Since Redis 2.6.0 pttl, -- |Get the time to live for a key in milliseconds (). Since Redis 2.6.0 randomkey, -- |Return a random key from the keyspace (). Since Redis 1.0.0 rename, -- |Rename a key (). Since Redis 1.0.0 renamenx, -- |Rename a key, only if the new key does not exist (). Since Redis 1.0.0 restore, -- |Create a key using the provided serialized value, previously obtained using DUMP (). The Redis command @RESTORE@ is split up into 'restore', 'restoreReplace'. Since Redis 2.6.0 restoreReplace, -- |Create a key using the provided serialized value, previously obtained using DUMP (). The Redis command @RESTORE@ is split up into 'restore', 'restoreReplace'. Since Redis 2.6.0 Cursor, cursor0, ScanOpts(..), defaultScanOpts, scan, -- |Incrementally iterate the keys space (). The Redis command @SCAN@ is split up into 'scan', 'scanOpts'. Since Redis 2.8.0 scanOpts, -- |Incrementally iterate the keys space (). The Redis command @SCAN@ is split up into 'scan', 'scanOpts'. Since Redis 2.8.0 SortOpts(..), defaultSortOpts, SortOrder(..), sort, -- |Sort the elements in a list, set or sorted set (). The Redis command @SORT@ is split up into 'sort', 'sortStore'. Since Redis 1.0.0 sortStore, -- |Sort the elements in a list, set or sorted set (). The Redis command @SORT@ is split up into 'sort', 'sortStore'. Since Redis 1.0.0 ttl, -- |Get the time to live for a key (). Since Redis 1.0.0 RedisType(..), getType, -- |Determine the type stored at key (). Since Redis 1.0.0 wait, -- |Wait for the synchronous replication of all the write commands sent in the context of the current connection (). Since Redis 3.0.0 -- ** Hashes hdel, -- |Delete one or more hash fields (). Since Redis 2.0.0 hexists, -- |Determine if a hash field exists (). Since Redis 2.0.0 hget, -- |Get the value of a hash field (). Since Redis 2.0.0 hgetall, -- |Get all the fields and values in a hash (). Since Redis 2.0.0 hincrby, -- |Increment the integer value of a hash field by the given number (). Since Redis 2.0.0 hincrbyfloat, -- |Increment the float value of a hash field by the given amount (). Since Redis 2.6.0 hkeys, -- |Get all the fields in a hash (). Since Redis 2.0.0 hlen, -- |Get the number of fields in a hash (). Since Redis 2.0.0 hmget, -- |Get the values of all the given hash fields (). Since Redis 2.0.0 hmset, -- |Set multiple hash fields to multiple values (). Since Redis 2.0.0 hscan, -- |Incrementally iterate hash fields and associated values (). The Redis command @HSCAN@ is split up into 'hscan', 'hscanOpts'. Since Redis 2.8.0 hscanOpts, -- |Incrementally iterate hash fields and associated values (). The Redis command @HSCAN@ is split up into 'hscan', 'hscanOpts'. Since Redis 2.8.0 hset, -- |Set the string value of a hash field (). Since Redis 2.0.0 hsetnx, -- |Set the value of a hash field, only if the field does not exist (). Since Redis 2.0.0 hstrlen, -- |Get the length of the value of a hash field (). Since Redis 3.2.0 hvals, -- |Get all the values in a hash (). Since Redis 2.0.0 -- ** HyperLogLogs pfadd, -- |Adds all the elements arguments to the HyperLogLog data structure stored at the variable name specified as first argument (). Since Redis 2.8.9 pfcount, -- |Return the approximated cardinality of the set(s) observed by the HyperLogLog at key(s) (). Since Redis 2.8.9 pfmerge, -- |Merge N different HyperLogLogs into a single one (). Since Redis 2.8.9 -- ** Lists blpop, -- |Remove and get the first element in a list, or block until one is available (). Since Redis 2.0.0 brpop, -- |Remove and get the last element in a list, or block until one is available (). Since Redis 2.0.0 brpoplpush, -- |Pop a value from a list, push it to another list and return it; or block until one is available (). Since Redis 2.2.0 lindex, -- |Get an element from a list by its index (). Since Redis 1.0.0 linsertBefore, -- |Insert an element before or after another element in a list (). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'. Since Redis 2.2.0 linsertAfter, -- |Insert an element before or after another element in a list (). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'. Since Redis 2.2.0 llen, -- |Get the length of a list (). Since Redis 1.0.0 lpop, -- |Remove and get the first element in a list (). Since Redis 1.0.0 lpush, -- |Prepend one or multiple values to a list (). Since Redis 1.0.0 lpushx, -- |Prepend a value to a list, only if the list exists (). Since Redis 2.2.0 lrange, -- |Get a range of elements from a list (). Since Redis 1.0.0 lrem, -- |Remove elements from a list (). Since Redis 1.0.0 lset, -- |Set the value of an element in a list by its index (). Since Redis 1.0.0 ltrim, -- |Trim a list to the specified range (). Since Redis 1.0.0 rpop, -- |Remove and get the last element in a list (). Since Redis 1.0.0 rpoplpush, -- |Remove the last element in a list, prepend it to another list and return it (). Since Redis 1.2.0 rpush, -- |Append one or multiple values to a list (). Since Redis 1.0.0 rpushx, -- |Append a value to a list, only if the list exists (). Since Redis 2.2.0 -- ** Scripting eval, -- |Execute a Lua script server side (). Since Redis 2.6.0 evalsha, -- |Execute a Lua script server side (). Since Redis 2.6.0 DebugMode, scriptDebug, -- |Set the debug mode for executed scripts (). Since Redis 3.2.0 scriptExists, -- |Check existence of scripts in the script cache (). Since Redis 2.6.0 scriptFlush, -- |Remove all the scripts from the script cache (). Since Redis 2.6.0 scriptKill, -- |Kill the script currently in execution (). Since Redis 2.6.0 scriptLoad, -- |Load the specified Lua script into the script cache (). Since Redis 2.6.0 -- ** Server bgrewriteaof, -- |Asynchronously rewrite the append-only file (). Since Redis 1.0.0 bgsave, -- |Asynchronously save the dataset to disk (). Since Redis 1.0.0 clientGetname, -- |Get the current connection name (). Since Redis 2.6.9 clientList, -- |Get the list of client connections (). Since Redis 2.4.0 clientPause, -- |Stop processing commands from clients for some time (). Since Redis 2.9.50 ReplyMode, clientReply, -- |Instruct the server whether to reply to commands (). Since Redis 3.2 clientSetname, -- |Set the current connection name (). Since Redis 2.6.9 commandCount, -- |Get total number of Redis commands (). Since Redis 2.8.13 commandInfo, -- |Get array of specific Redis command details (). Since Redis 2.8.13 configGet, -- |Get the value of a configuration parameter (). Since Redis 2.0.0 configResetstat, -- |Reset the stats returned by INFO (). Since Redis 2.0.0 configRewrite, -- |Rewrite the configuration file with the in memory configuration (). Since Redis 2.8.0 configSet, -- |Set a configuration parameter to the given value (). Since Redis 2.0.0 dbsize, -- |Return the number of keys in the selected database (). Since Redis 1.0.0 debugObject, -- |Get debugging information about a key (). Since Redis 1.0.0 flushall, -- |Remove all keys from all databases (). Since Redis 1.0.0 flushdb, -- |Remove all keys from the current database (). Since Redis 1.0.0 info, -- |Get information and statistics about the server (). The Redis command @INFO@ is split up into 'info', 'infoSection'. Since Redis 1.0.0 infoSection, -- |Get information and statistics about the server (). The Redis command @INFO@ is split up into 'info', 'infoSection'. Since Redis 1.0.0 lastsave, -- |Get the UNIX time stamp of the last successful save to disk (). Since Redis 1.0.0 save, -- |Synchronously save the dataset to disk (). Since Redis 1.0.0 slaveof, -- |Make the server a slave of another instance, or promote it as master (). Since Redis 1.0.0 Slowlog(..), slowlogGet, -- |Manages the Redis slow queries log (). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12 slowlogLen, -- |Manages the Redis slow queries log (). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12 slowlogReset, -- |Manages the Redis slow queries log (). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12 time, -- |Return the current server time (). Since Redis 2.6.0 -- ** Sets sadd, -- |Add one or more members to a set (). Since Redis 1.0.0 scard, -- |Get the number of members in a set (). Since Redis 1.0.0 sdiff, -- |Subtract multiple sets (). Since Redis 1.0.0 sdiffstore, -- |Subtract multiple sets and store the resulting set in a key (). Since Redis 1.0.0 sinter, -- |Intersect multiple sets (). Since Redis 1.0.0 sinterstore, -- |Intersect multiple sets and store the resulting set in a key (). Since Redis 1.0.0 sismember, -- |Determine if a given value is a member of a set (). Since Redis 1.0.0 smembers, -- |Get all the members in a set (). Since Redis 1.0.0 smove, -- |Move a member from one set to another (). Since Redis 1.0.0 spop, -- |Remove and return one or multiple random members from a set (). The Redis command @SPOP@ is split up into 'spop', 'spopN'. Since Redis 1.0.0 spopN, -- |Remove and return one or multiple random members from a set (). The Redis command @SPOP@ is split up into 'spop', 'spopN'. Since Redis 1.0.0 srandmember, -- |Get one or multiple random members from a set (). The Redis command @SRANDMEMBER@ is split up into 'srandmember', 'srandmemberN'. Since Redis 1.0.0 srandmemberN, -- |Get one or multiple random members from a set (). The Redis command @SRANDMEMBER@ is split up into 'srandmember', 'srandmemberN'. Since Redis 1.0.0 srem, -- |Remove one or more members from a set (). Since Redis 1.0.0 sscan, -- |Incrementally iterate Set elements (). The Redis command @SSCAN@ is split up into 'sscan', 'sscanOpts'. Since Redis 2.8.0 sscanOpts, -- |Incrementally iterate Set elements (). The Redis command @SSCAN@ is split up into 'sscan', 'sscanOpts'. Since Redis 2.8.0 sunion, -- |Add multiple sets (). Since Redis 1.0.0 sunionstore, -- |Add multiple sets and store the resulting set in a key (). Since Redis 1.0.0 -- ** Sorted Sets ZaddOpts(..), defaultZaddOpts, zadd, -- |Add one or more members to a sorted set, or update its score if it already exists (). The Redis command @ZADD@ is split up into 'zadd', 'zaddOpts'. Since Redis 1.2.0 zaddOpts, -- |Add one or more members to a sorted set, or update its score if it already exists (). The Redis command @ZADD@ is split up into 'zadd', 'zaddOpts'. Since Redis 1.2.0 zcard, -- |Get the number of members in a sorted set (). Since Redis 1.2.0 zcount, -- |Count the members in a sorted set with scores within the given values (). Since Redis 2.0.0 zincrby, -- |Increment the score of a member in a sorted set (). Since Redis 1.2.0 Aggregate(..), zinterstore, -- |Intersect multiple sorted sets and store the resulting sorted set in a new key (). The Redis command @ZINTERSTORE@ is split up into 'zinterstore', 'zinterstoreWeights'. Since Redis 2.0.0 zinterstoreWeights, -- |Intersect multiple sorted sets and store the resulting sorted set in a new key (). The Redis command @ZINTERSTORE@ is split up into 'zinterstore', 'zinterstoreWeights'. Since Redis 2.0.0 zlexcount, -- |Count the number of members in a sorted set between a given lexicographical range (). Since Redis 2.8.9 zrange, -- |Return a range of members in a sorted set, by index (). The Redis command @ZRANGE@ is split up into 'zrange', 'zrangeWithscores'. Since Redis 1.2.0 zrangeWithscores, -- |Return a range of members in a sorted set, by index (). The Redis command @ZRANGE@ is split up into 'zrange', 'zrangeWithscores'. Since Redis 1.2.0 RangeLex(..), zrangebylex, zrangebylexLimit, -- |Return a range of members in a sorted set, by lexicographical range (). Since Redis 2.8.9 zrangebyscore, -- |Return a range of members in a sorted set, by score (). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5 zrangebyscoreWithscores, -- |Return a range of members in a sorted set, by score (). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5 zrangebyscoreLimit, -- |Return a range of members in a sorted set, by score (). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5 zrangebyscoreWithscoresLimit, -- |Return a range of members in a sorted set, by score (). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5 zrank, -- |Determine the index of a member in a sorted set (). Since Redis 2.0.0 zrem, -- |Remove one or more members from a sorted set (). Since Redis 1.2.0 zremrangebylex, -- |Remove all members in a sorted set between the given lexicographical range (). Since Redis 2.8.9 zremrangebyrank, -- |Remove all members in a sorted set within the given indexes (). Since Redis 2.0.0 zremrangebyscore, -- |Remove all members in a sorted set within the given scores (). Since Redis 1.2.0 zrevrange, -- |Return a range of members in a sorted set, by index, with scores ordered from high to low (). The Redis command @ZREVRANGE@ is split up into 'zrevrange', 'zrevrangeWithscores'. Since Redis 1.2.0 zrevrangeWithscores, -- |Return a range of members in a sorted set, by index, with scores ordered from high to low (). The Redis command @ZREVRANGE@ is split up into 'zrevrange', 'zrevrangeWithscores'. Since Redis 1.2.0 zrevrangebyscore, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0 zrevrangebyscoreWithscores, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0 zrevrangebyscoreLimit, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0 zrevrangebyscoreWithscoresLimit, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0 zrevrank, -- |Determine the index of a member in a sorted set, with scores ordered from high to low (). Since Redis 2.0.0 zscan, -- |Incrementally iterate sorted sets elements and associated scores (). The Redis command @ZSCAN@ is split up into 'zscan', 'zscanOpts'. Since Redis 2.8.0 zscanOpts, -- |Incrementally iterate sorted sets elements and associated scores (). The Redis command @ZSCAN@ is split up into 'zscan', 'zscanOpts'. Since Redis 2.8.0 zscore, -- |Get the score associated with the given member in a sorted set (). Since Redis 1.2.0 zunionstore, -- |Add multiple sorted sets and store the resulting sorted set in a new key (). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'. Since Redis 2.0.0 zunionstoreWeights, -- |Add multiple sorted sets and store the resulting sorted set in a new key (). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'. Since Redis 2.0.0 -- ** Strings append, -- |Append a value to a key (). Since Redis 2.0.0 bitcount, -- |Count set bits in a string (). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'. Since Redis 2.6.0 bitcountRange, -- |Count set bits in a string (). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'. Since Redis 2.6.0 bitopAnd, -- |Perform bitwise operations between strings (). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0 bitopOr, -- |Perform bitwise operations between strings (). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0 bitopXor, -- |Perform bitwise operations between strings (). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0 bitopNot, -- |Perform bitwise operations between strings (). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0 bitpos, -- |Find first bit set or clear in a string (). Since Redis 2.8.7 decr, -- |Decrement the integer value of a key by one (). Since Redis 1.0.0 decrby, -- |Decrement the integer value of a key by the given number (). Since Redis 1.0.0 get, -- |Get the value of a key (). Since Redis 1.0.0 getbit, -- |Returns the bit value at offset in the string value stored at key (). Since Redis 2.2.0 getrange, -- |Get a substring of the string stored at a key (). Since Redis 2.4.0 getset, -- |Set the string value of a key and return its old value (). Since Redis 1.0.0 incr, -- |Increment the integer value of a key by one (). Since Redis 1.0.0 incrby, -- |Increment the integer value of a key by the given amount (). Since Redis 1.0.0 incrbyfloat, -- |Increment the float value of a key by the given amount (). Since Redis 2.6.0 mget, -- |Get the values of all the given keys (). Since Redis 1.0.0 mset, -- |Set multiple keys to multiple values (). Since Redis 1.0.1 msetnx, -- |Set multiple keys to multiple values, only if none of the keys exist (). Since Redis 1.0.1 psetex, -- |Set the value and expiration in milliseconds of a key (). Since Redis 2.6.0 Condition(..), SetOpts(..), set, -- |Set the string value of a key (). The Redis command @SET@ is split up into 'set', 'setOpts'. Since Redis 1.0.0 setOpts, -- |Set the string value of a key (). The Redis command @SET@ is split up into 'set', 'setOpts'. Since Redis 1.0.0 setbit, -- |Sets or clears the bit at offset in the string value stored at key (). Since Redis 2.2.0 setex, -- |Set the value and expiration of a key (). Since Redis 2.0.0 setnx, -- |Set the value of a key, only if the key does not exist (). Since Redis 1.0.0 setrange, -- |Overwrite part of a string at key starting at the specified offset (). Since Redis 2.2.0 strlen, -- |Get the length of the value stored in a key (). Since Redis 2.2.0 -- ** Streams XReadOpts(..), defaultXreadOpts, XReadResponse(..), StreamsRecord(..), TrimOpts(..), xadd, -- |Add a value to a stream (). Since Redis 5.0.0 xaddOpts, -- |Add a value to a stream (). The Redis command @XADD@ is split up into 'xadd', 'xaddOpts'. Since Redis 5.0.0 xread, -- |Read values from a stream (). The Redis command @XREAD@ is split up into 'xread', 'xreadOpts'. Since Redis 5.0.0 xreadOpts, -- |Read values from a stream (). The Redis command @XREAD@ is split up into 'xread', 'xreadOpts'. Since Redis 5.0.0 xreadGroup, -- |Read values from a stream as part of a consumer group (https://redis.io/commands/xreadgroup). The redis command @XREADGROUP@ is split up into 'xreadGroup' and 'xreadGroupOpts'. Since Redis 5.0.0 xreadGroupOpts, -- |Read values from a stream as part of a consumer group (https://redis.io/commands/xreadgroup). The redis command @XREADGROUP@ is split up into 'xreadGroup' and 'xreadGroupOpts'. Since Redis 5.0.0 xack, -- |Acknowledge receipt of a message as part of a consumer group. Since Redis 5.0.0 xgroupCreate, -- |Create a consumer group. The redis command @XGROUP@ is split up into 'xgroupCreate', 'xgroupSetId', 'xgroupDestroy', and 'xgroupDelConsumer'. Since Redis 5.0.0 xgroupSetId, -- |Set the id for a consumer group. The redis command @XGROUP@ is split up into 'xgroupCreate', 'xgroupSetId', 'xgroupDestroy', and 'xgroupDelConsumer'. Since Redis 5.0.0 xgroupDestroy, -- |Destroy a consumer group. The redis command @XGROUP@ is split up into 'xgroupCreate', 'xgroupSetId', 'xgroupDestroy', and 'xgroupDelConsumer'. Since Redis 5.0.0 xgroupDelConsumer, -- |Delete a consumer. The redis command @XGROUP@ is split up into 'xgroupCreate', 'xgroupSetId', 'xgroupDestroy', and 'xgroupDelConsumer'. Since Redis 5.0.0 xrange, -- |Read values from a stream within a range (https://redis.io/commands/xrange). Since Redis 5.0.0 xrevRange, -- |Read values from a stream within a range in reverse order (https://redis.io/commands/xrevrange). Since Redis 5.0.0 xlen, -- |Get the number of entries in a stream (https://redis.io/commands/xlen). Since Redis 5.0.0 XPendingSummaryResponse(..), xpendingSummary, -- |Get information about pending messages (https://redis.io/commands/xpending). The Redis @XPENDING@ command is split into 'xpendingSummary' and 'xpendingDetail'. Since Redis 5.0.0 XPendingDetailRecord(..), xpendingDetail, -- |Get detailed information about pending messages (https://redis.io/commands/xpending). The Redis @XPENDING@ command is split into 'xpendingSummary' and 'xpendingDetail'. Since Redis 5.0.0 XClaimOpts(..), defaultXClaimOpts, xclaim, -- |Change ownership of some messages to the given consumer, returning the updated messages. The Redis @XCLAIM@ command is split into 'xclaim' and 'xclaimJustIds'. Since Redis 5.0.0 xclaimJustIds, -- |Change ownership of some messages to the given consumer, returning only the changed message IDs. The Redis @XCLAIM@ command is split into 'xclaim' and 'xclaimJustIds'. Since Redis 5.0.0 XInfoConsumersResponse(..), xinfoConsumers, -- |Get info about consumers in a group. The Redis command @XINFO@ is split into 'xinfoConsumers', 'xinfoGroups', and 'xinfoStream'. Since Redis 5.0.0 XInfoGroupsResponse(..), xinfoGroups, -- |Get info about groups consuming from a stream. The Redis command @XINFO@ is split into 'xinfoConsumers', 'xinfoGroups', and 'xinfoStream'. Since Redis 5.0.0 XInfoStreamResponse(..), xinfoStream, -- |Get info about a stream. The Redis command @XINFO@ is split into 'xinfoConsumers', 'xinfoGroups', and 'xinfoStream'. Since Redis 5.0.0 xdel, -- |Delete messages from a stream. Since Redis 5.0.0 xtrim, -- |Set the upper bound for number of messages in a stream. Since Redis 5.0.0 inf, -- |Constructor for `inf` Redis argument values ClusterNodesResponse(..), ClusterNodesResponseEntry(..), ClusterNodesResponseSlotSpec(..), clusterNodes, ClusterSlotsResponse(..), ClusterSlotsResponseEntry(..), ClusterSlotsNode(..), clusterSlots, clusterSetSlotNode, clusterSetSlotStable, clusterSetSlotImporting, clusterSetSlotMigrating, clusterGetKeysInSlot, command -- * Unimplemented Commands -- |These commands are not implemented, as of now. Library -- users can implement these or other commands from -- experimental Redis versions by using the 'sendRequest' -- function. -- -- * COMMAND () -- -- -- * COMMAND GETKEYS () -- -- -- * ROLE () -- -- -- * CLIENT KILL () -- -- -- * ZREVRANGEBYLEX () -- -- -- * ZRANGEBYSCORE () -- -- -- * ZREVRANGEBYSCORE () -- -- -- * MONITOR () -- -- -- * SYNC () -- -- -- * SHUTDOWN () -- -- -- * DEBUG SEGFAULT () -- ) where import Prelude hiding (min,max) import Data.ByteString (ByteString) import Database.Redis.ManualCommands import Database.Redis.Types import Database.Redis.Core(sendRequest, RedisCtx) ttl :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) ttl key = sendRequest (["TTL"] ++ [encode key] ) setnx :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ value -> m (f Bool) setnx key value = sendRequest (["SETNX"] ++ [encode key] ++ [encode value] ) pttl :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) pttl key = sendRequest (["PTTL"] ++ [encode key] ) commandCount :: (RedisCtx m f) => m (f Integer) commandCount = sendRequest (["COMMAND","COUNT"] ) clientSetname :: (RedisCtx m f) => ByteString -- ^ connectionName -> m (f ByteString) clientSetname connectionName = sendRequest (["CLIENT","SETNAME"] ++ [encode connectionName] ) zrank :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ member -> m (f (Maybe Integer)) zrank key member = sendRequest (["ZRANK"] ++ [encode key] ++ [encode member] ) zremrangebyscore :: (RedisCtx m f) => ByteString -- ^ key -> Double -- ^ min -> Double -- ^ max -> m (f Integer) zremrangebyscore key min max = sendRequest (["ZREMRANGEBYSCORE"] ++ [encode key] ++ [encode min] ++ [encode max] ) hkeys :: (RedisCtx m f) => ByteString -- ^ key -> m (f [ByteString]) hkeys key = sendRequest (["HKEYS"] ++ [encode key] ) slaveof :: (RedisCtx m f) => ByteString -- ^ host -> ByteString -- ^ port -> m (f Status) slaveof host port = sendRequest (["SLAVEOF"] ++ [encode host] ++ [encode port] ) rpushx :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ value -> m (f Integer) rpushx key value = sendRequest (["RPUSHX"] ++ [encode key] ++ [encode value] ) debugObject :: (RedisCtx m f) => ByteString -- ^ key -> m (f ByteString) debugObject key = sendRequest (["DEBUG","OBJECT"] ++ [encode key] ) bgsave :: (RedisCtx m f) => m (f Status) bgsave = sendRequest (["BGSAVE"] ) hlen :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) hlen key = sendRequest (["HLEN"] ++ [encode key] ) rpoplpush :: (RedisCtx m f) => ByteString -- ^ source -> ByteString -- ^ destination -> m (f (Maybe ByteString)) rpoplpush source destination = sendRequest (["RPOPLPUSH"] ++ [encode source] ++ [encode destination] ) brpop :: (RedisCtx m f) => [ByteString] -- ^ key -> Integer -- ^ timeout -> m (f (Maybe (ByteString,ByteString))) brpop key timeout = sendRequest (["BRPOP"] ++ map encode key ++ [encode timeout] ) bgrewriteaof :: (RedisCtx m f) => m (f Status) bgrewriteaof = sendRequest (["BGREWRITEAOF"] ) zincrby :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ increment -> ByteString -- ^ member -> m (f Double) zincrby key increment member = sendRequest (["ZINCRBY"] ++ [encode key] ++ [encode increment] ++ [encode member] ) hgetall :: (RedisCtx m f) => ByteString -- ^ key -> m (f [(ByteString,ByteString)]) hgetall key = sendRequest (["HGETALL"] ++ [encode key] ) hmset :: (RedisCtx m f) => ByteString -- ^ key -> [(ByteString,ByteString)] -- ^ fieldValue -> m (f Status) hmset key fieldValue = sendRequest (["HMSET"] ++ [encode key] ++ concatMap (\(x,y) -> [encode x,encode y])fieldValue ) sinter :: (RedisCtx m f) => [ByteString] -- ^ key -> m (f [ByteString]) sinter key = sendRequest (["SINTER"] ++ map encode key ) pfadd :: (RedisCtx m f) => ByteString -- ^ key -> [ByteString] -- ^ value -> m (f Integer) pfadd key value = sendRequest (["PFADD"] ++ [encode key] ++ map encode value ) zremrangebyrank :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ start -> Integer -- ^ stop -> m (f Integer) zremrangebyrank key start stop = sendRequest (["ZREMRANGEBYRANK"] ++ [encode key] ++ [encode start] ++ [encode stop] ) flushdb :: (RedisCtx m f) => m (f Status) flushdb = sendRequest (["FLUSHDB"] ) sadd :: (RedisCtx m f) => ByteString -- ^ key -> [ByteString] -- ^ member -> m (f Integer) sadd key member = sendRequest (["SADD"] ++ [encode key] ++ map encode member ) lindex :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ index -> m (f (Maybe ByteString)) lindex key index = sendRequest (["LINDEX"] ++ [encode key] ++ [encode index] ) lpush :: (RedisCtx m f) => ByteString -- ^ key -> [ByteString] -- ^ value -> m (f Integer) lpush key value = sendRequest (["LPUSH"] ++ [encode key] ++ map encode value ) hstrlen :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ field -> m (f Integer) hstrlen key field = sendRequest (["HSTRLEN"] ++ [encode key] ++ [encode field] ) smove :: (RedisCtx m f) => ByteString -- ^ source -> ByteString -- ^ destination -> ByteString -- ^ member -> m (f Bool) smove source destination member = sendRequest (["SMOVE"] ++ [encode source] ++ [encode destination] ++ [encode member] ) zscore :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ member -> m (f (Maybe Double)) zscore key member = sendRequest (["ZSCORE"] ++ [encode key] ++ [encode member] ) configResetstat :: (RedisCtx m f) => m (f Status) configResetstat = sendRequest (["CONFIG","RESETSTAT"] ) pfcount :: (RedisCtx m f) => [ByteString] -- ^ key -> m (f Integer) pfcount key = sendRequest (["PFCOUNT"] ++ map encode key ) hdel :: (RedisCtx m f) => ByteString -- ^ key -> [ByteString] -- ^ field -> m (f Integer) hdel key field = sendRequest (["HDEL"] ++ [encode key] ++ map encode field ) incrbyfloat :: (RedisCtx m f) => ByteString -- ^ key -> Double -- ^ increment -> m (f Double) incrbyfloat key increment = sendRequest (["INCRBYFLOAT"] ++ [encode key] ++ [encode increment] ) setbit :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ offset -> ByteString -- ^ value -> m (f Integer) setbit key offset value = sendRequest (["SETBIT"] ++ [encode key] ++ [encode offset] ++ [encode value] ) flushall :: (RedisCtx m f) => m (f Status) flushall = sendRequest (["FLUSHALL"] ) incrby :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ increment -> m (f Integer) incrby key increment = sendRequest (["INCRBY"] ++ [encode key] ++ [encode increment] ) time :: (RedisCtx m f) => m (f (Integer,Integer)) time = sendRequest (["TIME"] ) smembers :: (RedisCtx m f) => ByteString -- ^ key -> m (f [ByteString]) smembers key = sendRequest (["SMEMBERS"] ++ [encode key] ) zlexcount :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ min -> ByteString -- ^ max -> m (f Integer) zlexcount key min max = sendRequest (["ZLEXCOUNT"] ++ [encode key] ++ [encode min] ++ [encode max] ) sunion :: (RedisCtx m f) => [ByteString] -- ^ key -> m (f [ByteString]) sunion key = sendRequest (["SUNION"] ++ map encode key ) sinterstore :: (RedisCtx m f) => ByteString -- ^ destination -> [ByteString] -- ^ key -> m (f Integer) sinterstore destination key = sendRequest (["SINTERSTORE"] ++ [encode destination] ++ map encode key ) hvals :: (RedisCtx m f) => ByteString -- ^ key -> m (f [ByteString]) hvals key = sendRequest (["HVALS"] ++ [encode key] ) configSet :: (RedisCtx m f) => ByteString -- ^ parameter -> ByteString -- ^ value -> m (f Status) configSet parameter value = sendRequest (["CONFIG","SET"] ++ [encode parameter] ++ [encode value] ) scriptFlush :: (RedisCtx m f) => m (f Status) scriptFlush = sendRequest (["SCRIPT","FLUSH"] ) dbsize :: (RedisCtx m f) => m (f Integer) dbsize = sendRequest (["DBSIZE"] ) wait :: (RedisCtx m f) => Integer -- ^ numslaves -> Integer -- ^ timeout -> m (f Integer) wait numslaves timeout = sendRequest (["WAIT"] ++ [encode numslaves] ++ [encode timeout] ) lpop :: (RedisCtx m f) => ByteString -- ^ key -> m (f (Maybe ByteString)) lpop key = sendRequest (["LPOP"] ++ [encode key] ) clientPause :: (RedisCtx m f) => Integer -- ^ timeout -> m (f Status) clientPause timeout = sendRequest (["CLIENT","PAUSE"] ++ [encode timeout] ) expire :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ seconds -> m (f Bool) expire key seconds = sendRequest (["EXPIRE"] ++ [encode key] ++ [encode seconds] ) mget :: (RedisCtx m f) => [ByteString] -- ^ key -> m (f [Maybe ByteString]) mget key = sendRequest (["MGET"] ++ map encode key ) bitpos :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ bit -> Integer -- ^ start -> Integer -- ^ end -> m (f Integer) bitpos key bit start end = sendRequest (["BITPOS"] ++ [encode key] ++ [encode bit] ++ [encode start] ++ [encode end] ) lastsave :: (RedisCtx m f) => m (f Integer) lastsave = sendRequest (["LASTSAVE"] ) pexpire :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ milliseconds -> m (f Bool) pexpire key milliseconds = sendRequest (["PEXPIRE"] ++ [encode key] ++ [encode milliseconds] ) clientList :: (RedisCtx m f) => m (f [ByteString]) clientList = sendRequest (["CLIENT","LIST"] ) renamenx :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ newkey -> m (f Bool) renamenx key newkey = sendRequest (["RENAMENX"] ++ [encode key] ++ [encode newkey] ) pfmerge :: (RedisCtx m f) => ByteString -- ^ destkey -> [ByteString] -- ^ sourcekey -> m (f ByteString) pfmerge destkey sourcekey = sendRequest (["PFMERGE"] ++ [encode destkey] ++ map encode sourcekey ) lrem :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ count -> ByteString -- ^ value -> m (f Integer) lrem key count value = sendRequest (["LREM"] ++ [encode key] ++ [encode count] ++ [encode value] ) sdiff :: (RedisCtx m f) => [ByteString] -- ^ key -> m (f [ByteString]) sdiff key = sendRequest (["SDIFF"] ++ map encode key ) get :: (RedisCtx m f) => ByteString -- ^ key -> m (f (Maybe ByteString)) get key = sendRequest (["GET"] ++ [encode key] ) getrange :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ start -> Integer -- ^ end -> m (f ByteString) getrange key start end = sendRequest (["GETRANGE"] ++ [encode key] ++ [encode start] ++ [encode end] ) sdiffstore :: (RedisCtx m f) => ByteString -- ^ destination -> [ByteString] -- ^ key -> m (f Integer) sdiffstore destination key = sendRequest (["SDIFFSTORE"] ++ [encode destination] ++ map encode key ) zcount :: (RedisCtx m f) => ByteString -- ^ key -> Double -- ^ min -> Double -- ^ max -> m (f Integer) zcount key min max = sendRequest (["ZCOUNT"] ++ [encode key] ++ [encode min] ++ [encode max] ) scriptLoad :: (RedisCtx m f) => ByteString -- ^ script -> m (f ByteString) scriptLoad script = sendRequest (["SCRIPT","LOAD"] ++ [encode script] ) getset :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ value -> m (f (Maybe ByteString)) getset key value = sendRequest (["GETSET"] ++ [encode key] ++ [encode value] ) dump :: (RedisCtx m f) => ByteString -- ^ key -> m (f ByteString) dump key = sendRequest (["DUMP"] ++ [encode key] ) keys :: (RedisCtx m f) => ByteString -- ^ pattern -> m (f [ByteString]) keys pattern = sendRequest (["KEYS"] ++ [encode pattern] ) configGet :: (RedisCtx m f) => ByteString -- ^ parameter -> m (f [(ByteString,ByteString)]) configGet parameter = sendRequest (["CONFIG","GET"] ++ [encode parameter] ) rpush :: (RedisCtx m f) => ByteString -- ^ key -> [ByteString] -- ^ value -> m (f Integer) rpush key value = sendRequest (["RPUSH"] ++ [encode key] ++ map encode value ) randomkey :: (RedisCtx m f) => m (f (Maybe ByteString)) randomkey = sendRequest (["RANDOMKEY"] ) hsetnx :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ field -> ByteString -- ^ value -> m (f Bool) hsetnx key field value = sendRequest (["HSETNX"] ++ [encode key] ++ [encode field] ++ [encode value] ) mset :: (RedisCtx m f) => [(ByteString,ByteString)] -- ^ keyValue -> m (f Status) mset keyValue = sendRequest (["MSET"] ++ concatMap (\(x,y) -> [encode x,encode y])keyValue ) setex :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ seconds -> ByteString -- ^ value -> m (f Status) setex key seconds value = sendRequest (["SETEX"] ++ [encode key] ++ [encode seconds] ++ [encode value] ) psetex :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ milliseconds -> ByteString -- ^ value -> m (f Status) psetex key milliseconds value = sendRequest (["PSETEX"] ++ [encode key] ++ [encode milliseconds] ++ [encode value] ) scard :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) scard key = sendRequest (["SCARD"] ++ [encode key] ) scriptExists :: (RedisCtx m f) => [ByteString] -- ^ script -> m (f [Bool]) scriptExists script = sendRequest (["SCRIPT","EXISTS"] ++ map encode script ) sunionstore :: (RedisCtx m f) => ByteString -- ^ destination -> [ByteString] -- ^ key -> m (f Integer) sunionstore destination key = sendRequest (["SUNIONSTORE"] ++ [encode destination] ++ map encode key ) persist :: (RedisCtx m f) => ByteString -- ^ key -> m (f Bool) persist key = sendRequest (["PERSIST"] ++ [encode key] ) strlen :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) strlen key = sendRequest (["STRLEN"] ++ [encode key] ) lpushx :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ value -> m (f Integer) lpushx key value = sendRequest (["LPUSHX"] ++ [encode key] ++ [encode value] ) hset :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ field -> ByteString -- ^ value -> m (f Integer) hset key field value = sendRequest (["HSET"] ++ [encode key] ++ [encode field] ++ [encode value] ) brpoplpush :: (RedisCtx m f) => ByteString -- ^ source -> ByteString -- ^ destination -> Integer -- ^ timeout -> m (f (Maybe ByteString)) brpoplpush source destination timeout = sendRequest (["BRPOPLPUSH"] ++ [encode source] ++ [encode destination] ++ [encode timeout] ) zrevrank :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ member -> m (f (Maybe Integer)) zrevrank key member = sendRequest (["ZREVRANK"] ++ [encode key] ++ [encode member] ) scriptKill :: (RedisCtx m f) => m (f Status) scriptKill = sendRequest (["SCRIPT","KILL"] ) setrange :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ offset -> ByteString -- ^ value -> m (f Integer) setrange key offset value = sendRequest (["SETRANGE"] ++ [encode key] ++ [encode offset] ++ [encode value] ) del :: (RedisCtx m f) => [ByteString] -- ^ key -> m (f Integer) del key = sendRequest (["DEL"] ++ map encode key ) hincrbyfloat :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ field -> Double -- ^ increment -> m (f Double) hincrbyfloat key field increment = sendRequest (["HINCRBYFLOAT"] ++ [encode key] ++ [encode field] ++ [encode increment] ) hincrby :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ field -> Integer -- ^ increment -> m (f Integer) hincrby key field increment = sendRequest (["HINCRBY"] ++ [encode key] ++ [encode field] ++ [encode increment] ) zremrangebylex :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ min -> ByteString -- ^ max -> m (f Integer) zremrangebylex key min max = sendRequest (["ZREMRANGEBYLEX"] ++ [encode key] ++ [encode min] ++ [encode max] ) rpop :: (RedisCtx m f) => ByteString -- ^ key -> m (f (Maybe ByteString)) rpop key = sendRequest (["RPOP"] ++ [encode key] ) rename :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ newkey -> m (f Status) rename key newkey = sendRequest (["RENAME"] ++ [encode key] ++ [encode newkey] ) zrem :: (RedisCtx m f) => ByteString -- ^ key -> [ByteString] -- ^ member -> m (f Integer) zrem key member = sendRequest (["ZREM"] ++ [encode key] ++ map encode member ) hexists :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ field -> m (f Bool) hexists key field = sendRequest (["HEXISTS"] ++ [encode key] ++ [encode field] ) clientGetname :: (RedisCtx m f) => m (f Status) clientGetname = sendRequest (["CLIENT","GETNAME"] ) configRewrite :: (RedisCtx m f) => m (f Status) configRewrite = sendRequest (["CONFIG","REWRITE"] ) decr :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) decr key = sendRequest (["DECR"] ++ [encode key] ) hmget :: (RedisCtx m f) => ByteString -- ^ key -> [ByteString] -- ^ field -> m (f [Maybe ByteString]) hmget key field = sendRequest (["HMGET"] ++ [encode key] ++ map encode field ) lrange :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ start -> Integer -- ^ stop -> m (f [ByteString]) lrange key start stop = sendRequest (["LRANGE"] ++ [encode key] ++ [encode start] ++ [encode stop] ) decrby :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ decrement -> m (f Integer) decrby key decrement = sendRequest (["DECRBY"] ++ [encode key] ++ [encode decrement] ) llen :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) llen key = sendRequest (["LLEN"] ++ [encode key] ) append :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ value -> m (f Integer) append key value = sendRequest (["APPEND"] ++ [encode key] ++ [encode value] ) incr :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) incr key = sendRequest (["INCR"] ++ [encode key] ) hget :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ field -> m (f (Maybe ByteString)) hget key field = sendRequest (["HGET"] ++ [encode key] ++ [encode field] ) pexpireat :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ millisecondsTimestamp -> m (f Bool) pexpireat key millisecondsTimestamp = sendRequest (["PEXPIREAT"] ++ [encode key] ++ [encode millisecondsTimestamp] ) ltrim :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ start -> Integer -- ^ stop -> m (f Status) ltrim key start stop = sendRequest (["LTRIM"] ++ [encode key] ++ [encode start] ++ [encode stop] ) zcard :: (RedisCtx m f) => ByteString -- ^ key -> m (f Integer) zcard key = sendRequest (["ZCARD"] ++ [encode key] ) lset :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ index -> ByteString -- ^ value -> m (f Status) lset key index value = sendRequest (["LSET"] ++ [encode key] ++ [encode index] ++ [encode value] ) expireat :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ timestamp -> m (f Bool) expireat key timestamp = sendRequest (["EXPIREAT"] ++ [encode key] ++ [encode timestamp] ) save :: (RedisCtx m f) => m (f Status) save = sendRequest (["SAVE"] ) move :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ db -> m (f Bool) move key db = sendRequest (["MOVE"] ++ [encode key] ++ [encode db] ) getbit :: (RedisCtx m f) => ByteString -- ^ key -> Integer -- ^ offset -> m (f Integer) getbit key offset = sendRequest (["GETBIT"] ++ [encode key] ++ [encode offset] ) msetnx :: (RedisCtx m f) => [(ByteString,ByteString)] -- ^ keyValue -> m (f Bool) msetnx keyValue = sendRequest (["MSETNX"] ++ concatMap (\(x,y) -> [encode x,encode y])keyValue ) commandInfo :: (RedisCtx m f) => [ByteString] -- ^ commandName -> m (f [ByteString]) commandInfo commandName = sendRequest (["COMMAND","INFO"] ++ map encode commandName ) quit :: (RedisCtx m f) => m (f Status) quit = sendRequest (["QUIT"] ) blpop :: (RedisCtx m f) => [ByteString] -- ^ key -> Integer -- ^ timeout -> m (f (Maybe (ByteString,ByteString))) blpop key timeout = sendRequest (["BLPOP"] ++ map encode key ++ [encode timeout] ) srem :: (RedisCtx m f) => ByteString -- ^ key -> [ByteString] -- ^ member -> m (f Integer) srem key member = sendRequest (["SREM"] ++ [encode key] ++ map encode member ) echo :: (RedisCtx m f) => ByteString -- ^ message -> m (f ByteString) echo message = sendRequest (["ECHO"] ++ [encode message] ) sismember :: (RedisCtx m f) => ByteString -- ^ key -> ByteString -- ^ member -> m (f Bool) sismember key member = sendRequest (["SISMEMBER"] ++ [encode key] ++ [encode member] ) hedis-0.15.2/src/Database/Redis/Connection.hs0000644000000000000000000002404607346545000017066 0ustar0000000000000000{-# LANGUAGE TupleSections #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} module Database.Redis.Connection where import Control.Exception import qualified Control.Monad.Catch as Catch import Control.Monad.IO.Class(liftIO, MonadIO) import Control.Monad(when) import Control.Concurrent.MVar(MVar, newMVar) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as Char8 import Data.Functor(void) import qualified Data.IntMap.Strict as IntMap import Data.Pool(Pool, withResource, createPool, destroyAllResources) import Data.Typeable import qualified Data.Time as Time import Network.TLS (ClientParams) import qualified Network.Socket as NS import qualified Data.HashMap.Strict as HM import qualified Database.Redis.ProtocolPipelining as PP import Database.Redis.Core(Redis, runRedisInternal, runRedisClusteredInternal) 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 , clusterSlots , command , ClusterSlotsResponse(..) , ClusterSlotsResponseEntry(..) , ClusterSlotsNode(..)) -------------------------------------------------------------------------------- -- Connection -- -- |A threadsafe pool of network connections to a Redis server. Use the -- 'connect' function to create one. data Connection = NonClusteredConnection (Pool PP.Connection) | ClusteredConnection (MVar ShardMap) (Pool Cluster.Connection) -- |Information for connnecting to a Redis server. -- -- It is recommended to not use the 'ConnInfo' data constructor directly. -- Instead use 'defaultConnectInfo' and update it with record syntax. For -- example to connect to a password protected Redis server running on localhost -- and listening to the default port: -- -- @ -- myConnectInfo :: ConnectInfo -- myConnectInfo = defaultConnectInfo {connectAuth = Just \"secret\"} -- @ -- data ConnectInfo = ConnInfo { connectHost :: NS.HostName -- ^ Ignored when 'connectPort' is a 'UnixSocket' , connectPort :: CC.PortID , connectAuth :: Maybe B.ByteString -- ^ When the server is protected by a password, set 'connectAuth' to 'Just' -- the password. Each connection will then authenticate by the 'auth' -- command. , connectDatabase :: Integer -- ^ Each connection will 'select' the database with the given index. , connectMaxConnections :: Int -- ^ Maximum number of connections to keep open. The smallest acceptable -- value is 1. , connectMaxIdleTime :: Time.NominalDiffTime -- ^ Amount of time for which an unused connection is kept open. The -- smallest acceptable value is 0.5 seconds. If the @timeout@ value in -- your redis.conf file is non-zero, it should be larger than -- 'connectMaxIdleTime'. , connectTimeout :: Maybe Time.NominalDiffTime -- ^ Optional timeout until connection to Redis gets -- established. 'ConnectTimeoutException' gets thrown if no socket -- get connected in this interval of time. , connectTLSParams :: Maybe ClientParams -- ^ Optional TLS parameters. TLS will be enabled if this is provided. } deriving Show data ConnectError = ConnectAuthError Reply | ConnectSelectError Reply deriving (Eq, Show, Typeable) instance Exception ConnectError -- |Default information for connecting: -- -- @ -- connectHost = \"localhost\" -- connectPort = PortNumber 6379 -- Redis default port -- connectAuth = Nothing -- No password -- connectDatabase = 0 -- SELECT database 0 -- connectMaxConnections = 50 -- Up to 50 connections -- connectMaxIdleTime = 30 -- Keep open for 30 seconds -- connectTimeout = Nothing -- Don't add timeout logic -- connectTLSParams = Nothing -- Do not use TLS -- @ -- defaultConnectInfo :: ConnectInfo defaultConnectInfo = ConnInfo { connectHost = "localhost" , connectPort = CC.PortNumber 6379 , connectAuth = Nothing , connectDatabase = 0 , connectMaxConnections = 50 , connectMaxIdleTime = 30 , connectTimeout = Nothing , connectTLSParams = Nothing } createConnection :: ConnectInfo -> IO PP.Connection createConnection ConnInfo{..} = do let timeoutOptUs = round . (1000000 *) <$> connectTimeout conn <- PP.connect connectHost connectPort timeoutOptUs conn' <- case connectTLSParams of Nothing -> return conn Just tlsParams -> PP.enableTLS tlsParams conn PP.beginReceiving conn' runRedisInternal conn' $ do -- AUTH case connectAuth of Nothing -> return () Just pass -> do resp <- auth pass case resp of Left r -> liftIO $ throwIO $ ConnectAuthError r _ -> return () -- SELECT when (connectDatabase /= 0) $ do resp <- select connectDatabase case resp of Left r -> liftIO $ throwIO $ ConnectSelectError r _ -> return () return conn' -- |Constructs a 'Connection' pool to a Redis server designated by the -- given 'ConnectInfo'. The first connection is not actually established -- until the first call to the server. connect :: ConnectInfo -> IO Connection connect cInfo@ConnInfo{..} = NonClusteredConnection <$> createPool (createConnection cInfo) PP.disconnect 1 connectMaxIdleTime connectMaxConnections -- |Constructs a 'Connection' pool to a Redis server designated by the -- given 'ConnectInfo', then tests if the server is actually there. -- Throws an exception if the connection to the Redis server can't be -- established. checkedConnect :: ConnectInfo -> IO Connection checkedConnect connInfo = do conn <- connect connInfo runRedis conn $ void ping return conn -- |Destroy all idle resources in the pool. disconnect :: Connection -> IO () disconnect (NonClusteredConnection pool) = destroyAllResources pool disconnect (ClusteredConnection _ pool) = destroyAllResources pool -- | Memory bracket around 'connect' and 'disconnect'. withConnect :: (Catch.MonadMask m, MonadIO m) => ConnectInfo -> (Connection -> m c) -> m c withConnect connInfo = Catch.bracket (liftIO $ connect connInfo) (liftIO . disconnect) -- | Memory bracket around 'checkedConnect' and 'disconnect' withCheckedConnect :: ConnectInfo -> (Connection -> IO c) -> IO c withCheckedConnect connInfo = bracket (checkedConnect connInfo) disconnect -- |Interact with a Redis datastore specified by the given 'Connection'. -- -- Each call of 'runRedis' takes a network connection from the 'Connection' -- pool and runs the given 'Redis' action. Calls to 'runRedis' may thus block -- while all connections from the pool are in use. runRedis :: Connection -> Redis a -> IO a runRedis (NonClusteredConnection pool) redis = withResource pool $ \conn -> runRedisInternal conn redis runRedis (ClusteredConnection _ pool) redis = withResource pool $ \conn -> runRedisClusteredInternal conn (refreshShardMap conn) redis newtype ClusterConnectError = ClusterConnectError Reply deriving (Eq, Show, Typeable) instance Exception ClusterConnectError -- |Constructs a 'ShardMap' of connections to clustered nodes. The argument is -- a 'ConnectInfo' for any node in the cluster -- -- Some Redis commands are currently not supported in cluster mode -- - CONFIG, AUTH -- - SCAN -- - MOVE, SELECT -- - PUBLISH, SUBSCRIBE, PSUBSCRIBE, UNSUBSCRIBE, PUNSUBSCRIBE, RESET connectCluster :: ConnectInfo -> IO Connection connectCluster bootstrapConnInfo = do conn <- createConnection bootstrapConnInfo 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 shardMapFromClusterSlotsResponse :: ClusterSlotsResponse -> IO ShardMap shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr mkShardMap (pure IntMap.empty) clusterSlotsResponseEntries where mkShardMap :: ClusterSlotsResponseEntry -> IO (IntMap.IntMap Shard) -> IO (IntMap.IntMap Shard) mkShardMap ClusterSlotsResponseEntry{..} accumulator = do accumulated <- accumulator let master = nodeFromClusterSlotNode True clusterSlotsResponseEntryMaster let replicas = map (nodeFromClusterSlotNode False) clusterSlotsResponseEntryReplicas let shard = Shard master replicas let slotMap = IntMap.fromList $ map (, shard) [clusterSlotsResponseEntryStartSlot..clusterSlotsResponseEntryEndSlot] return $ IntMap.union slotMap accumulated nodeFromClusterSlotNode :: Bool -> ClusterSlotsNode -> Node nodeFromClusterSlotNode isMaster ClusterSlotsNode{..} = let hostname = Char8.unpack clusterSlotsNodeIP role = if isMaster then Cluster.Master else Cluster.Slave in Cluster.Node clusterSlotsNodeID role hostname (toEnum clusterSlotsNodePort) refreshShardMap :: Cluster.Connection -> IO ShardMap refreshShardMap (Cluster.Connection nodeConns _ _ _) = do let (Cluster.NodeConnection ctx _ _) = head $ HM.elems nodeConns pipelineConn <- PP.fromCtx ctx _ <- PP.beginReceiving pipelineConn slotsResponse <- runRedisInternal pipelineConn clusterSlots case slotsResponse of Left e -> throwIO $ ClusterConnectError e Right slots -> shardMapFromClusterSlotsResponse slots hedis-0.15.2/src/Database/Redis/ConnectionContext.hs0000644000000000000000000001235707346545000020435 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Database.Redis.ConnectionContext ( ConnectionContext(..) , ConnectTimeout(..) , ConnectionLostException(..) , PortID(..) , connect , disconnect , send , recv , errConnClosed , enableTLS , flush , ioErrorToConnLost ) where import Control.Concurrent (threadDelay) import Control.Concurrent.Async (race) import Control.Monad(when) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import qualified Data.IORef as IOR import Control.Concurrent.MVar(newMVar, readMVar, swapMVar) import Control.Exception(bracketOnError, Exception, throwIO, try) import Data.Typeable import Data.Functor(void) import qualified Network.Socket as NS import qualified Network.TLS as TLS import System.IO(Handle, hSetBinaryMode, hClose, IOMode(..), hFlush, hIsOpen) import System.IO.Error(catchIOError) data ConnectionContext = NormalHandle Handle | TLSContext TLS.Context instance Show ConnectionContext where show (NormalHandle _) = "NormalHandle" show (TLSContext _) = "TLSContext" data Connection = Connection { ctx :: ConnectionContext , lastRecvRef :: IOR.IORef (Maybe B.ByteString) } instance Show Connection where show Connection{..} = "Connection{ ctx = " ++ show ctx ++ ", lastRecvRef = IORef}" data ConnectPhase = PhaseUnknown | PhaseResolve | PhaseOpenSocket deriving (Show) newtype ConnectTimeout = ConnectTimeout ConnectPhase deriving (Show, Typeable) instance Exception ConnectTimeout data ConnectionLostException = ConnectionLost deriving Show instance Exception ConnectionLostException data PortID = PortNumber NS.PortNumber | UnixSocket String deriving (Eq, Show) connect :: NS.HostName -> PortID -> Maybe Int -> IO ConnectionContext connect hostName portId timeoutOpt = bracketOnError hConnect hClose $ \h -> do hSetBinaryMode h True return $ NormalHandle h where hConnect = do phaseMVar <- newMVar PhaseUnknown let doConnect = hConnect' phaseMVar case timeoutOpt of Nothing -> doConnect Just micros -> do result <- race doConnect (threadDelay micros) case result of Left h -> return h Right () -> do phase <- readMVar phaseMVar errConnectTimeout phase hConnect' mvar = bracketOnError createSock NS.close $ \sock -> do NS.setSocketOption sock NS.KeepAlive 1 void $ swapMVar mvar PhaseResolve void $ swapMVar mvar PhaseOpenSocket NS.socketToHandle sock ReadWriteMode where createSock = case portId of PortNumber portNumber -> do addrInfo <- getHostAddrInfo hostName portNumber connectSocket addrInfo UnixSocket addr -> bracketOnError (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol) NS.close (\sock -> NS.connect sock (NS.SockAddrUnix addr) >> return sock) getHostAddrInfo :: NS.HostName -> NS.PortNumber -> IO [NS.AddrInfo] getHostAddrInfo hostname port = NS.getAddrInfo (Just hints) (Just hostname) (Just $ show port) where hints = NS.defaultHints { NS.addrSocketType = NS.Stream } errConnectTimeout :: ConnectPhase -> IO a errConnectTimeout phase = throwIO $ ConnectTimeout phase connectSocket :: [NS.AddrInfo] -> IO NS.Socket connectSocket [] = error "connectSocket: unexpected empty list" connectSocket (addr:rest) = tryConnect >>= \case Right sock -> return sock Left err -> if null rest then throwIO err else connectSocket rest where tryConnect :: IO (Either IOError NS.Socket) tryConnect = bracketOnError createSock NS.close $ \sock -> try (NS.connect sock $ NS.addrAddress addr) >>= \case Right () -> return (Right sock) Left err -> NS.close sock >> return (Left err) where createSock = NS.socket (NS.addrFamily addr) (NS.addrSocketType addr) (NS.addrProtocol addr) send :: ConnectionContext -> B.ByteString -> IO () send (NormalHandle h) requestData = ioErrorToConnLost (B.hPut h requestData) send (TLSContext ctx) requestData = ioErrorToConnLost (TLS.sendData ctx (LB.fromStrict requestData)) recv :: ConnectionContext -> IO B.ByteString recv (NormalHandle h) = ioErrorToConnLost $ B.hGetSome h 4096 recv (TLSContext ctx) = TLS.recvData ctx ioErrorToConnLost :: IO a -> IO a ioErrorToConnLost a = a `catchIOError` const errConnClosed errConnClosed :: IO a errConnClosed = throwIO ConnectionLost enableTLS :: TLS.ClientParams -> ConnectionContext -> IO ConnectionContext enableTLS tlsParams (NormalHandle h) = do ctx <- TLS.contextNew h tlsParams TLS.handshake ctx return $ TLSContext ctx enableTLS _ c@(TLSContext _) = return c disconnect :: ConnectionContext -> IO () disconnect (NormalHandle h) = do open <- hIsOpen h when open $ hClose h disconnect (TLSContext ctx) = do TLS.bye ctx TLS.contextClose ctx flush :: ConnectionContext -> IO () flush (NormalHandle h) = hFlush h flush (TLSContext c) = TLS.contextFlush c hedis-0.15.2/src/Database/Redis/Core.hs0000644000000000000000000000744107346545000015657 0ustar0000000000000000{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, RecordWildCards, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, CPP, DeriveDataTypeable, StandaloneDeriving #-} module Database.Redis.Core ( Redis(), unRedis, reRedis, RedisCtx(..), MonadRedis(..), send, recv, sendRequest, runRedisInternal, runRedisClusteredInternal, RedisEnv(..), ) where import Prelude #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Monad.Reader import qualified Data.ByteString as B import Data.IORef import Database.Redis.Core.Internal import Database.Redis.Protocol import qualified Database.Redis.ProtocolPipelining as PP import Database.Redis.Types import Database.Redis.Cluster(ShardMap) import qualified Database.Redis.Cluster as Cluster -------------------------------------------------------------------------------- -- The Redis Monad -- -- |This class captures the following behaviour: In a context @m@, a command -- will return its result wrapped in a \"container\" of type @f@. -- -- Please refer to the Command Type Signatures section of this page for more -- information. class (MonadRedis m) => RedisCtx m f | m -> f where returnDecode :: RedisResult a => Reply -> m (f a) class (Monad m) => MonadRedis m where liftRedis :: Redis a -> m a instance RedisCtx Redis (Either Reply) where returnDecode = return . decode instance MonadRedis Redis where liftRedis = id -- |Deconstruct Redis constructor. -- -- 'unRedis' and 'reRedis' can be used to define instances for -- arbitrary typeclasses. -- -- WARNING! These functions are considered internal and no guarantee -- is given at this point that they will not break in future. unRedis :: Redis a -> ReaderT RedisEnv IO a unRedis (Redis r) = r -- |Reconstruct Redis constructor. reRedis :: ReaderT RedisEnv IO a -> Redis a reRedis r = Redis r -- |Internal version of 'runRedis' that does not depend on the 'Connection' -- abstraction. Used to run the AUTH command when connecting. runRedisInternal :: PP.Connection -> Redis a -> IO a runRedisInternal conn (Redis redis) = do -- Dummy reply in case no request is sent. ref <- newIORef (SingleLine "nobody will ever see this") r <- runReaderT redis (NonClusteredEnv conn ref) -- Evaluate last reply to keep lazy IO inside runRedis. readIORef ref >>= (`seq` return ()) return r 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 setLastReply :: Reply -> ReaderT RedisEnv IO () setLastReply r = do ref <- asks envLastReply lift (writeIORef ref r) recv :: (MonadRedis m) => m Reply recv = liftRedis $ Redis $ do conn <- asks envConn r <- liftIO (PP.recv conn) setLastReply r return r send :: (MonadRedis m) => [B.ByteString] -> m () send req = liftRedis $ Redis $ do conn <- asks envConn liftIO $ PP.send conn (renderRequest req) -- |'sendRequest' can be used to implement commands from experimental -- versions of Redis. An example of how to implement a command is given -- below. -- -- @ -- -- |Redis DEBUG OBJECT command -- debugObject :: ByteString -> 'Redis' (Either 'Reply' ByteString) -- debugObject key = 'sendRequest' [\"DEBUG\", \"OBJECT\", key] -- @ -- sendRequest :: (RedisCtx m f, RedisResult a) => [B.ByteString] -> m (f a) sendRequest req = do r' <- liftRedis $ Redis $ do env <- ask case env of NonClusteredEnv{..} -> do r <- liftIO $ PP.request envConn (renderRequest req) setLastReply r return r ClusteredEnv{..} -> liftIO $ Cluster.requestPipelined refreshAction connection req returnDecode r' hedis-0.15.2/src/Database/Redis/Core/0000755000000000000000000000000007346545000015315 5ustar0000000000000000hedis-0.15.2/src/Database/Redis/Core/Internal.hs0000644000000000000000000000215107346545000017424 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Database.Redis.Core.Internal where #if __GLASGOW_HASKELL__ > 711 && __GLASGOW_HASKELL__ < 808 import Control.Monad.Fail (MonadFail) #endif import Control.Monad.Reader import Data.IORef import Database.Redis.Protocol import Control.Monad.IO.Unlift (MonadUnliftIO) import qualified Database.Redis.ProtocolPipelining as PP import qualified Database.Redis.Cluster as Cluster -- |Context for normal command execution, outside of transactions. Use -- 'runRedis' to run actions of this type. -- -- In this context, each result is wrapped in an 'Either' to account for the -- possibility of Redis returning an 'Error' reply. newtype Redis a = Redis (ReaderT RedisEnv IO a) deriving (Monad, MonadIO, Functor, Applicative, MonadUnliftIO) #if __GLASGOW_HASKELL__ > 711 deriving instance MonadFail Redis #endif data RedisEnv = NonClusteredEnv { envConn :: PP.Connection, envLastReply :: IORef Reply } | ClusteredEnv { refreshAction :: IO Cluster.ShardMap , connection :: Cluster.Connection } hedis-0.15.2/src/Database/Redis/ManualCommands.hs0000644000000000000000000013111207346545000017657 0ustar0000000000000000{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, FlexibleContexts #-} module Database.Redis.ManualCommands where import Prelude hiding (min, max) 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"] hedis-0.15.2/src/Database/Redis/Protocol.hs0000644000000000000000000000516607346545000016572 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} module Database.Redis.Protocol (Reply(..), reply, renderRequest) where import Prelude hiding (error, take) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.DeepSeq import Scanner (Scanner) import qualified Scanner import Data.ByteString.Char8 (ByteString) import GHC.Generics import qualified Data.ByteString.Char8 as B import qualified Data.Text.Encoding as Text import qualified Data.Text.Read as Text import Control.Monad (replicateM) -- |Low-level representation of replies from the Redis server. data Reply = SingleLine ByteString | Error ByteString | Integer Integer | Bulk (Maybe ByteString) | MultiBulk (Maybe [Reply]) deriving (Eq, Show, Generic) instance NFData Reply ------------------------------------------------------------------------------ -- Request -- renderRequest :: [ByteString] -> ByteString renderRequest req = B.concat (argCnt:args) where argCnt = B.concat ["*", showBS (length req), crlf] args = map renderArg req renderArg :: ByteString -> ByteString renderArg arg = B.concat ["$", argLen arg, crlf, arg, crlf] where argLen = showBS . B.length showBS :: (Show a) => a -> ByteString showBS = B.pack . show crlf :: ByteString crlf = "\r\n" ------------------------------------------------------------------------------ -- Reply parsers -- {-# INLINE reply #-} reply :: Scanner Reply reply = do c <- Scanner.anyChar8 case c of '+' -> string '-' -> error ':' -> integer '$' -> bulk '*' -> multi _ -> fail "Unknown reply type" {-# INLINE string #-} string :: Scanner Reply string = SingleLine <$> line {-# INLINE error #-} error :: Scanner Reply error = Error <$> line {-# INLINE integer #-} integer :: Scanner Reply integer = Integer <$> integral {-# INLINE bulk #-} bulk :: Scanner Reply bulk = Bulk <$> do len <- integral if len < 0 then return Nothing else Just <$> Scanner.take len <* eol -- don't inline it to break the circle between reply and multi {-# NOINLINE multi #-} multi :: Scanner Reply multi = MultiBulk <$> do len <- integral if len < 0 then return Nothing else Just <$> replicateM len reply {-# INLINE integral #-} integral :: Integral i => Scanner i integral = do str <- line case Text.signed Text.decimal (Text.decodeUtf8 str) of Left err -> fail (show err) Right (l, _) -> return l {-# INLINE line #-} line :: Scanner ByteString line = Scanner.takeWhileChar8 (/= '\r') <* eol {-# INLINE eol #-} eol :: Scanner () eol = do Scanner.char8 '\r' Scanner.char8 '\n' hedis-0.15.2/src/Database/Redis/ProtocolPipelining.hs0000644000000000000000000001303207346545000020600 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -- |A module for automatic, optimal protocol pipelining. -- -- Protocol pipelining is a technique in which multiple requests are written -- out to a single socket without waiting for the corresponding responses. -- The pipelining of requests results in a dramatic improvement in protocol -- performance. -- -- [Optimal Pipelining] uses the least number of network packets possible -- -- [Automatic Pipelining] means that requests are implicitly pipelined as much -- as possible, i.e. as long as a request's response is not used before any -- subsequent requests. -- module Database.Redis.ProtocolPipelining ( Connection, connect, enableTLS, beginReceiving, disconnect, request, send, recv, flush, fromCtx ) where import Prelude import Control.Monad 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 data Connection = Conn { connCtx :: CC.ConnectionContext -- ^ Connection socket-handle. , connReplies :: IORef [Reply] -- ^ Reply thunks for unsent requests. , connPending :: IORef [Reply] -- ^ Reply thunks for requests "in the pipeline". Refers to the same list as -- 'connReplies', but can have an offset. , connPendingCnt :: IORef Int -- ^ Number of pending replies and thus the difference length between -- 'connReplies' and 'connPending'. -- length connPending - pendingCount = length connReplies } fromCtx :: CC.ConnectionContext -> IO Connection fromCtx ctx = Conn ctx <$> newIORef [] <*> newIORef [] <*> newIORef 0 connect :: NS.HostName -> CC.PortID -> Maybe Int -> IO Connection connect hostName portId timeoutOpt = do connCtx <- CC.connect hostName portId timeoutOpt 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 writeIORef (connReplies conn) rs writeIORef (connPending conn) rs disconnect :: Connection -> IO () disconnect Conn{..} = CC.disconnect connCtx -- |Write the request to the socket output buffer, without actually sending. -- The 'Handle' is 'hFlush'ed when reading replies from the 'connCtx'. send :: Connection -> S.ByteString -> IO () send Conn{..} s = do CC.send connCtx s -- Signal that we expect one more reply from Redis. n <- atomicModifyIORef' connPendingCnt $ \n -> let n' = n+1 in (n', n') -- Limit the "pipeline length". This is necessary in long pipelines, to avoid -- thunk build-up, and thus space-leaks. -- TODO find smallest max pending with good-enough performance. when (n >= 1000) $ do -- Force oldest pending reply. r:_ <- readIORef connPending r `seq` return () -- |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 -- | 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 -- change requests. flush :: Connection -> IO () flush Conn{..} = CC.flush connCtx -- |Send a request and receive the corresponding reply request :: Connection -> S.ByteString -> IO Reply request conn req = send conn req >> recv conn -- |A list of all future 'Reply's of the 'Connection'. -- -- The spine of the list can be evaluated without forcing the replies. -- -- Evaluating/forcing a 'Reply' from the list will 'unsafeInterleaveIO' the -- reading and parsing from the 'connCtx'. To ensure correct ordering, each -- Reply first evaluates (and thus reads from the network) the previous one. -- -- 'unsafeInterleaveIO' only evaluates it's result once, making this function -- thread-safe. 'Handle' as implemented by GHC is also threadsafe, it is safe -- to call 'hFlush' here. The list constructor '(:)' must be called from -- /within/ unsafeInterleaveIO, to keep the replies in correct order. connGetReplies :: Connection -> IO [Reply] connGetReplies conn@Conn{..} = go S.empty (SingleLine "previous of first") where go rest previous = do -- lazy pattern match to actually delay the receiving ~(r, rest') <- unsafeInterleaveIO $ do -- Force previous reply for correct order. previous `seq` return () scanResult <- Scanner.scanWith readMore reply rest case scanResult of Scanner.Fail{} -> CC.errConnClosed Scanner.More{} -> error "Hedis: parseWith returned Partial" Scanner.Done rest' r -> do -- r is the same as 'head' of 'connPending'. Since we just -- received r, we remove it from the pending list. atomicModifyIORef' connPending $ \(_:rs) -> (rs, ()) -- 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), ()) return (r, rest') rs <- unsafeInterleaveIO (go rest' r) return (r:rs) readMore = CC.ioErrorToConnLost $ do flush conn CC.recv connCtx hedis-0.15.2/src/Database/Redis/PubSub.hs0000644000000000000000000007041207346545000016165 0ustar0000000000000000{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, EmptyDataDecls, FlexibleInstances, FlexibleContexts, GeneralizedNewtypeDeriving #-} module Database.Redis.PubSub ( publish, -- ** Subscribing to channels -- $pubsubexpl -- *** Single-thread Pub/Sub pubSub, Message(..), PubSub(), subscribe, unsubscribe, psubscribe, punsubscribe, -- *** Continuous Pub/Sub message controller pubSubForever, RedisChannel, RedisPChannel, MessageCallback, PMessageCallback, PubSubController, newPubSubController, currentChannels, currentPChannels, addChannels, addChannelsAndWait, removeChannels, removeChannelsAndWait, UnregisterCallbacksAction ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative import Data.Monoid hiding (<>) #endif import Control.Concurrent.Async (withAsync, waitEitherCatch, waitEitherCatchSTM) import Control.Concurrent.STM import Control.Exception (throwIO) import Control.Monad import Control.Monad.State import Data.ByteString.Char8 (ByteString) import Data.List (foldl') import Data.Maybe (isJust) import Data.Pool #if __GLASGOW_HASKELL__ < 808 import Data.Semigroup (Semigroup(..)) #endif import qualified Data.HashMap.Strict as HM import qualified Database.Redis.Core as Core import qualified Database.Redis.Connection as Connection import qualified Database.Redis.ProtocolPipelining as PP import Database.Redis.Protocol (Reply(..), renderRequest) import Database.Redis.Types -- |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 -- receive after a SUBSCRIBE or PSUBSCRIBE command. We can safely leave the -- PubSub mode when both these numbers are zero. data PubSubState = PubSubState { subCnt, pending :: Int } modifyPending :: (MonadState PubSubState m) => (Int -> Int) -> m () modifyPending f = modify $ \s -> s{ pending = f (pending s) } putSubCnt :: (MonadState PubSubState m) => Int -> m () putSubCnt n = modify $ \s -> s{ subCnt = n } data Subscribe data Unsubscribe data Channel data Pattern -- |Encapsulates subscription changes. Use 'subscribe', 'unsubscribe', -- 'psubscribe', 'punsubscribe' or 'mempty' to construct a value. Combine -- values by using the 'Monoid' interface, i.e. 'mappend' and 'mconcat'. data PubSub = PubSub { subs :: Cmd Subscribe Channel , unsubs :: Cmd Unsubscribe Channel , psubs :: Cmd Subscribe Pattern , punsubs :: Cmd Unsubscribe Pattern } deriving (Eq) instance Semigroup PubSub where (<>) p1 p2 = PubSub { subs = subs p1 `mappend` subs p2 , unsubs = unsubs p1 `mappend` unsubs p2 , psubs = psubs p1 `mappend` psubs p2 , punsubs = punsubs p1 `mappend` punsubs p2 } instance Monoid PubSub where mempty = PubSub mempty mempty mempty mempty mappend = (<>) data Cmd a b = DoNothing | Cmd { changes :: [ByteString] } deriving (Eq) instance Semigroup (Cmd Subscribe a) where (<>) DoNothing x = x (<>) x DoNothing = x (<>) (Cmd xs) (Cmd ys) = Cmd (xs ++ ys) instance Monoid (Cmd Subscribe a) where mempty = DoNothing mappend = (<>) instance Semigroup (Cmd Unsubscribe a) where (<>) DoNothing x = x (<>) x DoNothing = x -- empty subscription list => unsubscribe all channels and patterns (<>) (Cmd []) _ = Cmd [] (<>) _ (Cmd []) = Cmd [] (<>) (Cmd xs) (Cmd ys) = Cmd (xs ++ ys) instance Monoid (Cmd Unsubscribe a) where mempty = DoNothing mappend = (<>) class Command a where redisCmd :: a -> ByteString updatePending :: a -> Int -> Int 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 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 plusChangeCnt :: Cmd a b -> Int -> Int plusChangeCnt DoNothing = id plusChangeCnt (Cmd cs) = (+ length cs) instance Command (Cmd Subscribe Channel) where redisCmd = const "SUBSCRIBE" updatePending = plusChangeCnt instance Command (Cmd Subscribe Pattern) where redisCmd = const "PSUBSCRIBE" updatePending = plusChangeCnt instance Command (Cmd Unsubscribe Channel) where redisCmd = const "UNSUBSCRIBE" updatePending = const id instance Command (Cmd Unsubscribe Pattern) where redisCmd = const "PUNSUBSCRIBE" updatePending = const id data Message = Message { msgChannel, msgMessage :: ByteString} | PMessage { msgPattern, msgChannel, msgMessage :: ByteString} deriving (Show) data PubSubReply = Subscribed | Unsubscribed Int | Msg Message ------------------------------------------------------------------------------ -- Public Interface -- -- |Post a message to a channel (). publish :: (Core.RedisCtx m f) => ByteString -- ^ channel -> ByteString -- ^ message -> m (f Integer) publish channel message = Core.sendRequest ["PUBLISH", channel, message] -- |Listen for messages published to the given channels -- (). subscribe :: [ByteString] -- ^ channel -> PubSub subscribe [] = mempty subscribe cs = mempty{ subs = Cmd cs } -- |Stop listening for messages posted to the given channels -- (). unsubscribe :: [ByteString] -- ^ channel -> PubSub unsubscribe cs = mempty{ unsubs = Cmd cs } -- |Listen for messages published to channels matching the given patterns -- (). psubscribe :: [ByteString] -- ^ pattern -> PubSub psubscribe [] = mempty psubscribe ps = mempty{ psubs = Cmd ps } -- |Stop listening for messages posted to channels matching the given patterns -- (). punsubscribe :: [ByteString] -- ^ pattern -> PubSub punsubscribe ps = mempty{ punsubs = Cmd ps } -- |Listens to published messages on subscribed channels and channels matching -- the subscribed patterns. For documentation on the semantics of Redis -- Pub\/Sub see . -- -- The given callback function is called for each received message. -- Subscription changes are triggered by the returned 'PubSub'. To keep -- subscriptions unchanged, the callback can return 'mempty'. -- -- Example: Subscribe to the \"news\" channel indefinitely. -- -- @ -- pubSub (subscribe [\"news\"]) $ \\msg -> do -- putStrLn $ \"Message from \" ++ show (msgChannel msg) -- return mempty -- @ -- -- Example: Receive a single message from the \"chat\" channel. -- -- @ -- pubSub (subscribe [\"chat\"]) $ \\msg -> do -- putStrLn $ \"Message from \" ++ show (msgChannel msg) -- return $ unsubscribe [\"chat\"] -- @ -- -- It should be noted that Redis Pub\/Sub by its nature is asynchronous -- so returning `unsubscribe` does not mean that callback won't be able -- to receive any further messages. And to guarantee that you won't -- won't process messages after unsubscription and won't unsubscribe -- from the same channel more than once you need to use `IORef` or -- something similar -- pubSub :: PubSub -- ^ Initial subscriptions. -> (Message -> IO PubSub) -- ^ Callback function. -> Core.Redis () pubSub initial callback | initial == mempty = return () | otherwise = evalStateT (send initial) (PubSubState 0 0) where send :: PubSub -> StateT PubSubState Core.Redis () send PubSub{..} = do sendCmd subs sendCmd unsubs sendCmd psubs sendCmd punsubs recv recv :: StateT PubSubState Core.Redis () recv = do 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 -- | A Redis channel name type RedisChannel = ByteString -- | A Redis pattern channel name type RedisPChannel = ByteString -- | A handler for a message from a subscribed channel. -- The callback is passed the message content. -- -- Messages are processed synchronously in the receiving thread, so if the callback -- takes a long time it will block other callbacks and other messages from being -- received. If you need to move long-running work to a different thread, we suggest -- you use 'TBQueue' with a reasonable bound, so that if messages are arriving faster -- than you can process them, you do eventually block. -- -- If the callback throws an exception, the exception will be thrown from 'pubSubForever' -- which will cause the entire Redis connection for all subscriptions to be closed. -- As long as you call 'pubSubForever' in a loop you will reconnect to your subscribed -- channels, but you should probably add an exception handler to each callback to -- prevent this. type MessageCallback = ByteString -> IO () -- | A handler for a message from a psubscribed channel. -- The callback is passed the channel the message was sent on plus the message content. -- -- Similar to 'MessageCallback', callbacks are executed synchronously and any exceptions -- are rethrown from 'pubSubForever'. type PMessageCallback = RedisChannel -> ByteString -> IO () -- | An action that when executed will unregister the callbacks. It is returned from 'addChannels' -- or 'addChannelsAndWait' and typically you would use it in 'bracket' to guarantee that you -- unsubscribe from channels. For example, if you are using websockets to distribute messages to -- clients, you could use something such as: -- -- > websocketConn <- Network.WebSockets.acceptRequest pending -- > let mycallback msg = Network.WebSockets.sendTextData websocketConn msg -- > bracket (addChannelsAndWait ctrl [("hello", mycallback)] []) id $ const $ do -- > {- loop here calling Network.WebSockets.receiveData -} type UnregisterCallbacksAction = IO () newtype UnregisterHandle = UnregisterHandle Integer deriving (Eq, Show, Num) -- | 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. -- You should typically create the controller at the start of your program and then store it -- 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 , lastUsedCallbackId :: TVar UnregisterHandle } -- | 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 -- | 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) -- | 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) -- | 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 -- 'addChannelsAndWait' for that. -- -- You can subscribe to the same channel or pattern channel multiple times; the 'PubSubController' keeps -- a list of callbacks and executes each callback in response to a message. -- -- The return value is an action 'UnregisterCallbacksAction' which will unregister the callbacks, -- which should typically used with 'bracket'. addChannels :: MonadIO m => PubSubController -> [(RedisChannel, MessageCallback)] -- ^ the channels to subscribe to -> [(RedisPChannel, PMessageCallback)] -- ^ the channels to pattern subscribe to -> m UnregisterCallbacksAction addChannels _ [] [] = return $ return () addChannels ctrl newChans newPChans = liftIO $ do 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' 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). -- -- 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 -- 'ConnectionLost' and 'addChannelsAndWait' will continue to wait. Once you recall 'pubSubForever' -- with the same 'PubSubController', 'pubSubForever' will open a new connection, send subscription commands -- for all channels in the 'PubSubController' (which include the ones we are waiting for), -- and wait for the responses from Redis. Only once we receive the response from Redis that it has subscribed -- to all channels in 'PubSubController' will 'addChannelsAndWait' unblock and return. addChannelsAndWait :: MonadIO m => PubSubController -> [(RedisChannel, MessageCallback)] -- ^ the channels to subscribe to -> [(RedisPChannel, PMessageCallback)] -- ^ the channels to psubscribe to -> m UnregisterCallbacksAction addChannelsAndWait _ [] [] = return $ return () addChannelsAndWait ctrl newChans newPChans = do unreg <- addChannels ctrl newChans newPChans liftIO $ atomically $ do r <- readTVar (pendingCnt ctrl) when (r > 0) retry return unreg -- | 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 -- and Redis actually processes the unsubscribe request. This function is thread-safe. -- -- If you remove all channels, the connection in 'pubSubForever' to redis will stay open and waiting for -- any new channels from a call to 'addChannels'. If you really want to close the connection, -- use 'Control.Concurrent.killThread' or 'Control.Concurrent.Async.cancel' to kill the thread running -- 'pubSubForever'. removeChannels :: MonadIO m => PubSubController -> [RedisChannel] -> [RedisPChannel] -> 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) -- | 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 -- only worry about channels that exist let remChans = filter (\n -> HM.member n cm) chans remPChans = filter (\n -> HM.member n pm) pchans -- helper functions to filter out handlers that match let 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 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 -- maps after taking out channels matching the handle let cm' = foldl' removeHandles cm remChans pm' = foldl' removeHandles pm remPChans -- 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') -- do the unsubscribe writeTBQueue (sendChanges ctrl) ps writeTVar (callbacks ctrl) cm' writeTVar (pcallbacks ctrl) pm' modifyTVar (pendingCnt ctrl) (+ totalPendingChanges ps) return () -- | Call 'removeChannels' and then wait for all pending subscription change requests to be acknowledged -- by Redis. This uses the same waiting logic as 'addChannelsAndWait'. Since 'removeChannels' immediately -- notifies the 'PubSubController' to start discarding messages, you likely don't need this function and -- can just use 'removeChannels'. removeChannelsAndWait :: MonadIO m => PubSubController -> [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 -- | Internal thread which listens for messages and executes callbacks. -- This is the only thread which ever receives data from the underlying -- connection. listenThread :: PubSubController -> PP.Connection -> IO () 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) -- | Internal thread which sends subscription change requests. -- This is the only thread which ever sends data on the underlying -- connection. sendThread :: PubSubController -> PP.Connection -> IO () sendThread ctrl rawConn = forever $ do PubSub{..} <- atomically $ readTBQueue (sendChanges ctrl) rawSendCmd rawConn subs rawSendCmd rawConn unsubs rawSendCmd rawConn psubs rawSendCmd rawConn punsubs -- normally, the socket is flushed during 'recv', but -- 'recv' could currently be blocking on a message. PP.flush rawConn -- | Open a connection to the Redis server, register to all channels in the 'PubSubController', -- and process messages and subscription change requests forever. The only way this will ever -- exit is if there is an exception from the network code or an unhandled exception -- in a 'MessageCallback' or 'PMessageCallback'. For example, if the network connection to Redis -- dies, 'pubSubForever' will throw a 'ConnectionLost'. When such an exception is -- thrown, you can recall 'pubSubForever' with the same 'PubSubController' which will open a -- new connection and resubscribe to all the channels which are tracked in the 'PubSubController'. -- -- The general pattern is therefore during program startup create a 'PubSubController' and fork -- a thread which calls 'pubSubForever' in a loop (using an exponential backoff algorithm -- such as the package to not hammer the Redis -- server if it does die). For example, -- -- @ -- myhandler :: ByteString -> IO () -- myhandler msg = putStrLn $ unpack $ decodeUtf8 msg -- -- onInitialComplete :: IO () -- onInitialComplete = putStrLn "Redis acknowledged that mychannel is now subscribed" -- -- main :: IO () -- main = do -- conn <- connect defaultConnectInfo -- pubSubCtrl <- newPubSubController [("mychannel", myhandler)] [] -- concurrently ( forever $ -- pubSubForever conn pubSubCtrl onInitialComplete -- \`catch\` (\\(e :: SomeException) -> do -- putStrLn $ "Got error: " ++ show e -- threadDelay $ 50*1000) -- TODO: use exponential backoff -- ) $ restOfYourProgram -- -- -- {- elsewhere in your program, use pubSubCtrl to change subscriptions -} -- @ -- -- At most one active 'pubSubForever' can be running against a single 'PubSubController' at any time. If -- two active calls to 'pubSubForever' share a single 'PubSubController' there will be deadlocks. If -- you do want to process messages using multiple connections to Redis, you can create more than one -- 'PubSubController'. For example, create one PubSubController for each 'Control.Concurrent.getNumCapabilities' -- and then create a Haskell thread bound to each capability each calling 'pubSubForever' in a loop. -- This will create one network connection per controller/capability and allow you to -- register separate channels and callbacks for each controller, spreading the load across the capabilities. pubSubForever :: Connection.Connection -- ^ The connection pool -> PubSubController -- ^ The controller which keeps track of all subscriptions and handlers -> IO () -- ^ This action is executed once Redis acknowledges that all the subscriptions in -- the controller are now subscribed. You can use this after an exception (such as -- 'ConnectionLost') to signal that all subscriptions are now reactivated. -> IO () pubSubForever (Connection.NonClusteredConnection pool) ctrl onInitialLoad = withResource pool $ \rawConn -> do -- get initial subscriptions and write them into the queue. atomically $ do let loop = tryReadTBQueue (sendChanges ctrl) >>= \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) writeTBQueue (sendChanges ctrl) ps writeTVar (pendingCnt ctrl) (totalPendingChanges ps) withAsync (listenThread ctrl rawConn) $ \listenT -> withAsync (sendThread ctrl rawConn) $ \sendT -> do -- wait for initial subscription count to go to zero or for threads to fail mret <- atomically $ (Left <$> (waitEitherCatchSTM listenT sendT)) `orElse` (Right <$> (readTVar (pendingCnt ctrl) >>= \x -> if x > 0 then retry else return ())) case mret of Right () -> onInitialLoad _ -> return () -- if there is an error, waitEitherCatch below will also see it -- wait for threads to end with error merr <- waitEitherCatch listenT sendT case merr of (Right (Left err)) -> throwIO err (Left (Left err)) -> throwIO err _ -> return () -- should never happen, since threads exit only with an error pubSubForever (Connection.ClusteredConnection _ _) _ _ = undefined ------------------------------------------------------------------------------ -- Helpers -- decodeMsg :: Reply -> PubSubReply decodeMsg r@(MultiBulk (Just (r0:r1:r2:rs))) = either (errMsg r) id $ do kind <- decode r0 case kind :: ByteString of "message" -> Msg <$> decodeMessage "pmessage" -> Msg <$> decodePMessage "subscribe" -> return Subscribed "psubscribe" -> return Subscribed "unsubscribe" -> Unsubscribed <$> decodeCnt "punsubscribe" -> Unsubscribed <$> decodeCnt _ -> errMsg r where decodeMessage = Message <$> decode r1 <*> decode r2 decodePMessage = PMessage <$> decode r1 <*> decode r2 <*> decode (head rs) decodeCnt = fromInteger <$> decode r2 decodeMsg r = errMsg r errMsg :: Reply -> a errMsg r = error $ "Hedis: expected pub/sub-message but got: " ++ show r -- $pubsubexpl -- There are two Pub/Sub implementations. First, there is a single-threaded implementation 'pubSub' -- which is simpler to use but has the restriction that subscription changes can only be made in -- response to a message. Secondly, there is a more complicated Pub/Sub controller 'pubSubForever' -- that uses concurrency to support changing subscriptions at any time but requires more setup. -- You should only use one or the other. In addition, no types or utility functions (that are part -- of the public API) are shared, so functions or types in one of the following sections cannot -- be used for the other. In particular, be aware that they use different utility functions to subscribe -- and unsubscribe to channels. hedis-0.15.2/src/Database/Redis/Sentinel.hs0000644000000000000000000001761207346545000016551 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE StandaloneDeriving #-} -- | "Database.Redis" like interface with connection through Redis Sentinel. -- -- More details here: . -- -- Example: -- -- @ -- conn <- 'connect' 'SentinelConnectionInfo' (("localhost", PortNumber 26379) :| []) "mymaster" 'defaultConnectInfo' -- -- 'runRedis' conn $ do -- 'set' "hello" "world" -- @ -- -- When connection is opened, the Sentinels will be queried to get current master. Subsequent 'runRedis' -- calls will talk to that master. -- -- If 'runRedis' call fails, the next call will choose a new master to talk to. -- -- This implementation is based on Gist by Emanuel Borsboom -- at module Database.Redis.Sentinel ( -- * Connection SentinelConnectInfo(..) , SentinelConnection , connect -- * runRedis with Sentinel support , runRedis , RedisSentinelException(..) -- * Re-export Database.Redis , module Database.Redis ) where import Control.Concurrent import Control.Exception (Exception, IOException, evaluate, throwIO) import Control.Monad import Control.Monad.Catch (Handler (..), MonadCatch, catches, throwM) import Control.Monad.Except import 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 Database.Redis hiding (Connection, connect, runRedis) import qualified Database.Redis as Redis -- | Interact with a Redis datastore. See 'Database.Redis.runRedis' for details. runRedis :: SentinelConnection -> Redis (Either Reply a) -> IO (Either Reply a) runRedis (SentinelConnection connMVar) action = do (baseConn, preToken) <- modifyMVar connMVar $ \oldConnection@SentinelConnection' { rcCheckFailover , rcToken = oldToken , rcSentinelConnectInfo = oldConnectInfo , rcMasterConnectInfo = oldMasterConnectInfo , rcBaseConnection = oldBaseConnection } -> if rcCheckFailover then do (newConnectInfo, newMasterConnectInfo) <- updateMaster oldConnectInfo newToken <- newUnique (connInfo, conn) <- if sameHost newMasterConnectInfo oldMasterConnectInfo then return (oldMasterConnectInfo, oldBaseConnection) else do newConn <- Redis.connect newMasterConnectInfo return (newMasterConnectInfo, newConn) return ( SentinelConnection' { rcCheckFailover = False , rcToken = newToken , rcSentinelConnectInfo = newConnectInfo , rcMasterConnectInfo = connInfo , rcBaseConnection = conn } , (conn, newToken) ) else return (oldConnection, (oldBaseConnection, oldToken)) -- Use evaluate to make sure we catch exceptions from 'runRedis'. reply <- (Redis.runRedis baseConn action >>= evaluate) `catchRedisRethrow` (\_ -> setCheckSentinel preToken) case reply of Left (Error e) | "READONLY " `BS.isPrefixOf` e -> -- This means our connection has turned into a slave setCheckSentinel preToken _ -> return () return reply where sameHost :: Redis.ConnectInfo -> Redis.ConnectInfo -> Bool sameHost l r = connectHost l == connectHost r && connectPort l == connectPort r setCheckSentinel preToken = modifyMVar_ connMVar $ \conn@SentinelConnection'{rcToken} -> if preToken == rcToken then do newToken <- newUnique return (conn{rcToken = newToken, rcCheckFailover = True}) else return conn connect :: SentinelConnectInfo -> IO SentinelConnection connect origConnectInfo = do (connectInfo, masterConnectInfo) <- updateMaster origConnectInfo conn <- Redis.connect masterConnectInfo token <- newUnique SentinelConnection <$> newMVar SentinelConnection' { rcCheckFailover = False , rcToken = token , rcSentinelConnectInfo = connectInfo , rcMasterConnectInfo = masterConnectInfo , rcBaseConnection = conn } updateMaster :: SentinelConnectInfo -> IO (SentinelConnectInfo, Redis.ConnectInfo) updateMaster sci@SentinelConnectInfo{..} = do -- This is using the Either monad "backwards" -- Left means stop because we've made a connection, -- Right means try again. resultEither <- runExceptT $ forM_ connectSentinels $ \(host, port) -> do trySentinel host port `catchRedis` (\_ -> return ()) case resultEither of Left (conn, sentinelPair) -> return ( sci { connectSentinels = sentinelPair :| delete sentinelPair (toList connectSentinels) } , conn ) Right () -> throwIO $ NoSentinels connectSentinels where trySentinel :: HostName -> PortID -> ExceptT (Redis.ConnectInfo, (HostName, PortID)) IO () trySentinel sentinelHost sentinelPort = do -- bang to ensure exceptions from runRedis get thrown immediately. !replyE <- liftIO $ do !sentinelConn <- Redis.connect $ Redis.defaultConnectInfo { connectHost = sentinelHost , connectPort = sentinelPort , connectMaxConnections = 1 } Redis.runRedis sentinelConn $ sendRequest ["SENTINEL", "get-master-addr-by-name", connectMasterName] case replyE of Right [host, port] -> throwError ( connectBaseInfo { connectHost = BS8.unpack host , connectPort = maybe (PortNumber 26379) (PortNumber . fromIntegral . fst) $ BS8.readInt port } , (sentinelHost, sentinelPort) ) _ -> return () catchRedisRethrow :: MonadCatch m => m a -> (String -> m ()) -> m a catchRedisRethrow action handler = action `catches` [ Handler $ \ex -> handler (show @IOException ex) >> throwM ex , Handler $ \ex -> handler (show @ConnectionLostException ex) >> throwM ex ] catchRedis :: MonadCatch m => m a -> (String -> m a) -> m a catchRedis action handler = action `catches` [ Handler $ \ex -> handler (show @IOException ex) , Handler $ \ex -> handler (show @ConnectionLostException ex) ] newtype SentinelConnection = SentinelConnection (MVar SentinelConnection') data SentinelConnection' = SentinelConnection' { rcCheckFailover :: Bool , rcToken :: Unique , rcSentinelConnectInfo :: SentinelConnectInfo , rcMasterConnectInfo :: Redis.ConnectInfo , rcBaseConnection :: Redis.Connection } -- | Configuration of Sentinel hosts. data SentinelConnectInfo = SentinelConnectInfo { connectSentinels :: NonEmpty (HostName, PortID) -- ^ List of sentinels. , connectMasterName :: ByteString -- ^ Name of master to connect to. , connectBaseInfo :: Redis.ConnectInfo -- ^ This is used to configure auth and other parameters for Redis connection, -- but 'Redis.connectHost' and 'Redis.connectPort' are ignored. } deriving (Show) -- | Exception thrown by "Database.Redis.Sentinel". data RedisSentinelException = NoSentinels (NonEmpty (HostName, PortID)) -- ^ Thrown if no sentinel can be reached. deriving (Show, Typeable) deriving instance Exception RedisSentinelException hedis-0.15.2/src/Database/Redis/Transactions.hs0000644000000000000000000001067407346545000017441 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE CPP, OverloadedStrings, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} module Database.Redis.Transactions ( watch, unwatch, multiExec, Queued(), TxResult(..), RedisTx(), ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Monad.State.Strict import Control.DeepSeq import GHC.Generics import Data.ByteString (ByteString) import Data.Vector (Vector, fromList, (!)) import Database.Redis.Core import Database.Redis.Protocol import Database.Redis.Types -- |Command-context inside of MULTI\/EXEC transactions. Use 'multiExec' to run -- actions of this type. -- -- In the 'RedisTx' context, all commands return a 'Queued' value. It is a -- proxy object for the /actual/ result, which will only be available after -- finishing the transaction. newtype RedisTx a = RedisTx (StateT Int Redis a) deriving (Monad, MonadIO, Functor, Applicative) runRedisTx :: RedisTx a -> Redis a runRedisTx (RedisTx r) = evalStateT r 0 instance MonadRedis RedisTx where liftRedis = RedisTx . lift instance RedisCtx RedisTx Queued where returnDecode _queued = RedisTx $ do -- future index in EXEC result list i <- get put (i+1) return $ Queued (decode . (! i)) -- |A 'Queued' value represents the result of a command inside a transaction. It -- is a proxy object for the /actual/ result, which will only be available -- after returning from a 'multiExec' transaction. -- -- 'Queued' values are composable by utilizing the 'Functor', 'Applicative' or -- 'Monad' interfaces. data Queued a = Queued (Vector Reply -> Either Reply a) instance Functor Queued where fmap f (Queued g) = Queued (fmap f . g) instance Applicative Queued where pure x = Queued (const $ Right x) Queued f <*> Queued x = Queued $ \rs -> do f' <- f rs x' <- x rs return (f' x') instance Monad Queued where return = pure Queued x >>= f = Queued $ \rs -> do x' <- x rs let Queued f' = f x' f' rs -- | Result of a 'multiExec' transaction. data TxResult a = TxSuccess a -- ^ Transaction completed successfully. The wrapped value corresponds to -- the 'Queued' value returned from the 'multiExec' argument action. | TxAborted -- ^ Transaction aborted due to an earlier 'watch' command. | TxError String -- ^ At least one of the commands returned an 'Error' reply. deriving (Show, Eq, Generic) instance NFData a => NFData (TxResult a) -- |Watch the given keys to determine execution of the MULTI\/EXEC block -- (). watch :: [ByteString] -- ^ key -> Redis (Either Reply Status) watch key = sendRequest ("WATCH" : key) -- |Forget about all watched keys (). unwatch :: Redis (Either Reply Status) unwatch = sendRequest ["UNWATCH"] -- |Run commands inside a transaction. For documentation on the semantics of -- Redis transaction see . -- -- Inside the transaction block, command functions return their result wrapped -- in a 'Queued'. The 'Queued' result is a proxy object for the actual -- command\'s result, which will only be available after @EXEC@ing the -- transaction. -- -- Example usage (note how 'Queued' \'s 'Applicative' instance is used to -- combine the two individual results): -- -- @ -- runRedis conn $ do -- set \"hello\" \"hello\" -- set \"world\" \"world\" -- helloworld <- 'multiExec' $ do -- hello <- get \"hello\" -- world <- get \"world\" -- return $ (,) \<$\> hello \<*\> world -- liftIO (print helloworld) -- @ multiExec :: RedisTx (Queued a) -> Redis (TxResult a) multiExec rtx = do -- We don't need to catch exceptions and call DISCARD. The pool will close -- the connection anyway. _ <- multi Queued f <- runRedisTx rtx r <- exec case r of MultiBulk rs -> return $ maybe TxAborted (either (TxError . show) TxSuccess . f . fromList) rs _ -> error $ "hedis: EXEC returned " ++ show r multi :: Redis (Either Reply Status) multi = sendRequest ["MULTI"] exec :: Redis Reply exec = either id id <$> sendRequest ["EXEC"] hedis-0.15.2/src/Database/Redis/Types.hs0000644000000000000000000000723207346545000016071 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, OverloadedStrings #-} #if __GLASGOW_HASKELL__ < 710 {-# LANGUAGE OverlappingInstances #-} #endif module Database.Redis.Types where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.DeepSeq import Data.ByteString.Char8 (ByteString, pack) import qualified Data.ByteString.Lex.Fractional as F (readSigned, readExponential) import qualified Data.ByteString.Lex.Integral as I (readSigned, readDecimal) import GHC.Generics import Database.Redis.Protocol ------------------------------------------------------------------------------ -- Classes of types Redis understands -- class RedisArg a where encode :: a -> ByteString class RedisResult a where decode :: Reply -> Either Reply a ------------------------------------------------------------------------------ -- RedisArg instances -- instance RedisArg ByteString where encode = id instance RedisArg Integer where encode = pack . show instance RedisArg Double where encode a | isInfinite a && a > 0 = "+inf" | isInfinite a && a < 0 = "-inf" | otherwise = pack . show $ a ------------------------------------------------------------------------------ -- RedisResult instances -- data Status = Ok | Pong | Status ByteString deriving (Show, Eq, Generic) instance NFData Status data RedisType = None | String | Hash | List | Set | ZSet deriving (Show, Eq) instance RedisResult Reply where decode = Right instance RedisResult ByteString where decode (SingleLine s) = Right s decode (Bulk (Just s)) = Right s decode r = Left r instance RedisResult Integer where decode (Integer n) = Right n decode r = maybe (Left r) (Right . fst) . I.readSigned I.readDecimal =<< decode r instance RedisResult Double where decode r = maybe (Left r) (Right . fst) . F.readSigned F.readExponential =<< decode r instance RedisResult Status where decode (SingleLine s) = Right $ case s of "OK" -> Ok "PONG" -> Pong _ -> Status s decode r = Left r instance RedisResult RedisType where decode (SingleLine s) = Right $ case s of "none" -> None "string" -> String "hash" -> Hash "list" -> List "set" -> Set "zset" -> ZSet _ -> error $ "Hedis: unhandled redis type: " ++ show s decode r = Left r instance RedisResult Bool where decode (Integer 1) = Right True decode (Integer 0) = Right False decode (Bulk Nothing) = Right False -- Lua boolean false = nil bulk reply decode r = Left r instance (RedisResult a) => RedisResult (Maybe a) where decode (Bulk Nothing) = Right Nothing decode (MultiBulk Nothing) = Right Nothing decode r = Just <$> decode r instance #if __GLASGOW_HASKELL__ >= 710 {-# OVERLAPPABLE #-} #endif (RedisResult a) => RedisResult [a] where decode (MultiBulk (Just rs)) = mapM decode rs decode r = Left r instance (RedisResult a, RedisResult b) => RedisResult (a,b) where decode (MultiBulk (Just [x, y])) = (,) <$> decode x <*> decode y decode r = Left r instance (RedisResult k, RedisResult v) => RedisResult [(k,v)] where decode r = case r of (MultiBulk (Just rs)) -> pairs rs _ -> Left r where pairs [] = Right [] pairs (_:[]) = Left r pairs (r1:r2:rs) = do k <- decode r1 v <- decode r2 kvs <- pairs rs return $ (k,v) : kvs hedis-0.15.2/src/Database/Redis/URL.hs0000644000000000000000000000457307346545000015434 0ustar0000000000000000{-# LANGUAGE CPP #-} module Database.Redis.URL ( parseConnectInfo ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif import Control.Error.Util (note) import Control.Monad (guard) #if __GLASGOW_HASKELL__ < 808 import Data.Monoid ((<>)) #endif import Database.Redis.Connection (ConnectInfo(..), defaultConnectInfo) import qualified Database.Redis.ConnectionContext as CC import Network.HTTP.Base import Network.URI (parseURI, uriPath, uriScheme) import Text.Read (readMaybe) import qualified Data.ByteString.Char8 as C8 -- | Parse a @'ConnectInfo'@ from a URL -- -- Username is ignored, path is used to specify the database: -- -- >>> parseConnectInfo "redis://username:password@host:42/2" -- Right (ConnInfo {connectHost = "host", connectPort = PortNumber 42, connectAuth = Just "password", connectDatabase = 2, connectMaxConnections = 50, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing}) -- -- >>> 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" -- -- 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 :: 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 h = host uriAuth dbNumPart = dropWhile (== '/') (uriPath uri) 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 } hedis-0.15.2/test/0000755000000000000000000000000007346545000012043 5ustar0000000000000000hedis-0.15.2/test/ClusterMain.hs0000644000000000000000000000370507346545000014632 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module Main (main) where import qualified Test.Framework as Test import Database.Redis import Tests main :: IO () main = do -- We're looking for the cluster on a non-default port to support running -- this test in parallel witht the regular non-cluster tests. To quickly -- spin up a cluster on this port using docker you can run: -- -- docker run -e "IP=0.0.0.0" -p 7000-7010:7000-7010 grokzen/redis-cluster:5.0.6 conn <- connectCluster defaultConnectInfo { connectPort = PortNumber 7000 } Test.defaultMain (tests conn) tests :: Connection -> [Test.Test] tests conn = map ($conn) $ concat [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog] , testsZSets, [testTransaction], [testScripting] , testsConnection, testsServer, [testSScan, testHScan, testZScan], [testZrangelex] , [testXAddRead, testXReadGroup, testXRange, testXpending, testXClaim, testXInfo, testXDel, testXTrim] -- should always be run last as connection gets closed after it , [testQuit] ] testsServer :: [Test] testsServer = [testBgrewriteaof, testFlushall, testSlowlog, testDebugObject] testsConnection :: [Test] testsConnection = [ testConnectAuthUnexpected, testEcho, testPing ] testsKeys :: [Test] testsKeys = [ testKeys, testExpireAt, testSortCluster, testGetType, testObject ] testSortCluster :: Test testSortCluster = testCase "sort" $ do lpush "{same}ids" ["1","2","3"] >>=? 3 sort "{same}ids" defaultSortOpts >>=? ["1","2","3"] sortStore "{same}ids" "{same}anotherKey" defaultSortOpts >>=? 3 let opts = defaultSortOpts { sortOrder = Desc, sortAlpha = True , sortLimit = (1,2) , sortBy = Nothing , sortGet = [] } sort "{same}ids" opts >>=? ["2", "1"] hedis-0.15.2/test/Main.hs0000644000000000000000000000227607346545000013272 0ustar0000000000000000module Main (main) where import qualified Test.Framework as Test import Database.Redis import Tests import PubSubTest main :: IO () main = do conn <- connect defaultConnectInfo Test.defaultMain (tests conn) tests :: Connection -> [Test.Test] tests conn = map ($conn) $ concat [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog] , testsZSets, [testPubSub], [testTransaction], [testScripting] , testsConnection, testsServer, [testScans, testSScan, testHScan, testZScan], [testZrangelex] , [testXAddRead, testXReadGroup, testXRange, testXpending, testXClaim, testXInfo, testXDel, testXTrim] , testPubSubThreaded -- should always be run last as connection gets closed after it , [testQuit] ] testsServer :: [Test] testsServer = [testServer, testBgrewriteaof, testFlushall, testInfo, testConfig ,testSlowlog, testDebugObject] testsConnection :: [Test] testsConnection = [ testConnectAuth, testConnectAuthUnexpected, testConnectDb , testConnectDbUnexisting, testEcho, testPing, testSelect ] testsKeys :: [Test] testsKeys = [ testKeys, testKeysNoncluster, testExpireAt, testSort, testGetType, testObject ] hedis-0.15.2/test/PubSubTest.hs0000644000000000000000000001562207346545000014445 0ustar0000000000000000{-# LANGUAGE CPP, OverloadedStrings, DeriveDataTypeable #-} 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.ByteString import Control.Concurrent.STM import qualified Test.Framework as Test import qualified Test.Framework.Providers.HUnit as Test (testCase) import qualified Test.HUnit as HUnit import Database.Redis testPubSubThreaded :: [Connection -> Test.Test] testPubSubThreaded = [removeAllTest, callbackErrorTest, removeFromUnregister] -- | A handler label to be able to distinguish the handlers from one another -- to help make sure we unregister the correct handler. type HandlerLabel = Text data TestMsg = MsgFromChannel HandlerLabel ByteString | MsgFromPChannel HandlerLabel RedisChannel ByteString deriving (Show, Eq) type MsgVar = TVar [TestMsg] -- | A handler that just writes the message into the TVar handler :: HandlerLabel -> MsgVar -> MessageCallback handler label ref msg = atomically $ modifyTVar ref $ \x -> x ++ [MsgFromChannel label msg] -- | A pattern handler that just writes the message into the TVar phandler :: HandlerLabel -> MsgVar -> PMessageCallback phandler label ref chan msg = atomically $ modifyTVar ref $ \x -> x ++ [MsgFromPChannel label chan msg] -- | Wait for a given message to be received waitForMessage :: MsgVar -> HandlerLabel -> ByteString -> IO () waitForMessage ref label msg = atomically $ do let expected = MsgFromChannel label msg lst <- readTVar ref unless (expected `Prelude.elem` lst) retry writeTVar ref $ Prelude.filter (/= expected) lst -- | Wait for a given pattern message to be received waitForPMessage :: MsgVar -> HandlerLabel -> RedisChannel -> ByteString -> IO () waitForPMessage ref label chan msg = atomically $ do let expected = MsgFromPChannel label chan msg lst <- readTVar ref unless (expected `Prelude.elem` lst) retry writeTVar ref $ Prelude.filter (/= expected) lst expectRedisChannels :: Connection -> [RedisChannel] -> IO () expectRedisChannels conn expected = do actual <- runRedis conn $ sendRequest ["PUBSUB", "CHANNELS"] case actual of Left err -> HUnit.assertFailure $ "Error geting channels: " ++ show err Right s -> HUnit.assertEqual "redis channels" (Data.List.sort s) (Data.List.sort expected) -- | Test basic messages, plus using removeChannels removeAllTest :: Connection -> Test.Test removeAllTest conn = Test.testCase "Multithreaded Pub/Sub - basic" $ do msgVar <- newTVarIO [] initialComplete <- newTVarIO False ctrl <- newPubSubController [("foo1", handler "InitialFoo1" msgVar), ("foo2", handler "InitialFoo2" msgVar)] [("bar1:*", phandler "InitialBar1" msgVar), ("bar2:*", phandler "InitialBar2" msgVar)] withAsync (pubSubForever conn ctrl (atomically $ writeTVar initialComplete True)) $ \_ -> do -- wait for initial atomically $ readTVar initialComplete >>= \b -> if b then return () else retry expectRedisChannels conn ["foo1", "foo2"] runRedis conn $ publish "foo1" "Hello" waitForMessage msgVar "InitialFoo1" "Hello" runRedis conn $ publish "bar2:zzz" "World" waitForPMessage msgVar "InitialBar2" "bar2:zzz" "World" -- subscribe to foo1 and bar1 again addChannelsAndWait ctrl [("foo1", handler "NewFoo1" msgVar)] [("bar1:*", phandler "NewBar1" msgVar)] expectRedisChannels conn ["foo1", "foo2"] runRedis conn $ publish "foo1" "abcdef" waitForMessage msgVar "InitialFoo1" "abcdef" waitForMessage msgVar "NewFoo1" "abcdef" -- unsubscribe from foo1 and bar1 removeChannelsAndWait ctrl ["foo1", "unusued"] ["bar1:*", "unused:*"] expectRedisChannels conn ["foo2"] -- foo2 and bar2 are still subscribed runRedis conn $ publish "foo2" "12345" waitForMessage msgVar "InitialFoo2" "12345" runRedis conn $ publish "bar2:aaa" "0987" waitForPMessage msgVar "InitialBar2" "bar2:aaa" "0987" data TestError = TestError ByteString deriving (Eq, Show, Typeable) instance Exception TestError -- | Test an error thrown from a message handler callbackErrorTest :: Connection -> Test.Test callbackErrorTest conn = Test.testCase "Multithreaded Pub/Sub - error in handler" $ do initialComplete <- newTVarIO False ctrl <- newPubSubController [("foo", throwIO . TestError)] [] thread <- async (pubSubForever conn ctrl (atomically $ writeTVar initialComplete True)) atomically $ readTVar initialComplete >>= \b -> if b then return () else retry runRedis conn $ publish "foo" "Hello" ret <- waitCatch thread case ret of Left (SomeException e) | cast e == Just (TestError "Hello") -> return () _ -> HUnit.assertFailure $ "Did not properly throw error from message thread " ++ show ret -- | Test removing channels by using the return value of 'addHandlersAndWait'. removeFromUnregister :: Connection -> Test.Test removeFromUnregister conn = Test.testCase "Multithreaded Pub/Sub - unregister handlers" $ 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 -- register to some channels void $ addChannelsAndWait ctrl [("abc", handler "InitialAbc" msgVar), ("xyz", handler "InitialXyz" msgVar)] [("def:*", phandler "InitialDef" msgVar), ("uvw", phandler "InitialUvw" msgVar)] expectRedisChannels conn ["abc", "xyz"] runRedis conn $ publish "abc" "Hello" waitForMessage msgVar "InitialAbc" "Hello" -- register to some more channels unreg <- addChannelsAndWait ctrl [("abc", handler "SecondAbc" msgVar), ("123", handler "Second123" msgVar)] [("def:*", phandler "SecondDef" msgVar), ("890:*", phandler "Second890" msgVar)] expectRedisChannels conn ["abc", "xyz", "123"] -- check messages on all channels runRedis conn $ publish "abc" "World" waitForMessage msgVar "InitialAbc" "World" waitForMessage msgVar "SecondAbc" "World" runRedis conn $ publish "123" "World2" waitForMessage msgVar "Second123" "World2" runRedis conn $ publish "def:bbbb" "World3" waitForPMessage msgVar "InitialDef" "def:bbbb" "World3" waitForPMessage msgVar "SecondDef" "def:bbbb" "World3" runRedis conn $ publish "890:tttt" "World4" waitForPMessage msgVar "Second890" "890:tttt" "World4" -- unregister unreg -- we have no way of waiting until unregister actually happened, so just delay and hope threadDelay $ 1000*1000 -- 1 second expectRedisChannels conn ["abc", "xyz"] -- now only initial should be around. In particular, abc should still be subscribed runRedis conn $ publish "abc" "World5" waitForMessage msgVar "InitialAbc" "World5" runRedis conn $ publish "def:cccc" "World6" waitForPMessage msgVar "InitialDef" "def:cccc" "World6" hedis-0.15.2/test/Tests.hs0000644000000000000000000007070707346545000013514 0ustar0000000000000000{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, LambdaCase #-} module Tests where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative import Data.Monoid (mappend) #endif import qualified Control.Concurrent.Async as Async import Control.Exception (try) import Control.Concurrent import Control.Monad import Control.Monad.Trans import qualified Data.List as L import Data.Time import Data.Time.Clock.POSIX import qualified Test.Framework as Test (Test) import qualified Test.Framework.Providers.HUnit as Test (testCase) import qualified Test.HUnit as HUnit import Database.Redis ------------------------------------------------------------------------------ -- helpers -- type Test = Connection -> Test.Test testCase :: String -> Redis () -> Test testCase name r conn = Test.testCase name $ do withTimeLimit 0.5 $ runRedis conn $ flushdb >>=? Ok >> r where withTimeLimit limit act = do start <- getCurrentTime _ <- act deltaT <-fmap (`diffUTCTime` start) getCurrentTime when (deltaT > limit) $ putStrLn $ name ++ ": " ++ show deltaT (>>=?) :: (Eq a, Show a) => Redis (Either Reply a) -> a -> Redis () redis >>=? expected = do a <- redis liftIO $ case a of Left reply -> HUnit.assertFailure $ "Redis error: " ++ show reply Right actual -> expected HUnit.@=? actual assert :: Bool -> Redis () assert = liftIO . HUnit.assert ------------------------------------------------------------------------------ -- Miscellaneous -- testsMisc :: [Test] testsMisc = [ testConstantSpacePipelining, testForceErrorReply, testPipelining , testEvalReplies ] testConstantSpacePipelining :: Test testConstantSpacePipelining = testCase "constant-space pipelining" $ do -- This testcase should not exceed the maximum heap size, as set in -- the run-test.sh script. replicateM_ 100000 ping -- If the program didn't crash, pipelining takes constant memory. assert True testForceErrorReply :: Test testForceErrorReply = testCase "force error reply" $ do set "key" "value" >>= \case Left _ -> error "impossible" _ -> return () -- key is not a hash -> wrong kind of value reply <- hkeys "key" assert $ case reply of Left (Error _) -> True _ -> False testPipelining :: Test testPipelining = testCase "pipelining" $ do let n = 100 tPipe <- deltaT $ do pongs <- replicateM n ping assert $ pongs == replicate n (Right Pong) tNoPipe <- deltaT $ replicateM_ n (ping >>=? Pong) -- pipelining should at least be twice as fast. assert $ tNoPipe / tPipe > 2 where deltaT redis = do start <- liftIO $ getCurrentTime _ <- redis liftIO $ fmap (`diffUTCTime` start) getCurrentTime testEvalReplies :: Test testEvalReplies conn = testCase "eval unused replies" go conn where go = do _ <- liftIO $ runRedis conn $ set "key" "value" result <- liftIO $ do threadDelay $ 10 ^ (5 :: Int) mvar <- newEmptyMVar _ <- (Async.wait =<< Async.async (runRedis conn (get "key"))) >>= putMVar mvar takeMVar mvar pure result >>=? Just "value" ------------------------------------------------------------------------------ -- Keys -- testKeys :: Test testKeys = testCase "keys" $ do set "{same}key" "value" >>=? Ok get "{same}key" >>=? Just "value" exists "{same}key" >>=? True expire "{same}key" 1 >>=? True pexpire "{same}key" 1000 >>=? True ttl "{same}key" >>= \case Left _ -> error "error" Right t -> do assert $ t `elem` [0..1] pttl "{same}key" >>= \case Left _ -> error "error" Right pt -> do assert $ pt `elem` [990..1000] persist "{same}key" >>=? True dump "{same}key" >>= \case Left _ -> error "impossible" Right s -> do restore "{same}key'" 0 s >>=? Ok rename "{same}key" "{same}key'" >>=? Ok renamenx "{same}key'" "{same}key" >>=? True del ["{same}key"] >>=? 1 testKeysNoncluster :: Test testKeysNoncluster = testCase "keysNoncluster" $ do set "key" "value" >>=? Ok keys "*" >>=? ["key"] randomkey >>=? Just "key" move "key" 13 >>=? True select 13 >>=? Ok get "key" >>=? Just "value" select 0 >>=? Ok testExpireAt :: Test testExpireAt = testCase "expireat" $ do set "key" "value" >>=? Ok t <- ceiling . utcTimeToPOSIXSeconds <$> liftIO getCurrentTime let expiry = t+1 expireat "key" expiry >>=? True pexpireat "key" (expiry*1000) >>=? True testSort :: Test testSort = testCase "sort" $ do lpush "ids" ["1","2","3"] >>=? 3 sort "ids" defaultSortOpts >>=? ["1","2","3"] sortStore "ids" "anotherKey" defaultSortOpts >>=? 3 mset [("weight_1","1") ,("weight_2","2") ,("weight_3","3") ,("object_1","foo") ,("object_2","bar") ,("object_3","baz") ] >>= \case Left _ -> error "error" _ -> return () let opts = defaultSortOpts { sortOrder = Desc, sortAlpha = True , sortLimit = (1,2) , sortBy = Just "weight_*" , sortGet = ["#", "object_*"] } sort "ids" opts >>=? ["2", "bar", "1", "foo"] testGetType :: Test testGetType = testCase "getType" $ do getType "key" >>=? None forM_ ts $ \(setKey, typ) -> do setKey getType "key" >>=? typ del ["key"] >>=? 1 where ts = [ (set "key" "value" >>=? Ok, String) , (hset "key" "field" "value" >>=? 1, Hash) , (lpush "key" ["value"] >>=? 1, List) , (sadd "key" ["member"] >>=? 1, Set) , (zadd "key" [(42,"member"),(12.3,"value")] >>=? 2, ZSet) ] testObject :: Test testObject = testCase "object" $ do set "key" "value" >>=? Ok objectRefcount "key" >>=? 1 objectEncoding "key" >>= \case Left _ -> error "error" _ -> return () objectIdletime "key" >>=? 0 ------------------------------------------------------------------------------ -- Strings -- testsStrings :: [Test] testsStrings = [testStrings, testBitops] testStrings :: Test testStrings = testCase "strings" $ do setnx "key" "value" >>=? True getset "key" "hello" >>=? Just "value" append "key" "world" >>=? 10 strlen "key" >>=? 10 setrange "key" 0 "hello" >>=? 10 getrange "key" 0 4 >>=? "hello" mset [("{same}k1","v1"), ("{same}k2","v2")] >>=? Ok msetnx [("{same}k1","v1"), ("{same}k2","v2")] >>=? False mget ["key"] >>=? [Just "helloworld"] setex "key" 1 "42" >>=? Ok psetex "key" 1000 "42" >>=? Ok decr "key" >>=? 41 decrby "key" 1 >>=? 40 incr "key" >>=? 41 incrby "key" 1 >>=? 42 incrbyfloat "key" 1 >>=? 43 del ["key"] >>=? 1 setbit "key" 42 "1" >>=? 0 getbit "key" 42 >>=? 1 bitcount "key" >>=? 1 bitcountRange "key" 0 (-1) >>=? 1 testBitops :: Test testBitops = testCase "bitops" $ do set "{same}k1" "a" >>=? Ok set "{same}k2" "b" >>=? Ok bitopAnd "{same}k3" ["{same}k1", "{same}k2"] >>=? 1 bitopOr "{same}k3" ["{same}k1", "{same}k2"] >>=? 1 bitopXor "{same}k3" ["{same}k1", "{same}k2"] >>=? 1 bitopNot "{same}k3" "{same}k1" >>=? 1 ------------------------------------------------------------------------------ -- Hashes -- testHashes :: Test testHashes = testCase "hashes" $ do hset "key" "field" "another" >>=? 1 hset "key" "field" "another" >>=? 0 hset "key" "field" "value" >>=? 0 hsetnx "key" "field" "value" >>=? False hexists "key" "field" >>=? True hlen "key" >>=? 1 hget "key" "field" >>=? Just "value" hmget "key" ["field", "-"] >>=? [Just "value", Nothing] hgetall "key" >>=? [("field","value")] hkeys "key" >>=? ["field"] hvals "key" >>=? ["value"] hdel "key" ["field"] >>=? 1 hmset "key" [("field","40")] >>=? Ok hincrby "key" "field" 2 >>=? 42 hincrbyfloat "key" "field" 2 >>=? 44 ------------------------------------------------------------------------------ -- Lists -- testsLists :: [Test] testsLists = [testLists, testBpop] testLists :: Test testLists = testCase "lists" $ do lpushx "notAKey" "-" >>=? 0 rpushx "notAKey" "-" >>=? 0 lpush "key" ["value"] >>=? 1 lpop "key" >>=? Just "value" rpush "key" ["value"] >>=? 1 rpop "key" >>=? Just "value" rpush "key" ["v2"] >>=? 1 linsertBefore "key" "v2" "v1" >>=? 2 linsertAfter "key" "v2" "v3" >>=? 3 lindex "key" 0 >>=? Just "v1" lrange "key" 0 (-1) >>=? ["v1", "v2", "v3"] lset "key" 1 "v2" >>=? Ok lrem "key" 0 "v2" >>=? 1 llen "key" >>=? 2 ltrim "key" 0 1 >>=? Ok testBpop :: Test testBpop = testCase "blocking push/pop" $ do lpush "{same}key" ["v3","v2","v1"] >>=? 3 blpop ["{same}key"] 1 >>=? Just ("{same}key","v1") brpop ["{same}key"] 1 >>=? Just ("{same}key","v3") rpush "{same}k1" ["v1","v2"] >>=? 2 brpoplpush "{same}k1" "{same}k2" 1 >>=? Just "v2" rpoplpush "{same}k1" "{same}k2" >>=? Just "v1" ------------------------------------------------------------------------------ -- Sets -- testsSets :: [Test] testsSets = [testSets, testSetAlgebra] testSets :: Test testSets = testCase "sets" $ do sadd "set" ["member"] >>=? 1 sismember "set" "member" >>=? True scard "set" >>=? 1 smembers "set" >>=? ["member"] srandmember "set" >>=? Just "member" spop "set" >>=? Just "member" srem "set" ["member"] >>=? 0 smove "{same}set" "{same}set'" "member" >>=? False _ <- sadd "set" ["member1", "member2"] (fmap L.sort <$> spopN "set" 2) >>=? ["member1", "member2"] _ <- sadd "set" ["member1", "member2"] (fmap L.sort <$> srandmemberN "set" 2) >>=? ["member1", "member2"] testSetAlgebra :: Test testSetAlgebra = testCase "set algebra" $ do sadd "{same}s1" ["member"] >>=? 1 sdiff ["{same}s1", "{same}s2"] >>=? ["member"] sunion ["{same}s1", "{same}s2"] >>=? ["member"] sinter ["{same}s1", "{same}s2"] >>=? [] sdiffstore "{same}s3" ["{same}s1", "{same}s2"] >>=? 1 sunionstore "{same}s3" ["{same}s1", "{same}s2"] >>=? 1 sinterstore "{same}s3" ["{same}s1", "{same}s2"] >>=? 0 ------------------------------------------------------------------------------ -- Sorted Sets -- testsZSets :: [Test] testsZSets = [testZSets, testZStore] testZSets :: Test testZSets = testCase "sorted sets" $ do zadd "key" [(1,"v1"),(2,"v2"),(40,"v3")] >>=? 3 zcard "key" >>=? 3 zscore "key" "v3" >>=? Just 40 zincrby "key" 2 "v3" >>=? 42 zrank "key" "v1" >>=? Just 0 zrevrank "key" "v1" >>=? Just 2 zcount "key" 10 100 >>=? 1 zrange "key" 0 1 >>=? ["v1","v2"] zrevrange "key" 0 1 >>=? ["v3","v2"] zrangeWithscores "key" 0 1 >>=? [("v1",1),("v2",2)] zrevrangeWithscores "key" 0 1 >>=? [("v3",42),("v2",2)] zrangebyscore "key" 0.5 1.5 >>=? ["v1"] zrangebyscoreWithscores "key" 0.5 1.5 >>=? [("v1",1)] zrangebyscoreWithscores "key" (-inf) inf >>=? [("v1",1.0),("v2",2.0),("v3",42.0)] zrangebyscoreLimit "key" 0.5 2.5 0 1 >>=? ["v1"] zrangebyscoreWithscoresLimit "key" 0.5 2.5 0 1 >>=? [("v1",1)] zrevrangebyscore "key" 1.5 0.5 >>=? ["v1"] zrevrangebyscoreWithscores "key" 1.5 0.5 >>=? [("v1",1)] zrevrangebyscoreLimit "key" 2.5 0.5 0 1 >>=? ["v2"] zrevrangebyscoreWithscoresLimit "key" 2.5 0.5 0 1 >>=? [("v2",2)] zrem "key" ["v2"] >>=? 1 zremrangebyscore "key" 10 100 >>=? 1 zremrangebyrank "key" 0 0 >>=? 1 testZStore :: Test testZStore = testCase "zunionstore/zinterstore" $ do zadd "{same}k1" [(1, "v1"), (2, "v2")] >>= \case Left _ -> error "error" _ -> return () zadd "{same}k2" [(2, "v2"), (3, "v3")] >>= \case Left _ -> error "error" _ -> return () zinterstore "{same}newkey" ["{same}k1","{same}k2"] Sum >>=? 1 zinterstoreWeights "{same}newkey" [("{same}k1",1),("{same}k2",2)] Max >>=? 1 zunionstore "{same}newkey" ["{same}k1","{same}k2"] Sum >>=? 3 zunionstoreWeights "{same}newkey" [("{same}k1",1),("{same}k2",2)] Min >>=? 3 ------------------------------------------------------------------------------ -- HyperLogLog -- testHyperLogLog :: Test testHyperLogLog = testCase "hyperloglog" $ do -- test creation pfadd "hll1" ["a"] >>= \case Left _ -> error "error" _ -> return () pfcount ["hll1"] >>=? 1 -- test cardinality pfadd "hll1" ["a"] >>= \case Left _ -> error "error" _ -> return () pfcount ["hll1"] >>=? 1 pfadd "hll1" ["b", "c", "foo", "bar"] >>= \case Left _ -> error "error" _ -> return () pfcount ["hll1"] >>=? 5 -- test merge pfadd "{same}hll2" ["1", "2", "3"] >>= \case Left _ -> error "error" _ -> return () pfadd "{same}hll3" ["4", "5", "6"] >>= \case Left _ -> error "error" _ -> return () pfmerge "{same}hll4" ["{same}hll2", "{same}hll3"] >>= \case Left _ -> error "error" _ -> return () pfcount ["{same}hll4"] >>=? 6 -- test union cardinality pfcount ["{same}hll2", "{same}hll3"] >>=? 6 ------------------------------------------------------------------------------ -- Pub/Sub -- testPubSub :: Test testPubSub conn = testCase "pubSub" go conn where go = do -- producer asyncProducer <- liftIO $ Async.async $ do runRedis conn $ do let t = 10^(5 :: Int) liftIO $ threadDelay t publish "chan1" "hello" >>=? 1 liftIO $ threadDelay t publish "chan2" "world" >>=? 1 return () -- consumer pubSub (subscribe ["chan1"]) $ \msg -> do -- ready for a message case msg of Message{..} -> return (unsubscribe [msgChannel] `mappend` psubscribe ["chan*"]) PMessage{..} -> return (punsubscribe [msgPattern]) pubSub (subscribe [] `mappend` psubscribe []) $ \_ -> do liftIO $ HUnit.assertFailure "no subs: should return immediately" undefined liftIO $ Async.wait asyncProducer ------------------------------------------------------------------------------ -- Transaction -- testTransaction :: Test testTransaction = testCase "transaction" $ do watch ["{same}k1", "{same}k2"] >>=? Ok unwatch >>=? Ok set "{same}foo" "foo" >>= \case Left _ -> error "error" _ -> return () set "{same}bar" "bar" >>= \case Left _ -> error "error" _ -> return () foobar <- multiExec $ do foo <- get "{same}foo" bar <- get "{same}bar" return $ (,) <$> foo <*> bar assert $ foobar == TxSuccess (Just "foo", Just "bar") ------------------------------------------------------------------------------ -- Scripting -- testScripting :: Test testScripting conn = testCase "scripting" go conn where go = do let script = "return {false, 42}" scriptRes = (False, 42 :: Integer) scriptLoad script >>= \case Left _ -> error "error" Right scriptHash -> do eval script [] [] >>=? scriptRes evalsha scriptHash [] [] >>=? scriptRes scriptExists [scriptHash, "notAScript"] >>=? [True, False] scriptFlush >>=? Ok -- start long running script from another client configSet "lua-time-limit" "100" >>=? Ok evalFinished <- liftIO newEmptyMVar asyncScripting <- liftIO $ Async.async $ runRedis conn $ do -- we must pattern match to block the thread (eval "while true do end" [] [] :: Redis (Either Reply Integer)) >>= \case Left _ -> return () _ -> error "impossible" liftIO (putMVar evalFinished ()) return () liftIO (threadDelay 500000) -- 0.5s scriptKill >>=? Ok () <- liftIO (takeMVar evalFinished) liftIO $ Async.wait asyncScripting return () ------------------------------------------------------------------------------ -- Connection -- testConnectAuth :: Test testConnectAuth = testCase "connect/auth" $ do configSet "requirepass" "pass" >>=? Ok liftIO $ do c <- checkedConnect defaultConnectInfo { connectAuth = Just "pass" } runRedis c (ping >>=? Pong) auth "pass" >>=? Ok configSet "requirepass" "" >>=? Ok testConnectAuthUnexpected :: Test testConnectAuthUnexpected = testCase "connect/auth/unexpected" $ do liftIO $ do res <- try $ void $ checkedConnect connInfo HUnit.assertEqual "" err res where connInfo = defaultConnectInfo { connectAuth = Just "pass" } err = Left $ ConnectAuthError $ Error "ERR AUTH called without any password configured for the default user. Are you sure your configuration is correct?" testConnectDb :: Test testConnectDb = testCase "connect/db" $ do set "connect" "value" >>=? Ok liftIO $ void $ do c <- checkedConnect defaultConnectInfo { connectDatabase = 1 } runRedis c (get "connect" >>=? Nothing) testConnectDbUnexisting :: Test testConnectDbUnexisting = testCase "connect/db/unexisting" $ do liftIO $ do res <- try $ void $ checkedConnect connInfo case res of Left (ConnectSelectError _) -> return () _ -> HUnit.assertFailure $ "Expected ConnectSelectError, got " ++ show res where connInfo = defaultConnectInfo { connectDatabase = 100 } testEcho :: Test testEcho = testCase "echo" $ echo ("value" ) >>=? "value" testPing :: Test testPing = testCase "ping" $ ping >>=? Pong testQuit :: Test testQuit = testCase "quit" $ quit >>=? Ok testSelect :: Test testSelect = testCase "select" $ do select 13 >>=? Ok select 0 >>=? Ok ------------------------------------------------------------------------------ -- Server -- testServer :: Test testServer = testCase "server" $ do time >>= \case Right (_,_) -> return () Left _ -> error "error" slaveof "no" "one" >>=? Ok return () testBgrewriteaof :: Test testBgrewriteaof = testCase "bgrewriteaof/bgsave/save" $ do save >>=? Ok bgsave >>= \case Right (Status _) -> return () _ -> error "error" -- Redis needs time to finish the bgsave liftIO $ threadDelay (10^(5 :: Int)) bgrewriteaof >>= \case Right (Status _) -> return () _ -> error "error" return () testConfig :: Test testConfig = testCase "config/auth" $ do configGet "requirepass" >>=? [("requirepass", "")] configSet "requirepass" "pass" >>=? Ok auth "pass" >>=? Ok configSet "requirepass" "" >>=? Ok testFlushall :: Test testFlushall = testCase "flushall/flushdb" $ do flushall >>=? Ok flushdb >>=? Ok testInfo :: Test testInfo = testCase "info/lastsave/dbsize" $ do info >>= \case Left _ -> error "error" _ -> return () lastsave >>= \case Left _ -> error "error" _ -> return () dbsize >>=? 0 configResetstat >>=? Ok testSlowlog :: Test testSlowlog = testCase "slowlog" $ do slowlogReset >>=? Ok slowlogGet 5 >>=? [] slowlogLen >>=? 0 testDebugObject :: Test testDebugObject = testCase "debugObject/debugSegfault" $ do 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, []) where sOpts1 = defaultScanOpts { scanMatch = Just "k*" } sOpts2 = defaultScanOpts { scanMatch = Just "not*"} testSScan :: Test testSScan = testCase "sscan" $ do sadd "set" ["1"] >>=? 1 sscan "set" cursor0 >>=? (cursor0, ["1"]) testHScan :: Test testHScan = testCase "hscan" $ do hset "hash" "k" "v" >>=? 1 hscan "hash" cursor0 >>=? (cursor0, [("k", "v")]) testZScan :: Test testZScan = testCase "zscan" $ do zadd "zset" [(42, "2")] >>=? 1 zscan "zset" cursor0 >>=? (cursor0, [("2", 42)]) testZrangelex ::Test testZrangelex = testCase "zrangebylex" $ do let testSet = [(10, "aaa"), (10, "abb"), (10, "ccc"), (10, "ddd")] zadd "zrangebylex" testSet >>=? 4 zrangebylex "zrangebylex" (Incl "aaa") (Incl "bbb") >>=? ["aaa","abb"] zrangebylex "zrangebylex" (Excl "aaa") (Excl "ddd") >>=? ["abb","ccc"] zrangebylex "zrangebylex" Minr Maxr >>=? ["aaa","abb","ccc","ddd"] zrangebylexLimit "zrangebylex" Minr Maxr 2 1 >>=? ["ccc"] testXAddRead ::Test 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) xread [("{same}somestream", "0"), ("{same}otherstream", "0")] >>=? Just [ XReadResponse { stream = "{same}somestream", records = [StreamsRecord{recordId = "123-0", keyValues = [("key", "value"), ("key2", "value2")]}] }, XReadResponse { stream = "{same}otherstream", records = [StreamsRecord{recordId = "456-0", keyValues = [("key1", "value1")]}] }] xlen "{same}somestream" >>=? 1 testXReadGroup ::Test testXReadGroup = testCase "XGROUP */xreadgroup/xack" $ do xadd "somestream" "123" [("key", "value")] xgroupCreate "somestream" "somegroup" "0" xreadGroup "somegroup" "consumer1" [("somestream", ">")] >>=? 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 testXRange ::Test testXRange = testCase "xrange/xrevrange" $ do xadd "somestream" "121" [("key1", "value1")] xadd "somestream" "122" [("key2", "value2")] xadd "somestream" "123" [("key3", "value3")] xadd "somestream" "124" [("key4", "value4")] xrange "somestream" "122" "123" Nothing >>=? [ StreamsRecord{recordId = "122-0", keyValues = [("key2", "value2")]}, StreamsRecord{recordId = "123-0", keyValues = [("key3", "value3")]} ] xrevRange "somestream" "123" "122" Nothing >>=? [ StreamsRecord{recordId = "123-0", keyValues = [("key3", "value3")]}, StreamsRecord{recordId = "122-0", keyValues = [("key2", "value2")]} ] testXpending ::Test testXpending = testCase "xpending" $ do xadd "somestream" "121" [("key1", "value1")] xadd "somestream" "122" [("key2", "value2")] xadd "somestream" "123" [("key3", "value3")] xadd "somestream" "124" [("key4", "value4")] xgroupCreate "somestream" "somegroup" "0" xreadGroup "somegroup" "consumer1" [("somestream", ">")] xpendingSummary "somestream" "somegroup" Nothing >>=? 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 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 "somegroup" "consumer1" [("somestream", ">")] (defaultXreadOpts {recordCount = Just 2}) >>=? Just [ XReadResponse { stream = "somestream" , records = [ StreamsRecord {recordId = "121-0", keyValues = [("key1", "value1")]} , StreamsRecord {recordId = "122-0", keyValues = [("key2", "value2")]} ] } ] xclaim "somestream" "somegroup" "consumer2" 0 defaultXClaimOpts ["121-0"] >>=? [StreamsRecord {recordId = "121-0", keyValues = [("key1", "value1")]}] xclaimJustIds "somestream" "somegroup" "consumer2" 0 defaultXClaimOpts ["122-0"] >>=? ["122-0"] 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 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")] } } testXDel ::Test testXDel = testCase "xdel" $ do xadd "somestream" "121" [("key1", "value1")] xadd "somestream" "122" [("key2", "value2")] xdel "somestream" ["122"] >>=? 1 xlen "somestream" >>=? 1 testXTrim ::Test testXTrim = testCase "xtrim" $ do xadd "somestream" "121" [("key1", "value1")] xadd "somestream" "122" [("key2", "value2")] xadd "somestream" "123" [("key3", "value3")] xadd "somestream" "124" [("key4", "value4")] xadd "somestream" "125" [("key5", "value5")] xtrim "somestream" (Maxlen 2) >>=? 3