packages feed

hedis 0.6.10 → 0.16.1

raw patch · 29 files changed

Files

CHANGELOG view
@@ -1,5 +1,308 @@ # Changelog for Hedis +## 0.16.1++- PR #248 Introduced nix flakes and reproducible build environment. Thanks to Christian Georgii+- PR #249 PubSub supported on a cluster+- PR #250 All geospatial commands were supported.+- PR #251 New withPubSub for lightweight connections were introduced+- PR #253 Add runRedisNonBlocking function that will skip action if no connections in the pool are+  available. Thanks to Chordify++## 0.16++- PR #176. Exposed RedisArg type class so it's possible to (de)serialize application data structures.+- PR #182. Add MonadTrans instance for MonadRedis.+- PR #198. Extended Redis 6 and 7 support.+  - add `xgroupCreate`, `xgroupCreateConsumer`, `xgroupSetId`;+  - added support of the message trimming by message;+  - add support for count parameter for approximate trimming.+- New internal functions `unsubscribe1`, `punsubscribe1` functions that do not remove all subscriptions when empty lst is passed+- Fixes in cluster support:+  - connect authorizes with all nodes+  - TLS connection is instantiated with all nodes+  - Fixed resource leakage+- Added new methods for the cluster mode:+  - requestMasterNodes, masterNodes, getRandomConnection+++Breaking changes:++- **Connection** Fix connection API.++  ```haskell+  data PortID = PortNumber NS.PortNumber+              | UnixSocket String+              deriving (Eq, Show)+  ```++  And introduce instead `ConnectAddr`:++  ```haskell+  data ConnectAddr+    = ConnectAddrHostPort NS.HostName NS.PortNumber+    | ConnectAddrUnixSocket String+    deriving (Eq, Show)+  ```++  It allow to remove a hack with ignored path.++- **URI parsing** follows the redis client spec. Main changes:++  1. In `redis://password@host`, `password` is parsed as a password instead of a username.+  2. `redis-socket://[[username:]password@]path` is supported.++- **xpendingDetail** instead of 'Maybe ByteString' for a consumer name the method+receives XPendingOpts structure that can take number of milliseconds and consumer name.+In order to preserve an old behavior code should be rewritten as:++``` haskell+xpendingDetails s g f l t Nothing -> xpendingSummary s g f l t defaultXPendingDetailOpts+xpendingDetails s g f l t (Just c) -> xpendingSummary s g f l t defaultXPendingDetailOpts{xPeedingDetailConsumer=Just c)+```++- **xpendingSummary** no longer accepts consumer arguments as it was done in violation to spec and methodd never worked this way+- **XTrimOpts** type changed, because previous type didn't hold library invariants now instead of a simple ADT XTrimOpts is data that defines strategy of trimming and type, exact or approximate. Here is a conversion table:+  NoArg -> is not representable,+   In xaddOpts options use Nothing instead;+   In xtrim using NoArgs as a bug.+  Maxlen n -> TrimOpts{trimOptsStrategy=TrimMaxlen n, trimOptsType=TrimExact};+  MaxlenApprox n -> TrimOpts{trumOptsStrategy=TrimMaxlen n, trimOptsType=TrimApprox Nothing};+- 'addChannelsAndWait', 'removeChannelsAndWait' now wait only the channels that we run+  operations on, instead of waiting changes from all threads.+- `xreadGroupOpts` now accepts new `XReadGroupOpts` instead of `XReadOpts` type.++## 0.15.2++* PR #189. Document that UnixSocket ignores connectHost+* 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.
benchmark/Benchmark.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, LambdaCase, OverloadedLists #-}  module Main where @@ -22,8 +22,10 @@     conn <- connect defaultConnectInfo     runRedis conn $ do         _ <- flushall-        Right _ <- mset [ ("k1","v1"), ("k2","v2"), ("k3","v3")-                        , ("k4","v4"), ("k5","v5") ]+        mset [ ("k1","v1"), ("k2","v2"), ("k3","v3")+                        , ("k4","v4"), ("k5","v5") ] >>= \case+          Left _ -> error "error"+          _ -> return ()              return ()     @@ -38,7 +40,8 @@             action             liftIO $ putMVar done () -    let timeAction name nActions action = do+    let+      timeAction name nActions action = do         startT <- getCurrentTime         -- each clients runs ACTION nRepetitions times         let nRepetitions = nRequests `div` nClients `div` nActions@@ -55,38 +58,56 @@     -- Benchmarks     --     timeAction "ping" 1 $ do-        Right Pong <- ping+        ping >>= \case+          Right Pong -> return ()+          _ -> error "error"         return ()              timeAction "get" 1 $ do-        Right Nothing <- get "key"+        get "key" >>= \case+          Right Nothing -> return ()+          _ -> error "error"         return ()          timeAction "mget" 1 $ do-        Right vs <- mget ["k1","k2","k3","k4","k5"]-        let expected = map Just ["v1","v2","v3","v4","v5"]-        True <- return $ vs == expected-        return ()+        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)-        True <- return $ pongs == expected+        case pongs == expected of+              True -> return ()+              _ -> error "error"         return ()      timeAction "multiExec get 1" 1 $ do-        TxSuccess _ <- multiExec $ get "foo"+        multiExec (get "foo") >>= \case+          TxSuccess _ -> return ()+          _ -> error "error"         return ()          timeAction "multiExec get 50" 50 $ do-        TxSuccess 50 <- multiExec $ do-                            rs <- replicateM 50 (get "foo")-                            return $ fmap length (sequence rs)+        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-        TxSuccess 1000 <- multiExec $ do+        res <- multiExec $ do                             rs <- replicateM 1000 (get "foo")                             return $ fmap length (sequence rs)+        case res of+          TxSuccess 1000 -> return ()+          _ -> error "error"         return ()
hedis.cabal view
@@ -1,7 +1,9 @@+cabal-version:      3.0+build-type:         Simple name:               hedis-version:            0.6.10+version:            0.16.1 synopsis:-    Client library for the Redis datastore: supports full command set,  +    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@@ -10,9 +12,11 @@     datastore. Compared to other Haskell client libraries it has some     advantages:     .-    [Complete Redis 2.6 command set:] All Redis commands-        (<http://redis.io/commands>) are available as haskell functions, except-        for the MONITOR and SYNC commands. Additionally, a low-level API is+    [Compatibility with Latest Stable Redis:] Hedis is intended+        to be used with the latest stable version of Redis (currently 5.0).+    Most redis commands (<http://redis.io/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.     .@@ -34,71 +38,203 @@     .     For detailed documentation, see the "Database.Redis" module.     .-license:            BSD3+license:            BSD-3-Clause license-file:       LICENSE-author:             Falko Peters-maintainer:         falko.peters@gmail.com+author:             Falko Peters <falko.peters@gmail.com>+maintainer:         Kostiantyn Rybnikov <k-bx@k-bx.com>, Alexander Vershilov <alexander.vershilov@gmail.com> copyright:          Copyright (c) 2011 Falko Peters category:           Database-build-type:         Simple-cabal-version:      >=1.8 homepage:           https://github.com/informatikr/hedis bug-reports:        https://github.com/informatikr/hedis/issues extra-source-files: CHANGELOG +tested-with: GHC == { 9.6.7, 9.8.4, 9.10.3, 9.12.4, 9.14.1 }+ source-repository head   type:     git   location: https://github.com/informatikr/hedis +flag dev+  description: enable this for local development -Werror and profiling options+  default: False+  manual: True++flag cluster+  description: enable it to run cluster tests if you have required setup+  default: False+  manual: True+ library+  default-language: Haskell2010   hs-source-dirs:   src-  ghc-options:      -Wall -fwarn-tabs-  ghc-prof-options: -auto-all+  ghc-options:      -Wall -Wcompat+  if impl(ghc >= 9.8)+    ghc-options:    -Wno-x-partial+  if flag(dev)+    ghc-options:    -Werror+  if flag(dev)+    ghc-prof-options: -auto-all   exposed-modules:  Database.Redis-  build-depends:    attoparsec >= 0.12,-                    base >= 4.6 && < 5,-                    BoundedChan >= 1.0,-                    bytestring >= 0.9,-                    bytestring-lexing >= 0.5,-                    mtl >= 2,-                    network >= 2,-                    resource-pool >= 0.2,-                    time,-                    vector >= 0.9+                  , Database.Redis.Cluster+                  , Database.Redis.Cluster.Command+                  , Database.Redis.Cluster.HashSlot+                  , Database.Redis.Commands+                  , Database.Redis.Connection+                  , Database.Redis.ConnectionContext+                  , Database.Redis.Core+                  , Database.Redis.Core.Internal+                  , Database.Redis.Hooks+                  , Database.Redis.ManualCommands+                  , Database.Redis.Protocol+                  , Database.Redis.ProtocolPipelining+                  , Database.Redis.PubSub+                  , Database.Redis.Sentinel+                  , Database.Redis.Transactions+                  , Database.Redis.Types+                  , Database.Redis.URL+  build-depends:    scanner >= 0.2 && <0.4,+                    async >= 2.1 && <2.3,+                    base >= 4.18 && < 5,+                    bytestring >= 0.9 && <0.13,+                    bytestring-lexing >= 0.5 && <0.6,+                    exceptions >= 0.10 && <0.11,+                    unordered-containers >= 0.2 && <0.3,+                    containers >= 0.6 && <0.9,+                    http-types >= 0.12 && <0.13,+                    text >= 2.0 && <2.2,+                    deepseq <1.6,+                    mtl >= 2 && <3,+                    network >= 2 && < 3.3,+                    resource-pool >= 0.5 && <0.6,+                    stm < 2.6,+                    time < 1.17,+                    tls >= 1.3 && <2.5,+                    vector >= 0.9 && <0.14,+                    HTTP < 4001,+                    errors < 2.4,+                    network-uri < 2.7,+                    unliftio-core < 0.2.2,+                    hashable <1.6+  if !impl(ghc >= 8.0)+    build-depends:+      semigroups >= 0.11 && < 0.19 -  other-modules:    Database.Redis.Core,-                    Database.Redis.ProtocolPipelining,-                    Database.Redis.Protocol,-                    Database.Redis.PubSub,-                    Database.Redis.Transactions,-                    Database.Redis.Types-                    Database.Redis.Commands,-                    Database.Redis.ManualCommands+  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.*,+        mtl >= 2.0,         hedis,         time >= 1.2     ghc-options: -O2 -Wall -rtsopts-    ghc-prof-options: -auto-all+    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-    main-is: test/Test.hs+    hs-source-dirs: test+    main-is: Main.hs+    other-modules: PubSubTest+                   Tests     build-depends:         base == 4.*,-        bytestring >= 0.9 && < 0.11,+        bytestring >= 0.10,         hedis,-        HUnit == 1.2.*,+        HUnit,+        async,+        stm,+        text,         mtl == 2.*,+        network,         test-framework,         test-framework-hunit,+        transformers,         time     -- We use -O0 here, since GHC takes *very* long to compile so many constants     ghc-options: -O0 -Wall -rtsopts -fno-warn-unused-do-bind-    ghc-prof-options: -auto-all-    +    if flag(dev)+      ghc-options: -Werror+    if flag(dev)+      ghc-prof-options: -auto-all++test-suite redis7+    default-language: Haskell2010+    type: exitcode-stdio-1.0+    hs-source-dirs: test+    main-is: MainRedis7.hs+    other-modules: PubSubTest+                   Tests+    build-depends:+        base == 4.*,+        bytestring >= 0.10,+        hedis,+        HUnit,+        async,+        stm,+        text,+        mtl == 2.*,+        network,+        test-framework,+        test-framework-hunit,+        transformers,+        time+    -- We use -O0 here, since GHC takes *very* long to compile so many constants+    ghc-options: -O0 -Wall -rtsopts -fno-warn-unused-do-bind+    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.*,+        network,+        test-framework,+        test-framework-hunit,+        time,+        transformers+    -- We use -O0 here, since GHC takes *very* long to compile so many constants+    ghc-options: -O0 -Wall -rtsopts -fno-warn-unused-do-bind+    if flag(dev)+      ghc-options: -Werror+      ghc-prof-options: -auto-all+    if !flag(cluster)+      buildable: False++test-suite hedis-test-hooks+    default-language: Haskell2010+    type: exitcode-stdio-1.0+    hs-source-dirs: test+    main-is: MainHooks.hs+    build-depends:+        base == 4.*,+        hedis,+        HUnit,+        test-framework,+        test-framework-hunit+    -- We use -O0 here, since GHC takes *very* long to compile so many constants+    ghc-options: -O0 -Wall -rtsopts -fno-warn-unused-do-bind -Wunused-packages+    if flag(dev)+      ghc-options: -Werror+    if flag(dev)+      ghc-prof-options: -auto-all
src/Database/Redis.hs view
@@ -5,11 +5,25 @@     --     -- @     -- -- connects to localhost:6379-    -- conn <- 'connect' 'defaultConnectInfo'+    -- 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 { connectAddr = ConnectAddrHostPort "foobar.redis.cache.windows.net" 6380, connectTLSParams = Just tlsParams, connectAuth = Just "Foobar!" }+    -- conn <- checkedConnect redisConnInfo+    -- @+    --     -- Send commands to the server:-    -- +    --     -- @     -- {-\# LANGUAGE OverloadedStrings \#-}     -- ...@@ -20,6 +34,12 @@     --      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@@ -94,22 +114,23 @@     --  The Redis Scripting website (<http://redis.io/commands/eval>)     --  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 also works across several calls to 'runRedis', as-    --  long as replies are only evaluated /outside/ the 'runRedis' block.+    --  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@@ -121,34 +142,48 @@     --    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,-    RedisCtx(), MonadRedis(),+    Redis(), runRedis, runRedisNonBlocking,+    unRedis, reRedis,+    RedisCtx(..), MonadRedis(..),      -- * Connection-    Connection, connect,-    ConnectInfo(..),defaultConnectInfo,-    HostName,PortID(..),-    +    Connection, ConnectError(..), connect, checkedConnect,+    ClusterConnectError (..), connectCluster, checkedConnectCluster,+    disconnect, withConnect, withCheckedConnect,+    ConnectInfo(..), defaultConnectInfo, parseConnectInfo, ConnectAddr(..),+     -- * Commands     module Database.Redis.Commands,-    +     -- * Transactions     module Database.Redis.Transactions,-    +     -- * Pub\/Sub     module Database.Redis.PubSub, +    -- * Hooks+    Hooks(..), SendRequestHook, SendPubSubHook, CallbackHook, SendHook, ReceiveHook, defaultHooks,+     -- * Low-Level Command API     sendRequest,-    Reply(..),Status(..),RedisResult(..),ConnectionLostException(..),-    +    Reply(..), Status(..), RedisArg(..), RedisResult(..), ConnectionLostException(..),+    ConnectTimeout(..),+     -- |[Solution to Exercise]     --     --  Type of 'expire' inside a transaction:@@ -159,14 +194,32 @@     --     --  > lindex :: ByteString -> Integer -> Redis (Either Reply ByteString)     --+    HashSlot, keyToSlot ) where  import Database.Redis.Core+import Database.Redis.Connection+    ( runRedis+    , runRedisNonBlocking+    , connectCluster+    , defaultConnectInfo+    , ConnectInfo(..)+    , disconnect+    , checkedConnect+    , connect+    , checkedConnectCluster+    , connectCluster+    , ConnectError(..)+    , ClusterConnectError(..)+    , Connection(..)+    , withConnect+    , withCheckedConnect)+import Database.Redis.ConnectionContext(ConnectAddr(..), ConnectionLostException(..), ConnectTimeout(..)) import Database.Redis.PubSub import Database.Redis.Protocol-import Database.Redis.ProtocolPipelining-    (HostName, PortID(..), ConnectionLostException(..)) import Database.Redis.Transactions import Database.Redis.Types+import Database.Redis.URL  import Database.Redis.Commands+import Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot)
+ src/Database/Redis/Cluster.hs view
@@ -0,0 +1,499 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+module Database.Redis.Cluster+  ( Connection(..)+  , NodeRole(..)+  , NodeConnection(..)+  , Node(..)+  , ShardMap(..)+  , HashSlot+  , Shard(..)+  , connect+  , connectWith+  , disconnect+  , requestPipelined+  , nodes+  , hooks+  , requestMasterNodes+  , masterNodes+  , getRandomConnection+) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as Char8+import qualified Data.IORef as IOR+import Data.List(nub, sortBy, find)+import Data.Maybe(mapMaybe, fromMaybe)+import Data.Map(fromListWith, assocs)+import Data.Function(on)+import Control.Exception(Exception, throwIO, BlockedIndefinitelyOnMVar(..), catches, Handler(..), bracketOnError)+import Control.Concurrent.MVar(MVar, newMVar, readMVar, modifyMVar, modifyMVar_)+import Control.Monad(zipWithM, when, replicateM, forM_)+import Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot)+import qualified Database.Redis.ConnectionContext as CC+import qualified Data.HashMap.Strict as HM+import qualified Data.IntMap.Strict as IntMap+import qualified Scanner+import System.IO.Unsafe(unsafeInterleaveIO)++import Database.Redis.Protocol(Reply(..), renderRequest, reply)+import qualified Database.Redis.Cluster.Command as CMD+import Database.Redis.Hooks (Hooks)+import Network.TLS (ClientParams (..))++-- This module implements a clustered connection whilst maintaining+-- compatibility with the original Hedis codebase. In particular it still+-- 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 composed of a map from Node IDs to+-- | 'NodeConnection's, a 'Pipeline', and a 'ShardMap'+data Connection = Connection+  { connectionNodes :: HM.HashMap NodeID NodeConnection+  , connectionPipeline :: MVar Pipeline+  , connectionShardMap :: MVar ShardMap+  , connectionInfoMap :: CMD.InfoMap+  , connectionHooks :: Hooks+  }++-- | A connection to a single node in the cluster, similar to 'ProtocolPipelining.Connection'+data NodeConnection = NodeConnection+  { nodeConnectionContext :: CC.ConnectionContext+  , nodeConnectionLastRecvRef :: IOR.IORef (Maybe B.ByteString)+  , nodeConnectionNodeId :: NodeID+  }++instance Eq NodeConnection where+    NodeConnection{nodeConnectionNodeId=id1} == NodeConnection{nodeConnectionNodeId=id2} = id1 == id2++instance Ord NodeConnection where+    compare NodeConnection{nodeConnectionNodeId=id1} NodeConnection{nodeConnectionNodeId=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++-- | Represents a single node, note that this type does not include the+-- connection to the node because the shard map can be shared amongst multiple+-- connections+data Node = Node+  { nodeId :: NodeID+  , nodeRole :: NodeRole+  , nodeHost :: Host+  , nodePort :: Port+  } deriving (Show, Eq, Ord)++type MasterNode = Node+type SlaveNode = Node++-- | A 'shard' is a master node and 0 or more slaves, (the 'master', 'slave'+-- terminology is unfortunate but I felt it better to follow the documentation+-- until it changes).+data Shard = Shard+  { shardMaster :: MasterNode+  , shardSlaves :: [SlaveNode]+  } deriving (Show, Eq, Ord)++-- | A map from hashslot to shards+newtype ShardMap = ShardMap (IntMap.IntMap Shard) deriving (Show)++newtype MissingNodeException = MissingNodeException [B.ByteString] deriving (Show)+instance Exception MissingNodeException++newtype UnsupportedClusterCommandException = UnsupportedClusterCommandException [B.ByteString] deriving (Show)+instance Exception UnsupportedClusterCommandException++newtype CrossSlotException = CrossSlotException [[B.ByteString]] deriving (Show)+instance Exception CrossSlotException++data ClusterAuthError = ClusterAuthError Host Port Reply deriving (Show)+instance Exception ClusterAuthError++-- | Backwards compatible version of connect that can't provide authentication or TLS parameters.+{-# DEPRECATED connect "Use connectWith instead, passing Nothing for the parameters you don't need." #-}+connect :: [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> Hooks -> IO Connection+connect = connectWith Nothing Nothing Nothing++-- | Connects to cluster.+connectWith :: Maybe B.ByteString -> Maybe B.ByteString -> Maybe ClientParams -> [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> Hooks -> IO Connection+connectWith mUsername mPassword mTlsParams commandInfos shardMapVar timeoutOpt hooks' = do+        shardMap <- readMVar shardMapVar+        stateVar <- newMVar $ Pending []+        pipelineVar <- newMVar $ Pipeline stateVar+        nodeConns <- nodeConnections shardMap+        return $ Connection nodeConns pipelineVar shardMapVar (CMD.newInfoMap commandInfos) hooks' where+    nodeConnections :: ShardMap -> IO (HM.HashMap NodeID NodeConnection)+    nodeConnections shardMap = HM.fromList <$> connectNodes (nub $ nodes shardMap)+    connectNodes :: [Node] -> IO [(NodeID, NodeConnection)]+    connectNodes [] = return []+    connectNodes (z@Node{nodeHost = host, nodePort = port}:ns) = do+        bracketOnError+          (CC.connect (CC.ConnectAddrHostPort host $ toEnum port) timeoutOpt mTlsParams)+          (CC.disconnect) $ \ctx0 -> do+            nodeConn <- connectNode z ctx0+            rest <- connectNodes ns+            return $ nodeConn : rest+    connectNode :: Node -> CC.ConnectionContext -> IO (NodeID, NodeConnection)+    connectNode Node{nodeId = n, nodeHost = host, nodePort = port} ctx0 = do+        ref <- IOR.newIORef Nothing+        let nodeConn = NodeConnection ctx0 ref n+        forM_ mPassword $ \password -> do+            let reqOpts = maybe [password] (:[password]) mUsername+            authReply <- requestNode1 nodeConn ( ["AUTH"] <> reqOpts )+            case authReply of+              SingleLine "OK" -> pure ()+              _ -> throwIO $ ClusterAuthError host port authReply+        return (n, nodeConn)++disconnect :: Connection -> IO ()+disconnect Connection{connectionNodes=nodeConnMap} = mapM_ disconnectNode (HM.elems nodeConnMap) where+    disconnectNode (NodeConnection nodeCtx _ _) = CC.disconnect nodeCtx++-- Add a request to the current pipeline for this connection. The pipeline will+-- be executed implicitly as soon as any result returned from this function is+-- evaluated.+requestPipelined :: IO ShardMap -> Connection -> [B.ByteString] -> IO Reply+requestPipelined refreshAction conn@Connection{connectionPipeline=pipelineVar, connectionShardMap=shardMapVar} nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do+    (newStateVar, repliesIndex) <- hasLocked $ modifyMVar stateVar $ \case+        Pending requests | isMulti nextRequest -> do+            replies <- evaluatePipeline shardMapVar refreshAction conn requests+            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{connectionInfoMap=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{connectionInfoMap=infoMap} = conn+    keys <- mconcat <$> mapM (requestKeys infoMap) requests+    -- In cluster mode Redis expects commands in transactions to all work on the+    -- same hashslot. We find that hashslot here.+    -- 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{connectionNodes=nodeConns} = conn+    (ShardMap shardMap) <- hasLocked $ readMVar shardMapVar+    node <-+        case IntMap.lookup (fromEnum hashSlot) shardMap of+            Nothing -> throwIO exception+            Just Shard{shardMaster = 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{connectionNodes=nodeConns} host port = do+    node <- nodeWithHostAndPort shardMap host port+    HM.lookup (nodeId node) nodeConns++nodeConnectionForCommand :: Connection -> ShardMap -> [B.ByteString] -> IO [NodeConnection]+nodeConnectionForCommand conn@Connection{connectionNodes=nodeConns, connectionInfoMap=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{shardMaster = 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{connectionNodes=nodeConns} (ShardMap shardMap) =+    mapM (flip HM.lookup nodeConns . nodeId) masters+  where+    masters = shardMaster <$> nub (IntMap.elems shardMap)++requestNode :: NodeConnection -> [[B.ByteString]] -> IO [Reply]+requestNode nodeConn@(NodeConnection ctx _ _) requests = do+    mapM_ (sendNode . renderRequest) requests+    _ <- CC.flush ctx+    replicateM (length requests) $ recvNode nodeConn++    where++    sendNode :: B.ByteString -> IO ()+    sendNode = CC.send ctx++requestNode1 :: NodeConnection -> [B.ByteString] -> IO Reply+requestNode1 nodeConn@NodeConnection{nodeConnectionContext=ctx} request = do+    CC.send ctx $ renderRequest request+    _ <- CC.flush ctx+    recvNode nodeConn++recvNode :: NodeConnection -> IO Reply+recvNode NodeConnection{nodeConnectionContext = ctx, nodeConnectionLastRecvRef = lastRecvRef} = do+    maybeLastRecv <- IOR.readIORef lastRecvRef+    scanResult <- case maybeLastRecv of+        Just lastRecv -> Scanner.scanWith (CC.recv ctx) reply lastRecv+        Nothing -> Scanner.scanWith (CC.recv ctx) reply B.empty++    case scanResult of+      Scanner.Fail{}       -> CC.errConnClosed+      Scanner.More{}    -> error "Hedis: parseWith returned Partial"+      Scanner.Done rest' r -> do+        IOR.writeIORef lastRecvRef (Just rest')+        return r++nodes :: ShardMap -> [Node]+nodes (ShardMap shardMap) = concatMap snd $ IntMap.toList $ fmap shardNodes shardMap where+    shardNodes :: Shard -> [Node]+    shardNodes Shard{..} = shardMaster:shardSlaves+++nodeWithHostAndPort :: ShardMap -> Host -> Port -> Maybe Node+nodeWithHostAndPort shardMap host port = find (\Node{nodeHost = h, nodePort = p} -> port == p && host == h) (nodes shardMap)++hasLocked :: IO a -> IO a+hasLocked action =+  action `catches`+  [ Handler $ \exc@BlockedIndefinitelyOnMVar -> throwIO exc+  ]++hooks :: Connection -> Hooks+hooks = connectionHooks++-- | Send a request to all master nodes in the cluster. This is useful for commands that need to be sent to all master nodes, such as `FLUSHALL` or `CONFIG SET`.+requestMasterNodes :: Connection -> [B.ByteString] -> IO [Reply]+requestMasterNodes conn req = do+    masterNodeConns <- masterNodes conn+    concat <$> mapM (`requestNode` [req]) masterNodeConns++-- | Get connection to a master nodes in the cluster.+-- This is useful for commands that need to be sent to all master nodes, such as `FLUSHALL` or `CONFIG SET`.+masterNodes :: Connection -> IO [NodeConnection]+masterNodes (Connection nodeConns _ shardMapVar _ _) = do+    (ShardMap shardMap) <- readMVar shardMapVar+    let masters = map shardMaster $ nub $ IntMap.elems shardMap+    let masterNodeIds = map nodeId masters+    return $ mapMaybe (`HM.lookup` nodeConns) masterNodeIds++-- | Get connection to a random node in the cluster that is not the same as the provided connection.+getRandomConnection :: NodeConnection -> Connection -> NodeConnection+getRandomConnection nc Connection{connectionNodes = hmn} =+  let conns = HM.elems hmn+      in fromMaybe (head conns) $ find (nc /= ) conns
+ src/Database/Redis/Cluster/Command.hs view
@@ -0,0 +1,196 @@+{-# 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]))+    -- since redis 7.0+    decode (MultiBulk (Just+        [ name@(Bulk (Just _))+        , arity@(Integer _)+        , flags@(MultiBulk (Just _))+        , firstPos@(Integer _)+        , lastPos@(Integer _)+        , step@(Integer _)+        , MultiBulk _  -- ACL categories+        , MultiBulk _  -- Tips+        , MultiBulk _  -- Key specifications+        , MultiBulk _  -- Subcommands+        ])) =+        decode (MultiBulk (Just [name, arity, flags, firstPos, lastPos, step]))++    decode e = Left e++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 _ ["OBJECT", "refcount", key] =+    Just [key]+keysForRequest _ ["OBJECT", "encoding", key] =+    Just [key]+keysForRequest _ ["OBJECT", "idletime", key] =+    Just [key]+keysForRequest _ ("XINFO":_:key:_) =+    Just [key]+keysForRequest (InfoMap infoMap) request@(command:_) = do+    info <- HM.lookup (map toLower $ Char8.unpack command) infoMap+    keysForRequest' info request+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) = readXreadgroupKeys rest+readXreadgroupKeys ("BLOCK":_:rest) = readXreadgroupKeys rest+readXreadgroupKeys ("NOACK":rest) = readXreadgroupKeys 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
+ src/Database/Redis/Cluster/HashSlot.hs view
@@ -0,0 +1,62 @@+{-# 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.Maybe (fromMaybe)+import Data.Word(Word8, Word16)++-- $setup+-- >>> :set -XOverloadedStrings++newtype HashSlot = HashSlot Word16 deriving (Num, Eq, Ord, Real, Enum, Integral, Show)++numHashSlots :: Word16+numHashSlots = 16384++-- | Compute the hashslot associated with a key+--+-- >>> keyToSlot "123"+-- HashSlot 5970+-- >>> keyToSlot "{123"+-- HashSlot 2872+-- >>> keyToSlot "{123}"+-- HashSlot 5970+-- >>> keyToSlot "{}123"+-- HashSlot 7640+-- >>> keyToSlot "{123}1{abc}"+-- HashSlot 5970+-- >>> keyToSlot "\00\01"+-- HashSlot 4129+keyToSlot :: BS.ByteString -> HashSlot+keyToSlot = HashSlot . (.&.) (numHashSlots - 1) . crc16 . findSubKey++-- | Find the section of a key to compute the slot for.+findSubKey :: BS.ByteString -> BS.ByteString+findSubKey key = fromMaybe key (go key) where+  go bs = case Char8.break (=='{') bs of+    (_, "") -> Nothing+    (_, xs)  -> case Char8.break (=='}') (Char8.tail xs) of+      ("", _) -> go (Char8.tail xs)+      (_, "") -> Nothing+      (subKey, _) -> Just subKey++crc16 :: BS.ByteString -> Word16+crc16 = BS.foldl (crc16Update 0x1021) 0++-- 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+
src/Database/Redis/Commands.hs view
@@ -1,966 +1,1575 @@--- Generated by GenCmds.hs. DO NOT EDIT.--{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}--module Database.Redis.Commands (---- ** Connection-auth, -- |Authenticate to the server (<http://redis.io/commands/auth>).-echo, -- |Echo the given string (<http://redis.io/commands/echo>).-ping, -- |Ping the server (<http://redis.io/commands/ping>).-quit, -- |Close the connection (<http://redis.io/commands/quit>).-select, -- |Change the selected database for the current connection (<http://redis.io/commands/select>).---- ** Keys-del, -- |Delete a key (<http://redis.io/commands/del>).-dump, -- |Return a serialized version of the value stored at the specified key. (<http://redis.io/commands/dump>).-exists, -- |Determine if a key exists (<http://redis.io/commands/exists>).-expire, -- |Set a key's time to live in seconds (<http://redis.io/commands/expire>).-expireat, -- |Set the expiration for a key as a UNIX timestamp (<http://redis.io/commands/expireat>).-keys, -- |Find all keys matching the given pattern (<http://redis.io/commands/keys>).-migrate, -- |Atomically transfer a key from a Redis instance to another one. (<http://redis.io/commands/migrate>).-move, -- |Move a key to another database (<http://redis.io/commands/move>).-objectRefcount, -- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'.-objectEncoding, -- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'.-objectIdletime, -- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'.-persist, -- |Remove the expiration from a key (<http://redis.io/commands/persist>).-pexpire, -- |Set a key's time to live in milliseconds (<http://redis.io/commands/pexpire>).-pexpireat, -- |Set the expiration for a key as a UNIX timestamp specified in milliseconds (<http://redis.io/commands/pexpireat>).-pttl, -- |Get the time to live for a key in milliseconds (<http://redis.io/commands/pttl>).-randomkey, -- |Return a random key from the keyspace (<http://redis.io/commands/randomkey>).-rename, -- |Rename a key (<http://redis.io/commands/rename>).-renamenx, -- |Rename a key, only if the new key does not exist (<http://redis.io/commands/renamenx>).-restore, -- |Create a key using the provided serialized value, previously obtained using DUMP. (<http://redis.io/commands/restore>).-SortOpts(..),-defaultSortOpts,-SortOrder(..),-sort, -- |Sort the elements in a list, set or sorted set (<http://redis.io/commands/sort>). The Redis command @SORT@ is split up into 'sort', 'sortStore'.-sortStore, -- |Sort the elements in a list, set or sorted set (<http://redis.io/commands/sort>). The Redis command @SORT@ is split up into 'sort', 'sortStore'.-ttl, -- |Get the time to live for a key (<http://redis.io/commands/ttl>).-RedisType(..),-getType, -- |Determine the type stored at key (<http://redis.io/commands/type>).---- ** Hashes-hdel, -- |Delete one or more hash fields (<http://redis.io/commands/hdel>).-hexists, -- |Determine if a hash field exists (<http://redis.io/commands/hexists>).-hget, -- |Get the value of a hash field (<http://redis.io/commands/hget>).-hgetall, -- |Get all the fields and values in a hash (<http://redis.io/commands/hgetall>).-hincrby, -- |Increment the integer value of a hash field by the given number (<http://redis.io/commands/hincrby>).-hincrbyfloat, -- |Increment the float value of a hash field by the given amount (<http://redis.io/commands/hincrbyfloat>).-hkeys, -- |Get all the fields in a hash (<http://redis.io/commands/hkeys>).-hlen, -- |Get the number of fields in a hash (<http://redis.io/commands/hlen>).-hmget, -- |Get the values of all the given hash fields (<http://redis.io/commands/hmget>).-hmset, -- |Set multiple hash fields to multiple values (<http://redis.io/commands/hmset>).-hset, -- |Set the string value of a hash field (<http://redis.io/commands/hset>).-hsetnx, -- |Set the value of a hash field, only if the field does not exist (<http://redis.io/commands/hsetnx>).-hvals, -- |Get all the values in a hash (<http://redis.io/commands/hvals>).---- ** HyperLogLogs-pfadd, -- |Adds all the elements arguments to the HyperLogLog data structure stored at the variable name specified as first argument. (<http://redis.io/commands/pfadd>).-pfcount, -- |Returns the approximated cardinality for the union of the HyperLogLogs stored in the specified keys. (<http://redis.io/commands/pfcount>).-pfmerge, -- |Merge multiple HyperLogLog values into an unique value that will approximate the cardinality of the union of the observed Sets of the source HyperLogLog structures. (<http://redis.io/commands/pfmerge>).---- ** Lists-blpop, -- |Remove and get the first element in a list, or block until one is available (<http://redis.io/commands/blpop>).-brpop, -- |Remove and get the last element in a list, or block until one is available (<http://redis.io/commands/brpop>).-brpoplpush, -- |Pop a value from a list, push it to another list and return it; or block until one is available (<http://redis.io/commands/brpoplpush>).-lindex, -- |Get an element from a list by its index (<http://redis.io/commands/lindex>).-linsertBefore, -- |Insert an element before or after another element in a list (<http://redis.io/commands/linsert>). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'.-linsertAfter, -- |Insert an element before or after another element in a list (<http://redis.io/commands/linsert>). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'.-llen, -- |Get the length of a list (<http://redis.io/commands/llen>).-lpop, -- |Remove and get the first element in a list (<http://redis.io/commands/lpop>).-lpush, -- |Prepend one or multiple values to a list (<http://redis.io/commands/lpush>).-lpushx, -- |Prepend a value to a list, only if the list exists (<http://redis.io/commands/lpushx>).-lrange, -- |Get a range of elements from a list (<http://redis.io/commands/lrange>).-lrem, -- |Remove elements from a list (<http://redis.io/commands/lrem>).-lset, -- |Set the value of an element in a list by its index (<http://redis.io/commands/lset>).-ltrim, -- |Trim a list to the specified range (<http://redis.io/commands/ltrim>).-rpop, -- |Remove and get the last element in a list (<http://redis.io/commands/rpop>).-rpoplpush, -- |Remove the last element in a list, append it to another list and return it (<http://redis.io/commands/rpoplpush>).-rpush, -- |Append one or multiple values to a list (<http://redis.io/commands/rpush>).-rpushx, -- |Append a value to a list, only if the list exists (<http://redis.io/commands/rpushx>).---- ** Scripting-eval, -- |Execute a Lua script server side (<http://redis.io/commands/eval>).-evalsha, -- |Execute a Lua script server side (<http://redis.io/commands/evalsha>).-scriptExists, -- |Check existence of scripts in the script cache. (<http://redis.io/commands/script-exists>).-scriptFlush, -- |Remove all the scripts from the script cache. (<http://redis.io/commands/script-flush>).-scriptKill, -- |Kill the script currently in execution. (<http://redis.io/commands/script-kill>).-scriptLoad, -- |Load the specified Lua script into the script cache. (<http://redis.io/commands/script-load>).---- ** Server-bgrewriteaof, -- |Asynchronously rewrite the append-only file (<http://redis.io/commands/bgrewriteaof>).-bgsave, -- |Asynchronously save the dataset to disk (<http://redis.io/commands/bgsave>).-configGet, -- |Get the value of a configuration parameter (<http://redis.io/commands/config-get>).-configResetstat, -- |Reset the stats returned by INFO (<http://redis.io/commands/config-resetstat>).-configSet, -- |Set a configuration parameter to the given value (<http://redis.io/commands/config-set>).-dbsize, -- |Return the number of keys in the selected database (<http://redis.io/commands/dbsize>).-debugObject, -- |Get debugging information about a key (<http://redis.io/commands/debug-object>).-flushall, -- |Remove all keys from all databases (<http://redis.io/commands/flushall>).-flushdb, -- |Remove all keys from the current database (<http://redis.io/commands/flushdb>).-info, -- |Get information and statistics about the server (<http://redis.io/commands/info>).-lastsave, -- |Get the UNIX time stamp of the last successful save to disk (<http://redis.io/commands/lastsave>).-save, -- |Synchronously save the dataset to disk (<http://redis.io/commands/save>).-slaveof, -- |Make the server a slave of another instance, or promote it as master (<http://redis.io/commands/slaveof>).-Slowlog(..),-slowlogGet, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'.-slowlogLen, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'.-slowlogReset, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'.-time, -- |Return the current server time (<http://redis.io/commands/time>).---- ** Sets-sadd, -- |Add one or more members to a set (<http://redis.io/commands/sadd>).-scard, -- |Get the number of members in a set (<http://redis.io/commands/scard>).-sdiff, -- |Subtract multiple sets (<http://redis.io/commands/sdiff>).-sdiffstore, -- |Subtract multiple sets and store the resulting set in a key (<http://redis.io/commands/sdiffstore>).-sinter, -- |Intersect multiple sets (<http://redis.io/commands/sinter>).-sinterstore, -- |Intersect multiple sets and store the resulting set in a key (<http://redis.io/commands/sinterstore>).-sismember, -- |Determine if a given value is a member of a set (<http://redis.io/commands/sismember>).-smembers, -- |Get all the members in a set (<http://redis.io/commands/smembers>).-smove, -- |Move a member from one set to another (<http://redis.io/commands/smove>).-spop, -- |Remove and return a random member from a set (<http://redis.io/commands/spop>).-srandmember, -- |Get a random member from a set (<http://redis.io/commands/srandmember>).-srem, -- |Remove one or more members from a set (<http://redis.io/commands/srem>).-sunion, -- |Add multiple sets (<http://redis.io/commands/sunion>).-sunionstore, -- |Add multiple sets and store the resulting set in a key (<http://redis.io/commands/sunionstore>).---- ** Sorted Sets-zadd, -- |Add one or more members to a sorted set, or update its score if it already exists (<http://redis.io/commands/zadd>).-zcard, -- |Get the number of members in a sorted set (<http://redis.io/commands/zcard>).-zcount, -- |Count the members in a sorted set with scores within the given values (<http://redis.io/commands/zcount>).-zincrby, -- |Increment the score of a member in a sorted set (<http://redis.io/commands/zincrby>).-Aggregate(..),-zinterstore, -- |Intersect multiple sorted sets and store the resulting sorted set in a new key (<http://redis.io/commands/zinterstore>). The Redis command @ZINTERSTORE@ is split up into 'zinterstore', 'zinterstoreWeights'.-zinterstoreWeights, -- |Intersect multiple sorted sets and store the resulting sorted set in a new key (<http://redis.io/commands/zinterstore>). The Redis command @ZINTERSTORE@ is split up into 'zinterstore', 'zinterstoreWeights'.-zrange, -- |Return a range of members in a sorted set, by index (<http://redis.io/commands/zrange>). The Redis command @ZRANGE@ is split up into 'zrange', 'zrangeWithscores'.-zrangeWithscores, -- |Return a range of members in a sorted set, by index (<http://redis.io/commands/zrange>). The Redis command @ZRANGE@ is split up into 'zrange', 'zrangeWithscores'.-zrangebyscore, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'.-zrangebyscoreWithscores, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'.-zrangebyscoreLimit, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'.-zrangebyscoreWithscoresLimit, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'.-zrank, -- |Determine the index of a member in a sorted set (<http://redis.io/commands/zrank>).-zrem, -- |Remove one or more members from a sorted set (<http://redis.io/commands/zrem>).-zremrangebyrank, -- |Remove all members in a sorted set within the given indexes (<http://redis.io/commands/zremrangebyrank>).-zremrangebyscore, -- |Remove all members in a sorted set within the given scores (<http://redis.io/commands/zremrangebyscore>).-zrevrange, -- |Return a range of members in a sorted set, by index, with scores ordered from high to low (<http://redis.io/commands/zrevrange>). The Redis command @ZREVRANGE@ is split up into 'zrevrange', 'zrevrangeWithscores'.-zrevrangeWithscores, -- |Return a range of members in a sorted set, by index, with scores ordered from high to low (<http://redis.io/commands/zrevrange>). The Redis command @ZREVRANGE@ is split up into 'zrevrange', 'zrevrangeWithscores'.-zrevrangebyscore, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (<http://redis.io/commands/zrevrangebyscore>). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'.-zrevrangebyscoreWithscores, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (<http://redis.io/commands/zrevrangebyscore>). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'.-zrevrangebyscoreLimit, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (<http://redis.io/commands/zrevrangebyscore>). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'.-zrevrangebyscoreWithscoresLimit, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (<http://redis.io/commands/zrevrangebyscore>). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'.-zrevrank, -- |Determine the index of a member in a sorted set, with scores ordered from high to low (<http://redis.io/commands/zrevrank>).-zscore, -- |Get the score associated with the given member in a sorted set (<http://redis.io/commands/zscore>).-zunionstore, -- |Add multiple sorted sets and store the resulting sorted set in a new key (<http://redis.io/commands/zunionstore>). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'.-zunionstoreWeights, -- |Add multiple sorted sets and store the resulting sorted set in a new key (<http://redis.io/commands/zunionstore>). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'.---- ** Strings-append, -- |Append a value to a key (<http://redis.io/commands/append>).-bitcount, -- |Count set bits in a string (<http://redis.io/commands/bitcount>). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'.-bitcountRange, -- |Count set bits in a string (<http://redis.io/commands/bitcount>). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'.-bitopAnd, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'.-bitopOr, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'.-bitopXor, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'.-bitopNot, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'.-decr, -- |Decrement the integer value of a key by one (<http://redis.io/commands/decr>).-decrby, -- |Decrement the integer value of a key by the given number (<http://redis.io/commands/decrby>).-get, -- |Get the value of a key (<http://redis.io/commands/get>).-getbit, -- |Returns the bit value at offset in the string value stored at key (<http://redis.io/commands/getbit>).-getrange, -- |Get a substring of the string stored at a key (<http://redis.io/commands/getrange>).-getset, -- |Set the string value of a key and return its old value (<http://redis.io/commands/getset>).-incr, -- |Increment the integer value of a key by one (<http://redis.io/commands/incr>).-incrby, -- |Increment the integer value of a key by the given amount (<http://redis.io/commands/incrby>).-incrbyfloat, -- |Increment the float value of a key by the given amount (<http://redis.io/commands/incrbyfloat>).-mget, -- |Get the values of all the given keys (<http://redis.io/commands/mget>).-mset, -- |Set multiple keys to multiple values (<http://redis.io/commands/mset>).-msetnx, -- |Set multiple keys to multiple values, only if none of the keys exist (<http://redis.io/commands/msetnx>).-psetex, -- |Set the value and expiration in milliseconds of a key (<http://redis.io/commands/psetex>).-set, -- |Set the string value of a key (<http://redis.io/commands/set>).-setbit, -- |Sets or clears the bit at offset in the string value stored at key (<http://redis.io/commands/setbit>).-setex, -- |Set the value and expiration of a key (<http://redis.io/commands/setex>).-setnx, -- |Set the value of a key, only if the key does not exist (<http://redis.io/commands/setnx>).-setrange, -- |Overwrite part of a string at key starting at the specified offset (<http://redis.io/commands/setrange>).-strlen, -- |Get the length of the value stored in a key (<http://redis.io/commands/strlen>).---- * 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.------ * MONITOR (<http://redis.io/commands/monitor>)--------- * SYNC (<http://redis.io/commands/sync>)--------- * SHUTDOWN (<http://redis.io/commands/shutdown>)--------- * DEBUG SEGFAULT (<http://redis.io/commands/debug-segfault>)----) where--import Prelude hiding (min,max)-import Data.ByteString (ByteString)-import Database.Redis.ManualCommands-import Database.Redis.Types-import Database.Redis.Core--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] )--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] )--spop-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> m (f (Maybe ByteString))-spop key = sendRequest (["SPOP"] ++ [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] )--set-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> ByteString -- ^ value-    -> m (f Status)-set key value = sendRequest (["SET"] ++ [encode key] ++ [encode value] )--lpush-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> [ByteString] -- ^ value-    -> m (f Integer)-lpush key value = sendRequest (["LPUSH"] ++ [encode key] ++ map encode value )--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] )--exists-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> m (f Bool)-exists key = sendRequest (["EXISTS"] ++ [encode key] )--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 )--ping-    :: (RedisCtx m f)-    => m (f Status)-ping  = sendRequest (["PING"] )--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] )--restore-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> Integer -- ^ timeToLive-    -> ByteString -- ^ serializedValue-    -> m (f Status)-restore key timeToLive serializedValue = sendRequest (["RESTORE"] ++ [encode key] ++ [encode timeToLive] ++ [encode serializedValue] )--scriptFlush-    :: (RedisCtx m f)-    => m (f Status)-scriptFlush  = sendRequest (["SCRIPT","FLUSH"] )--dbsize-    :: (RedisCtx m f)-    => m (f Integer)-dbsize  = sendRequest (["DBSIZE"] )--lpop-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> m (f (Maybe ByteString))-lpop key = sendRequest (["LPOP"] ++ [encode key] )--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 )--lastsave-    :: (RedisCtx m f)-    => m (f Integer)-lastsave  = sendRequest (["LASTSAVE"] )--zadd-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> [(Double,ByteString)] -- ^ scoreMember-    -> m (f Integer)-zadd key scoreMember = sendRequest (["ZADD"] ++ [encode key] ++ concatMap (\(x,y) -> [encode x,encode y])scoreMember )--pexpire-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> Integer -- ^ milliseconds-    -> m (f Bool)-pexpire key milliseconds = sendRequest (["PEXPIRE"] ++ [encode key] ++ [encode milliseconds] )--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] )--srandmember-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> m (f (Maybe ByteString))-srandmember key = sendRequest (["SRANDMEMBER"] ++ [encode key] )--hset-    :: (RedisCtx m f)-    => ByteString -- ^ key-    -> ByteString -- ^ field-    -> ByteString -- ^ value-    -> m (f Bool)-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] )--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] )--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] )--info-    :: (RedisCtx m f)-    => m (f ByteString)-info  = sendRequest (["INFO"] )--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 )--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] )--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"] ++ [encode host] ++ [encode port] ++ [encode key] ++ [encode destinationDb] ++ [encode timeout] )---+{-# LANGUAGE OverloadedStrings, FlexibleContexts, OverloadedLists #-}++module Database.Redis.Commands (++-- ** Connection++-- *** auth+-- $auth+auth,+authOpts,+AuthOpts(..),+defaultAuthOpts,+-- *** Other commands+echo,+ping,+quit,+select,++-- ** Keys+del,+dump,+exists,+expire,+ExpireOpts(..),+expireOpts,+expireat,+expireatOpts,+keys,+MigrateOpts(..),+defaultMigrateOpts,+migrate,+migrateMultiple,+move,+objectRefcount,+objectEncoding,+objectIdletime,+persist,+pexpire,+pexpireat,+pexpireatOpts,+pttl,+randomkey,+rename,+renamenx,+restore,+restoreReplace,+Cursor,+cursor0,+ScanOpts(..),+defaultScanOpts,+scan,+scanOpts,+SortOpts(..),+defaultSortOpts,+SortOrder(..),+sort,+sortStore,+ttl,+RedisType(..),+getType,+wait,++-- ** Hashes+hdel,+hexists,+hget,+hgetall,+hincrby,+hincrbyfloat,+hkeys,+hlen,+hmget,+hmset,+hscan,+hscanOpts,+hset,+hsetnx,+hstrlen,+hvals,++-- ** HyperLogLogs+pfadd,+pfcount,+pfmerge,++-- ** Lists+blpop,+blpopFloat,+brpop,+brpopFloat,+brpoplpush,+lindex,+linsertBefore,+linsertAfter,+llen,+lpop,+lpopCount,+lpush,+lpushx,+lrange,+lrem,+lset,+ltrim,+rpop,+rpopCount,+rpoplpush,+rpush,+rpushx,++-- ** Scripting+eval,+evalsha,+DebugMode,+scriptDebug,+scriptExists,+scriptFlush,+scriptKill,+scriptLoad,++-- ** Server+bgrewriteaof,+bgsave,+bgsaveSchedule,+clientGetname,+clientId,+clientList,+clientPause,+ReplyMode,+clientReply,+clientSetname,+commandCount,+commandInfo,+configGet,+configResetstat,+configRewrite,+configSet,+dbsize,+debugObject,+flushall,+flushallOpts,+FlushOpts(..),+flushdb,+flushdbOpts,+info, -- |Get information and statistics about the server (<http://redis.io/commands/info>). The Redis command @INFO@ is split up into 'info', 'infoSection'. Since Redis 1.0.0+infoSection, -- |Get information and statistics about the server (<http://redis.io/commands/info>). The Redis command @INFO@ is split up into 'info', 'infoSection'. Since Redis 1.0.0+lastsave, -- |Get the UNIX time stamp of the last successful save to disk (<http://redis.io/commands/lastsave>). Since Redis 1.0.0+save,+slaveof,+Slowlog(..),+slowlogGet, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12+slowlogLen, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12+slowlogReset, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12+time,++-- ** Sets+sadd,+scard,+sdiff,+sdiffstore,+sinter,+sinterstore,+sismember,+smembers,+smove,+spop,+spopN,+srandmember,+srandmemberN,+srem,+sscan,+sscanOpts,+sunion,+sunionstore,++-- ** Sorted Sets+ZaddOpts(..),+defaultZaddOpts,+zadd,+zaddOpts,+SizeCondition(..),+zcard,+zcount,+zincrby,+Aggregate(..),+zinterstore,+zinterstoreWeights,+zlexcount,+zrange,+zrangeWithscores,+RangeLex(..),+zrangebylex, zrangebylexLimit,+zrangebyscore, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5+zrangebyscoreWithscores, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5+zrangebyscoreLimit, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5+zrangebyscoreWithscoresLimit, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5+zrank,+zrankWithScore,+zrem,+zremrangebylex,+zremrangebyrank,+zremrangebyscore,+zrevrange, -- |Return a range of members in a sorted set, by index, with scores ordered from high to low (<http://redis.io/commands/zrevrange>). The Redis command @ZREVRANGE@ is split up into 'zrevrange', 'zrevrangeWithscores'. Since Redis 1.2.0+zrevrangeWithscores, -- |Return a range of members in a sorted set, by index, with scores ordered from high to low (<http://redis.io/commands/zrevrange>). The Redis command @ZREVRANGE@ is split up into 'zrevrange', 'zrevrangeWithscores'. Since Redis 1.2.0+zrevrangebyscore, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (<http://redis.io/commands/zrevrangebyscore>). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0+zrevrangebyscoreWithscores, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (<http://redis.io/commands/zrevrangebyscore>). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0+zrevrangebyscoreLimit, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (<http://redis.io/commands/zrevrangebyscore>). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0+zrevrangebyscoreWithscoresLimit, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (<http://redis.io/commands/zrevrangebyscore>). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0+zrevrank,+zrevrankWithScore,+zscan, -- |Incrementally iterate sorted sets elements and associated scores (<http://redis.io/commands/zscan>). The Redis command @ZSCAN@ is split up into 'zscan', 'zscanOpts'. Since Redis 2.8.0+zscanOpts, -- |Incrementally iterate sorted sets elements and associated scores (<http://redis.io/commands/zscan>). The Redis command @ZSCAN@ is split up into 'zscan', 'zscanOpts'. Since Redis 2.8.0+zscore,+zunionstore, -- |Add multiple sorted sets and store the resulting sorted set in a new key (<http://redis.io/commands/zunionstore>). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'. Since Redis 2.0.0+zunionstoreWeights, -- |Add multiple sorted sets and store the resulting sorted set in a new key (<http://redis.io/commands/zunionstore>). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'. Since Redis 2.0.0++-- ** Strings+append,+bitcount, -- |Count set bits in a string (<http://redis.io/commands/bitcount>). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'. Since Redis 2.6.0+bitcountRange, -- |Count set bits in a string (<http://redis.io/commands/bitcount>). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'. Since Redis 2.6.0+bitopAnd, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0+bitopOr, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0+bitopXor, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0+bitopNot, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0+bitpos,+bitposOpts,+BitposOpts(..),+BitposType(..),+decr,+decrby,+get,+getbit,+getrange,+getset,+incr,+incrby,+incrbyfloat,+mget,+mset,+msetnx,+psetex,+Condition(..),+SetOpts(..),+set, -- |Set the string value of a key (<http://redis.io/commands/set>). The Redis command @SET@ is split up into 'set', 'setOpts', 'setGet', 'setGetOpts'. Since Redis 1.0.0+setOpts, -- |Set the string value of a key (<http://redis.io/commands/set>). The Redis command @SET@ is split up into 'set', 'setOpts', 'setGet', 'setGetOpts'. Since Redis 1.0.0+setGet, -- |Set the string value of a key (<http://redis.io/commands/set>). The Redis command @SET@ is split up into 'set', 'setOpts', 'setGet', 'setGetOpts'. Since Redis 1.0.0+setGetOpts, -- |Set the string value of a key (<http://redis.io/commands/set>). The Redis command @SET@ is split up into 'set', 'setOpts', 'setGet', 'setGetOpts'. Since Redis 1.0.0+setbit,+setex,+setnx,+setrange,+strlen,+++-- ** Streams+XReadOpts(..),+defaultXreadOpts,+XReadResponse(..),+StreamsRecord(..),+xadd,+xaddOpts,+XAddOpts(..),+defaultXAddOpts,+TrimStrategy(..),+TrimType(..),+trimOpts,+xread, -- |Read values from a stream (<https://redis.io/commands/xread>). The Redis command @XREAD@ is split up into 'xread', 'xreadOpts'. Since Redis 5.0.0+xreadOpts, -- |Read values from a stream (<https://redis.io/commands/xread>). The Redis command @XREAD@ is split up into 'xread', 'xreadOpts'. Since Redis 5.0.0+xreadGroup, -- |Read values from a stream as part of a consumer group (https://redis.io/commands/xreadgroup). The redis command @XREADGROUP@ is split up into 'xreadGroup' and 'xreadGroupOpts'. Since Redis 5.0.0+XReadGroupOpts(..),+defaultXReadGroupOpts,+xreadGroupOpts, -- |Read values from a stream as part of a consumer group (https://redis.io/commands/xreadgroup). The redis command @XREADGROUP@ is split up into 'xreadGroup' and 'xreadGroupOpts'. Since Redis 5.0.0+xack, -- |Acknowledge receipt of a message as part of a consumer group. Since Redis 5.0.0++-- *** XGROUP CREATE+-- $xgroupCreate+xgroupCreate,+xgroupCreateOpts,+XGroupCreateOpts(..),+defaultXGroupCreateOpts,++-- *** XGROUP CREATECONSUMER+xgroupCreateConsumer,++-- *** XGROUP SETID+-- $xgroupSetId+xgroupSetId,+xgroupSetIdOpts,+XGroupSetIdOpts(..),+defaultXGroupSetIdOpts,++-- *** XGROUP DESTROY+xgroupDestroy,++-- *** XGROUP DELCONSUMER+xgroupDelConsumer,++xrange, -- |Read values from a stream within a range (https://redis.io/commands/xrange). Since Redis 5.0.0+xrevRange, -- |Read values from a stream within a range in reverse order (https://redis.io/commands/xrevrange). Since Redis 5.0.0+xlen, -- |Get the number of entries in a stream (https://redis.io/commands/xlen). Since Redis 5.0.0++-- *** XPENDING+-- $xpending+xpendingSummary,+XPendingSummaryResponse(..),+XPendingDetailOpts(..),+defaultXPendingDetailOpts,+XPendingDetailRecord(..),+xpendingDetail,++XClaimOpts(..),+defaultXClaimOpts,+xclaim, -- |Change ownership of some messages to the given consumer, returning the updated messages. The Redis @XCLAIM@ command is split into 'xclaim' and 'xclaimJustIds'. Since Redis 5.0.0+xclaimJustIds, -- |Change ownership of some messages to the given consumer, returning only the changed message IDs. The Redis @XCLAIM@ command is split into 'xclaim' and 'xclaimJustIds'. Since Redis 5.0.0++-- ** Geo commands+GeoUnit(..),+GeoOrder(..),+GeoCoordinates(..),+GeoLocation(..),+GeoSearchFrom(..),+GeoSearchBy(..),+GeoSearchOpts(..),+defaultGeoSearchOpts,+GeoSearchStoreOpts(..),+defaultGeoSearchStoreOpts,+GeoAddOpts(..),+defaultGeoAddOpts,+geoadd,+geoaddOpts,+geodist,+geopos,+geoSearch,+geoSearchStore,++-- *** Autoclaim+-- $autoclaim+xautoclaim,+xautoclaimOpts,+XAutoclaimOpts(..),+XAutoclaimStreamsResult,+XAutoclaimResult(..),+xautoclaimJustIds,+xautoclaimJustIdsOpts,+XAutoclaimJustIdsResult,+XInfoConsumersResponse(..),+xinfoConsumers,+XInfoGroupsResponse(..),+xinfoGroups,+XInfoStreamResponse(..),+xinfoStream,+xdel,+xtrim,+inf,+ClusterInfoResponse (..),+ClusterInfoResponseState (..),+clusterInfo,+ClusterNodesResponse(..),+ClusterNodesResponseEntry(..),+ClusterNodesResponseSlotSpec(..),+clusterNodes,+ClusterSlotsResponse(..),+ClusterSlotsResponseEntry(..),+ClusterSlotsNode(..),+clusterSlots,+clusterSetSlotNode,+clusterSetSlotStable,+clusterSetSlotImporting,+clusterSetSlotMigrating,+clusterGetKeysInSlot,+command+-- * Unimplemented Commands+-- |These commands are not implemented, as of now. Library+--  users can implement these or other commands from+--  experimental Redis versions by using the 'sendRequest'+--  function.+--+-- * COMMAND (<http://redis.io/commands/command>)+--+--+-- * COMMAND GETKEYS (<http://redis.io/commands/command-getkeys>)+--+--+-- * ROLE (<http://redis.io/commands/role>)+--+--+-- * CLIENT KILL (<http://redis.io/commands/client-kill>)+--+--+-- * ZREVRANGEBYLEX (<http://redis.io/commands/zrevrangebylex>)+--+--+-- * ZRANGEBYSCORE (<http://redis.io/commands/zrangebyscore>)+--+--+-- * ZREVRANGEBYSCORE (<http://redis.io/commands/zrevrangebyscore>)+--+--+-- * MONITOR (<http://redis.io/commands/monitor>)+--+--+-- * SYNC (<http://redis.io/commands/sync>)+--+--+-- * SHUTDOWN (<http://redis.io/commands/shutdown>)+--+--+-- * DEBUG SEGFAULT (<http://redis.io/commands/debug-segfault>)+--+) where++import Prelude hiding (min,max)+import Data.Int+import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import Database.Redis.ManualCommands+import Database.Redis.Types+import Database.Redis.Core(sendRequest, RedisCtx)++-- | /O(1)/+-- Get the time to live for a key (<http://redis.io/commands/ttl>).+-- Since Redis 1.0.0+--+-- This command returns:+--   * -2 if the key does not exist+--   * -1 if the key exists but has no associated value+--+ttl+    :: (RedisCtx m f)+    => ByteString -- ^ Key to check.+    -> m (f Integer)+ttl key = sendRequest ["TTL", encode key]++-- | /O(1)/+-- Sets the value of a key, only if the key does not exist (<http://redis.io/commands/setnx>).+--+-- Returns a result if a value was set.+--+-- Since Redis 1.0.0+setnx+    :: (RedisCtx m f)+    => ByteString -- ^ Key to set.+    -> ByteString -- ^ Value to set.+    -> m (f Bool)+setnx key value = sendRequest ["SETNX", encode key, encode value]++-- | /O(1)/+-- Get the time to live for a key in milliseconds (<http://redis.io/commands/pttl>).+-- Since Redis 2.6.0+--+-- This command returns @-2@ if the key does not exist.+-- This command returns @-1@ if the key exists but has no associated value+pttl+    :: (RedisCtx m f)+    => ByteString -- ^ Key.+    -> m (f Integer)+pttl key = sendRequest ["PTTL", encode key]++-- | /O(1)/+-- Get total number of Redis commands (<http://redis.io/commands/command-count>).+-- Since Redis 2.8.13+commandCount+    :: (RedisCtx m f)+    => m (f Integer)+commandCount  = sendRequest ["COMMAND","COUNT"]++-- | Set the current connection name (<http://redis.io/commands/client-setname>).+-- Since Redis 2.6.9+clientSetname+    :: (RedisCtx m f)+    => ByteString -- ^ Connection Name.+    -> m (f Status)+clientSetname connectionName = sendRequest ["CLIENT","SETNAME",encode connectionName]++-- | Determine the index of a member in a sorted set (<http://redis.io/commands/zrank>).+--+-- Since Redis 2.0.0+zrank+    :: (RedisCtx m f)+    => ByteString -- ^ Key.of the set.+    -> ByteString -- ^ Member+    -> m (f (Maybe Integer))+zrank key member = sendRequest ["ZRANK", encode key, encode member]++-- |+-- Since  Redis 7.2.0: fails on earlier versions+zrankWithScore+    :: (RedisCtx m f)+    => ByteString -- ^ Key of the set.+    -> ByteString -- ^ Member.+    -> m (f (Maybe (Integer,Double)))+zrankWithScore key member = sendRequest ["ZRANK", encode key, encode member, "WITHSCORE"]++-- | /O(log(N)+M)/ with @N@ number of elements in the set, @M@ number of elements to be removed.+--+-- Remove all members in a sorted set within the given scores (<http://redis.io/commands/zremrangebyscore>).+--+-- Returns a number of elements that were removed.+--+-- Since Redis 1.2.0+zremrangebyscore+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Double -- ^ min+    -> Double -- ^ max+    -> m (f Integer)+zremrangebyscore key min max =+  sendRequest ["ZREMRANGEBYSCORE",encode key,encode min,encode max]++-- | /O(N)/ where @N@ is size of the hash.+-- Get all the fields in a hash (<http://redis.io/commands/hkeys>).+-- Since Redis 2.0.0+hkeys+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f [ByteString])+hkeys key = sendRequest ["HKEYS",encode key]++-- |Make the server a slave of another instance, or promote it as master (<http://redis.io/commands/slaveof>).+-- Deprecated in Redis, can be replaced by replicaif since redis 5.0+-- Since Redis 1.0.0+slaveof+    :: (RedisCtx m f)+    => ByteString -- ^ host+    -> ByteString -- ^ port+    -> m (f Status)+slaveof host port = sendRequest ["SLAVEOF",encode host,encode port]++-- | /O(1)/ for each element added.+-- Append a value to a list, only if the list exists (<http://redis.io/commands/rpushx>).+-- Since Redis 2.2.0+rpushx+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> NonEmpty ByteString -- ^ value+    -> m (f Integer)+rpushx key (value:|values) = sendRequest ("RPUSHX":encode key:value:values)++-- |Get debugging information about a key (<http://redis.io/commands/debug-object>). Since Redis 1.0.0+debugObject+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f ByteString)+debugObject key = sendRequest ["DEBUG","OBJECT",encode key]++-- |Asynchronously save the dataset to disk (<http://redis.io/commands/bgsave>).+--+-- Since Redis 1.0.0+bgsave+    :: (RedisCtx m f)+    => m (f Status)+bgsave  = sendRequest ["BGSAVE"]++-- |Asynchronously save the dataset to disk (<http://redis.io/commands/bgsave>).+--+-- Immediately returns OK when an AOF rewrite is in progress and schedule the background save+-- to run at the next opportunity.+--+-- A client may bee able to check if the operation succeeded using the 'lastsave' command+--+-- Since Redis 3.2.2+bgsaveSchedule+    :: (RedisCtx m f)+    => m (f Status)+bgsaveSchedule = sendRequest ["BGSAVE", "SCHEDULE"]+++-- | /O(1)/ Get the number of fields in a hash (<http://redis.io/commands/hlen>).+--+-- Since Redis 2.0.0+hlen+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f Integer)+hlen key = sendRequest ["HLEN", key]++-- |Remove the last element in a list, prepend it to another list and return that+-- element f it existed (<http://redis.io/commands/rpoplpush>).+-- Since Redis 1.2.0+rpoplpush+    :: (RedisCtx m f)+    => ByteString -- ^ source+    -> ByteString -- ^ destination+    -> m (f (Maybe ByteString))+rpoplpush source destination = sendRequest ["RPOPLPUSH",encode source,encode destination]++-- | /O(N)/+-- Remove and get the last element in a list, or block until one is available (<http://redis.io/commands/brpop>).+--+-- Since Redis 2.0.0+brpop+    :: (RedisCtx m f)+    => NonEmpty ByteString -- ^ key+    -> Integer -- ^ timeout+    -> m (f (Maybe (ByteString,ByteString)))+brpop (key:|rest) timeout = sendRequest (("BRPOP":key:rest)  ++ [encode timeout])++-- | /O(N)/+-- Remove and get the last element in a list, or block until one is available (<http://redis.io/commands/brpop>).+--+-- Since Redis 2.0.0+brpopFloat+    :: (RedisCtx m f)+    => [ByteString] -- ^ key+    -> Double -- ^ timeout+    -> m (f (Maybe (ByteString,ByteString)))+brpopFloat key timeout = sendRequest (["BRPOP"] ++ map encode key ++ [encode timeout])++-- |Asynchronously rewrite the append-only file (<http://redis.io/commands/bgrewriteaof>). Since Redis 1.0.0+bgrewriteaof+    :: (RedisCtx m f)+    => m (f Status)+bgrewriteaof  = sendRequest ["BGREWRITEAOF"]++-- | /O(log(N))/+--+-- Increment the score of a member in a sorted set (<http://redis.io/commands/zincrby>).+--+-- Returns new score of the element.+--+-- Since Redis 1.2.0+zincrby+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ increment+    -> ByteString -- ^ member+    -> m (f Double)+zincrby key increment member = sendRequest ["ZINCRBY",encode key,encode increment,encode member]++-- | Get all the fields and values in a hash (<http://redis.io/commands/hgetall>).+--+-- Since Redis 2.0.0.+hgetall+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f [(ByteString,ByteString)])+hgetall key = sendRequest ["HGETALL", encode key]+++-- | Set multiple hash fields to multiple values (<http://redis.io/commands/hmset>).+--+-- Deprecated by Redis, consider using 'hset' with multiple field-value pairs.+--+-- Since Redis 2.0.0+hmset+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> NonEmpty (ByteString,ByteString) -- ^ fieldValue+    -> m (f Status)+hmset key ((field,value):|fieldValues) =+  sendRequest ("HMSET":key:field:value: concatMap (\(x,y) -> [x,y]) fieldValues)++-- |Intersect multiple sets (<http://redis.io/commands/sinter>).+-- Since Redis 1.0.0+sinter+    :: (RedisCtx m f)+    => NonEmpty ByteString -- ^ Keys.+    -> m (f [ByteString])+sinter (key:|keys_) = sendRequest ("SINTER":key:keys_)++-- | /O(1)/+-- Adds all the elements arguments to the HyperLogLog data structure stored at the variable name specified as first argument (<http://redis.io/commands/pfadd>).+-- Since Redis 2.8.9+pfadd+    :: (RedisCtx m f)+    => ByteString -- ^ Key.+    -> NonEmpty ByteString -- ^ Value.+    -> m (f Integer)+pfadd key (value:|values) = sendRequest ("PFADD":key:value:values)++-- | /O(log(N)+M/ with @N@ being the number of elements in the sorted set and @M@ the number of elemnts removed by the operation.+--+-- Remove all members in a sorted set within the given indexes (<http://redis.io/commands/zremrangebyrank>).+--+-- Returns a number of elements that were removed.+--+-- Since Redis 2.0.0+zremrangebyrank+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ stop+    -> m (f Integer)+zremrangebyrank key start stop =+  sendRequest ["ZREMRANGEBYRANK",encode key,encode start,encode stop]++-- |Remove all keys from the current database (<http://redis.io/commands/flushdb>).+-- Since Redis 1.0.0+flushdb+    :: (RedisCtx m f)+    => m (f Status)+flushdb = sendRequest ["FLUSHDB"]++-- | /O(1)/ for each element added.+-- Add one or more members to a set (<http://redis.io/commands/sadd>).+-- Since Redis 1.0.0+sadd+    :: (RedisCtx m f)+    => ByteString -- ^ Key where set is stored.+    -> NonEmpty ByteString -- ^ Member to add to the set.+    -> m (f Integer)+sadd key member = sendRequest ("SADD":encode key:NE.toList (fmap encode member))++-- |Get an element from a list by its index (<http://redis.io/commands/lindex>).+-- Since Redis 1.0.0+lindex+    :: (RedisCtx m f)+    => ByteString -- ^ Key.+    -> Integer -- ^ Index+    -> m (f (Maybe ByteString))+lindex key index = sendRequest ["LINDEX",encode key,encode index]++-- | Prepend one or multiple values to a list (<http://redis.io/commands/lpush>).+-- Since Redis 1.0.0+lpush+    :: (RedisCtx m f)+    => ByteString -- ^ Key+    -> NonEmpty ByteString -- ^ Value+    -> m (f Integer)+lpush key (value:|values) = sendRequest ("LPUSH":key:value:values)++-- |Get the length of the value of a hash field (<http://redis.io/commands/hstrlen>).+-- Since Redis 3.2.0+hstrlen+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ field+    -> m (f Integer)+hstrlen key field = sendRequest ["HSTRLEN", key, field]++-- |+-- Move a member from one set to another (<http://redis.io/commands/smove>).+-- Since Redis 1.0.0+smove+    :: (RedisCtx m f)+    => ByteString -- ^ source+    -> ByteString -- ^ destination+    -> ByteString -- ^ member+    -> m (f Bool)+smove source destination member =+  sendRequest ["SMOVE", source, destination, member]++-- |Get the score associated with the given member in a sorted set (<http://redis.io/commands/zscore>).+-- Since Redis 1.2.0+zscore+    :: (RedisCtx m f)+    => ByteString -- ^ Key.+    -> ByteString -- ^ Member.+    -> m (f (Maybe Double))+zscore key member = sendRequest ["ZSCORE",encode key,encode member]++-- |Reset the stats returned by INFO (<http://redis.io/commands/config-resetstat>).+-- Since Redis 2.0.0+configResetstat+    :: (RedisCtx m f)+    => m (f Status)+configResetstat  = sendRequest ["CONFIG","RESETSTAT"]++-- |+-- Return the approximated cardinality of the set(s) observed by the HyperLogLog at key(s) (<http://redis.io/commands/pfcount>).+-- Since Redis 2.8.9+pfcount+    :: (RedisCtx m f)+    => NonEmpty ByteString -- ^ key+    -> m (f Integer)+pfcount (key:|keys_) = sendRequest ("PFCOUNT": key: keys_)++-- | Delete one or more hash fields (<http://redis.io/commands/hdel>).+-- Since Redis 2.0.0+hdel+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> NonEmpty ByteString -- ^ field+    -> m (f Integer)+hdel key (field:|fields) = sendRequest ("HDEL":key:field:fields)++-- |Increment the float value of a key by the given amount (<http://redis.io/commands/incrbyfloat>).+-- Since Redis 2.6.0+incrbyfloat+    :: (RedisCtx m f)+    => ByteString -- ^ Key.+    -> Double -- ^ Increment.+    -> m (f Double)+incrbyfloat key increment = sendRequest ["INCRBYFLOAT", key, encode increment]++-- |Sets or clears the bit at offset in the string value stored at key (<http://redis.io/commands/setbit>).+-- Since Redis 2.2.0+setbit+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ offset+    -> ByteString -- ^ value+    -> m (f Integer)+setbit key offset value = sendRequest ["SETBIT", key, encode offset, value]++-- | Remove all keys from all databases (<http://redis.io/commands/flushall>). Since Redis 1.0.0+flushall+    :: (RedisCtx m f)+    => m (f Status)+flushall  = sendRequest ["FLUSHALL"]++-- |Increment the integer value of a key by the given amount (<http://redis.io/commands/incrby>).+-- Since Redis 1.0.0+incrby+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ increment+    -> m (f Integer)+incrby key increment = sendRequest ["INCRBY", key, encode increment]++-- | Return the current server time (<http://redis.io/commands/time>).+-- Since Redis 2.6.0+time+    :: (RedisCtx m f)+    => m (f (Integer,Integer))+time  = sendRequest ["TIME"]++-- |Get all the members in a set (<http://redis.io/commands/smembers>). Since Redis 1.0.0+smembers+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f [ByteString])+smembers key = sendRequest ["SMEMBERS", key]++-- |Count the number of members in a sorted set between a given lexicographical range (<http://redis.io/commands/zlexcount>).+-- Since Redis 2.8.9+zlexcount+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ min+    -> ByteString -- ^ max+    -> m (f Integer)+zlexcount key min max = sendRequest ["ZLEXCOUNT", key, min, max]++-- |Add multiple sets (<http://redis.io/commands/sunion>).+-- Since Redis 1.0.0+sunion+    :: (RedisCtx m f)+    => NonEmpty ByteString -- ^ key+    -> m (f [ByteString])+sunion (key:|keys_) = sendRequest ("SUNION":key:keys_)++-- |Intersect multiple sets and store the resulting set in a key (<http://redis.io/commands/sinterstore>).+-- Since Redis 1.0.0+sinterstore+    :: (RedisCtx m f)+    => ByteString -- ^ destination+    -> NonEmpty ByteString -- ^ key+    -> m (f Integer)+sinterstore destination (key:|keys_) =+  sendRequest ("SINTERSTORE":destination:key:keys_)++-- | Get all the values in a hash (<http://redis.io/commands/hvals>).+-- Since Redis 2.0.0+hvals+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f [ByteString])+hvals key = sendRequest ["HVALS", key]++-- |Set a configuration parameter to the given value (<http://redis.io/commands/config-set>).+-- Since Redis 2.0.0+configSet+    :: (RedisCtx m f)+    => ByteString -- ^ parameter+    -> ByteString -- ^ value+    -> m (f Status)+configSet parameter value = sendRequest ["CONFIG","SET", parameter, value]++-- |Remove all the scripts from the script cache (<http://redis.io/commands/script-flush>).+-- Since Redis 2.6.0+scriptFlush+    :: (RedisCtx m f)+    => m (f Status)+scriptFlush  = sendRequest ["SCRIPT","FLUSH"]++-- |Return the number of keys in the selected database (<http://redis.io/commands/dbsize>).+-- Since Redis 1.0.0+dbsize+    :: (RedisCtx m f)+    => m (f Integer)+dbsize  = sendRequest ["DBSIZE"]++-- |Wait for the synchronous replication of all the write commands sent in the context of the current connection (<http://redis.io/commands/wait>).+-- Since Redis 3.0.0+wait+    :: (RedisCtx m f)+    => Integer -- ^ numslaves+    -> Integer -- ^ timeout+    -> m (f Integer)+wait numslaves timeout = sendRequest ["WAIT", encode numslaves, encode timeout]++-- |Remove and get the first element in a list (<http://redis.io/commands/lpop>). Since Redis 1.0.0+lpop+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f (Maybe ByteString))+lpop key = sendRequest ["LPOP", encode key]++-- |+-- Remove and get the first element in a list (<http://redis.io/commands/lpop>).+-- The reply will consist of up to count elements, depending on the list's length.+-- Since Redis 1.0.0+lpopCount+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer+    -> m (f [ByteString])+lpopCount key count = sendRequest ["LPOP", key, encode count]++-- |Stop processing commands from clients for some time (<http://redis.io/commands/client-pause>).+-- Since Redis 2.9.50+clientPause+    :: (RedisCtx m f)+    => Integer -- ^ timeout+    -> m (f Status)+clientPause timeout = sendRequest ["CLIENT","PAUSE", encode timeout]++-- |Set a key's time to live in seconds (<http://redis.io/commands/expire>). Since Redis 1.0.0+expire+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ seconds+    -> m (f Bool)+expire key seconds = sendRequest ["EXPIRE", key, encode seconds]++-- |Get the values of all the given keys (<http://redis.io/commands/mget>).+-- Since Redis 1.0.0+mget+    :: (RedisCtx m f)+    => NonEmpty ByteString -- ^ key+    -> m (f [Maybe ByteString])+mget (key:|keys_) = sendRequest ("MGET":key:keys_)++-- |+-- Find first bit set or clear in a string (<http://redis.io/commands/bitpos>).+-- Since Redis 2.8.7+bitpos+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ bit+    -> Integer -- ^ start+    -> Integer -- ^ end+    -> m (f Integer)+bitpos key bit start end = sendRequest ["BITPOS", key, encode bit, encode start, encode end]++lastsave+    :: (RedisCtx m f)+    => m (f Integer)+lastsave  = sendRequest (["LASTSAVE"] )++-- | Set a key's time to live in milliseconds (<http://redis.io/commands/pexpire>).+-- Since Redis 2.6.0+pexpire+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ milliseconds+    -> m (f Bool)+pexpire key milliseconds = sendRequest ["PEXPIRE", key, encode milliseconds]++-- |Get the list of client connections (<http://redis.io/commands/client-list>). Since Redis 2.4.0+clientList+    :: (RedisCtx m f)+    => m (f [ByteString])+clientList  = sendRequest (["CLIENT","LIST"] )++-- |Rename a key, only if the new key does not exist (<http://redis.io/commands/renamenx>). Since Redis 1.0.0+renamenx+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ newkey+    -> m (f Bool)+renamenx key newkey = sendRequest ["RENAMENX", key, newkey]++-- |Merge N different HyperLogLogs into a single one (<http://redis.io/commands/pfmerge>). Since Redis 2.8.9+pfmerge+    :: (RedisCtx m f)+    => ByteString -- ^ destkey+    -> [ByteString] -- ^ sourcekey+    -> m (f ByteString)+pfmerge destkey sourcekey = sendRequest ("PFMERGE": destkey: sourcekey)++-- | Remove elements from a list (<http://redis.io/commands/lrem>). Since Redis 1.0.0+lrem+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ count+    -> ByteString -- ^ value+    -> m (f Integer)+lrem key count value = sendRequest ["LREM", key, encode count, value]++-- |Subtract multiple sets (<http://redis.io/commands/sdiff>). Since Redis 1.0.0+sdiff+    :: (RedisCtx m f)+    => NonEmpty ByteString -- ^ key+    -> m (f [ByteString])+sdiff (key_:|keys_) = sendRequest ("SDIFF":key_:keys_)++-- |Get the value of a key (<http://redis.io/commands/get>). Since Redis 1.0.0+get+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f (Maybe ByteString))+get key = sendRequest (["GET"] ++ [encode key] )++-- |Get a substring of the string stored at a key (<http://redis.io/commands/getrange>).+-- Since Redis 2.4.0+getrange+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ end+    -> m (f ByteString)+getrange key start end = sendRequest ["GETRANGE", key, encode start, encode end]++-- |Subtract multiple sets and store the resulting set in a key (<http://redis.io/commands/sdiffstore>). Since Redis 1.0.0+sdiffstore+    :: (RedisCtx m f)+    => ByteString -- ^ destination+    -> NonEmpty ByteString -- ^ key+    -> m (f Integer)+sdiffstore destination (key_:|keys_) = sendRequest ("SDIFFSTORE": destination: key_: keys_)++-- |Count the members in a sorted set with scores within the given values (<http://redis.io/commands/zcount>). Since Redis 2.0.0+zcount+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Double -- ^ min+    -> Double -- ^ max+    -> m (f Integer)+zcount key min max = sendRequest ["ZCOUNT", key, encode min, encode max]++-- |Load the specified Lua script into the script cache (<http://redis.io/commands/script-load>). Since Redis 2.6.0+scriptLoad+    :: (RedisCtx m f)+    => ByteString -- ^ script+    -> m (f ByteString)+scriptLoad script = sendRequest ["SCRIPT","LOAD", encode script]++-- |Set the string value of a key and return its old value (<http://redis.io/commands/getset>). Since Redis 1.0.0+getset+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ value+    -> m (f (Maybe ByteString))+getset key value = sendRequest ["GETSET", key, value]++-- |Return a serialized version of the value stored at the specified key (<http://redis.io/commands/dump>). Since Redis 2.6.0+dump+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f ByteString)+dump key = sendRequest ["DUMP", key]++-- |Find all keys matching the given pattern (<http://redis.io/commands/keys>). Since Redis 1.0.0+keys+    :: (RedisCtx m f)+    => ByteString -- ^ pattern+    -> m (f [ByteString])+keys pattern = sendRequest ["KEYS", pattern]++-- |Get the value of a configuration parameter (<http://redis.io/commands/config-get>). Since Redis 2.0.0+configGet+    :: (RedisCtx m f)+    => NonEmpty ByteString -- ^ parameter+    -> m (f [(ByteString,ByteString)])+configGet (parameter:|parameters) = sendRequest ("CONFIG":"GET":parameter:parameters)++-- |Append one or multiple values to a list (<http://redis.io/commands/rpush>). Since Redis 1.0.0+rpush+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> NonEmpty ByteString -- ^ value+    -> m (f Integer)+rpush key (value:|values) = sendRequest ("RPUSH": encode key:value:values)++-- |Return a random key from the keyspace (<http://redis.io/commands/randomkey>). Since Redis 1.0.0+randomkey+    :: (RedisCtx m f)+    => m (f (Maybe ByteString))+randomkey  = sendRequest ["RANDOMKEY"]++-- |Set the value of a hash field, only if the field does not exist (<http://redis.io/commands/hsetnx>). Since Redis 2.0.0+hsetnx+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ field+    -> ByteString -- ^ value+    -> m (f Bool)+hsetnx key field value = sendRequest ["HSETNX", key, field, value]++-- |Set multiple keys to multiple values (<http://redis.io/commands/mset>). Since Redis 1.0.1+mset+    :: (RedisCtx m f)+    => NonEmpty (ByteString,ByteString) -- ^ keyValue+    -> m (f Status)+mset ((key_,value):|keyValue) =+  sendRequest ("MSET":key_:value: concatMap (\(x,y) -> [encode x,encode y]) keyValue)++-- |Set the value and expiration of a key (<http://redis.io/commands/setex>).+-- Regarded as deprected since 2.6 as it can be replaced by SET with the EX argument when+-- migrating or writing new code.+-- Since Redis 2.0.0+setex+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ seconds+    -> ByteString -- ^ value+    -> m (f Status)+setex key seconds value = sendRequest ["SETEX", key, encode seconds, value]++-- |Set the value and expiration in milliseconds of a key (<http://redis.io/commands/psetex>).+-- Condidered deprecated since it can be replaced by SET with the PX argument when migrating or writing new code+-- Since Redis 2.6.0+psetex+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ milliseconds+    -> ByteString -- ^ value+    -> m (f Status)+psetex key milliseconds value = sendRequest ["PSETEX", key, encode milliseconds, value]++-- |Get the number of members in a set (<http://redis.io/commands/scard>). Since Redis 1.0.0+scard+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f Integer)+scard key = sendRequest ["SCARD", key]++-- |Check existence of scripts in the script cache (<http://redis.io/commands/script-exists>). Since Redis 2.6.0+scriptExists+    :: (RedisCtx m f)+    => NonEmpty ByteString -- ^ script+    -> m (f [Bool])+scriptExists (script:|scripts) = sendRequest ("SCRIPT":"EXISTS":script:scripts)++-- |Add multiple sets and store the resulting set in a key (<http://redis.io/commands/sunionstore>). Since Redis 1.0.0+sunionstore+    :: (RedisCtx m f)+    => ByteString -- ^ destination+    -> NonEmpty ByteString -- ^ key+    -> m (f Integer)+sunionstore destination (key_:|keys_) =+  sendRequest ("SUNIONSTORE":destination:key_:keys_)++-- |Remove the expiration from a key (<http://redis.io/commands/persist>). Since Redis 2.2.0+persist+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f Bool)+persist key = sendRequest ["PERSIST", key]++-- |Get the length of the value stored in a key (<http://redis.io/commands/strlen>). Since Redis 2.2.0+strlen+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f Integer)+strlen key = sendRequest ["STRLEN", encode key]++-- |Prepend a value to a list, only if the list exists (<http://redis.io/commands/lpushx>). Since Redis 2.2.0+lpushx+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> NonEmpty ByteString -- ^ value+    -> m (f Integer)+lpushx key (value:|values) = sendRequest ("LPUSHX":key:value:values)++-- |Set the string value of a hash field (<http://redis.io/commands/hset>).+--+-- This command oveerides keys if they exist in the hash.+--+-- Since Redis 2.0.0+hset+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> NonEmpty (ByteString, ByteString) -- ^ Values.+    -> m (f Integer)+hset key ((field,value):|fieldValues) =+  sendRequest ("HSET":encode key:encode field:encode value:concatMap (\(f,v) ->[f,v]) fieldValues)++-- |Pop a value from a list, push it to another list and return it; or block until one is available (<http://redis.io/commands/brpoplpush>).+--+-- Since Redis 6.0 this command considered deprecated: it can be replaced by BLMOVE with the RIGHT and LEFT arguments when migrating or writing new code.+--+-- Since Redis 2.2.0+brpoplpush+    :: (RedisCtx m f)+    => ByteString -- ^ source+    -> ByteString -- ^ destination+    -> Integer -- ^ timeout+    -> m (f (Maybe ByteString))+brpoplpush source destination timeout =+  sendRequest ["BRPOPLPUSH", source, destination, encode timeout]++-- |Determine the index of a member in a sorted set, with scores ordered from high to low (<http://redis.io/commands/zrevrank>).+-- Since Redis 2.0.0+zrevrank+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ member+    -> m (f (Maybe Integer))+zrevrank key member = sendRequest ["ZREVRANK", key, member]++zrevrankWithScore+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ member+    -> m (f (Maybe (Integer, Double)))+zrevrankWithScore key member = sendRequest ["ZREVRANK", key, member]++-- |Kill the script currently in execution (<http://redis.io/commands/script-kill>). Since Redis 2.6.0+scriptKill+    :: (RedisCtx m f)+    => m (f Status)+scriptKill  = sendRequest ["SCRIPT","KILL"]++-- |Overwrite part of a string at key starting at the specified offset (<http://redis.io/commands/setrange>).+--+-- Returns the lenght of the string after it was modified.+--+-- Since Redis 2.2.0+setrange+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ offset+    -> ByteString -- ^ value+    -> m (f Integer)+setrange key offset value = sendRequest ["SETRANGE", key, encode offset, value]++-- | Delete a key (<http://redis.io/commands/del>).+-- Returns a number of keys that were removed.+-- Since Redis 1.0.0+del+    :: (RedisCtx m f)+    => NonEmpty ByteString -- ^ List of keys to delete.+    -> m (f Integer)+del (key:|rest) = sendRequest ("DEL":key:rest)++-- |Increment the float value of a hash field by the given amount (<http://redis.io/commands/hincrbyfloat>).+-- Since Redis 2.6.0+hincrbyfloat+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ field+    -> Double -- ^ increment+    -> m (f Double)+hincrbyfloat key field increment = sendRequest ["HINCRBYFLOAT", key, field, encode increment]++-- | Increment the integer value of a hash field by the given number (<http://redis.io/commands/hincrby>). Since Redis 2.0.0+hincrby+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ field+    -> Int64 -- ^ increment+    -> m (f Int64)+hincrby key field increment = sendRequest ["HINCRBY", encode key, encode field, encode increment]++-- | O(log(N)+M) with @N@ being thee number of elements in thee sorted set and @M@ the number+-- of elements removed by the operation.+--+-- Remove all members in a sorted set between the given lexicographical range (<http://redis.io/commands/zremrangebylex>).+--+-- Returns number of elements that were removed.+--+-- Since Redis 2.8.9+zremrangebylex+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ min+    -> ByteString -- ^ max+    -> m (f Integer)+zremrangebylex key min max = sendRequest (["ZREMRANGEBYLEX"] ++ [encode key] ++ [encode min] ++ [encode max] )++-- |Remove and get the last element in a list (<http://redis.io/commands/rpop>).+-- Since Redis 1.0.0+rpop+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f (Maybe ByteString))+rpop key = sendRequest ["RPOP", encode key]++-- |Remove and get the last element in a list (<http://redis.io/commands/rpop>).+-- The reply will consist of up to count elements, depending on the list's length.+-- Result will have no more than @N@ arguments.+--+-- Since Redis 1.0.0+rpopCount+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer+    -> m (f [ByteString])+rpopCount key count = sendRequest (["RPOP",key, encode count] )++-- |Rename a key (<http://redis.io/commands/rename>). Since Redis 1.0.0+--+-- Does not return a error even if newkey existed.+rename+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ newkey+    -> m (f Status)+rename key newkey = sendRequest ["RENAME",  encode key, encode newkey]++-- | /O(M*log(N))/ with @N@ number of elements in the sorted set, @M@ number of elements to be+-- removed.+--+-- Removes one or more members from a sorted set (<http://redis.io/commands/zrem>).+--+-- Since Redis 1.2.0+zrem+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> NonEmpty ByteString -- ^ member+    -> m (f Integer)+zrem key (member:|members) = sendRequest ("ZREM":encode key:encode member:members)++-- |Determine if a hash field exists (<http://redis.io/commands/hexists>).+-- Since Redis 2.0.0+hexists+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ field+    -> m (f Bool)+hexists key field = sendRequest ["HEXISTS", key, field]++-- |Get the current connection ID (<http://redis.io/commands/client-id>). Since Redis 5.0.0+clientId+    :: (RedisCtx m f)+    => m (f Integer)+clientId  = sendRequest ["CLIENT","ID"]++-- |Get the current connection name (<http://redis.io/commands/client-getname>). Since Redis 2.6.9+clientGetname+    :: (RedisCtx m f)+    => m (f (Maybe ByteString))+clientGetname  = sendRequest ["CLIENT","GETNAME"]++-- |Rewrite the configuration file with the in memory configuration (<http://redis.io/commands/config-rewrite>). Since Redis 2.8.0+configRewrite+    :: (RedisCtx m f)+    => m (f Status)+configRewrite  = sendRequest ["CONFIG","REWRITE"]++-- |Decrement the integer value of a key by one (<http://redis.io/commands/decr>).+-- Since Redis 1.0.0+decr+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f Integer)+decr key = sendRequest ["DECR", key]++-- |Get the values of all the given hash fields (<http://redis.io/commands/hmget>).+-- Since Redis 2.0.0+hmget+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> NonEmpty ByteString -- ^ field+    -> m (f [Maybe ByteString])+hmget key (field:|fields) = sendRequest ("HMGET":key:field:fields)++-- |Get a range of elements from a list (<http://redis.io/commands/lrange>). Since Redis 1.0.0+lrange+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ stop+    -> m (f [ByteString])+lrange key start stop = sendRequest ["LRANGE", key, encode start, encode stop]++-- |Decrement the integer value of a key by the given number (<http://redis.io/commands/decrby>).+-- Since Redis 1.0.0+decrby+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ decrement+    -> m (f Integer)+decrby key decrement = sendRequest ["DECRBY",key, encode decrement]++-- |Get the length of a list (<http://redis.io/commands/llen>). Since Redis 1.0.0+llen+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f Integer)+llen key = sendRequest ["LLEN", encode key]++-- | /O(1)/ Append a value to a key (<http://redis.io/commands/append>). Since Redis 2.0.0+append+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ value+    -> m (f Integer)+append key value = sendRequest ["APPEND", key, value]++-- |Increment the integer value of a key by one (<http://redis.io/commands/incr>). Since Redis 1.0.0+incr+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f Integer)+incr key = sendRequest ["INCR", key]++-- |Get the value of a hash field (<http://redis.io/commands/hget>). Since Redis 2.0.0+hget+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ field+    -> m (f (Maybe ByteString))+hget key field = sendRequest ["HGET",key,field]++-- |Set the expiration for a key as a UNIX timestamp specified in milliseconds (<http://redis.io/commands/pexpireat>). Since Redis 2.6.0+pexpireat+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ millisecondsTimestamp+    -> m (f Bool)+pexpireat key millisecondsTimestamp = sendRequest ["PEXPIREAT", key, encode millisecondsTimestamp]++-- | Trim a list to the specified range (<http://redis.io/commands/ltrim>).+-- Since Redis 1.0.0+ltrim+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ stop+    -> m (f Status)+ltrim key start stop = sendRequest ["LTRIM", key, encode start, encode stop]++-- | /O(1)/+-- Get the number of members in a sorted set (<http://redis.io/commands/zcard>).+-- Since Redis 1.2.0+zcard+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f Integer)+zcard key = sendRequest ["ZCARD", key]++-- | Set the value of an element in a list by its index (<http://redis.io/commands/lset>).+-- Since Redis 1.0.0+lset+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ index+    -> ByteString -- ^ value+    -> m (f Status)+lset key index value = sendRequest ["LSET", key, encode index, value]++-- | Set the expiration for a key as a UNIX timestamp (<http://redis.io/commands/expireat>).+-- Since Redis 1.2.0+expireat+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ timestamp+    -> m (f Bool)+expireat key timestamp = sendRequest ["EXPIREAT", key, encode timestamp]++-- | Synchronously save the dataset to disk (<http://redis.io/commands/save>).+-- Since Redis 1.0.0+save+    :: (RedisCtx m f)+    => m (f Status)+save  = sendRequest ["SAVE"]++-- |+-- Move a key to another database (<http://redis.io/commands/move>).+-- Since Redis 1.0.0+move+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ db+    -> m (f Bool)+move key db = sendRequest ["MOVE", key, encode db]++-- |+-- Returns the bit value at offset in the string value stored at key (<http://redis.io/commands/getbit>). Since Redis 2.2.0+getbit+    :: (RedisCtx m f)+    => ByteString -- ^ Key.+    -> Integer -- ^ Offset.+    -> m (f Integer)+getbit key offset = sendRequest ["GETBIT", key, encode offset]++-- |Set multiple keys to multiple values, only if none of the keys exist (<http://redis.io/commands/msetnx>).+-- Since Redis 1.0.1+msetnx+    :: (RedisCtx m f)+    => NonEmpty (ByteString,ByteString) -- ^ keyValue+    -> m (f Bool)+msetnx ((key,value):|keysValues) =+  sendRequest ("MSETNX":key:value:concatMap (\(x,y) -> [encode x,encode y]) keysValues)++-- |Get array of specific Redis command details (<http://redis.io/commands/command-info>).+-- Since Redis 2.8.13+commandInfo+    :: (RedisCtx m f)+    => [ByteString] -- ^ commandName+    -> m (f [ByteString])+commandInfo commandName = sendRequest ("COMMAND":"INFO":map encode commandName )++-- | Close the connection (<http://redis.io/commands/quit>). Since Redis 1.0.0+quit+    :: (RedisCtx m f)+    => m (f Status)+quit  = sendRequest ["QUIT"]++-- |Remove and get the first element in a list, or block until one is available (<http://redis.io/commands/blpop>). Since Redis 2.0.0+blpop+    :: (RedisCtx m f)+    => [ByteString] -- ^ key+    -> Integer -- ^ timeout+    -> m (f (Maybe (ByteString,ByteString)))+blpop keys_ timeout = sendRequest ("BLPOP":keys_ ++ [encode timeout] )++-- |Remove and get the first element in a list, or block until one is available (<http://redis.io/commands/blpop>). Since Redis 6.0.0+blpopFloat+    :: (RedisCtx m f)+    => [ByteString] -- ^ key+    -> Integer -- ^ timeout+    -> m (f (Maybe (ByteString,ByteString)))+blpopFloat keys_ timeout = sendRequest ("BLPOP":keys_ ++ [encode timeout] )++-- | /O(N)/ where @N@ is the number of members to be removed.+-- Remove one or more members from a set (<http://redis.io/commands/srem>).+--+-- Returns the number of members that were removed from the seet, not including non+-- existing elements.+--+-- Since Redis 1.0.0+srem+    :: (RedisCtx m f)+    => ByteString -- ^ Key of the set.+    -> NonEmpty ByteString -- ^ List of members to be removed.+    -> m (f Integer)+srem key (member:|members) = sendRequest ("SREM":key:member:members)++-- |Echo the given string (<http://redis.io/commands/echo>). Since Redis 1.0.0+echo+    :: (RedisCtx m f)+    => ByteString -- ^ message+    -> m (f ByteString)+echo message = sendRequest ["ECHO", encode message]++-- |Determine if a given value is a member of a set (<http://redis.io/commands/sismember>).+--  Since Redis 1.0.0+sismember+    :: (RedisCtx m f)+    => ByteString -- ^ Key.+    -> ByteString -- ^ member+    -> m (f Bool)+sismember key member = sendRequest ["SISMEMBER",key, member]++-- $autoclaim+--+-- Family of the commands related to the autoclaim command in redis, they provide an+-- ability to claim messages that are not processed for a long time.+--+-- Transfers ownership of pending stream entries that match+-- the specified criteria. The message should be pending for more than \<min-idle-time\>+-- milliseconds and ID should be greater than \<start\>.+--+-- Redis @xautoclaim@ command is split info `xautoclaim`, `xautoclaimOpts`, `xautoclaimJustIds`+-- `xautoclaimJustIdsOpt` functions.+--+-- All commands are available since Redis 7.0++-- $xpending+-- The Redis @XPENDING@ command is split into 'xpendingSummary' and 'xpendingDetail'.++-- $xgroupCreate+-- Create a consumer group. The redis command @XGROUP CREATE@ is split up into 'xgroupCreate', 'xgroupCreateOpts'.++-- $xgroupSetId+-- Sets last delivered ID for a consumer group. The redis command @XGROUP SETID@ is split up into 'xgroupSetId' and 'xgroupSetIdOpts' methods.+++-- $auth+-- Authenticate to the server (<http://redis.io/commands/auth>). Since Redis 1.0.0
+ src/Database/Redis/Connection.hs view
@@ -0,0 +1,293 @@+{-# 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, forM_)+import Control.Concurrent.MVar(MVar, newMVar)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as Char8+import Data.Functor(void)+import qualified Data.IntMap.Strict as IntMap+import Data.Pool+import qualified Data.Time as Time+import Network.TLS (ClientParams)+import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T++import qualified Database.Redis.ProtocolPipelining as PP+import Database.Redis.Core(Redis, Hooks, runRedisInternal, runRedisClusteredInternal, defaultHooks)+import Database.Redis.Protocol(Reply(..))+import Database.Redis.Cluster(ShardMap(..), Node, Shard(..))+import qualified Database.Redis.Cluster as Cluster+import qualified Database.Redis.ConnectionContext as CC+import Database.Redis.Commands+    ( ping+    , select+    , authOpts+    , defaultAuthOpts+    , AuthOpts(..)+    , clusterInfo+    , clusterSlots+    , command+    , ClusterInfoResponseState (..)+    , ClusterInfoResponse (..)+    , 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+    { connectAddr           :: CC.ConnectAddr+    , connectAuth           :: Maybe B.ByteString+    -- ^ When the server is protected by a password, set 'connectAuth' to 'Just'+    --   the password. Each connection will then authenticate by the 'auth'+    --   command.+    , connectUsername       :: Maybe B.ByteString+    -- ^ When ACL is used set 'connectUsername' as the user.+    , connectDatabase       :: Integer+    -- ^ Each connection will 'select' the database with the given index.+    , connectMaxConnections :: Int+    -- ^ Maximum number of connections to keep open. The smallest acceptable+    --   value is 1.+    , connectNumStripes     :: Maybe Int+    -- ^ Number of stripes in the connection pool.+    , connectMaxIdleTime    :: Time.NominalDiffTime+    -- ^ Amount of time for which an unused connection is kept open. The+    --   smallest acceptable value is 0.5 seconds. If the @timeout@ value in+    --   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.+    , connectHooks          :: Hooks+    -- ^ Connection hooks.+    , connectPoolLabel      :: T.Text+    -- ^ Label of the connection pool for instrumentation.+    } deriving Show++data ConnectError = ConnectAuthError Reply+                  | ConnectSelectError Reply+    deriving (Eq, Show)++instance Exception ConnectError++-- |Default information for connecting:+--+-- @+--  connectAddr           = ConnectAddrHostPort \"localhost\" 6379 -- Redis default port+--  connectAuth           = Nothing         -- No password+--  connectUsername       = Nothing         -- No user+--  connectDatabase       = 0               -- SELECT database 0+--  connectMaxConnections = 50              -- Up to 50 connections+--  connectNumStripes     = Just 1          -- A single stripe+--  connectMaxIdleTime    = 30              -- Keep open for 30 seconds+--  connectTimeout        = Nothing         -- Don't add timeout logic+--  connectTLSParams      = Nothing         -- Do not use TLS+--  connectHooks          = defaultHooks    -- Do nothing+--  connectPoolLabel      = ""              -- no label+-- @+--+defaultConnectInfo :: ConnectInfo+defaultConnectInfo = ConnInfo+    { connectAddr           = CC.ConnectAddrHostPort "localhost" 6379+    , connectAuth           = Nothing+    , connectUsername       = Nothing+    , connectDatabase       = 0+    , connectMaxConnections = 50+    , connectNumStripes     = Just 1+    , connectMaxIdleTime    = 30+    , connectTimeout        = Nothing+    , connectTLSParams      = Nothing+    , connectHooks          = defaultHooks+    , connectPoolLabel      = ""+    }++createConnection :: ConnectInfo -> IO PP.Connection+createConnection ConnInfo{..} = do+    let timeoutOptUs =+          round . (1000000 *) <$> connectTimeout+    conn' <- PP.connectWithHooks connectAddr timeoutOptUs connectTLSParams connectHooks+    PP.beginReceiving conn'++    runRedisInternal conn' $ do+        -- AUTH+        forM_ connectAuth $ \pass -> do+            resp <- authOpts pass defaultAuthOpts{ authOptsUsername = connectUsername}+            case resp of+              Left r -> liftIO $ throwIO $ ConnectAuthError r+              _      -> return ()+        -- SELECT+        when (connectDatabase /= 0) $ do+          resp <- select connectDatabase+          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 <$>+    newPool (setPoolLabel connectPoolLabel . setNumStripes connectNumStripes $ defaultPoolConfig (createConnection cInfo) PP.disconnect (realToFrac connectMaxIdleTime) connectMaxConnections)++-- |Constructs a 'Connection' pool to a Redis server designated by the+--  given 'ConnectInfo', then tests if the server is actually there.+--  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++-- |Constructs a 'Connection' pool to a Redis cluster designated by the+--  given 'ConnectInfo', then tests if the server is actually there.+--  Throws an exception if the connection to the Redis server can't be+--  established.+checkedConnectCluster :: ConnectInfo -> IO Connection+checkedConnectCluster connInfo = do+  conn <- connectCluster connInfo+  res <- runRedis conn clusterInfo+  case res of+    Right r -> case clusterInfoResponseState r of+      OK -> pure conn+      Down -> throwIO $ ClusterDownError r+    Left e -> throwIO $ ClusterConnectError e++newtype ClusterDownError = ClusterDownError ClusterInfoResponse+  deriving (Eq, Show)++instance Exception ClusterDownError++-- |Destroy all idle resources in the pool.+disconnect :: Connection -> IO ()+disconnect (NonClusteredConnection pool) = destroyAllResources pool+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++-- |Interact with a Redis datastore specified by the given 'Connection', but return early+--  if acquiring from the connection pool would block.+--+--  Like 'runRedis', but if all connections in the 'Connection' pool are used, it+--  immediately returns 'Nothing'. This can be useful for logging purposes.+runRedisNonBlocking :: Connection -> Redis a -> IO (Maybe a)+runRedisNonBlocking (NonClusteredConnection pool) redis =+  tryWithResource pool $ \conn -> runRedisInternal conn redis+runRedisNonBlocking (ClusteredConnection _ pool) redis =+    tryWithResource pool $ \conn -> runRedisClusteredInternal conn (refreshShardMap conn) redis++newtype ClusterConnectError = ClusterConnectError Reply+    deriving (Eq, Show)++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+    bracket (createConnection bootstrapConnInfo) PP.disconnect $ \conn -> do+        slotsResponse <- runRedisInternal conn clusterSlots+        shardMapVar <- case slotsResponse of+            Left e -> throwIO $ ClusterConnectError e+            Right slots -> do+                shardMap <- shardMapFromClusterSlotsResponse slots+                newMVar shardMap+        commandInfos <- runRedisInternal conn command+        let timeoutOptUs =+              round . (1000000 *) <$> connectTimeout bootstrapConnInfo+        case commandInfos of+            Left e -> throwIO $ ClusterConnectError e+            Right infos -> do+                pool <- newPool (setPoolLabel (connectPoolLabel bootstrapConnInfo)+                                $ setNumStripes (connectNumStripes bootstrapConnInfo)+                                $ defaultPoolConfig+                                    (Cluster.connectWith+                                      (connectUsername bootstrapConnInfo)+                                      (connectAuth bootstrapConnInfo)+                                      (connectTLSParams bootstrapConnInfo)+                                      infos shardMapVar timeoutOptUs+                                      $ connectHooks bootstrapConnInfo)+                                    Cluster.disconnect+                                    (realToFrac $ connectMaxIdleTime bootstrapConnInfo)+                                    (connectMaxConnections bootstrapConnInfo))+                return $ ClusteredConnection shardMapVar pool++shardMapFromClusterSlotsResponse :: ClusterSlotsResponse -> IO ShardMap+shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr mkShardMap (pure IntMap.empty)  clusterSlotsResponseEntries where+    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{connectionNodes=nodeConns} = do+    let Cluster.NodeConnection{nodeConnectionContext=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
+ src/Database/Redis/ConnectionContext.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+module Database.Redis.ConnectionContext (+    ConnectionContext(..)+  , ConnectTimeout(..)+  , ConnectionLostException(..)+  , ConnectAddr(..)+  , connect+  , disconnect+  , send+  , recv+  , errConnClosed+  , enableTLS+  , flush+  , ioErrorToConnLost+) where++import Control.Monad(when)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as Char8+import qualified Data.ByteString.Lazy as LB+import qualified Data.IORef as IOR+import Control.Concurrent.MVar(newMVar, readMVar, swapMVar)+import Control.Exception(bracketOnError, Exception, throwIO, try, finally, mask_)+import Data.Functor(void)+import qualified Network.Socket as NS+import qualified Network.TLS as TLS+import System.IO(Handle, hSetBinaryMode, hClose, IOMode(..), hFlush, hIsOpen)+import System.IO.Error(catchIOError)+import System.Timeout (timeout)++data ConnectionContext = NormalHandle Handle | TLSContext TLS.Context Handle++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)++instance Exception ConnectTimeout++data ConnectionLostException = ConnectionLost deriving Show+instance Exception ConnectionLostException++data ConnectAddr+  = ConnectAddrHostPort NS.HostName NS.PortNumber+  | ConnectAddrUnixSocket String+  deriving (Eq, Show)++connect :: ConnectAddr -> Maybe Int -> Maybe TLS.ClientParams -> IO ConnectionContext+connect connectAddr timeoutOpt mTlsParams =+  bracketOnError hConnect hClose $ \h -> do+    hSetBinaryMode h True+    case (mTlsParams, connectAddr) of+      (Just defaultTlsParams, ConnectAddrHostPort host port) -> do+        -- The defaultTlsParams are used to connect to the first+        -- host in the cluster, other hosts have different+        -- hostnames and so require a different server+        -- identification params+        let tlsParams = defaultTlsParams {+              TLS.clientServerIdentification =  (host, Char8.pack $ show port)+            }+        enableTLS tlsParams (NormalHandle h)+      _ -> return $ NormalHandle h+  where+        hConnect = do+          phaseMVar <- newMVar PhaseUnknown+          let doConnect = hConnect' phaseMVar+          case timeoutOpt of+            Nothing -> doConnect+            Just micros -> do+              result <- timeout micros doConnect+              case result of+                Just h -> return h+                Nothing -> 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 connectAddr of+              ConnectAddrHostPort hostName portNumber -> do+                addrInfo <- getHostAddrInfo hostName portNumber+                connectSocket addrInfo+              ConnectAddrUnixSocket addr -> bracketOnError+                (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol)+                NS.close+                (\sock -> NS.connect sock (NS.SockAddrUnix addr) >> return sock)++getHostAddrInfo :: NS.HostName -> NS.PortNumber -> IO [NS.AddrInfo]+getHostAddrInfo hostname port = NS.getAddrInfo (Just hints) (Just hostname) (Just $ show port)+  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 h+enableTLS _ c@(TLSContext _ _) = return c+++disconnect :: ConnectionContext -> IO ()+disconnect (NormalHandle h) = mask_ $ do+  open <- hIsOpen h+  when open $ hClose h+disconnect (TLSContext ctx h) =+  TLS.bye ctx `finally` TLS.contextClose ctx `finally` (hIsOpen h >>= \open -> when open $ hClose h)++flush :: ConnectionContext -> IO ()+flush (NormalHandle h) = hFlush h+flush (TLSContext ctx _) = TLS.contextFlush ctx
src/Database/Redis/Core.hs view
@@ -1,78 +1,107 @@ {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, RecordWildCards,-    MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}+    MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, CPP,+    DeriveDataTypeable, StandaloneDeriving, UndecidableInstances #-}  module Database.Redis.Core (-    Connection, connect,-    ConnectInfo(..), defaultConnectInfo,-    Redis(),runRedis,+    Redis(), unRedis, reRedis,     RedisCtx(..), MonadRedis(..),+    Hooks(..), SendRequestHook, SendPubSubHook, CallbackHook, SendHook, ReceiveHook,     send, recv, sendRequest,-    auth, select+    runRedisInternal,+    runRedisClusteredInternal,+    defaultHooks,+    RedisEnv(..), ) where  import Prelude+#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+#endif import Control.Monad.Reader import qualified Data.ByteString as B-import Data.Pool-import Data.Time-import Network-+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+import Database.Redis.Hooks  -------------------------------------------------------------------------------- -- The Redis Monad -- --- |Context for normal command execution, outside of transactions. Use---  'runRedis' to run actions of this type.------  In this context, each result is wrapped in an 'Either' to account for the---  possibility of Redis returning an 'Error' reply.-newtype Redis a = Redis (ReaderT (PP.Connection Reply) IO a)-    deriving (Monad, MonadIO, Functor, Applicative)- -- |This class captures the following behaviour: In a context @m@, a command---  will return it's result wrapped in a \"container\" of type @f@.+--  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) -instance RedisCtx Redis (Either Reply) where-    returnDecode = return . decode- class (Monad m) => MonadRedis m where     liftRedis :: Redis a -> m a +instance {-# OVERLAPPABLE #-}+  ( MonadTrans t+  , MonadRedis m+  , Monad (t m)+  ) => MonadRedis (t m) where+  liftRedis = lift . liftRedis++instance RedisCtx Redis (Either Reply) where+    returnDecode = return . decode+ instance MonadRedis Redis where     liftRedis = id --- |Interact with a Redis datastore specified by the given 'Connection'.+-- |Deconstruct Redis constructor. -----  Each call of 'runRedis' takes a network connection from the 'Connection'---  pool and runs the given 'Redis' action. Calls to 'runRedis' may thus block---  while all connections from the pool are in use.-runRedis :: Connection -> Redis a -> IO a-runRedis (Conn pool) redis =-    withResource pool $ \conn -> runRedisInternal conn redis+--  '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 Reply -> Redis a -> IO a-runRedisInternal env (Redis redis) = runReaderT redis env+--  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+    ref <- newIORef (SingleLine "no reply yet")+    r <- runReaderT redis (ClusteredEnv refreshShardmapAction connection ref)+    r `seq` return r +setLastReply :: Reply -> ReaderT RedisEnv IO ()+setLastReply r = do+  ref <- asks envLastReply+  lift (writeIORef ref r)+ recv :: (MonadRedis m) => m Reply-recv = liftRedis $ Redis $ ask >>= liftIO . PP.recv+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 <- ask+    conn <- asks envConn     liftIO $ PP.send conn (renderRequest req)  -- |'sendRequest' can be used to implement commands from experimental@@ -88,100 +117,15 @@ sendRequest :: (RedisCtx m f, RedisResult a)     => [B.ByteString] -> m (f a) sendRequest req = do-    r <- liftRedis $ Redis $ do-        conn <- ask-        liftIO $ PP.request conn (renderRequest req)-    returnDecode r-------------------------------------------------------------------------------------- Connection------- |A threadsafe pool of network connections to a Redis server. Use the---  'connect' function to create one.-newtype Connection = Conn (Pool (PP.Connection Reply))---- |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           :: HostName-    , connectPort           :: PortID-    , connectAuth           :: Maybe B.ByteString-    -- ^ When the server is protected by a password, set 'connectAuth' to 'Just'-    --   the password. Each connection will then authenticate by the 'auth'-    --   command.-    , connectDatabase       :: Integer-    -- ^ Each connection will 'select' the database with the given index.-    , connectMaxConnections :: Int-    -- ^ Maximum number of connections to keep open. The smallest acceptable-    --   value is 1.-    , connectMaxIdleTime    :: NominalDiffTime-    -- ^ Amount of time for which an unused connection is kept open. The-    --   smallest acceptable value is 0.5 seconds. If the @timeout@ value in-    --   your redis.conf file is non-zero, it should be larger than-    --   'connectMaxIdleTime'.-    } deriving Show---- |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--- @----defaultConnectInfo :: ConnectInfo-defaultConnectInfo = ConnInfo-    { connectHost           = "localhost"-    , connectPort           = PortNumber 6379-    , connectAuth           = Nothing-    , connectDatabase       = 0-    , connectMaxConnections = 50-    , connectMaxIdleTime    = 30-    }---- |Opens a 'Connection' to a Redis server designated by the given---  'ConnectInfo'.-connect :: ConnectInfo -> IO Connection-connect ConnInfo{..} = Conn <$>-    createPool create destroy 1 connectMaxIdleTime connectMaxConnections-  where-    create = do-        conn <- PP.connect connectHost connectPort reply-        runRedisInternal conn $ do-            -- AUTH-            case connectAuth of-                Nothing   -> return ()-                Just pass -> void $ auth pass-            -- SELECT-            when (connectDatabase /= 0) (void $ select connectDatabase)-        return conn--    destroy = PP.disconnect---- The AUTH command. It has to be here because it is used in 'connect'.-auth-    :: B.ByteString -- ^ password-    -> Redis (Either Reply Status)-auth password = sendRequest ["AUTH", password]---- The SELECT command. Used in 'connect'.-select-    :: RedisCtx m f-    => Integer -- ^ index-    -> m (f Status)-select ix = sendRequest ["SELECT", encode ix]+    r' <- liftRedis $ Redis $ do+        env <- ask+        case env of+            NonClusteredEnv{..} -> do+                r <- liftIO $ sendRequestHook (PP.hooks envConn) (PP.request envConn . renderRequest) req+                setLastReply r+                return r+            ClusteredEnv{..} -> do+                r <- liftIO $ sendRequestHook (Cluster.hooks connection) (Cluster.requestPipelined refreshAction connection) req+                setLastReply r+                return r+    returnDecode r'
+ src/Database/Redis/Core/Internal.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}++module Database.Redis.Core.Internal where+#if __GLASGOW_HASKELL__ > 711 && __GLASGOW_HASKELL__ < 808+import Control.Monad.Fail (MonadFail)+#endif+import Control.Monad.Catch+import Control.Monad.Reader+import Data.IORef+import Database.Redis.Protocol+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, MonadThrow, MonadCatch, MonadMask)+#if __GLASGOW_HASKELL__ > 711+deriving instance MonadFail Redis+#endif+data RedisEnv+    = NonClusteredEnv { envConn :: PP.Connection, nonClusteredLastReply :: IORef Reply }+    | ClusteredEnv+        { refreshAction :: IO Cluster.ShardMap+        , connection :: Cluster.Connection+        , clusteredLastReply :: IORef Reply+        }++envLastReply :: RedisEnv -> IORef Reply+envLastReply NonClusteredEnv{..} = nonClusteredLastReply+envLastReply ClusteredEnv{..} = clusteredLastReply
+ src/Database/Redis/Hooks.hs view
@@ -0,0 +1,44 @@+module Database.Redis.Hooks where++import Data.ByteString (ByteString)+import Database.Redis.Protocol (Reply)+import {-# SOURCE #-} Database.Redis.PubSub (Message, PubSub)++data Hooks =+  Hooks+    { sendRequestHook :: SendRequestHook+    , sendPubSubHook :: SendPubSubHook+    , callbackHook :: CallbackHook+    , sendHook :: SendHook+    , receiveHook :: ReceiveHook+    }++-- | A hook for sending commands to the server and receiving replys from the server.+type SendRequestHook = ([ByteString] -> IO Reply) -> [ByteString] -> IO Reply++-- | A hook for sending pub/sub messages to the server.+type SendPubSubHook = ([ByteString] -> IO ()) -> [ByteString] -> IO ()++-- | A hook for invoking callbacks with pub/sub messages.+type CallbackHook = (Message -> IO PubSub) -> Message -> IO PubSub++-- | A hook for just sending raw data to the server.+type SendHook = (ByteString -> IO ()) -> ByteString -> IO ()++-- | A hook for receiving raw data from the server.+type ReceiveHook = IO Reply -> IO Reply++-- | The default hooks.+-- Every hook is the identity function.+defaultHooks :: Hooks+defaultHooks =+  Hooks+    { sendRequestHook = id+    , sendPubSubHook = id+    , callbackHook = id+    , sendHook = id+    , receiveHook = id+    }++instance Show Hooks where+  show _ = "Hooks {sendRequestHook = _, sendPubSubHook = _, callbackHook = _, sendHook = _, receiveHook = _}"
src/Database/Redis/ManualCommands.hs view
@@ -1,403 +1,2487 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleContexts #-}--module Database.Redis.ManualCommands where--import Prelude hiding (min,max)-import Data.ByteString (ByteString)-import Database.Redis.Core-import Database.Redis.Protocol-import Database.Redis.Types---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.-    } 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-        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)--evalsha-    :: (RedisCtx m f, RedisResult a)-    => ByteString -- ^ 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+{-# 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.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (maybeToList, catMaybes, fromMaybe)+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup ((<>))+#endif++++import Database.Redis.Core+import Database.Redis.Protocol+import Database.Redis.Types+import qualified Database.Redis.Cluster.Command as CMD++-- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3+objectRefcount+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f Integer)+objectRefcount key = sendRequest ["OBJECT", "refcount", key]++objectIdletime+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f Integer)+objectIdletime key = sendRequest ["OBJECT", "idletime", key]++-- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3+objectEncoding+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f ByteString)+objectEncoding key = sendRequest ["OBJECT", "encoding", key]++-- |Insert an element before or after another element in a list (<http://redis.io/commands/linsert>). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'. Since Redis 2.2.0+linsertBefore+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ pivot+    -> ByteString -- ^ value+    -> m (f Integer)+linsertBefore key pivot value =+    sendRequest ["LINSERT", key, "BEFORE", pivot, value]++-- |Insert an element before or after another element in a list (<http://redis.io/commands/linsert>). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'. Since Redis 2.2.0+linsertAfter+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ pivot+    -> ByteString -- ^ value+    -> m (f Integer)+linsertAfter key pivot value =+        sendRequest ["LINSERT", encode key, "AFTER", encode pivot, encode value]++-- |Determine the type stored at key (<http://redis.io/commands/type>). Since Redis 1.0.0+getType+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f RedisType)+getType key = sendRequest ["TYPE", key]++-- |A single entry from the slowlog.+data Slowlog = Slowlog+    { slowlogId        :: Integer+      -- ^ A unique progressive identifier for every slow log entry.+    , slowlogTimestamp :: Integer+      -- ^ The unix timestamp at which the logged command was processed.+    , slowlogMicros    :: Integer+      -- ^ The amount of time needed for its execution, in microseconds.+    , slowlogCmd       :: [ByteString]+      -- ^ The command and it's arguments.+    , slowlogClientIpAndPort :: Maybe ByteString+    , slowlogClientName :: Maybe ByteString+    } deriving (Show, Eq)++instance RedisResult Slowlog where+    decode (MultiBulk (Just [logId,timestamp,micros,cmd])) = do+        slowlogId        <- decode logId+        slowlogTimestamp <- decode timestamp+        slowlogMicros    <- decode micros+        slowlogCmd       <- decode cmd+        let slowlogClientIpAndPort = Nothing+            slowlogClientName = Nothing+        return Slowlog{..}+    decode (MultiBulk (Just [logId,timestamp,micros,cmd,ip,cname])) = do+        slowlogId        <- decode logId+        slowlogTimestamp <- decode timestamp+        slowlogMicros    <- decode micros+        slowlogCmd       <- decode cmd+        slowlogClientIpAndPort <- Just <$> decode ip+        slowlogClientName <- Just <$> decode cname+        return Slowlog{..}+    decode r = Left r++slowlogGet+    :: (RedisCtx m f)+    => Integer -- ^ cnt+    -> m (f [Slowlog])+slowlogGet n = sendRequest ["SLOWLOG", "GET", encode n]++slowlogLen :: (RedisCtx m f) => m (f Integer)+slowlogLen = sendRequest ["SLOWLOG", "LEN"]++slowlogReset :: (RedisCtx m f) => m (f Status)+slowlogReset = sendRequest ["SLOWLOG", "RESET"]++-- |Return a range of members in a sorted set, by index (<http://redis.io/commands/zrange>). The Redis command @ZRANGE@ is split up into 'zrange', 'zrangeWithscores'. Since Redis 1.2.0+zrange+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ stop+    -> m (f [ByteString])+zrange key start stop =+    sendRequest ["ZRANGE", encode key, encode start, encode stop]++-- |Return a range of members in a sorted set, by index (<http://redis.io/commands/zrange>). The Redis command @ZRANGE@ is split up into 'zrange', 'zrangeWithscores'. Since Redis 1.2.0+zrangeWithscores+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ stop+    -> m (f [(ByteString, Double)])+zrangeWithscores key start stop =+    sendRequest ["ZRANGE", encode key, encode start, encode stop, "WITHSCORES"]++zrevrange+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ stop+    -> m (f [ByteString])+zrevrange key start stop =+    sendRequest ["ZREVRANGE", encode key, encode start, encode stop]++zrevrangeWithscores+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ stop+    -> m (f [(ByteString, Double)])+zrevrangeWithscores key start stop =+    sendRequest ["ZREVRANGE", encode key, encode start, encode stop+                ,"WITHSCORES"]++zrangebyscore+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Double -- ^ min+    -> Double -- ^ max+    -> m (f [ByteString])+zrangebyscore key min max =+    sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max]++zrangebyscoreWithscores+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Double -- ^ min+    -> Double -- ^ max+    -> m (f [(ByteString, Double)])+zrangebyscoreWithscores key min max =+    sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max+                ,"WITHSCORES"]++zrangebyscoreLimit+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Double -- ^ min+    -> Double -- ^ max+    -> Integer -- ^ offset+    -> Integer -- ^ count+    -> m (f [ByteString])+zrangebyscoreLimit key min max offset count =+    sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max+                ,"LIMIT", encode offset, encode count]++zrangebyscoreWithscoresLimit+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Double -- ^ min+    -> Double -- ^ max+    -> Integer -- ^ offset+    -> Integer -- ^ count+    -> m (f [(ByteString, Double)])+zrangebyscoreWithscoresLimit key min max offset count =+    sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max+                ,"WITHSCORES","LIMIT", encode offset, encode count]++zrevrangebyscore+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Double -- ^ max+    -> Double -- ^ min+    -> m (f [ByteString])+zrevrangebyscore key min max =+    sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max]++zrevrangebyscoreWithscores+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Double -- ^ max+    -> Double -- ^ min+    -> m (f [(ByteString, Double)])+zrevrangebyscoreWithscores key min max =+    sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max+                ,"WITHSCORES"]++zrevrangebyscoreLimit+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Double -- ^ max+    -> Double -- ^ min+    -> Integer -- ^ offset+    -> Integer -- ^ count+    -> m (f [ByteString])+zrevrangebyscoreLimit key min max offset count =+    sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max+                ,"LIMIT", encode offset, encode count]++zrevrangebyscoreWithscoresLimit+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Double -- ^ max+    -> Double -- ^ min+    -> Integer -- ^ offset+    -> Integer -- ^ count+    -> m (f [(ByteString, Double)])+zrevrangebyscoreWithscoresLimit key min max offset count =+    sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max+                ,"WITHSCORES","LIMIT", encode offset, encode count]++-- |Options for the 'sort' command.+data SortOpts = SortOpts+    { sortBy     :: Maybe ByteString+    , sortLimit  :: (Integer,Integer)+    , sortGet    :: [ByteString]+    , sortOrder  :: SortOrder+    , sortAlpha  :: Bool+    } deriving (Show, Eq)++-- |Redis default 'SortOpts'. Equivalent to omitting all optional parameters.+--+-- @+-- SortOpts+--     { sortBy    = Nothing -- omit the BY option+--     , sortLimit = (0,-1)  -- return entire collection+--     , sortGet   = []      -- omit the GET option+--     , sortOrder = Asc     -- sort in ascending order+--     , sortAlpha = False   -- sort numerically, not lexicographically+--     }+-- @+--+defaultSortOpts :: SortOpts+defaultSortOpts = SortOpts+    { sortBy    = Nothing+    , sortLimit = (0,-1)+    , sortGet   = []+    , sortOrder = Asc+    , sortAlpha = False+    }++data SortOrder = Asc | Desc deriving (Show, Eq)++-- |Sort the elements in a list, set or sorted set (<http://redis.io/commands/sort>). The Redis command @SORT@ is split up into 'sort', 'sortStore'. Since Redis 1.0.0+sortStore+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ destination+    -> SortOpts+    -> m (f Integer)+sortStore key dest = sortInternal key (Just dest)++-- |Sort the elements in a list, set or sorted set (<http://redis.io/commands/sort>). The Redis command @SORT@ is split up into 'sort', 'sortStore'. Since Redis 1.0.0+sort+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> SortOpts+    -> m (f [ByteString])+sort key = sortInternal key Nothing++sortInternal+    :: (RedisResult a, RedisCtx m f)+    => ByteString -- ^ key+    -> Maybe ByteString -- ^ destination+    -> SortOpts+    -> m (f a)+sortInternal key destination SortOpts{..} = sendRequest $+    concat [["SORT", encode key], by, limit, get, order, alpha, store]+  where+    by    = maybe [] (\pattern -> ["BY", pattern]) sortBy+    limit = let (off,cnt) = sortLimit in ["LIMIT", encode off, encode cnt]+    get   = concatMap (\pattern -> ["GET", pattern]) sortGet+    order = case sortOrder of Desc -> ["DESC"]; Asc -> ["ASC"]+    alpha = ["ALPHA" | sortAlpha]+    store = maybe [] (\dest -> ["STORE", dest]) destination+++data Aggregate = Sum | Min | Max deriving (Show,Eq)++zunionstore+    :: (RedisCtx m f)+    => ByteString -- ^ destination+    -> [ByteString] -- ^ keys+    -> Aggregate+    -> m (f Integer)+zunionstore dest keys =+    zstoreInternal "ZUNIONSTORE" dest keys []++zunionstoreWeights+    :: (RedisCtx m f)+    => ByteString -- ^ destination+    -> [(ByteString,Double)] -- ^ weighted keys+    -> Aggregate+    -> m (f Integer)+zunionstoreWeights dest kws =+    let (keys,weights) = unzip kws+    in zstoreInternal "ZUNIONSTORE" dest keys weights++-- |Intersect multiple sorted sets and store the resulting sorted set in a new key (<http://redis.io/commands/zinterstore>). The Redis command @ZINTERSTORE@ is split up into 'zinterstore', 'zinterstoreWeights'. Since Redis 2.0.0+zinterstore+    :: (RedisCtx m f)+    => ByteString -- ^ destination+    -> NonEmpty ByteString -- ^ keys+    -> Aggregate+    -> m (f Integer)+zinterstore dest (key_:|keys_) =+    zstoreInternal "ZINTERSTORE" dest (key_:keys_) []++-- |Intersect multiple sorted sets and store the resulting sorted set in a new key (<http://redis.io/commands/zinterstore>). The Redis command @ZINTERSTORE@ is split up into 'zinterstore', 'zinterstoreWeights'. Since Redis 2.0.0+zinterstoreWeights+    :: (RedisCtx m f)+    => ByteString -- ^ destination+    -> NonEmpty (ByteString,Double) -- ^ weighted keys+    -> Aggregate+    -> m (f Integer)+zinterstoreWeights dest kws =+    let (keys,weights) = unzip (NE.toList kws)+    in zstoreInternal "ZINTERSTORE" dest keys weights++zstoreInternal+    :: (RedisCtx m f)+    => ByteString -- ^ cmd+    -> ByteString -- ^ destination+    -> [ByteString] -- ^ keys+    -> [Double] -- ^ weights+    -> Aggregate+    -> m (f Integer)+zstoreInternal cmd dest keys weights aggregate = sendRequest $+    concat [ [cmd, dest, encode . toInteger $ length keys ], keys+           , if null weights then [] else "WEIGHTS" : map encode weights+           , ["AGGREGATE", aggregate']+           ]+  where+    aggregate' = case aggregate of+        Sum -> "SUM"+        Min -> "MIN"+        Max -> "MAX"++-- |Execute a Lua script server side (<http://redis.io/commands/eval>). Since Redis 2.6.0+eval+    :: (RedisCtx m f, RedisResult a)+    => ByteString -- ^ script+    -> [ByteString] -- ^ keys+    -> [ByteString] -- ^ args+    -> m (f a)+eval script keys args =+    sendRequest $ ["EVAL", script, encode numkeys] ++ keys ++ args+  where+    numkeys = toInteger (length keys)++-- | Works like 'eval', but sends the SHA1 hash of the script instead of the script itself.+-- Fails if the server does not recognise the hash, in which case, 'eval' should be used instead.+evalsha+    :: (RedisCtx m f, RedisResult a)+    => ByteString -- ^ base16-encoded sha1 hash of the script+    -> [ByteString] -- ^ keys+    -> [ByteString] -- ^ args+    -> m (f a)+evalsha script keys args =+    sendRequest $ ["EVALSHA", script, encode numkeys] ++ keys ++ args+  where+    numkeys = toInteger (length keys)++bitcount+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f Integer)+bitcount key = sendRequest ["BITCOUNT", key]++bitcountRange+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ start+    -> Integer -- ^ end+    -> m (f Integer)+bitcountRange key start end =+    sendRequest ["BITCOUNT", key, encode start, encode end]++bitopAnd+    :: (RedisCtx m f)+    => ByteString -- ^ destkey+    -> [ByteString] -- ^ srckeys+    -> m (f Integer)+bitopAnd dst srcs = bitop "AND" (dst:srcs)++bitopOr+    :: (RedisCtx m f)+    => ByteString -- ^ destkey+    -> [ByteString] -- ^ srckeys+    -> m (f Integer)+bitopOr dst srcs = bitop "OR" (dst:srcs)++bitopXor+    :: (RedisCtx m f)+    => ByteString -- ^ destkey+    -> [ByteString] -- ^ srckeys+    -> m (f Integer)+bitopXor dst srcs = bitop "XOR" (dst:srcs)++bitopNot+    :: (RedisCtx m f)+    => ByteString -- ^ destkey+    -> ByteString -- ^ srckey+    -> m (f Integer)+bitopNot dst src = bitop "NOT" [dst, src]++bitop+    :: (RedisCtx m f)+    => ByteString -- ^ operation+    -> [ByteString] -- ^ keys+    -> m (f Integer)+bitop op ks = sendRequest $ "BITOP" : op : ks++-- |Atomically transfer a key from a Redis instance to another one (<http://redis.io/commands/migrate>). The Redis command @MIGRATE@ is split up into 'migrate', 'migrateMultiple'. Since Redis 2.6.0+migrate+    :: (RedisCtx m f)+    => ByteString -- ^ host+    -> ByteString -- ^ port+    -> ByteString -- ^ key+    -> Integer -- ^ destinationDb+    -> Integer -- ^ timeout+    -> m (f Status)+migrate host port key destinationDb timeout =+  sendRequest ["MIGRATE", host, port, key, encode destinationDb, encode timeout]++data MigrateAuth+  = MigrateAuth ByteString+  | MigrateAuth2 ByteString ByteString+  deriving (Show, Eq)++-- |Options for the 'migrate' command.+data MigrateOpts = MigrateOpts+    { migrateCopy    :: Bool+    , migrateReplace :: Bool+    , migrateAuth :: Maybe MigrateAuth+    } deriving (Show, Eq)++-- |Redis default 'MigrateOpts'. Equivalent to omitting all optional parameters.+--+-- @+-- MigrateOpts+--     { migrateCopy    = False -- remove the key from the local instance+--     , migrateReplace = False -- don't replace existing key on the remote instance+--     , migrateAuth = Nothing+--     }+-- @+--+defaultMigrateOpts :: MigrateOpts+defaultMigrateOpts = MigrateOpts+    { migrateCopy    = False+    , migrateReplace = False+    , migrateAuth = Nothing+    }++-- |Atomically transfer a key from a Redis instance to another one (<http://redis.io/commands/migrate>). The Redis command @MIGRATE@ is split up into 'migrate', 'migrateMultiple'. Since Redis 2.6.0+migrateMultiple+    :: (RedisCtx m f)+    => ByteString   -- ^ host+    -> ByteString   -- ^ port+    -> Integer      -- ^ destinationDb+    -> Integer      -- ^ timeout+    -> MigrateOpts+    -> [ByteString] -- ^ keys+    -> m (f Status)+migrateMultiple host port destinationDb timeout MigrateOpts{..} keys =+    sendRequest $+    concat [["MIGRATE", host, port, empty, encode destinationDb, encode timeout],+            auth_, copy, replace, keys]+  where+    copy = ["COPY" | migrateCopy]+    replace = ["REPLACE" | migrateReplace]+    auth_ = case migrateAuth of+     Nothing -> []+     Just (MigrateAuth pass)  -> ["AUTH", pass]+     Just (MigrateAuth2 user pass)  -> ["AUTH2", user, pass]+++-- |Create a key using the provided serialized value, previously obtained using DUMP (<http://redis.io/commands/restore>). The Redis command @RESTORE@ is split up into 'restore', 'restoreReplace'. Since Redis 2.6.0+restore+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ timeToLive+    -> ByteString -- ^ serializedValue+    -> m (f Status)+restore key timeToLive serializedValue =+  sendRequest ["RESTORE", key, encode timeToLive, serializedValue]++data RestoreOpts = RestoreOpts+  { restoreOptsReplace :: Bool+  , restoreOptsAbsTTL :: Bool+  , restoreOptsIdle  :: Maybe Integer+  , restoreOptsFreq :: Maybe Integer+  }++-- |Create a key using the provided serialized value, previously obtained using DUMP (<http://redis.io/commands/restore>). The Redis command @RESTORE@ is split up into 'restore', 'restoreReplace'. Since Redis 2.6.0+restoreOpts+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ timeToLive+    -> ByteString -- ^ serializedValue+    -> RestoreOpts -- ^ restore options+    -> m (f Status)+restoreOpts key timeToLive serializedValue RestoreOpts{..} =+  sendRequest ("RESTORE": key: encode timeToLive: serializedValue:rest) where+  rest =  replace <> absttl <> idle <> freq+  replace = ["REPLACE" | restoreOptsReplace]+  absttl  = ["ABSTTL" | restoreOptsAbsTTL]+  idle    = maybe [] (\i -> ["IDLE", encode i]) restoreOptsIdle+  freq    = maybe [] (\f -> ["FREQ", encode f]) restoreOptsFreq++-- |Create a key using the provided serialized value, previously obtained using DUMP (<http://redis.io/commands/restore>). The Redis command @RESTORE@ is split up into 'restore', 'restoreReplace'. Since Redis 2.6.0++restoreReplace+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ timeToLive+    -> ByteString -- ^ serializedValue+    -> m (f Status)+restoreReplace key timeToLive serializedValue =+  sendRequest ["RESTORE", key, encode timeToLive, serializedValue, "REPLACE"]+++set+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ value+    -> m (f Status)+set key value = sendRequest ["SET", key, value]+++data Condition =+  Nx | -- ^ Only set the key if it does not already exist.+  Xx   -- ^ Only set the key if it already exists.+   deriving (Show, Eq)+++instance RedisArg Condition where+  encode Nx = "NX"+  encode Xx = "XX"+++data SetOpts = SetOpts+  { setSeconds           :: Maybe Integer -- ^ Set the specified expire time, in seconds.+  , setMilliseconds      :: Maybe Integer -- ^ Set the specified expire time, in milliseconds.+  , setUnixSeconds       :: Maybe Integer+  {- ^ Set the specified Unix time at which the key will expire, in seconds.++  Since Redis 6.2+  -}+  , setUnixMilliseconds  :: Maybe Integer+  {- ^ Set the specified Unix time at which the key will expire, in milliseconds.+  -}+  , setCondition         :: Maybe Condition -- ^ Set the key on condition+  , setKeepTTL           :: Bool+  {- ^ Retain the time to live associated with the key.++  Since Redis 6.0+  -}+  } deriving (Show, Eq)++internalSetOptsToArgs :: SetOpts -> [ByteString]+internalSetOptsToArgs SetOpts{..} = concat [ex, px, exat, pxat, keepttl, condition]+  where+    ex   = maybe [] (\s -> ["EX",   encode s]) setSeconds+    px   = maybe [] (\s -> ["PX",   encode s]) setMilliseconds+    exat = maybe [] (\s -> ["EXAT", encode s]) setUnixSeconds+    pxat = maybe [] (\s -> ["PXAT", encode s]) setUnixMilliseconds+    keepttl = ["KEEPTTL" | setKeepTTL]+    condition = map encode $ maybeToList setCondition++setOpts+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ value+    -> SetOpts+    -> m (f Status)+setOpts key value opts = sendRequest $ ["SET", key, value] ++ internalSetOptsToArgs opts++setGet+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ value+    -> m (f ByteString)+setGet key value = sendRequest ["SET", key, value, "GET"]++setGetOpts+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> ByteString -- ^ value+    -> SetOpts+    -> m (f ByteString)+setGetOpts key value opts = sendRequest $ ["SET", key, value, "GET"] ++ internalSetOptsToArgs opts+++data DebugMode = Yes | Sync | No deriving (Show, Eq)+++instance RedisArg DebugMode where+  encode Yes = "YES"+  encode Sync = "SYNC"+  encode No = "NO"++-- |Set the debug mode for executed scripts (<http://redis.io/commands/script-debug>). Since Redis 3.2.0+scriptDebug+    :: (RedisCtx m f)+    => DebugMode+    -> m (f Bool)+scriptDebug mode =+    sendRequest ["SCRIPT DEBUG", encode mode]++-- |Add one or more members to a sorted set, or update its score if it already exists (<http://redis.io/commands/zadd>). The Redis command @ZADD@ is split up into 'zadd', 'zaddOpts'. Since Redis 1.2.0+zadd+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> [(Double,ByteString)] -- ^ scoreMember+    -> m (f Integer)+zadd key scoreMembers =+  zaddOpts key scoreMembers defaultZaddOpts+++data SizeCondition =+    CGT | -- ^  Only update existing elements if the new score is greater than the current score. This flag doesn't prevent adding new elements.+    CLT   -- ^  Only update existing elements if the new score is less than the current score. This flag doesn't prevent adding new elements.+    deriving (Show, Eq)++instance RedisArg SizeCondition where+  encode CGT = "GT"+  encode CLT = "LT"++-- |Add one or more members to a sorted set, or update its score if it already exists (<http://redis.io/commands/zadd>). The Redis command @ZADD@ is split up into 'zadd', 'zaddOpts'. Since Redis 1.2.0+data ZaddOpts = ZaddOpts+  { zaddCondition :: Maybe Condition -- ^ Add on condition+  , zaddSizeCondition :: Maybe SizeCondition+  {- ^ Only update existing elements on condition++  Since Redis 6.2+  -}+  , zaddChange    :: Bool -- ^ Modify the return value from the number of new elements added, to the total number of elements changed+  , zaddIncrement :: Bool -- ^ When this option is specified ZADD acts like ZINCRBY. Only one score-element pair can be specified in this mode.+  } deriving (Show, Eq)+++-- |Redis default 'ZaddOpts'. Equivalent to omitting all optional parameters.+--+-- @+-- ZaddOpts+--     { zaddCondition = Nothing -- omit NX and XX options+--     , zaddChange    = False   -- don't modify the return value from the number of new elements added, to the total number of elements changed+--     , zaddIncrement = False   -- don't add like ZINCRBY+--     }+-- @+--+defaultZaddOpts :: ZaddOpts+defaultZaddOpts = ZaddOpts+  { zaddCondition = Nothing+  , zaddChange    = False+  , zaddIncrement = False+  , zaddSizeCondition = Nothing+  }+++zaddOpts+    :: (RedisCtx m f)+    => ByteString            -- ^ key+    -> [(Double,ByteString)] -- ^ scoreMember+    -> ZaddOpts              -- ^ options+    -> m (f Integer)+zaddOpts key scoreMembers ZaddOpts{..} =+    sendRequest $ concat [["ZADD", key], condition, sizeCondition, change, increment, scores]+  where+    scores = concatMap (\(x,y) -> [encode x,encode y]) scoreMembers+    condition = map encode $ maybeToList zaddCondition+    sizeCondition = map encode $ maybeToList zaddSizeCondition+    change = ["CH" | zaddChange]+    increment = ["INCR" | zaddIncrement]+++data ReplyMode = On | Off | Skip deriving (Show, Eq)+++instance RedisArg ReplyMode where+  encode On = "ON"+  encode Off = "OFF"+  encode Skip = "SKIP"++-- |Instruct the server whether to reply to commands (<http://redis.io/commands/client-reply>). Since Redis 3.2+clientReply+    :: (RedisCtx m f)+    => ReplyMode+    -> m (f Bool)+clientReply mode =+    sendRequest ["CLIENT REPLY", encode mode]++-- |Get one or multiple random members from a set (<http://redis.io/commands/srandmember>). The Redis command @SRANDMEMBER@ is split up into 'srandmember', 'srandmemberN'. Since Redis 1.0.0+srandmember+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f (Maybe ByteString))+srandmember key = sendRequest ["SRANDMEMBER", key]+++-- |Get one or multiple random members from a set (<http://redis.io/commands/srandmember>). The Redis command @SRANDMEMBER@ is split up into 'srandmember', 'srandmemberN'. Since Redis 1.0.0+srandmemberN+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ count+    -> m (f [ByteString])+srandmemberN key count = sendRequest ["SRANDMEMBER", key, encode count]++-- |Remove and return one or multiple random members from a set (<http://redis.io/commands/spop>). The Redis command @SPOP@ is split up into 'spop', 'spopN'. Since Redis 1.0.0+spop+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f (Maybe ByteString))+spop key = sendRequest ["SPOP", key]++-- |Remove and return one or multiple random members from a set (<http://redis.io/commands/spop>). The Redis command @SPOP@ is split up into 'spop', 'spopN'. Since Redis 1.0.0+spopN+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ count+    -> m (f [ByteString])+spopN key count = sendRequest ["SPOP", key, encode count]+++info+    :: (RedisCtx m f)+    => m (f ByteString)+info = sendRequest ["INFO"]+++infoSection+    :: (RedisCtx m f)+    => ByteString -- ^ section+    -> m (f ByteString)+infoSection section = sendRequest ["INFO", section]++-- |Determine if a key exists (<http://redis.io/commands/exists>). Since Redis 1.0.0+exists+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> m (f Bool)+exists key = sendRequest ["EXISTS", key]++newtype Cursor = Cursor ByteString deriving (Show, Eq)+++instance RedisArg Cursor where+  encode (Cursor c) = encode c+++instance RedisResult Cursor where+  decode (Bulk (Just s)) = Right $ Cursor s+  decode r               = Left r+++cursor0 :: Cursor+cursor0 = Cursor "0"++-- |Incrementally iterate the keys space (<http://redis.io/commands/scan>). The Redis command @SCAN@ is split up into 'scan', 'scanOpts'. Since Redis 2.8.0+scan+    :: (RedisCtx m f)+    => Cursor+    -> m (f (Cursor, [ByteString])) -- ^ next cursor and values+scan cursor = scanOpts cursor defaultScanOpts Nothing+++data ScanOpts = ScanOpts+  { scanMatch :: Maybe ByteString+  , scanCount :: Maybe Integer+  } deriving (Show, Eq)+++-- |Redis default 'ScanOpts'. Equivalent to omitting all optional parameters.+--+-- @+-- ScanOpts+--     { scanMatch = Nothing -- don't match any pattern+--     , scanCount = Nothing -- don't set any requirements on number elements returned (works like value @COUNT 10@)+--     }+-- @+--+defaultScanOpts :: ScanOpts+defaultScanOpts = ScanOpts+  { scanMatch = Nothing+  , scanCount = Nothing+  }++-- | Incrementally iterate the keys space (<http://redis.io/commands/scan>). The Redis command @SCAN@ is split up into 'scan', 'scanOpts'. Since Redis 2.8.0+scanOpts+    :: (RedisCtx m f)+    => Cursor+    -> ScanOpts+    -> Maybe ByteString -- ^ types of the object to  scan+    -> m (f (Cursor, [ByteString])) -- ^ next cursor and values+scanOpts cursor opts mtype_  = sendRequest $ addScanOpts ["SCAN", encode cursor] opts+    ++ maybe [] (\type_  -> ["TYPE", type_]) mtype_+++addScanOpts+    :: [ByteString] -- ^ main part of scan command+    -> ScanOpts+    -> [ByteString]+addScanOpts cmd ScanOpts{..} =+    concat [cmd, match, count]+  where+    prepend x y = [x, y]+    match       = maybe [] (prepend "MATCH") scanMatch+    count       = maybe [] ((prepend "COUNT").encode) scanCount++-- |Incrementally iterate Set elements (<http://redis.io/commands/sscan>). The Redis command @SSCAN@ is split up into 'sscan', 'sscanOpts'. Since Redis 2.8.0+sscan+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Cursor+    -> m (f (Cursor, [ByteString])) -- ^ next cursor and values+sscan key cursor = sscanOpts key cursor defaultScanOpts++-- |Incrementally iterate Set elements (<http://redis.io/commands/sscan>). The Redis command @SSCAN@ is split up into 'sscan', 'sscanOpts'. Since Redis 2.8.0+sscanOpts+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Cursor+    -> ScanOpts+    -> m (f (Cursor, [ByteString])) -- ^ next cursor and values+sscanOpts key cursor opts = sendRequest $ addScanOpts ["SSCAN", key, encode cursor] opts++-- |Incrementally iterate hash fields and associated values (<http://redis.io/commands/hscan>). The Redis command @HSCAN@ is split up into 'hscan', 'hscanOpts'. Since Redis 2.8.0+hscan+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Cursor+    -> m (f (Cursor, [(ByteString, ByteString)])) -- ^ next cursor and values+hscan key cursor = hscanOpts key cursor defaultScanOpts++-- |Incrementally iterate hash fields and associated values (<http://redis.io/commands/hscan>). The Redis command @HSCAN@ is split up into 'hscan', 'hscanOpts'. Since Redis 2.8.0+hscanOpts+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Cursor+    -> ScanOpts+    -> m (f (Cursor, [(ByteString, ByteString)])) -- ^ next cursor and values+hscanOpts key cursor opts = sendRequest $ addScanOpts ["HSCAN", key, encode cursor] opts+++zscan+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Cursor+    -> m (f (Cursor, [(ByteString, Double)])) -- ^ next cursor and values+zscan key cursor = zscanOpts key cursor defaultScanOpts+++zscanOpts+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Cursor+    -> ScanOpts+    -> m (f (Cursor, [(ByteString, Double)])) -- ^ next cursor and values+zscanOpts key cursor opts = sendRequest $ addScanOpts ["ZSCAN", key, encode cursor] opts++data RangeLex a = Incl a | Excl a | Minr | Maxr++instance RedisArg a => RedisArg (RangeLex a) where+  encode (Incl bs) = "[" `append` encode bs+  encode (Excl bs) = "(" `append` encode bs+  encode Minr      = "-"+  encode Maxr      = "+"++-- |Return a range of members in a sorted set, by lexicographical range (<http://redis.io/commands/zrangebylex>). Since Redis 2.8.9+zrangebylex::(RedisCtx m f) =>+    ByteString             -- ^ key+    -> RangeLex ByteString -- ^ min+    -> RangeLex ByteString -- ^ max+    -> m (f [ByteString])+zrangebylex key min max =+    sendRequest ["ZRANGEBYLEX", encode key, encode min, encode max]++zrangebylexLimit+    ::(RedisCtx m f)+    => ByteString -- ^ key+    -> RangeLex ByteString -- ^ min+    -> RangeLex ByteString -- ^ max+    -> Integer             -- ^ offset+    -> Integer             -- ^ count+    -> m (f [ByteString])+zrangebylexLimit key min max offset count  =+    sendRequest ["ZRANGEBYLEX", encode key, encode min, encode max,+                 "LIMIT", encode offset, encode count]++-- | Trimming strategy.+--+-- @since 0.16.0+data TrimStrategy+  = TrimMaxlen Integer+    -- ^ Evicts entries as long as the stream's length exceeds the specified threshold, where threshold is a positive integer.+  | TrimMinId ByteString+   {- ^  Evicts entries with IDs lower than threshold, where threshold is a stream ID.++   Since Redis 6.2: will fail if used on ealier versions.+   -}++-- | Type of the trimming.+--+-- @since 0.16.0+data TrimType+  = TrimExact {- ^ Exact trimming -}+  | TrimApprox (Maybe Integer) {- ^ Approximate trimming. Is faster, but may leave slightly more+    elements in the stream if they can't be immediately deleted.++    Additional parameter Specifies the maximal count of entries that will be evicted. When LIMIT and count aren't specified, the default value of 100 * the number of entries in a macro node will be implicitly used as the count, @Just 0@ removes the limit entirely.+    -}++data TrimOpts = TrimOpts+  { trimOptsStrategy :: TrimStrategy+  , trimOptsType :: TrimType+  }++-- | Converts trim options to the low level parameters+internalTrimArgToList :: TrimOpts -> [ByteString]+internalTrimArgToList TrimOpts{..} = trimArg ++ limitArg+  where trimArg = case trimOptsStrategy of+           TrimMaxlen max -> ("MAXLEN":approxArg:encode max:[])+           TrimMinId i -> ("MINID":approxArg:i:[])+        (approxArg, limitArg) = case trimOptsType of+            TrimExact -> ("=", [])+            TrimApprox limit -> ("~",  maybe [] (("LIMIT":) . (:[]) . encode) limit)++trimOpts :: TrimStrategy -> TrimType -> TrimOpts+trimOpts = TrimOpts++data XAddOpts = XAddOpts {+    xAddTrimOpts :: Maybe TrimOpts, -- ^ Call XTRIM right after XADD+    xAddnoMkStream :: Bool+    {- ^ Don't create a new stream if it doesn't exist++    @since Redis 6.2+    -}+}++defaultXAddOpts :: XAddOpts+defaultXAddOpts = XAddOpts {+    xAddTrimOpts = Nothing,+    xAddnoMkStream = False+}++-- |Add a value to a stream (<https://redis.io/commands/xadd>). The Redis command @XADD@ is split up into 'xadd', 'xaddOpts'. Since Redis 5.0.0+xaddOpts+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name.+    -> ByteString -- ^ Message ID+    -> [(ByteString, ByteString)] -- ^ Message data (field, value)+    -> XAddOpts -- ^ Additional parameteers+    -> m (f ByteString) -- ^ ID of the added entry.+xaddOpts key entryId fieldValues opts = sendRequest $+    ["XADD", key] ++ noMkStreamArgs ++ trimArgs ++ [entryId] ++ fieldArgs+    where+        fieldArgs = concatMap (\(x,y) -> [x,y]) fieldValues+        noMkStreamArgs = ["NOMKSTREAM" | xAddnoMkStream opts]+        trimArgs = maybe [] (internalTrimArgToList) (xAddTrimOpts opts)++-- | /O(1)/ Adds a value to a stream (<https://redis.io/commands/xadd>). Since Redis 5.0.0+xadd+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name+    -> ByteString -- ^ Message id+    -> [(ByteString, ByteString)] -- ^ Message data (field, value)+    -> m (f ByteString)+xadd key entryId fieldValues = xaddOpts key entryId fieldValues defaultXAddOpts++-- | Additional parameters.+newtype XAutoclaimOpts = XAutoclaimOpts {+    xAutoclaimCount :: Maybe Integer -- ^  The upper limit of the number of entries that the command attempts to claim (default: 100).+}++-- | Default 'XAutoclaimOpts' value.+--+-- Prefer to use this function over direct use of constructor to preserve+-- backwards compatibility.+--+-- Defaults to @[Count 100)@+defaultXAutoclaimOpts :: XAutoclaimOpts+defaultXAutoclaimOpts = XAutoclaimOpts {+    xAutoclaimCount = Nothing+}++-- | Result of the 'xautoclaim' family of calls+data XAutoclaimResult resultFormat = XAutoclaimResult {+    xAutoclaimResultId :: ByteString,+    -- ^ ID of message that should be used in the next 'xautoclaim' call as a start parameter.+    xAutoclaimClaimedMessages :: [resultFormat],+    -- ^ List of succesfully claimed messages.+    xAutoclaimDeletedMessages :: [ByteString]+    -- ^ List of the messages that are available in the PEL but already deleted from the stream.+} deriving (Show, Eq)++instance RedisResult a => RedisResult (XAutoclaimResult a) where+    decode (MultiBulk (Just [+        Bulk (Just xAutoclaimResultId) ,+        claimedMsg,+        deletedMsg])) = do+            xAutoclaimClaimedMessages <- decode claimedMsg+            xAutoclaimDeletedMessages <- decode deletedMsg+            Right XAutoclaimResult{..}+    decode (MultiBulk (Just [+        Bulk (Just xAutoclaimResultId) ,+        MultiBulk (Just [])+        ])) = do+            let xAutoclaimClaimedMessages = []+            let xAutoclaimDeletedMessages = []+            Right XAutoclaimResult{..}+    decode a = Left a++-- | Version of the autoclaim result that contains data of the messages.+type XAutoclaimStreamsResult = XAutoclaimResult StreamsRecord+-- | Version of the autoclaim result that contains only IDs.+type XAutoclaimJustIdsResult = XAutoclaimResult ByteString++-- | /O(1)/ Transfers ownership of pending stream entries that match+-- the specified criteria. The message should be pending for more than \<min-idle-time\>+-- milliseconds and ID should be greater than \<start\>.+--+-- @XAUTOCLAIM \<stream name\> \<consumer group name\> \<min idle time\> \<start\>@+--+-- This version of function  claims no more than 100 mesages, use 'xautoclaimOpt' to+-- override this behavior.+--+-- Since Redis 7.0: fails on ealier versions.+xautoclaim+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name.+    -> ByteString -- ^ Consumer group name.+    -> ByteString -- ^ Consumer name.+    -> Integer -- ^ Min idle time (ms).+    -> ByteString -- ^ ID of the message to start.+    -> m (f XAutoclaimStreamsResult)+xautoclaim key group consumer min_idle_time start = xautoclaimOpts key group consumer min_idle_time start defaultXAutoclaimOpts++-- | /O(1) if count is small/. Transfers ownership of pending stream entries that match+-- the specified criteria. See 'xautoclaim' for details.+--+-- Allows to pass additional optional parameters to set limit.+--+-- @XAUTOCLAIM \<stream name\> \<consumer group name\> \<min idle time\> \<start\> COUNT \<count\>@+--+-- Since Redis 7.0: fails on the ealier versions.+xautoclaimOpts+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name.+    -> ByteString -- ^ Consumer group name.+    -> ByteString -- ^ Consumer name.+    -> Integer -- ^ min idle time (ms).+    -> ByteString -- ^ start ID.+    -> XAutoclaimOpts -- ^ Additional parameters.+    -> m (f XAutoclaimStreamsResult)+xautoclaimOpts key group consumer min_idle_time start opts = sendRequest $+    ["XAUTOCLAIM", key, group, consumer, encode min_idle_time, start] ++ count+    where count  = maybe [] (("COUNT":) . (:[]) . encode) (xAutoclaimCount opts)++-- | /O(1)/ Transfers ownership of pending stream entries that match+-- the specified criteria. See 'xautoclaim' for more details about criteria.+--+-- This variant returns only id of the messages without data. This method+-- claims no more than 100 messages, see 'xautoclaimJustIdsOpts' for changing+-- this default.+--+-- @XAUTOCLAIM \<stream name\> \<consumer group name\> \<min idle time\> \<start\> JUSTID@+--+-- Since Redis 7.0: fails on the ealier versions.+xautoclaimJustIds+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name.+    -> ByteString -- ^ Consumer group name.+    -> ByteString -- ^ Consumer name.+    -> Integer -- ^ Min idle time (ms).+    -> ByteString -- ^ start ID.+    -> m (f XAutoclaimJustIdsResult)+xautoclaimJustIds key group consumer min_idle_time start =+  xautoclaimJustIdsOpts key group consumer min_idle_time start defaultXAutoclaimOpts++-- | /O(1) if count is small/ Transfers ownership of pending stream entries that match+-- the specified criteria. See 'xautoclaim' for more details about criteria.+--+-- This variant returns only id of the messages without data and allows to set the maximum+-- number of messages to be claimed.+--+-- @XAUTOCLAIM \<stream name\> \<consumer group name\> \<min idle time\> \<start\> COUNT \<count\> JUSTID@+--+-- Since Redis 7.0: fails on the ealier versions.+xautoclaimJustIdsOpts+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name.+    -> ByteString -- ^ Consumers group name.+    -> ByteString -- ^ Consumer namee.+    -> Integer -- ^ min idle time (ms).+    -> ByteString -- ^ Start ID.+    -> XAutoclaimOpts -- ^ Additional parametres.+    -> m (f XAutoclaimJustIdsResult)+xautoclaimJustIdsOpts key group consumer min_idle_time start opts = sendRequest $+    ["XAUTOCLAIM", key, group, consumer, encode min_idle_time, start] ++ count ++ ["JUSTID"]+    where count  = maybe [] (("COUNT":) . (:[]) . encode) (xAutoclaimCount opts)++data StreamsRecord = StreamsRecord+    { recordId :: ByteString+    , keyValues :: [(ByteString, ByteString)]+    } deriving (Show, Eq)++instance RedisResult StreamsRecord where+    decode (MultiBulk (Just [Bulk (Just recordId), MultiBulk (Just rawKeyValues)])) = do+        keyValuesList <- mapM decode rawKeyValues+        let keyValues = decodeKeyValues keyValuesList+        return StreamsRecord{..}+        where+            decodeKeyValues :: [ByteString] -> [(ByteString, ByteString)]+            decodeKeyValues (x:y:rest) = (x,y):decodeKeyValues rest+            decodeKeyValues _ = []+    decode a = Left a++data XReadOpts = XReadOpts+    { block :: Maybe Integer+    , recordCount :: Maybe Integer+    } deriving (Show, Eq)++-- |Redis default 'XReadOpts'. Equivalent to omitting all optional parameters.+--+-- @+-- XReadOpts+--     { block = Nothing -- Don't block waiting for more records+--     , recordCount    = Nothing   -- no record count+--     }+-- @+--+defaultXreadOpts :: XReadOpts+defaultXreadOpts = XReadOpts { block = Nothing, recordCount = Nothing }++data XReadResponse = XReadResponse+    { stream :: ByteString+    , records :: [StreamsRecord]+    } deriving (Show, Eq)++instance RedisResult XReadResponse where+    decode (MultiBulk (Just [Bulk (Just stream), MultiBulk (Just rawRecords)])) = do+        records <- mapM decode rawRecords+        return XReadResponse{..}+    decode a = Left a++xreadOpts+    :: (RedisCtx m f)+    => [(ByteString, ByteString)] -- ^ (stream, id) pairs+    -> XReadOpts -- ^ Options+    -> m (f (Maybe [XReadResponse]))+xreadOpts streamsAndIds opts = sendRequest $+    ["XREAD"] ++ (internalXreadArgs streamsAndIds opts)++internalXreadArgs :: [(ByteString, ByteString)] -> XReadOpts -> [ByteString]+internalXreadArgs streamsAndIds XReadOpts{..} =+    concat [blockArgs, countArgs, ["STREAMS"], streams, recordIds]+    where+        blockArgs = maybe [] (\blockMillis -> ["BLOCK", encode blockMillis]) block+        countArgs = maybe [] (\countRecords -> ["COUNT", encode countRecords]) recordCount+        streams = map (\(stream, _) -> stream) streamsAndIds+        recordIds = map (\(_, recordId) -> recordId) streamsAndIds+++xread+    :: (RedisCtx m f)+    => [(ByteString, ByteString)] -- ^ (stream, id) pairs+    -> m( f (Maybe [XReadResponse]))+xread streamsAndIds = xreadOpts streamsAndIds defaultXreadOpts++data XReadGroupOpts = XReadGroupOpts+    { xReadGroupBlock :: Maybe Integer+    , xReadGroupCount :: Maybe Integer+    , xReadGroupNoAck :: Bool+    } deriving (Show, Eq)++defaultXReadGroupOpts :: XReadGroupOpts+defaultXReadGroupOpts = XReadGroupOpts+    { xReadGroupBlock = Nothing+    , xReadGroupCount = Nothing+    , xReadGroupNoAck = False+    }++xreadGroupOpts+    :: (RedisCtx m f)+    => ByteString -- ^ group name+    -> ByteString -- ^ consumer name+    -> [(ByteString, ByteString)] -- ^ (stream, id) pairs+    -> XReadGroupOpts -- ^ Options+    -> m (f (Maybe [XReadResponse]))+xreadGroupOpts groupName consumerName streamsAndIds XReadGroupOpts{..} = sendRequest $+    ["XREADGROUP", "GROUP", groupName, consumerName] ++ internalXreadGroupArgs+    where+        internalXreadGroupArgs = concat [countArgs, blockArgs, noAckArgs, ["STREAMS"], streams, recordIds]+        blockArgs = maybe [] (\blockMillis -> ["BLOCK", encode blockMillis]) xReadGroupBlock+        countArgs = maybe [] (\countRecords -> ["COUNT", encode countRecords]) xReadGroupCount+        noAckArgs = ["NOACK" | xReadGroupNoAck]+        streams = map (\(stream, _) -> stream) streamsAndIds+        recordIds = map (\(_, recordId) -> recordId) streamsAndIds++xreadGroup+    :: (RedisCtx m f)+    => ByteString -- ^ group name+    -> ByteString -- ^ consumer name+    -> [(ByteString, ByteString)] -- ^ (stream, id) pairs+    -> m (f (Maybe [XReadResponse]))+xreadGroup groupName consumerName streamsAndIds = xreadGroupOpts groupName consumerName streamsAndIds defaultXReadGroupOpts++-- | Additional parameters of the XGroupCreate+data XGroupCreateOpts = XGroupCreateOpts+    { xGroupCreateMkStream :: Bool -- ^ If a stream does not exist, create it automatically with length of 0+    , xGroupCreateEntriesRead :: Maybe ByteString+    {- ^ Enable consumer group lag tracking, specify an arbitrary ID.+     An arbitrary ID is any ID that isn't the ID of the stream's first entry,+     last entry, or zero (@"0-0"@) ID. Use it to find out how many entries+     are between the arbitrary ID (excluding it) and the stream's last entry.++     Since Redis 7.0, fails if set on the ealier versions.+    -}+    } deriving (Show, Eq)++-- | Specifies default group opts.+--+-- Prefer using this method over use of constructor to preserve backwards compatibility.+defaultXGroupCreateOpts :: XGroupCreateOpts+defaultXGroupCreateOpts = XGroupCreateOpts{+    xGroupCreateEntriesRead = Nothing,+    xGroupCreateMkStream = False+}++-- | /O(1)/ Creates consumer group.+--+-- Fails if called on with the stream name that does not exist, use 'xgroupCreateOpts'+-- to override this behavior.+xgroupCreate+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name.+    -> ByteString -- ^ Consumer group name.+    -> ByteString -- ^ ID of the message to start reading with.+    -> m (f Status)+xgroupCreate stream groupName startId = xgroupCreateOpts stream groupName startId defaultXGroupCreateOpts++-- | /O(1)/ Creates consumer group, accepts additional parameters.+xgroupCreateOpts+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name.+    -> ByteString -- ^ Consumer group name.+    -> ByteString -- ^ ID of the message to start reading with.+    -> XGroupCreateOpts -- ^ Additional parameters.+    -> m (f Status)+xgroupCreateOpts stream groupName startId opts = sendRequest $ ["XGROUP", "CREATE", stream, groupName, startId] ++ args+    where args = mkstream ++ entriesRead+          mkstream    = ["MKSTREAM" | xGroupCreateMkStream opts]+          entriesRead = maybe []  (("ENTRIESREAD":) . (:[])) (xGroupCreateEntriesRead opts)++-- | /O(1)/ Creates new consumer in the consumers group.+--+-- Since redis 6.2.0: fails on the ealier versions.+xgroupCreateConsumer+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name.+    -> ByteString -- ^ Consumer group name.+    -> ByteString -- ^ Consumer name.+    -> m (f Bool) -- ^ Returns if the consumer was created or not.+xgroupCreateConsumer key group consumer = sendRequest ["XGROUP", "CREATECONSUMER", key, group, consumer]++-- | /O(1)/ Sets last delivered id for a consumer group.+xgroupSetId+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name.+    -> ByteString -- ^ Consumr group name.+    -> ByteString -- ^ Message ID or @$@+    -> m (f Status)+xgroupSetId stream group messageId = xgroupSetIdOpts stream group messageId defaultXGroupSetIdOpts++-- | Additional parameters for the 'xgroupSetId' method+newtype XGroupSetIdOpts = XGroupSetIdOpts {+    xGroupSetIdEntriesRead :: Maybe ByteString+    {- ^ Enable consumer group lag tracking for an arbitrary ID. An arbitrary ID is any ID that isn't the ID of the stream's first entry, its last entry or the zero (@"0-0"@) ID++    @since Redis 7.0, fails if set to Just on ealier versions.+    -}+}++-- | Default value for the 'XGroupSetIdOpts'.+--+-- Prefer use this method over the raw constructor in order to preserve+-- backwards compatibility.+defaultXGroupSetIdOpts :: XGroupSetIdOpts+defaultXGroupSetIdOpts = XGroupSetIdOpts {xGroupSetIdEntriesRead = Nothing}++-- | /O(1)/ a variant of the 'xgroupSetId' that allowes to pass additional parameters.+xgroupSetIdOpts+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name.+    -> ByteString -- ^ Consumer group name.+    -> ByteString -- ^ Message id or @$S+    -> XGroupSetIdOpts -- ^ Additional parameters.+    -> m (f Status)+xgroupSetIdOpts stream group messageId opts = sendRequest $ ["XGROUP", "SETID", stream, group, messageId] ++ entriesRead+    where entriesRead = maybe [] (("ENTRIESREAD":) . (:[])) (xGroupSetIdEntriesRead opts)++-- | /O(1)/ Delete consumer.+xgroupDelConsumer+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name.+    -> ByteString -- ^ Consumer group name.+    -> ByteString -- ^ Consumer name.+    -> m (f Integer) -- ^ The number of pending messages owned by the consumer.+xgroupDelConsumer stream group consumer = sendRequest ["XGROUP", "DELCONSUMER", stream, group, consumer]++-- | /O(1)/ destroys a group.+xgroupDestroy+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name.+    -> ByteString -- ^ Consumer group name.+    -> m (f Bool)  -- ^ Tells if the group was destroyed or not.+xgroupDestroy stream group = sendRequest ["XGROUP", "DESTROY", stream, group]++xack+    :: (RedisCtx m f)+    => ByteString -- ^ stream+    -> ByteString -- ^ group name+    -> [ByteString] -- ^ message IDs+    -> m (f Integer)+xack stream groupName messageIds = sendRequest $ ["XACK", stream, groupName] ++ messageIds++xrange+    :: (RedisCtx m f)+    => ByteString -- ^ stream+    -> ByteString -- ^ start+    -> ByteString -- ^ end+    -> Maybe Integer -- ^ COUNT+    -> m (f [StreamsRecord])+xrange stream start end count = sendRequest $ ["XRANGE", stream, start, end] ++ countArgs+    where countArgs = maybe [] (\c -> ["COUNT", encode c]) count++xrevRange+    :: (RedisCtx m f)+    => ByteString -- ^ stream+    -> ByteString -- ^ end+    -> ByteString -- ^ start+    -> Maybe Integer -- ^ COUNT+    -> m (f [StreamsRecord])+xrevRange stream end start count = sendRequest $ ["XREVRANGE", stream, end, start] ++ countArgs+    where countArgs = maybe [] (\c -> ["COUNT", encode c]) count++xlen+    :: (RedisCtx m f)+    => ByteString -- ^ stream+    -> m (f Integer)+xlen stream = sendRequest ["XLEN", stream]++data XPendingSummaryResponse = XPendingSummaryResponse+    { numPendingMessages :: Integer+    , smallestPendingMessageId :: ByteString+    , largestPendingMessageId :: ByteString+    , numPendingMessagesByconsumer :: [(ByteString, Integer)]+    } deriving (Show, Eq)++instance RedisResult XPendingSummaryResponse where+    decode (MultiBulk (Just [+        Integer numPendingMessages,+        Bulk (Just smallestPendingMessageId),+        Bulk (Just largestPendingMessageId),+        MultiBulk (Just [MultiBulk (Just rawGroupsAndCounts)])])) = do+            let groupsAndCounts = chunksOfTwo rawGroupsAndCounts+            numPendingMessagesByconsumer <- decodeGroupsAndCounts groupsAndCounts+            return XPendingSummaryResponse{..}+            where+                decodeGroupsAndCounts :: [(Reply, Reply)] -> Either Reply [(ByteString, Integer)]+                decodeGroupsAndCounts bs = sequence $ map decodeGroupCount bs+                decodeGroupCount :: (Reply, Reply) -> Either Reply (ByteString, Integer)+                decodeGroupCount (x, y) = do+                    decodedX <- decode x+                    decodedY <- decode y+                    return (decodedX, decodedY)+                chunksOfTwo (x:y:rest) = (x,y):chunksOfTwo rest+                chunksOfTwo _ = []+    decode a = Left a++-- | /O(N)/ N - number of message beign returned.+--+-- Get information about pending messages (https://redis.io/commands/xpending).+--+-- Since Redis 5.0.+xpendingSummary+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name.+    -> ByteString -- ^ Stream consumer group.+    -> m (f XPendingSummaryResponse)+xpendingSummary stream group = sendRequest $ ["XPENDING", stream, group]++-- | Details about message returned by the 'xpendingDetails'+data XPendingDetailRecord = XPendingDetailRecord+    { messageId :: ByteString+    , consumer :: ByteString+    , millisSinceLastDelivered :: Integer+    , numTimesDelivered :: Integer+    } deriving (Show, Eq)++instance RedisResult XPendingDetailRecord where+    decode (MultiBulk (Just [+        Bulk (Just messageId) ,+        Bulk (Just consumer),+        Integer millisSinceLastDelivered,+        Integer numTimesDelivered])) = Right XPendingDetailRecord{..}+    decode a = Left a++-- | Additional parameters of the xpending call family+data XPendingDetailOpts = XPendingDetailOpts+  {+    xPendingDetailConsumer :: Maybe ByteString, -- ^ Fetch the messages having a specific owner.+    xPendingDetailIdle :: Maybe Integer+    {- ^  Filter pending stream entries by their idle-time, ms++    Since Redis 6.2: Just values will fail+    -}+  }++-- | Default 'XPendingOpts' values.+--+-- Prefer this method over use of the constructor in order to preserve+-- backwards compatibility.+defaultXPendingDetailOpts :: XPendingDetailOpts+defaultXPendingDetailOpts = XPendingDetailOpts {+    xPendingDetailConsumer = Nothing,+    xPendingDetailIdle     = Nothing+}++-- | /O(N)/ N - number of messages returned.+--+-- Get detailed information about pending messages (https://redis.io/commands/xpending).+xpendingDetail+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name.+    -> ByteString -- ^ Consumer group name.+    -> ByteString -- ^ ID of the first interesting message.+    -> ByteString -- ^ ID of the last intersting message.+    -> Integer -- ^ Limits the numbere of messages returned from the call.+    -> XPendingDetailOpts+    -> m (f [XPendingDetailRecord])+xpendingDetail stream group startId endId count opts = sendRequest $+    ["XPENDING", stream, group] ++ idleArg ++ [startId, endId, encode count] ++ consumerArg+    where consumerArg = maybeToList (xPendingDetailConsumer opts)+          idleArg = maybe [] (("IDLE":) . (:[]) . encode) (xPendingDetailIdle opts)++data XClaimOpts = XClaimOpts+    { xclaimIdle :: Maybe Integer+    , xclaimTime :: Maybe Integer+    , xclaimRetryCount :: Maybe Integer+    , xclaimForce :: Bool+    } deriving (Show, Eq)++defaultXClaimOpts :: XClaimOpts+defaultXClaimOpts = XClaimOpts+    { xclaimIdle = Nothing+    , xclaimTime = Nothing+    , xclaimRetryCount = Nothing+    , xclaimForce = False+    }+++-- |Format a request for XCLAIM.+xclaimRequest+    :: ByteString -- ^ stream+    -> ByteString -- ^ group+    -> ByteString -- ^ consumer+    -> Integer -- ^ min idle time+    -> XClaimOpts -- ^ optional arguments+    -> [ByteString] -- ^ message IDs+    -> [ByteString]+xclaimRequest stream group consumer minIdleTime XClaimOpts{..} messageIds =+    ["XCLAIM", stream, group, consumer, encode minIdleTime] ++ ( map encode messageIds ) ++ optArgs+    where optArgs = idleArg ++ timeArg ++ retryCountArg ++ forceArg+          idleArg = optArg "IDLE" xclaimIdle+          timeArg = optArg "TIME" xclaimTime+          retryCountArg = optArg "RETRYCOUNT" xclaimRetryCount+          forceArg = if xclaimForce then ["FORCE"] else []+          optArg name maybeArg = maybe [] (\x -> [name, encode x]) maybeArg++xclaim+    :: (RedisCtx m f)+    => ByteString -- ^ stream+    -> ByteString -- ^ group+    -> ByteString -- ^ consumer+    -> Integer -- ^ min idle time+    -> XClaimOpts -- ^ optional arguments+    -> [ByteString] -- ^ message IDs+    -> m (f [StreamsRecord])+xclaim stream group consumer minIdleTime opts messageIds = sendRequest $+    xclaimRequest stream group consumer minIdleTime opts messageIds++xclaimJustIds+    :: (RedisCtx m f)+    => ByteString -- ^ stream+    -> ByteString -- ^ group+    -> ByteString -- ^ consumer+    -> Integer -- ^ min idle time+    -> XClaimOpts -- ^ optional arguments+    -> [ByteString] -- ^ message IDs+    -> m (f [ByteString])+xclaimJustIds stream group consumer minIdleTime opts messageIds = sendRequest $+    (xclaimRequest stream group consumer minIdleTime opts messageIds) ++ ["JUSTID"]++data GeoUnit+    = GeoMeters+    | GeoKilometers+    | GeoFeet+    | GeoMiles+    deriving (Show, Eq)++instance RedisArg GeoUnit where+    encode GeoMeters = "m"+    encode GeoKilometers = "km"+    encode GeoFeet = "ft"+    encode GeoMiles = "mi"++data GeoOrder+    = GeoAsc+    | GeoDesc+    deriving (Show, Eq)++instance RedisArg GeoOrder where+    encode GeoAsc = "ASC"+    encode GeoDesc = "DESC"++data GeoCoordinates = GeoCoordinates+    { geoLongitude :: Double+    , geoLatitude :: Double+    } deriving (Show, Eq)++instance RedisResult GeoCoordinates where+    decode (MultiBulk (Just [lon, lat])) =+        GeoCoordinates <$> decode lon <*> decode lat+    decode r = Left r++data GeoLocation = GeoLocation+    { geoLocationMember :: ByteString+    , geoLocationDist :: Maybe Double+    , geoLocationHash :: Maybe Integer+    , geoLocationCoordinates :: Maybe GeoCoordinates+    } deriving (Show, Eq)++instance RedisResult GeoLocation where+    decode r@(Bulk (Just _)) =+        GeoLocation <$> decode r <*> pure Nothing <*> pure Nothing <*> pure Nothing+    decode r@(SingleLine _) =+        GeoLocation <$> decode r <*> pure Nothing <*> pure Nothing <*> pure Nothing+    decode (MultiBulk (Just (memberReply:details))) = do+        geoLocationMember <- decode memberReply+        (geoLocationDist, geoLocationHash, geoLocationCoordinates) <- decodeGeoLocationDetails details+        pure GeoLocation {..}+      where+        decodeGeoLocationDetails :: [Reply] -> Either Reply (Maybe Double, Maybe Integer, Maybe GeoCoordinates)+        decodeGeoLocationDetails = go Nothing Nothing Nothing++        go md mh mc [] = Right (md, mh, mc)+        go md mh mc (x:xs) = case x of+            MultiBulk _ -> do+                coord <- decode x+                go md mh (Just coord) xs+            Integer _ -> do+                hashValue <- decode x+                go md (Just hashValue) mc xs+            _ -> do+                dist <- decode x+                go (Just dist) mh mc xs+    decode r = Left r++data GeoSearchFrom+    = GeoSearchFromMember ByteString+    | GeoSearchFromLonLat Double Double+    deriving (Show, Eq)++data GeoSearchBy+    = GeoSearchByRadius Double GeoUnit+    | GeoSearchByBox Double Double GeoUnit+    deriving (Show, Eq)++data GeoSearchOpts = GeoSearchOpts+    { geoSearchWithCoord :: Bool+    , geoSearchWithDist :: Bool+    , geoSearchWithHash :: Bool+    , geoSearchCount :: Maybe Integer+    , geoSearchCountAny :: Bool+    , geoSearchOrder :: Maybe GeoOrder+    } deriving (Show, Eq)++defaultGeoSearchOpts :: GeoSearchOpts+defaultGeoSearchOpts = GeoSearchOpts+    { geoSearchWithCoord = False+    , geoSearchWithDist = False+    , geoSearchWithHash = False+    , geoSearchCount = Nothing+    , geoSearchCountAny = False+    , geoSearchOrder = Nothing+    }++data GeoSearchStoreOpts = GeoSearchStoreOpts+    { geoSearchStoreCount :: Maybe Integer+    , geoSearchStoreCountAny :: Bool+    , geoSearchStoreOrder :: Maybe GeoOrder+    , geoSearchStoreStoredist :: Bool+    } deriving (Show, Eq)++defaultGeoSearchStoreOpts :: GeoSearchStoreOpts+defaultGeoSearchStoreOpts = GeoSearchStoreOpts+    { geoSearchStoreCount = Nothing+    , geoSearchStoreCountAny = False+    , geoSearchStoreOrder = Nothing+    , geoSearchStoreStoredist = False+    }++-- |Adds one or more members to a geospatial index (<https://redis.io/commands/geoadd>). The Redis command @GEOADD@ is split up into 'geoadd' and 'geoAddOpts'. Since Redis 3.2.0+data GeoAddOpts = GeoAddOpts+    { geoAddCondition :: Maybe Condition+    , geoAddChange :: Bool+    {- ^ Modify the return value from the number of new elements added, to the number of elements changed.++    Since Redis 6.2.0+    -}+    } deriving (Show, Eq)++-- |Redis default 'GeoAddOpts'. Equivalent to omitting all optional parameters.+defaultGeoAddOpts :: GeoAddOpts+defaultGeoAddOpts = GeoAddOpts+    { geoAddCondition = Nothing+    , geoAddChange = False+    }++-- |Adds one or more members to a geospatial index (<https://redis.io/commands/geoadd>).+-- The Redis command @GEOADD@ is split up into 'geoadd' and 'geoAddOpts'.+--+-- Note: there is no @geodel@ command because you can use 'zrem' to remove elements.+-- The Geo index structure is just a sorted set.+--+-- Since Redis 3.2.0+--+-- Redis tags: write, geo, slow+geoadd+    :: (RedisCtx m f)+    => ByteString+    -> [(Double, Double, ByteString)]+    -> m (f Integer)+geoadd key values = geoaddOpts key values defaultGeoAddOpts++-- |Adds one or more members to a geospatial index (<https://redis.io/commands/geoadd>).+-- The Redis command @GEOADD@ is split up into 'geoadd' and 'geoAddOpts'.+--+-- Since Redis 6.2.0+geoaddOpts+    :: (RedisCtx m f)+    => ByteString+    -> [(Double, Double, ByteString)]+    -> GeoAddOpts+    -> m (f Integer)+geoaddOpts key values GeoAddOpts{..} =+    sendRequest $ ["GEOADD", key] ++ conditionArg ++ changeArg ++ concatMap encodeGeoValue values+  where+    conditionArg = foldMap (\condition -> [encode condition]) geoAddCondition+    changeArg = ["CH" | geoAddChange]+    encodeGeoValue (lon, lat, member) = [encode lon, encode lat, member]++-- |Returns the distance between two members of a geospatial index (<https://redis.io/commands/geodist>). Since Redis 3.2.0+--+-- Redis tags: read, geo, slow+geodist+    :: (RedisCtx m f)+    => ByteString+    -> ByteString+    -> ByteString+    -> Maybe GeoUnit+    -> m (f (Maybe Double))+geodist key member1 member2 munit =+    sendRequest $ ["GEODIST", key, member1, member2] ++ maybeToList (encode <$> munit)++-- |Returns the longitude and latitude of members from a geospatial index (<https://redis.io/commands/geopos>). Since Redis 3.2.0+--+-- ACL categories: @read, @geo, @slow.+geopos+    :: (RedisCtx m f)+    => ByteString+    -> [ByteString]+    -> m (f [Maybe GeoCoordinates])+geopos key members = sendRequest $ ["GEOPOS", key] ++ members++-- |Queries a geospatial index for members inside an area of a box or a circle (<https://redis.io/commands/geosearch>). Since Redis 6.2.0+--+-- $O(N+\log(M))$ where N is the number of elements in the grid-aligned bounding box area around the shape provided as the filter and M is the number of items inside the shape+--+-- ACL: @read, @geo, @slow+--+-- Since: Redis 6.2.0+geoSearch+    :: (RedisCtx m f)+    => ByteString+    -> GeoSearchFrom+    -> GeoSearchBy+    -> GeoSearchOpts+    -> m (f [GeoLocation])+geoSearch key from by opts =+    sendRequest $ ["GEOSEARCH", key] ++ geoSearchFromArgs from ++ geoSearchByArgs by ++ geoSearchOptsArgs opts++-- |Queries a geospatial index for members inside an area of a box or a circle, optionally stores the result (<https://redis.io/commands/geosearchstore>). Since Redis 6.2.0+geoSearchStore+    :: (RedisCtx m f)+    => ByteString+    -> ByteString+    -> GeoSearchFrom+    -> GeoSearchBy+    -> GeoSearchStoreOpts+    -> m (f Integer)+geoSearchStore destination source from by opts =+    sendRequest $ ["GEOSEARCHSTORE", destination, source] ++ geoSearchFromArgs from ++ geoSearchByArgs by ++ geoSearchStoreOptsArgs opts++geoSearchFromArgs :: GeoSearchFrom -> [ByteString]+geoSearchFromArgs (GeoSearchFromMember member) = ["FROMMEMBER", member]+geoSearchFromArgs (GeoSearchFromLonLat lon lat) = ["FROMLONLAT", encode lon, encode lat]++geoSearchByArgs :: GeoSearchBy -> [ByteString]+geoSearchByArgs (GeoSearchByRadius radius unit) = ["BYRADIUS", encode radius, encode unit]+geoSearchByArgs (GeoSearchByBox width height unit) = ["BYBOX", encode width, encode height, encode unit]++geoSearchOptsArgs :: GeoSearchOpts -> [ByteString]+geoSearchOptsArgs GeoSearchOpts{..} =+    orderArg ++ countArg ++ withCoord ++ withDist ++ withHash+  where+    orderArg = maybe [] (\order -> [encode order]) geoSearchOrder+    countArg = maybe [] (\count -> ["COUNT", encode count] ++ ["ANY" | geoSearchCountAny]) geoSearchCount+    withCoord = ["WITHCOORD" | geoSearchWithCoord]+    withDist = ["WITHDIST" | geoSearchWithDist]+    withHash = ["WITHHASH" | geoSearchWithHash]++geoSearchStoreOptsArgs :: GeoSearchStoreOpts -> [ByteString]+geoSearchStoreOptsArgs GeoSearchStoreOpts{..} =+    orderArg ++ countArg ++ storeDistArg+  where+    orderArg = maybe [] (\order -> [encode order]) geoSearchStoreOrder+    countArg = maybe [] (\count -> ["COUNT", encode count] ++ ["ANY" | geoSearchStoreCountAny]) geoSearchStoreCount+    storeDistArg = ["STOREDIST" | geoSearchStoreStoredist]++-- | Data structure that is returned as a result of  'xinfoConsumers'+data XInfoConsumersResponse = XInfoConsumersResponse+    { xinfoConsumerName :: ByteString -- ^ The name of the consumer.+    , xinfoConsumerNumPendingMessages :: Integer -- ^ The number of entries in the PEL (pending elemeent list): pending messages for the consumer, which are messages that were delivered but are yet to be acknowledged+    , xinfoConsumerIdleTime :: Integer -- ^ The number of milliseconds that have passed since the consumer's last attempted interaction (Examples: 'xreadGroup', 'xclam', 'xautoclaim')+    , xinfoConsumerInactive :: Maybe Integer+    {- ^ The number of milliseconds that have passed since the consumer's last successful interaction (Examples: 'xreadGroup' that actually read some entries into the PEL, 'xclaim'/'xautoclaim' that actually claimed some entries)++    @since Redis 7.0: always @Nothing@ for previous versions.+    -}+    } deriving (Show, Eq)++instance RedisResult XInfoConsumersResponse where+    decode = decodeRedis6 <> decodeRedis7+      where decodeRedis6 (MultiBulk (Just [+                Bulk (Just "name"),+                Bulk (Just xinfoConsumerName),+                Bulk (Just "pending"),+                Integer xinfoConsumerNumPendingMessages,+                Bulk (Just "idle"),+                Integer xinfoConsumerIdleTime])) = Right XInfoConsumersResponse{xinfoConsumerInactive = Nothing, ..}+            decodeRedis6 a = Left a++            decodeRedis7 (MultiBulk (Just [+                Bulk (Just "name"),+                Bulk (Just xinfoConsumerName),+                Bulk (Just "pending"),+                Integer xinfoConsumerNumPendingMessages,+                Bulk (Just "idle"),+                Integer xinfoConsumerIdleTime,+                Bulk (Just "inactive"),+                Integer xinfoConsumerInactive])) = Right XInfoConsumersResponse{xinfoConsumerInactive = Just xinfoConsumerInactive, ..}+            decodeRedis7 a = Left a++-- | /O(1)/+-- Returns information about the list of the consumers beloging to the consumer group.+--+-- Available since Redis 5.0.0+--+-- Wrapper over @XINFO CONSUMERS \<stream name\> \<group name\>@+xinfoConsumers+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name.+    -> ByteString -- ^ Group name.+    -> m (f [XInfoConsumersResponse])+xinfoConsumers stream group = sendRequest $ ["XINFO", "CONSUMERS", stream, group]++-- | Result of the 'xinfoGroups' call.+data XInfoGroupsResponse = XInfoGroupsResponse+    { xinfoGroupsGroupName :: ByteString -- ^ Name of the consumer group.+    , xinfoGroupsNumConsumers :: Integer -- ^ The number of consumers in the group.+    , xinfoGroupsNumPendingMessages :: Integer -- ^ The length of the group's pending entries list (PEL), which are messages that were delivered but are yet to be acknowledged.+    , xinfoGroupsLastDeliveredMessageId :: ByteString -- ^ The ID of the last entry delivered to the group's consumers.+    , xinfoGroupsEntriesRead :: Maybe Integer+    {- ^ The logical "read counter" of the last entry delivered to group's consumers.++    Since Redis 7.0: always @Nothing@ on the previous versions.+    -}+    , xinfoGroupsLag :: Maybe Integer+    {- ^ the number of entries in the stream that are still waiting to be delivered to the group's consumers, or a Nothing when that number can't be determined.++    Since Redis 7.0: always @Nothing@ on the previous versions.+    -}+    } deriving (Show, Eq)++instance RedisResult XInfoGroupsResponse where+    decode = decodeRedis6 <> decodeRedis7+      where decodeRedis6 (MultiBulk (Just [+              Bulk (Just "name"),      Bulk (Just xinfoGroupsGroupName),+              Bulk (Just "consumers"), Integer xinfoGroupsNumConsumers,+              Bulk (Just "pending"),   Integer xinfoGroupsNumPendingMessages,+              Bulk (Just "last-delivered-id"),+              Bulk (Just xinfoGroupsLastDeliveredMessageId)])) =+                Right XInfoGroupsResponse{+                      xinfoGroupsEntriesRead = Nothing+                    , xinfoGroupsLag         = Nothing+                    , ..}+            decodeRedis6 a = Left a++            decodeRedis7 (MultiBulk (Just [+              Bulk (Just "name"),              Bulk (Just xinfoGroupsGroupName),+              Bulk (Just "consumers"),         Integer xinfoGroupsNumConsumers,+              Bulk (Just "pending"),           Integer xinfoGroupsNumPendingMessages,+              Bulk (Just "last-delivered-id"), Bulk (Just xinfoGroupsLastDeliveredMessageId),+              Bulk (Just "entries-read"),      Integer xinfoGroupsEntriesRead,+              Bulk (Just "lag"),               Integer xinfoGroupsLag])) =+                Right XInfoGroupsResponse{+                      xinfoGroupsEntriesRead = Just xinfoGroupsEntriesRead+                    , xinfoGroupsLag         = Just xinfoGroupsLag+                    , ..}+            decodeRedis7 a = Left a++-- | /O(1)/ Returns information about the groups.+--+-- Available since: Redis 5.0.0+--+-- Wrapper around @XINFO GROUPS \<stream name\>@ call.+xinfoGroups+    :: (RedisCtx m f)+    => ByteString -- ^ Stream name.+    -> m (f [XInfoGroupsResponse])+xinfoGroups stream = sendRequest ["XINFO", "GROUPS", stream]++data XInfoStreamResponse+    = XInfoStreamResponse+    { xinfoStreamLength :: Integer -- ^ The number of entries in the stream.+    , xinfoStreamRadixTreeKeys :: Integer -- ^ The number of keys in the underlying radix data structure.+    , xinfoStreamRadixTreeNodes :: Integer -- ^ The number of nodes in the underlying radix data structure.+    , xinfoMaxDeletedEntryId :: Maybe ByteString+    {- ^ The maximal entry ID that was deleted from the stream++    Since Redis 7.0: always returns @Nothing@ on the previous versions.+    -}+    , xinfoEntriesAdded :: Maybe Integer+    {- ^ The count of all entries added to the stream during its lifetime++    Since Redis 7.0: always returns @Nothing@ on the previous versions.+    -}+    , xinfoRecordedFirstEntryId :: Maybe ByteString+    {- ^ ID of first recorded entry.++    Since Redis 7.0: always returns @Nothing@ on the previous versions.+    -}+    , xinfoStreamNumGroups :: Integer -- ^ The number of consumer groups defined for the stream.+    , xinfoStreamLastEntryId :: ByteString -- ^ ID of the last entry in the stream.+    , xinfoStreamFirstEntry :: StreamsRecord -- ^ ID and field-value tuples of the first entry in the stream.+    , xinfoStreamLastEntry :: StreamsRecord -- ^ ID and field-value tuples of the last entry in the stream.+    }+    | XInfoStreamEmptyResponse+    { xinfoStreamLength :: Integer -- ^ The number of entries in the stream.+    , xinfoStreamRadixTreeKeys :: Integer -- ^ The number of keys in the underlying radix data structure.+    , xinfoStreamRadixTreeNodes :: Integer -- ^ The number of nodes in the underlying radix data structure.+    , xinfoMaxDeletedEntryId :: Maybe ByteString+    {- ^ The maximal entry ID that was deleted from the stream.++    Since Redis 7.0: always returns @Nothing@ on the previous versions.+    -}+    , xinfoEntriesAdded :: Maybe Integer+    {- ^ The count of all entries added to the stream during its lifetime++    Since Redis 7.0: always returns @Nothing@ on the previous versions.+    -}+    , xinfoRecordedFirstEntryId :: Maybe ByteString+    {- ^ ID of first recorded entry.++    Since Redis 7.0: always returns @Nothing@ on the previous versions.+    -}+    , xinfoStreamNumGroups :: Integer -- ^ The number of consumer groups defined for the stream.+    , xinfoStreamLastEntryId :: ByteString -- ^ The ID of the last entry in the stream.+    }+    deriving (Show, Eq)++instance RedisResult XInfoStreamResponse where+    decode = decodeRedis5 <> decodeRedis6 <> decodeRedis7+        where+            decodeRedis5 (MultiBulk (Just [+                 Bulk (Just "length"),            Integer xinfoStreamLength,+                 Bulk (Just "radix-tree-keys"),   Integer xinfoStreamRadixTreeKeys,+                 Bulk (Just "radix-tree-nodes"),  Integer xinfoStreamRadixTreeNodes,+                 Bulk (Just "groups"),            Integer xinfoStreamNumGroups,+                 Bulk (Just "last-generated-id"), Bulk (Just xinfoStreamLastEntryId),+                 Bulk (Just "first-entry"),       Bulk Nothing ,+                 Bulk (Just "last-entry"),        Bulk Nothing ])) = do+                    return XInfoStreamEmptyResponse{+                          xinfoMaxDeletedEntryId    = Nothing+                        , xinfoEntriesAdded         = Nothing+                        , xinfoRecordedFirstEntryId = Nothing+                        , ..}+            decodeRedis5 (MultiBulk (Just [+                Bulk (Just "length"),            Integer xinfoStreamLength,+                Bulk (Just "radix-tree-keys"),   Integer xinfoStreamRadixTreeKeys,+                Bulk (Just "radix-tree-nodes"),  Integer xinfoStreamRadixTreeNodes,+                Bulk (Just "groups"),            Integer xinfoStreamNumGroups,+                Bulk (Just "last-generated-id"), Bulk (Just xinfoStreamLastEntryId),+                Bulk (Just "first-entry"),       rawFirstEntry ,+                Bulk (Just "last-entry"),        rawLastEntry ])) = do+                    xinfoStreamFirstEntry <- decode rawFirstEntry+                    xinfoStreamLastEntry  <- decode rawLastEntry+                    return XInfoStreamResponse{+                          xinfoMaxDeletedEntryId    = Nothing+                        , xinfoEntriesAdded         = Nothing+                        , xinfoRecordedFirstEntryId = Nothing+                        , ..}+            decodeRedis5 a = Left a++            decodeRedis6 (MultiBulk (Just [+                Bulk (Just "length"),            Integer xinfoStreamLength,+                Bulk (Just "radix-tree-keys"),   Integer xinfoStreamRadixTreeKeys,+                Bulk (Just "radix-tree-nodes"),  Integer xinfoStreamRadixTreeNodes,+                Bulk (Just "last-generated-id"), Bulk (Just xinfoStreamLastEntryId),+                Bulk (Just "groups"),            Integer xinfoStreamNumGroups,+                Bulk (Just "first-entry"),       Bulk Nothing ,+                Bulk (Just "last-entry"),        Bulk Nothing ])) = do+                    return XInfoStreamEmptyResponse{+                          xinfoMaxDeletedEntryId    = Nothing+                        , xinfoEntriesAdded         = Nothing+                        , xinfoRecordedFirstEntryId = Nothing+                        , ..}+            decodeRedis6 (MultiBulk (Just [+                Bulk (Just "length"),            Integer xinfoStreamLength,+                Bulk (Just "radix-tree-keys"),   Integer xinfoStreamRadixTreeKeys,+                Bulk (Just "radix-tree-nodes"),  Integer xinfoStreamRadixTreeNodes,+                Bulk (Just "last-generated-id"), Bulk (Just xinfoStreamLastEntryId),+                Bulk (Just "groups"),            Integer xinfoStreamNumGroups,+                Bulk (Just "first-entry"),       rawFirstEntry ,+                Bulk (Just "last-entry"),        rawLastEntry ])) = do+                    xinfoStreamFirstEntry <- decode rawFirstEntry+                    xinfoStreamLastEntry  <- decode rawLastEntry+                    return XInfoStreamResponse{+                          xinfoMaxDeletedEntryId    = Nothing+                        , xinfoEntriesAdded         = Nothing+                        , xinfoRecordedFirstEntryId = Nothing+                        , ..}+            decodeRedis6 a = Left a++            decodeRedis7 (MultiBulk (Just [+                Bulk (Just "length"),                  Integer xinfoStreamLength,+                Bulk (Just "radix-tree-keys"),         Integer xinfoStreamRadixTreeKeys,+                Bulk (Just "radix-tree-nodes"),        Integer xinfoStreamRadixTreeNodes,+                Bulk (Just "last-generated-id"),       Bulk (Just xinfoStreamLastEntryId),+                Bulk (Just "max-deleted-entry-id"),    Bulk (Just xinfoMaxDeletedEntryId),+                Bulk (Just "entries-added"),           Integer xinfoEntriesAdded,+                Bulk (Just "recorded-first-entry-id"), Bulk (Just xinfoRecordedFirstEntryId),+                Bulk (Just "groups"),                  Integer xinfoStreamNumGroups,+                Bulk (Just "first-entry"),             Bulk Nothing ,+                Bulk (Just "last-entry"),              Bulk Nothing ])) = do+                    return XInfoStreamEmptyResponse{+                          xinfoMaxDeletedEntryId    = Just xinfoMaxDeletedEntryId+                        , xinfoEntriesAdded         = Just xinfoEntriesAdded+                        , xinfoRecordedFirstEntryId = Just xinfoRecordedFirstEntryId+                        , ..}++            decodeRedis7 (MultiBulk (Just [+                Bulk (Just "length"),                  Integer xinfoStreamLength,+                Bulk (Just "radix-tree-keys"),         Integer xinfoStreamRadixTreeKeys,+                Bulk (Just "radix-tree-nodes"),        Integer xinfoStreamRadixTreeNodes,+                Bulk (Just "last-generated-id"),       Bulk (Just xinfoStreamLastEntryId),+                Bulk (Just "max-deleted-entry-id"),    Bulk (Just xinfoMaxDeletedEntryId),+                Bulk (Just "entries-added"),           Integer xinfoEntriesAdded,+                Bulk (Just "recorded-first-entry-id"), Bulk (Just xinfoRecordedFirstEntryId),+                Bulk (Just "groups"),                  Integer xinfoStreamNumGroups,+                Bulk (Just "first-entry"),          rawFirstEntry ,+                Bulk (Just "last-entry"),           rawLastEntry ])) = do+                    xinfoStreamFirstEntry <- decode rawFirstEntry+                    xinfoStreamLastEntry  <- decode rawLastEntry+                    return XInfoStreamResponse{+                          xinfoMaxDeletedEntryId    = Just xinfoMaxDeletedEntryId+                        , xinfoEntriesAdded         = Just xinfoEntriesAdded+                        , xinfoRecordedFirstEntryId = Just xinfoRecordedFirstEntryId+                        , ..}+            decodeRedis7 a = Left a++-- | Get info about a stream. The Redis command @XINFO@ is split into 'xinfoConsumers', 'xinfoGroups', and 'xinfoStream'.+-- Since Redis 5.0.0+xinfoStream+    :: (RedisCtx m f)+    => ByteString -- ^ stream+    -> m (f XInfoStreamResponse)+xinfoStream stream = sendRequest ["XINFO", "STREAM", stream]++-- | Delete messages from a stream.+-- Since Redis 5.0.0+xdel+    :: (RedisCtx m f)+    => ByteString -- ^ stream+    -> NonEmpty ByteString -- ^ message IDs+    -> m (f Integer)+xdel stream (messageId:|messageIds) = sendRequest ("XDEL":stream:messageId: messageIds)++-- |Set the upper bound for number of messages in a stream. Since Redis 5.0.0+xtrim+    :: (RedisCtx m f)+    => ByteString -- ^ stream+    -> TrimOpts+    -> m (f Integer)+xtrim stream opts = sendRequest ("XTRIM":stream:internalTrimArgToList opts)++-- |Constructor for `inf` Redis argument values+inf :: RealFloat a => a+inf = 1 / 0++-- | Additional parameters for the auth command.+data AuthOpts = AuthOpts+  { authOptsUsername+    :: Maybe ByteString+    {- ^ Username.++      Since Redis 6.0: fails on earlier+     -}+  }+  deriving Show++-- | Default options for AuthOpts+--+-- >>> defaultAuthOpts+-- AuthOpts {authOptsUsername = Nothing}+defaultAuthOpts :: AuthOpts+defaultAuthOpts = AuthOpts+  { authOptsUsername = Nothing+  }++-- | /O(N)/ where N is the number of passwords defined for the user.+--+-- Authenticates client to the server.+auth+    :: RedisCtx m f+    => ByteString -- ^ Password.+    -> m (f Status)+auth password = authOpts password defaultAuthOpts++-- | /O(N)/ where N is the number of passwords defined for the user.+--+-- Authenticates client to the server.+--+-- This method allows passing additional options.+authOpts+    :: RedisCtx m f+    => ByteString -- ^ Password.+    -> AuthOpts -- ^ Additional options.+    -> m (f Status)+authOpts password AuthOpts{..} = sendRequest $+  ["AUTH"] <> maybe [] (:[]) authOptsUsername <> [password]++-- |Change the selected database for the current connection (<http://redis.io/commands/select>). Since Redis 1.0.0+select+    :: RedisCtx m f+    => Integer -- ^ index+    -> m (f Status)+select ix = sendRequest ["SELECT", encode ix]++-- |Ping the server (<http://redis.io/commands/ping>). Since Redis 1.0.0+ping+    :: (RedisCtx m f)+    => m (f Status)+ping  = sendRequest (["PING"] )++-- https://redis.io/commands/cluster-info/+data ClusterInfoResponse = ClusterInfoResponse+  { clusterInfoResponseState :: ClusterInfoResponseState,+    clusterInfoResponseSlotsAssigned :: Integer,+    clusterInfoResponseSlotsOK :: Integer,+    clusterInfoResponseSlotsPfail :: Integer,+    clusterInfoResponseSlotsFail :: Integer,+    clusterInfoResponseKnownNodes :: Integer,+    clusterInfoResponseSize :: Integer,+    clusterInfoResponseCurrentEpoch :: Integer,+    clusterInfoResponseMyEpoch :: Integer,+    clusterInfoResponseStatsMessagesSent :: Integer,+    clusterInfoResponseStatsMessagesReceived :: Integer,+    clusterInfoResponseTotalLinksBufferLimitExceeded :: Integer,+    clusterInfoResponseStatsMessagesPingSent :: Maybe Integer,+    clusterInfoResponseStatsMessagesPingReceived :: Maybe Integer,+    clusterInfoResponseStatsMessagesPongSent :: Maybe Integer,+    clusterInfoResponseStatsMessagesPongReceived :: Maybe Integer,+    clusterInfoResponseStatsMessagesMeetSent :: Maybe Integer,+    clusterInfoResponseStatsMessagesMeetReceived :: Maybe Integer,+    clusterInfoResponseStatsMessagesFailSent :: Maybe Integer,+    clusterInfoResponseStatsMessagesFailReceived :: Maybe Integer,+    clusterInfoResponseStatsMessagesPublishSent :: Maybe Integer,+    clusterInfoResponseStatsMessagesPublishReceived :: Maybe Integer,+    clusterInfoResponseStatsMessagesAuthReqSent :: Maybe Integer,+    clusterInfoResponseStatsMessagesAuthReqReceived :: Maybe Integer,+    clusterInfoResponseStatsMessagesAuthAckSent :: Maybe Integer,+    clusterInfoResponseStatsMessagesAuthAckReceived :: Maybe Integer,+    clusterInfoResponseStatsMessagesUpdateSent :: Maybe Integer,+    clusterInfoResponseStatsMessagesUpdateReceived :: Maybe Integer,+    clusterInfoResponseStatsMessagesMfstartSent :: Maybe Integer,+    clusterInfoResponseStatsMessagesMfstartReceived :: Maybe Integer,+    clusterInfoResponseStatsMessagesModuleSent :: Maybe Integer,+    clusterInfoResponseStatsMessagesModuleReceived :: Maybe Integer,+    clusterInfoResponseStatsMessagesPublishshardSent :: Maybe Integer,+    clusterInfoResponseStatsMessagesPublishshardReceived :: Maybe Integer+  }+  deriving (Show, Eq)++data ClusterInfoResponseState+  = OK+  | Down+  deriving (Show, Eq)++defClusterInfoResponse :: ClusterInfoResponse+defClusterInfoResponse =+  ClusterInfoResponse+    { clusterInfoResponseState = Down,+      clusterInfoResponseSlotsAssigned = 0,+      clusterInfoResponseSlotsOK = 0,+      clusterInfoResponseSlotsPfail = 0,+      clusterInfoResponseSlotsFail = 0,+      clusterInfoResponseKnownNodes = 0,+      clusterInfoResponseSize = 0,+      clusterInfoResponseCurrentEpoch = 0,+      clusterInfoResponseMyEpoch = 0,+      clusterInfoResponseStatsMessagesSent = 0,+      clusterInfoResponseStatsMessagesReceived = 0,+      clusterInfoResponseTotalLinksBufferLimitExceeded = 0,+      clusterInfoResponseStatsMessagesPingSent = Nothing,+      clusterInfoResponseStatsMessagesPingReceived = Nothing,+      clusterInfoResponseStatsMessagesPongSent = Nothing,+      clusterInfoResponseStatsMessagesPongReceived = Nothing,+      clusterInfoResponseStatsMessagesMeetSent = Nothing,+      clusterInfoResponseStatsMessagesMeetReceived = Nothing,+      clusterInfoResponseStatsMessagesFailSent = Nothing,+      clusterInfoResponseStatsMessagesFailReceived = Nothing,+      clusterInfoResponseStatsMessagesPublishSent = Nothing,+      clusterInfoResponseStatsMessagesPublishReceived = Nothing,+      clusterInfoResponseStatsMessagesAuthReqSent = Nothing,+      clusterInfoResponseStatsMessagesAuthReqReceived = Nothing,+      clusterInfoResponseStatsMessagesAuthAckSent = Nothing,+      clusterInfoResponseStatsMessagesAuthAckReceived = Nothing,+      clusterInfoResponseStatsMessagesUpdateSent = Nothing,+      clusterInfoResponseStatsMessagesUpdateReceived = Nothing,+      clusterInfoResponseStatsMessagesMfstartSent = Nothing,+      clusterInfoResponseStatsMessagesMfstartReceived = Nothing,+      clusterInfoResponseStatsMessagesModuleSent = Nothing,+      clusterInfoResponseStatsMessagesModuleReceived = Nothing,+      clusterInfoResponseStatsMessagesPublishshardSent = Nothing,+      clusterInfoResponseStatsMessagesPublishshardReceived = Nothing+    }++parseClusterInfoResponse :: [[ByteString]] -> ClusterInfoResponse -> Maybe ClusterInfoResponse+parseClusterInfoResponse fields resp = case fields of+  [] -> pure resp+  (["cluster_state", state] : fs) -> parseState state >>= \s -> parseClusterInfoResponse fs $ resp {clusterInfoResponseState = s}+  (["cluster_slots_assigned", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseSlotsAssigned = v}+  (["cluster_slots_ok", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseSlotsOK = v}+  (["cluster_slots_pfail", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseSlotsPfail = v}+  (["cluster_slots_fail", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseSlotsFail = v}+  (["cluster_known_nodes", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseKnownNodes = v}+  (["cluster_size", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseSize = v}+  (["cluster_current_epoch", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseCurrentEpoch = v}+  (["cluster_my_epoch", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseMyEpoch = v}+  (["cluster_stats_messages_sent", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesSent = v}+  (["cluster_stats_messages_received", value] : fs) -> parseInteger value >>= \v -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesReceived = v}+  (["total_cluster_links_buffer_limit_exceeded", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseTotalLinksBufferLimitExceeded = fromMaybe 0 $ parseInteger value} -- this value should be mandatory according to the spec, but isn't necessarily set in Redis 6+  (["cluster_stats_messages_ping_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPingSent = parseInteger value}+  (["cluster_stats_messages_ping_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPingReceived = parseInteger value}+  (["cluster_stats_messages_pong_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPongSent = parseInteger value}+  (["cluster_stats_messages_pong_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPongReceived = parseInteger value}+  (["cluster_stats_messages_meet_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesMeetSent = parseInteger value}+  (["cluster_stats_messages_meet_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesMeetReceived = parseInteger value}+  (["cluster_stats_messages_fail_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesFailSent = parseInteger value}+  (["cluster_stats_messages_fail_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesFailReceived = parseInteger value}+  (["cluster_stats_messages_publish_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPublishSent = parseInteger value}+  (["cluster_stats_messages_publish_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPublishReceived = parseInteger value}+  (["cluster_stats_messages_auth_req_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesAuthReqSent = parseInteger value}+  (["cluster_stats_messages_auth_req_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesAuthReqReceived = parseInteger value}+  (["cluster_stats_messages_auth_ack_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesAuthAckSent = parseInteger value}+  (["cluster_stats_messages_auth_ack_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesAuthAckReceived = parseInteger value}+  (["cluster_stats_messages_update_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesUpdateSent = parseInteger value}+  (["cluster_stats_messages_update_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesUpdateReceived = parseInteger value}+  (["cluster_stats_messages_mfstart_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesMfstartSent = parseInteger value}+  (["cluster_stats_messages_mfstart_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesMfstartReceived = parseInteger value}+  (["cluster_stats_messages_module_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesModuleSent = parseInteger value}+  (["cluster_stats_messages_module_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesModuleReceived = parseInteger value}+  (["cluster_stats_messages_publishshard_sent", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPublishshardSent = parseInteger value}+  (["cluster_stats_messages_publishshard_received", value] : fs) -> parseClusterInfoResponse fs $ resp {clusterInfoResponseStatsMessagesPublishshardReceived = parseInteger value}+  (_ : fs) -> parseClusterInfoResponse fs resp+  where+    parseState bs = case bs of+      "ok" -> Just OK+      "fail" -> Just Down+      _ -> Nothing+    parseInteger = fmap fst . Char8.readInteger++instance RedisResult ClusterInfoResponse where+  decode r@(Bulk (Just bulkData)) =+    maybe (Left r) Right+      . flip parseClusterInfoResponse defClusterInfoResponse+      . map (Char8.split ':' . Char8.takeWhile (/= '\r'))+      $ Char8.lines bulkData+  decode r = Left r++clusterInfo :: RedisCtx m f => m (f ClusterInfoResponse)+clusterInfo = sendRequest ["CLUSTER", "INFO"]++data ClusterNodesResponse = ClusterNodesResponse+    { clusterNodesResponseEntries :: [ClusterNodesResponseEntry]+    } deriving (Show, Eq)++data ClusterNodesResponseEntry = ClusterNodesResponseEntry { clusterNodesResponseNodeId :: ByteString+    , clusterNodesResponseNodeIp :: ByteString+    , clusterNodesResponseNodePort :: Integer+    , clusterNodesResponseNodeFlags :: [ByteString]+    , clusterNodesResponseMasterId :: Maybe ByteString+    , clusterNodesResponsePingSent :: Integer+    , clusterNodesResponsePongReceived :: Integer+    , clusterNodesResponseConfigEpoch :: Integer+    , clusterNodesResponseLinkState :: ByteString+    , clusterNodesResponseSlots :: [ClusterNodesResponseSlotSpec]+    } deriving (Show, Eq)++data ClusterNodesResponseSlotSpec+    = ClusterNodesResponseSingleSlot Integer+    | ClusterNodesResponseSlotRange Integer Integer+    | ClusterNodesResponseSlotImporting Integer ByteString+    | ClusterNodesResponseSlotMigrating Integer ByteString deriving (Show, Eq)+++instance RedisResult ClusterNodesResponse where+    decode r@(Bulk (Just bulkData)) = maybe (Left r) Right $ do+        infos <- mapM parseNodeInfo $ Char8.lines bulkData+        return $ ClusterNodesResponse infos where+            parseNodeInfo :: ByteString -> Maybe ClusterNodesResponseEntry+            parseNodeInfo line = case Char8.words line of+              (nodeId : hostNamePort : flags : masterNodeId : pingSent : pongRecv : epoch : linkState : slots) ->+                case Char8.split ':' hostNamePort of+                  [hostName, port] -> ClusterNodesResponseEntry <$> pure nodeId+                                               <*> pure hostName+                                               <*> readInteger port+                                               <*> pure (Char8.split ',' flags)+                                               <*> pure (readMasterNodeId masterNodeId)+                                               <*> readInteger pingSent+                                               <*> readInteger pongRecv+                                               <*> readInteger epoch+                                               <*> pure linkState+                                               <*> (pure . catMaybes $ map readNodeSlot slots)+                  _ -> Nothing+              _ -> Nothing+            readInteger :: ByteString -> Maybe Integer+            readInteger = fmap fst . Char8.readInteger++            readMasterNodeId :: ByteString -> Maybe ByteString+            readMasterNodeId "-"    = Nothing+            readMasterNodeId nodeId = Just nodeId++            readNodeSlot :: ByteString -> Maybe ClusterNodesResponseSlotSpec+            readNodeSlot slotSpec = case '[' `Char8.elem` slotSpec of+                True -> readSlotImportMigrate slotSpec+                False -> case '-' `Char8.elem` slotSpec of+                    True -> readSlotRange slotSpec+                    False -> ClusterNodesResponseSingleSlot <$> readInteger slotSpec+            readSlotImportMigrate :: ByteString -> Maybe ClusterNodesResponseSlotSpec+            readSlotImportMigrate slotSpec = case BS.breakSubstring "->-" slotSpec of+                (_, "") -> case BS.breakSubstring "-<-" slotSpec of+                    (_, "") -> Nothing+                    (leftPart, rightPart) -> ClusterNodesResponseSlotImporting+                        <$> (readInteger $ Char8.drop 1 leftPart)+                        <*> (pure $ BS.take (BS.length rightPart - 1) rightPart)+                (leftPart, rightPart) -> ClusterNodesResponseSlotMigrating+                    <$> (readInteger $ Char8.drop 1 leftPart)+                    <*> (pure $ BS.take (BS.length rightPart - 1) rightPart)+            readSlotRange :: ByteString -> Maybe ClusterNodesResponseSlotSpec+            readSlotRange slotSpec = case BS.breakSubstring "-" slotSpec of+                (_, "") -> Nothing+                (leftPart, rightPart) -> ClusterNodesResponseSlotRange+                    <$> readInteger leftPart+                    <*> (readInteger $ BS.drop 1 rightPart)++    decode r = Left r++clusterNodes+    :: (RedisCtx m f)+    => m (f ClusterNodesResponse)+clusterNodes = sendRequest $ ["CLUSTER", "NODES"]++data ClusterSlotsResponse = ClusterSlotsResponse { clusterSlotsResponseEntries :: [ClusterSlotsResponseEntry] } deriving (Show)++data ClusterSlotsNode = ClusterSlotsNode+    { clusterSlotsNodeIP :: ByteString+    , clusterSlotsNodePort :: Int+    , clusterSlotsNodeID :: ByteString+    } deriving (Show)++data ClusterSlotsResponseEntry = ClusterSlotsResponseEntry+    { clusterSlotsResponseEntryStartSlot :: Int+    , clusterSlotsResponseEntryEndSlot :: Int+    , clusterSlotsResponseEntryMaster :: ClusterSlotsNode+    , clusterSlotsResponseEntryReplicas :: [ClusterSlotsNode]+    } deriving (Show)++instance RedisResult ClusterSlotsResponse where+    decode (MultiBulk (Just bulkData)) = do+        clusterSlotsResponseEntries <- mapM decode bulkData+        return ClusterSlotsResponse{..}+    decode a = Left a++instance RedisResult ClusterSlotsResponseEntry where+    decode (MultiBulk (Just+        ((Integer startSlot):(Integer endSlot):masterData:replicas))) = do+            clusterSlotsResponseEntryMaster <- decode masterData+            clusterSlotsResponseEntryReplicas <- mapM decode replicas+            let clusterSlotsResponseEntryStartSlot = fromInteger startSlot+            let clusterSlotsResponseEntryEndSlot = fromInteger endSlot+            return ClusterSlotsResponseEntry{..}+    decode a = Left a++instance RedisResult ClusterSlotsNode where+    decode (MultiBulk (Just ((Bulk (Just clusterSlotsNodeIP)):(Integer port):(Bulk (Just clusterSlotsNodeID)):_))) = Right ClusterSlotsNode{..}+        where clusterSlotsNodePort = fromInteger port+    decode a = Left a+++clusterSlots+    :: (RedisCtx m f)+    => m (f ClusterSlotsResponse)+clusterSlots = sendRequest $ ["CLUSTER", "SLOTS"]++clusterSetSlotImporting+    :: (RedisCtx m f)+    => Integer+    -> ByteString+    -> m (f Status)+clusterSetSlotImporting slot sourceNodeId = sendRequest $ ["CLUSTER", "SETSLOT", (encode slot), "IMPORTING", sourceNodeId]++clusterSetSlotMigrating+    :: (RedisCtx m f)+    => Integer+    -> ByteString+    -> m (f Status)+clusterSetSlotMigrating slot destinationNodeId = sendRequest $ ["CLUSTER", "SETSLOT", (encode slot), "MIGRATING", destinationNodeId]++clusterSetSlotStable+    :: (RedisCtx m f)+    => Integer+    -> m (f Status)+clusterSetSlotStable slot = sendRequest $ ["CLUSTER", "SETSLOT", "STABLE", (encode slot)]++clusterSetSlotNode+    :: (RedisCtx m f)+    => Integer+    -> ByteString+    -> m (f Status)+clusterSetSlotNode slot node = sendRequest ["CLUSTER", "SETSLOT", (encode slot), "NODE", node]++clusterGetKeysInSlot+    :: (RedisCtx m f)+    => Integer+    -> Integer+    -> m (f [ByteString])+clusterGetKeysInSlot slot count = sendRequest ["CLUSTER", "GETKEYSINSLOT", (encode slot), (encode count)]++command :: (RedisCtx m f) => m (f [CMD.CommandInfo])+command = sendRequest ["COMMAND"]+++data ExpireOpts+  = ExpireOptsTime Condition+  | ExpireOptsValue SizeCondition++instance RedisArg ExpireOpts where+  encode (ExpireOptsTime c)  = encode c+  encode (ExpireOptsValue c) = encode c++-- |Set the expiration for a key as a UNIX timestamp specified in milliseconds (<http://redis.io/commands/pexpireat>).+-- Since Redis 7.0+pexpireatOpts+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ millisecondsTimestamp+    -> ExpireOpts+    -> m (f Bool)+pexpireatOpts key millisecondsTimestamp opts =+  sendRequest ["PEXPIREAT", key, encode millisecondsTimestamp, encode opts]++expireOpts+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ seconds+    -> ExpireOpts+    -> m (f Bool)+expireOpts key seconds opts = sendRequest ["EXPIRE", key, encode seconds, encode opts]++-- | Set the expiration for a key as a UNIX timestamp (<http://redis.io/commands/expireat>).+-- Since Redis 1.2.0+expireatOpts+    :: (RedisCtx m f)+    => ByteString -- ^ key+    -> Integer -- ^ timestamp+    -> ExpireOpts+    -> m (f Bool)+expireatOpts key timestamp opts = sendRequest ["EXPIREAT", key, encode timestamp, encode opts]++data FlushOpts+  = FlushOptsSync+  | FlushOptsAsync++instance RedisArg FlushOpts where+  encode FlushOptsSync = "SYNC"+  encode FlushOptsAsync = "ASYNC"++-- |Remove all keys from the current database (<http://redis.io/commands/flushdb>).+-- Since Redis 6.2+flushdbOpts+    :: (RedisCtx m f)+    => FlushOpts+    -> m (f Status)+flushdbOpts opts = sendRequest ["FLUSHDB", encode opts]++-- |Remove all keys from the current database (<http://redis.io/commands/flushdb>).+-- Since Redis 6.2+flushallOpts+    :: (RedisCtx m f)+    => FlushOpts+    -> m (f Status)+flushallOpts opts = sendRequest ["FLUSHALL", encode opts]++data BitposType = Byte | Bit++instance RedisArg BitposType where+  encode Byte = "BYTE"+  encode Bit = "BIT"++data BitposOpts+  = BitposOptsStart Integer+  | BitposOptsStartEnd Integer Integer (Maybe BitposType)++bitposOpts+    :: (RedisCtx m f)+    => ByteString+    -> Integer+    -> BitposOpts+    -> m (f Integer)+bitposOpts key_ bit opts = sendRequest ("BITPOS": key_:encode bit: rest) where+  rest  = case opts of+    BitposOptsStart s -> [encode s]+    BitposOptsStartEnd start end bits ->+      [encode start, encode end] ++ [ encode bits_ | Just bits_ <- pure bits]
src/Database/Redis/Protocol.hs view
@@ -1,13 +1,22 @@+{-# 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-import Data.Attoparsec.ByteString (takeTill)-import Data.Attoparsec.ByteString.Char8 hiding (takeTill)+#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@@ -15,8 +24,10 @@            | Integer Integer            | Bulk (Maybe ByteString)            | MultiBulk (Maybe [Reply])-         deriving (Eq, Show)+         deriving (Eq, Show, Generic) +instance NFData Reply+ ------------------------------------------------------------------------------ -- Request --@@ -40,28 +51,61 @@ ------------------------------------------------------------------------------ -- Reply parsers ---reply :: Parser Reply-reply = choice [singleLine, integer, bulk, multiBulk, error]+{-# INLINE reply #-}+reply :: Scanner Reply+reply = do+  c <- Scanner.anyChar8+  case c of+    '+' -> string+    '-' -> error+    ':' -> integer+    '$' -> bulk+    '*' -> multi+    _ -> fail "Unknown reply type" -singleLine :: Parser Reply-singleLine = SingleLine <$> (char '+' *> takeTill isEndOfLine <* endOfLine)+{-# INLINE string #-}+string :: Scanner Reply+string = SingleLine <$> line -error :: Parser Reply-error = Error <$> (char '-' *> takeTill isEndOfLine <* endOfLine)+{-# INLINE error #-}+error :: Scanner Reply+error = Error <$> line -integer :: Parser Reply-integer = Integer <$> (char ':' *> signed decimal <* endOfLine)+{-# INLINE integer #-}+integer :: Scanner Reply+integer = Integer <$> integral -bulk :: Parser Reply+{-# INLINE bulk #-}+bulk :: Scanner Reply bulk = Bulk <$> do-    len <- char '$' *> signed decimal <* endOfLine-    if len < 0-        then return Nothing-        else Just <$> take len <* endOfLine+  len <- integral+  if len < 0+    then return Nothing+    else Just <$> Scanner.take len <* eol -multiBulk :: Parser Reply-multiBulk = MultiBulk <$> do-    len <- char '*' *> signed decimal <* endOfLine-    if len < 0-        then return Nothing-        else Just <$> count len reply+-- 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'
src/Database/Redis/ProtocolPipelining.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}  -- |A module for automatic, optimal protocol pipelining. --@@ -13,120 +15,134 @@ --      as possible, i.e. as long as a request's response is not used before any --      subsequent requests. -----  We use a BoundedChan to make sure the evaluator thread can only start to---  evaluate a reply after the request is written to the output buffer.---  Otherwise we will flush the output buffer (in hGetReplies) before a command---  is written by the user thread, creating a deadlock.---------  # Notes------  [Eval thread synchronization]---      * BoundedChan performs better than Control.Concurrent.STM.TBQueue--- module Database.Redis.ProtocolPipelining (-    Connection,-    connect, disconnect, request, send, recv,-    ConnectionLostException(..),-    HostName, PortID(..)+  Connection,+  connect, connectWithHooks, beginReceiving, disconnect, request, send, recv, flush, fromCtx, fromCtxWithHooks, hooks ) where  import           Prelude-import           Control.Concurrent (ThreadId, forkIO, killThread)-import           Control.Concurrent.BoundedChan-import           Control.Exception import           Control.Monad-import           Data.Attoparsec.ByteString+import qualified Scanner import qualified Data.ByteString as S import           Data.IORef-import           Data.Typeable-import           Network-import           System.IO+import qualified Network.TLS as TLS import           System.IO.Unsafe +import           Database.Redis.Protocol+import qualified Database.Redis.ConnectionContext as CC+import           Database.Redis.Hooks -data Connection a = Conn-    { connHandle   :: Handle        -- ^ Connection socket-handle.-    , connReplies  :: IORef [a]     -- ^ Reply thunks.-    , connThunks   :: BoundedChan a -- ^ See note [Eval thread synchronization].-    , connEvalTId  :: ThreadId      -- ^ 'ThreadID' of the eval thread.-    }+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+  , hooks         :: Hooks+  } -data ConnectionLostException = ConnectionLost-    deriving (Show, Typeable) -instance Exception ConnectionLostException+fromCtx :: CC.ConnectionContext -> IO Connection+fromCtx ctx = Conn ctx <$> newIORef [] <*> newIORef [] <*> newIORef 0 <*> pure defaultHooks -connect-    :: HostName-    -> PortID-    -> Parser a-    -> IO (Connection a)-connect host port parser = do-    connHandle  <- connectTo host port-    hSetBinaryMode connHandle True-    rs          <- hGetReplies connHandle parser-    connReplies <- newIORef rs-    connThunks  <- newBoundedChan 1000-    connEvalTId <- forkIO $ forever $ readChan connThunks >>= evaluate+fromCtxWithHooks :: CC.ConnectionContext -> Hooks -> IO Connection+fromCtxWithHooks ctx hooks = Conn ctx <$> newIORef [] <*> newIORef [] <*> newIORef 0 <*> pure hooks++connect :: CC.ConnectAddr -> Maybe Int -> Maybe TLS.ClientParams -> IO Connection+connect connectAddr timeoutOpt mTlsParams = connectWithHooks connectAddr timeoutOpt mTlsParams defaultHooks++connectWithHooks :: CC.ConnectAddr -> Maybe Int -> Maybe TLS.ClientParams -> Hooks -> IO Connection+connectWithHooks connectAddr timeoutOpt mTlsParams hooks = do+    connCtx <- CC.connect connectAddr timeoutOpt mTlsParams+    connReplies <- newIORef []+    connPending <- newIORef []+    connPendingCnt <- newIORef 0     return Conn{..} -disconnect :: Connection a -> IO ()-disconnect Conn{..} = do-    open <- hIsOpen connHandle-    when open (hClose connHandle)-    killThread connEvalTId+beginReceiving :: Connection -> IO ()+beginReceiving conn = do+  rs <- connGetReplies conn+  writeIORef (connReplies conn) rs+  writeIORef (connPending conn) rs --- |Write the request to the socket output buffer.------  The 'Handle' is 'hFlush'ed when reading replies.-send :: Connection a -> S.ByteString -> IO ()-send Conn{..} = S.hPut connHandle+disconnect :: Connection -> IO ()+disconnect Conn{..} = CC.disconnect connCtx --- |Take a reply from the list of future replies.------  The list of thunks must be deconstructed lazily, i.e. strictly matching (:)---  would block until a reply can be read. Using 'head' and 'tail' achieves ~2%---  more req/s in pipelined code than a lazy pattern match @~(r:rs)@.-recv :: Connection a -> IO a-recv Conn{..} = do-    rs <- readIORef connReplies-    writeIORef connReplies (tail rs)-    let r = head rs-    writeChan connThunks r+-- |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+  sendHook hooks (CC.send connCtx) s++  -- Signal that we expect one more reply from Redis.+  n <- atomicModifyIORef' connPendingCnt $ \n -> let n' = n+1 in (n', n')+  -- 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{..} =+  receiveHook hooks $ do+    (r:rs) <- readIORef connReplies+    writeIORef connReplies rs     return r -request :: Connection a -> S.ByteString -> IO a+-- | 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 --- |Read all the replies from the Handle and return them as a lazy list.+-- |A list of all future 'Reply's of the 'Connection'. -----  The actual reading and parsing of each 'Reply' is deferred until the spine---  of the list is evaluated up to that 'Reply'. Each 'Reply' is cons'd in front---  of the (unevaluated) list of all remaining replies.+--  The spine of the list can be evaluated without forcing the replies. -----  'unsafeInterleaveIO' only evaluates it's result once, making this function +--  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.-hGetReplies :: Handle -> Parser a -> IO [a]-hGetReplies h parser = go S.empty+connGetReplies :: Connection -> IO [Reply]+connGetReplies conn@Conn{..} = go S.empty (SingleLine "previous of first")   where-    go rest = unsafeInterleaveIO $ do        -        parseResult <- parseWith readMore parser rest-        case parseResult of-            Fail{}       -> errConnClosed-            Partial{}    -> error "Hedis: parseWith returned Partial"-            Done rest' r -> do-                rs <- go rest'-                return (r:rs)--    readMore = do-        hFlush h -- send any pending requests-        S.hGetSome h maxRead `catchIOError` const errConnClosed--    maxRead       = 4*1024-    errConnClosed = throwIO ConnectionLost+    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 $ \case+               (_:rs) -> (rs, ())+               [] -> error "Hedis: impossible happened parseWith missing value that it just received"+            -- We now expect one less reply from Redis. We don't count to+            -- negative, which would otherwise occur during pubsub.+            atomicModifyIORef' connPendingCnt $ \n -> (max 0 (n-1), ())+            return (r, rest')+      rs <- unsafeInterleaveIO (go rest' r)+      return (r:rs) -    catchIOError :: IO a -> (IOError -> IO a) -> IO a-    catchIOError = catch+    readMore = CC.ioErrorToConnLost $ do+      flush conn+      CC.recv connCtx
src/Database/Redis/PubSub.hs view
@@ -1,22 +1,62 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards, EmptyDataDecls,-    FlexibleInstances, FlexibleContexts #-}+{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, EmptyDataDecls,+    FlexibleInstances, FlexibleContexts, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables, TupleSections, ConstraintKinds #-}+{-# LANGUAGE BlockArguments #-}  module Database.Redis.PubSub (     publish,++    -- ** Subscribing to channels+    -- $pubsubexpl++    -- *** Single-thread Pub/Sub     pubSub,     Message(..),     PubSub(),-    subscribe, unsubscribe, psubscribe, punsubscribe+    subscribe, unsubscribe, psubscribe, punsubscribe,+    -- *** Continuous Pub/Sub message controller+    pubSubForever,+    RedisChannel, RedisPChannel, MessageCallback, PMessageCallback,+    PubSubController, newPubSubController, currentChannels, currentPChannels,+    addChannels, addChannelsAndWait, removeChannels, removeChannelsAndWait,+    UnregisterCallbacksAction,+    pendingChannels, pendingPatternChannels,+    -- ** Short lived connections+    -- $shortlivedexpl+    withPubSub ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative+import Data.Monoid hiding (<>)+#endif+import Control.Arrow (second)+import Control.Concurrent.Async (withAsync, waitEitherCatch, waitEitherCatchSTM, concurrently)+import Control.Concurrent.STM+import Control.Exception (throwIO, finally)+import qualified Database.Redis.ProtocolPipelining as PP import Control.Monad+import Control.Monad.Reader (asks) import Control.Monad.State import Data.ByteString.Char8 (ByteString)-import Data.Monoid+import Data.Function (fix)+import qualified Data.List as L+import qualified Data.List.NonEmpty as NE+import Data.Maybe (isJust)+import Data.Pool+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup (Semigroup(..))+#endif+import Data.Hashable (Hashable)+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Database.Redis.Cluster as Cluster import qualified Database.Redis.Core as Core-import Database.Redis.Protocol (Reply(..))+import qualified Database.Redis.Connection as Connection+import Database.Redis.Protocol (Reply(..), renderRequest) import Database.Redis.Types+import Control.Monad.IO.Unlift (MonadUnliftIO(withRunInIO))+import Data.Functor (($>))  -- |While in PubSub mode, we keep track of the number of current subscriptions --  (as reported by Redis replies) and the number of messages we expect to@@ -45,32 +85,40 @@     , punsubs :: Cmd Unsubscribe Pattern     } deriving (Eq) -instance Monoid PubSub where-    mempty        = PubSub mempty mempty mempty mempty-    mappend p1 p2 = PubSub { subs    = subs p1 `mappend` subs p2+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 DoNothing x         = x-    mappend x         DoNothing = x-    mappend (Cmd xs)  (Cmd ys)  = Cmd (xs ++ ys)-    -instance Monoid (Cmd Unsubscribe a) where-    mempty                       = DoNothing-    mappend DoNothing x          = x-    mappend x         DoNothing  = x-    -- empty subscription list => unsubscribe all channels and patterns-    mappend (Cmd [])  _          = Cmd []-    mappend _         (Cmd [])   = Cmd []-    mappend (Cmd xs)  (Cmd ys)   = Cmd (xs ++ ys)+  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@@ -78,9 +126,18 @@ 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)+  conn <- lift $ Core.reRedis $ asks Core.envConn+  let hook = Core.sendPubSubHook $ PP.hooks conn+  lift $ withRunInIO $ \runInIO -> hook (runInIO . Core.send) (redisCmd cmd : changes cmd)+  modifyPending (updatePending cmd) +rawSendCmd :: (Command (Cmd a b)) => PP.Connection -> Cmd a b -> IO ()+rawSendCmd _ DoNothing = return ()+rawSendCmd conn cmd    =+  let hook = Core.sendPubSubHook $ PP.hooks conn+      msg = redisCmd cmd : changes cmd+  in hook (PP.send conn . renderRequest) msg+ plusChangeCnt :: Cmd a b -> Int -> Int plusChangeCnt DoNothing = id plusChangeCnt (Cmd cs)  = (+ length cs)@@ -106,7 +163,12 @@              | PMessage { msgPattern, msgChannel, msgMessage :: ByteString}     deriving (Show) -data PubSubReply = Subscribed | Unsubscribed Int | Msg Message+data PubSubReply+    = Subscribed RedisChannel+    | PSubscribed RedisPChannel+    | Unsubscribed RedisChannel Int+    | PUnsubscribed RedisPChannel Int+    | Msg Message   ------------------------------------------------------------------------------@@ -127,7 +189,7 @@ subscribe     :: [ByteString] -- ^ channel     -> PubSub-subscribe []       = mempty+subscribe [] = mempty subscribe cs = mempty{ subs = Cmd cs }  -- |Stop listening for messages posted to the given channels@@ -137,29 +199,47 @@     -> PubSub unsubscribe cs = mempty{ unsubs = Cmd cs } --- |Listen for messages published to channels matching the given patterns +-- |Stop listening for messages posted to the given channels.+-- It works like 'unsubscribe', except it does not unsubscribe from+-- all channels when no channel is passed+unsubscribe1+    :: [ByteString] -- ^ channel+    -> PubSub+unsubscribe1 [] = mempty+unsubscribe1 cs = mempty{ unsubs = Cmd cs }++-- |Listen for messages published to channels matching the given patterns --  (<http://redis.io/commands/psubscribe>). psubscribe     :: [ByteString] -- ^ pattern     -> PubSub-psubscribe []       = mempty+psubscribe [] = mempty psubscribe ps = mempty{ psubs = Cmd ps } --- |Stop listening for messages posted to channels matching the given patterns +-- |Stop listening for messages posted to channels matching the given patterns --  (<http://redis.io/commands/punsubscribe>). punsubscribe     :: [ByteString] -- ^ pattern     -> PubSub punsubscribe ps = mempty{ punsubs = Cmd ps } +-- |Stop listening for messages posted to channels matching the given patterns.+-- It works like 'punsubscribe', except it does not unsubscribe from all channels+-- in case when the list is empty.+punsubscribe1+    :: [ByteString] -- ^ pattern+    -> PubSub+punsubscribe1 [] = mempty+punsubscribe1 ps = mempty{ punsubs = Cmd ps }+ -- |Listens to published messages on subscribed channels and channels matching --  the subscribed patterns. For documentation on the semantics of Redis --  Pub\/Sub see <http://redis.io/topics/pubsub>.---  ---  The given callback function is called for each received message. +--+--  The given callback function is called for each received message. --  Subscription changes are triggered by the returned 'PubSub'. To keep --  subscriptions unchanged, the callback can return 'mempty'.---  +-- --  Example: Subscribe to the \"news\" channel indefinitely. -- --  @@@ -176,6 +256,13 @@ --      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.@@ -194,15 +281,449 @@      recv :: StateT PubSubState Core.Redis ()     recv = do+        hook <- lift $ Core.reRedis $ asks $ Core.callbackHook . PP.hooks . Core.envConn         reply <- lift Core.recv         case decodeMsg reply of-            Msg msg        -> liftIO (callback msg) >>= send-            Subscribed     -> modifyPending (subtract 1) >> recv-            Unsubscribed n -> do-                putSubCnt n-                PubSubState{..} <- get-                unless (subCnt == 0 && pending == 0) recv+            Msg msg           -> liftIO (hook callback msg) >>= send+            Subscribed _      -> modifyPending (subtract 1) >> recv+            PSubscribed _     -> modifyPending (subtract 1) >> recv+            PUnsubscribed _ n -> onUnsubscribe n+            Unsubscribed _ n  -> onUnsubscribe n +    onUnsubscribe :: Int -> StateT PubSubState Core.Redis ()+    onUnsubscribe n = do+        putSubCnt n+        PubSubState{..} <- get+        unless (subCnt == 0 && pending == 0) recv++-- | A Redis channel name+type RedisChannel = ByteString++-- | 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)++-- | Stores channels subscribed, pending subscription, and pending removal+-- by type, where type can be a normal channel, or a pattern channel.+data ChannelData channel callback+    = ChannelData+    { cdSubscribedChannels :: !(TVar (HM.HashMap channel [(UnregisterHandle, callback)]))+    , cdChannelsPendingSubscription :: !(TVar (HS.HashSet channel))+    , cdChannelsPendingRemoval :: !(TVar (HS.HashSet channel))+    }++-- | A controller that stores a set of channels, pattern channels, and callbacks.+-- It allows you to manage Pub/Sub subscriptions and pattern subscriptions and alter them at+-- any time throughout the life of your program.+-- 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+  { sendChanges :: TBQueue PubSub+  , pscChannelData :: ChannelData RedisChannel MessageCallback+  , pscPChannelData :: ChannelData RedisPChannel PMessageCallback+  , lastUsedCallbackId :: TVar UnregisterHandle+  }++newChannelData :: Hashable channel => [(channel, callback)] -> STM (ChannelData channel callback)+newChannelData initialSubs+    = ChannelData+    <$> newTVar (HM.fromListWith (++) $ map (second $ pure . (0,)) initialSubs)+    <*> newTVar mempty+    <*> newTVar mempty++-- | Create a new 'PubSubController'.  Note that this does not subscribe to any channels, it just+-- creates the controller.  The subscriptions will happen once 'pubSubForever' is called.+newPubSubController :: MonadIO m => [(RedisChannel, MessageCallback)] -- ^ the initial subscriptions+                                 -> [(RedisPChannel, PMessageCallback)] -- ^ the initial pattern subscriptions+                                 -> m PubSubController+newPubSubController initialSubs initialPSubs = liftIO $ atomically $ do+    c <- newTBQueue 10+    lastId <- newTVar 0+    channelData' <- newChannelData initialSubs+    pchannelData' <- newChannelData initialPSubs+    return $ PubSubController c channelData' pchannelData' lastId++#if __GLASGOW_HASKELL__ < 710+type FunctorMonadIO m = (MonadIO m, Functor m)+#else+type FunctorMonadIO m = MonadIO m+#endif++-- | Get the list of current channels in the 'PubSubController'.  WARNING! This might not+-- exactly reflect the subscribed channels in the Redis server, because there is a delay+-- between adding or removing a channel in the 'PubSubController' and when Redis receives+-- and processes the subscription change request.+currentChannels :: FunctorMonadIO m => PubSubController -> m [RedisChannel]+currentChannels ctrl = HM.keys <$> (liftIO $ atomically $ readTVar $ cdSubscribedChannels $ pscChannelData ctrl)++-- | Get the list of current pattern channels in the 'PubSubController'.  WARNING! This might not+-- exactly reflect the subscribed channels in the Redis server, because there is a delay+-- between adding or removing a channel in the 'PubSubController' and when Redis receives+-- and processes the subscription change request.+currentPChannels :: FunctorMonadIO m => PubSubController -> m [RedisPChannel]+currentPChannels ctrl = HM.keys <$> (liftIO $ atomically $ readTVar $ cdSubscribedChannels $ pscPChannelData ctrl)++pendingChannels :: MonadIO m => PubSubController -> m (HS.HashSet RedisChannel)+pendingChannels ctrl = liftIO $ readTVarIO $ cdChannelsPendingSubscription $ pscChannelData ctrl++pendingPatternChannels :: MonadIO m => PubSubController -> m (HS.HashSet RedisPChannel)+pendingPatternChannels ctrl = liftIO $ readTVarIO $ cdChannelsPendingSubscription $ pscPChannelData ctrl++-- type CallbackMap a = HM.HashMap ByteString [(UnregisterHandle, a)]++-- | Helper for `addChannels`. Can take either normal or pattern channels.+addChannelsOfType+    :: Hashable channel+    => UnregisterHandle+    -> [(channel, callback)]+    -> ChannelData channel callback+    -> STM [channel]+addChannelsOfType ident newChans channelData = do+    callbacks <- readTVar $ cdSubscribedChannels channelData+    pendingCallbacks <- readTVar $ cdChannelsPendingSubscription channelData+    let newChans' = filter (not . memberMapOrSet callbacks pendingCallbacks) $ fst <$> newChans+    writeTVar (cdSubscribedChannels channelData) (HM.unionWith (++) callbacks $ (\z -> [(ident,z)]) <$> HM.fromList newChans)+    writeTVar (cdChannelsPendingSubscription channelData) $ HS.union pendingCallbacks $ HS.fromList newChans'+    pure newChans'++-- | Add channels into the 'PubSubController', and if there is an active 'pubSubForever', send the subscribe+-- and psubscribe commands to Redis.  The 'addChannels' function is thread-safe.  This function+-- does not wait for Redis to acknowledge that the channels have actually been subscribed; use+-- '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+      newChannels <- addChannelsOfType ident newChans $ pscChannelData ctrl+      newPChannels <- addChannelsOfType ident newPChans $ pscPChannelData ctrl+      let ps = subscribe newChannels `mappend` psubscribe newPChannels+      writeTBQueue (sendChanges ctrl) 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 requested subscription change requests, so if you for example call+-- 'addChannelsAndWait' from multiple threads simultaneously, they will all wait their pending+-- subscription changes to be acknowledged by Redis.+--+-- This also correctly waits if the network connection dies during the subscription change.  Say that the+-- network connection dies right after we send a subscription change to Redis.  'pubSubForever' will throw+-- '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 $+    waitUntilAbsent+      [ (cdChannelsPendingSubscription $ pscChannelData ctrl, fst <$> newChans)+      , (cdChannelsPendingSubscription $ pscPChannelData ctrl, fst <$> newPChans)+      ]+  return unreg++-- | Wait until all interesting channels are instantiated.+waitUntilAbsent :: Hashable channel => [(TVar (HS.HashSet channel), [channel])] -> IO ()+waitUntilAbsent pending  = atomically $ do+  forM_ pending $ \(tPendingChannels, channels) -> do+    unless (null channels) $ do+      pendingChannels' <- readTVar tPendingChannels+      when (any (\ch -> HS.member ch pendingChannels') channels) retry++-- | Remove channels from the 'PubSubController', and if there is an active 'pubSubForever', send the+-- unsubscribe commands to Redis.  Note that as soon as this function returns, no more callbacks will be+-- executed even if more messages arrive during the period when we request to unsubscribe from the channel+-- 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+    remChans' <- removeChannels' (pscChannelData ctrl) remChans+    remPChans' <- removeChannels' (pscPChannelData ctrl) remPChans+    writeTBQueue (sendChanges ctrl) $ unsubscribe1 remChans' `mappend` punsubscribe1 remPChans'++#if !(MIN_VERSION_stm(2,3,0))+-- | Strict version of 'modifyTVar'.+--+-- @since 2.3+modifyTVar' :: TVar a -> (a -> a) -> STM ()+modifyTVar' var f = do+    x <- readTVar var+    writeTVar var $! f x+{-# INLINE modifyTVar' #-}+#endif++-- Helper for `removeChannels` that works on normal or pattern channels+removeChannels' :: (Hashable channel) => ChannelData channel callback -> [channel] -> STM [channel]+removeChannels' channelData remChannels = do+    subbedChannels <- readTVar $ cdSubscribedChannels channelData+    pendingChannelSubs <- readTVar $ cdChannelsPendingSubscription channelData+    let remChannels' = filter (memberMapOrSet subbedChannels pendingChannelSubs) remChannels+    writeTVar (cdSubscribedChannels channelData) (L.foldl' (flip HM.delete) subbedChannels remChannels')+    writeTVar (cdChannelsPendingSubscription channelData) (L.foldl' (flip HS.delete) pendingChannelSubs remChannels')+    modifyTVar' (cdChannelsPendingRemoval channelData) $ flip (L.foldl' $ flip HS.insert) remChannels'+    pure remChannels'++memberMapOrSet :: Hashable k => HM.HashMap k v1 -> HS.HashSet k -> k -> Bool+memberMapOrSet m s k = HM.member k m || HS.member k s++unregisterHandles+    :: forall channel callback. Hashable channel => ChannelData channel callback+    -> [channel]+    -> UnregisterHandle+    -> STM [channel]+unregisterHandles channelData remChansParam h = do+    callbacks <- readTVar $ cdSubscribedChannels channelData+    let remChans = filter (`HM.member` callbacks) remChansParam++    -- helper functions to filter out handlers that match+    -- returns number of removals, and remaining subscriptions+    -- maps after taking out channels matching the handle+    let callbacks' = L.foldl' removeHandles callbacks remChans+        remChans' = filter (\chan -> HM.member chan callbacks && not (HM.member chan callbacks')) remChans++    writeTVar (cdSubscribedChannels channelData) callbacks'+    unless (null remChans') $ modifyTVar (cdChannelsPendingSubscription channelData) (`HS.difference` HS.fromList remChans')+    pure remChans'++    where+        filterHandle :: Maybe [(UnregisterHandle,a)] -> Maybe [(UnregisterHandle,a)]+        filterHandle Nothing = Nothing+        filterHandle (Just lst) = case filter (\x -> fst x /= h) lst of+                                    [] -> Nothing+                                    xs -> Just xs++        removeHandles :: HM.HashMap channel [(UnregisterHandle,a)]+                      -> channel+                      -> HM.HashMap channel [(UnregisterHandle,a)]+        removeHandles m k = case filterHandle (HM.lookup k m) of -- recent versions of unordered-containers have alter+            Nothing -> HM.delete k m+            Just v  -> HM.insert k v m++-- | Internal function to unsubscribe only from those channels matching the given handle.+unsubChannels :: PubSubController -> [RedisChannel] -> [RedisPChannel] -> UnregisterHandle -> IO ()+unsubChannels ctrl chans pchans h = liftIO $ atomically $ do+    channelsToDrop <- unregisterHandles (pscChannelData ctrl) chans h+    pChannelsToDrop <- unregisterHandles (pscPChannelData ctrl) pchans h++    let commands = unsubscribe1 channelsToDrop `mappend` punsubscribe1 pChannelsToDrop++    -- do the unsubscribe+    writeTBQueue (sendChanges ctrl) commands+    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 ctrl remChannels remPChannels = liftIO $ do+    (remChans', remPChans') <- atomically $ do+        remChans' <- removeChannels' (pscChannelData ctrl) remChannels+        remPChans' <- removeChannels' (pscPChannelData ctrl) remPChannels+        writeTBQueue (sendChanges ctrl) $ unsubscribe1 remChans' `mappend` punsubscribe1 remPChans'+        pure (remChans', remPChans')+    waitUntilAbsent+      [ (cdChannelsPendingRemoval $ pscChannelData ctrl, remChans')+      , (cdChannelsPendingRemoval $ pscPChannelData ctrl, remPChans')+      ]++-- | Internal thread which listens for messages and executes callbacks.+-- This is the only thread which ever receives data from the underlying+-- connection.+listenThread :: PubSubController -> PP.Connection -> IO ()+listenThread ctrl rawConn = forever $ do+    msg <- PP.recv rawConn+    case decodeMsg msg of+        Msg message@(Message channel _) -> do+          cm <- atomically $ readTVar $ cdSubscribedChannels $ pscChannelData ctrl+          forM_ (HM.lookup channel cm) $ \c -> do+            void $ Core.callbackHook (PP.hooks rawConn) (\m -> mapM_ (\(_,x) -> x $ msgMessage m) c $> mempty) message+        Msg message@(PMessage pattern _ _) -> do+          pm <- atomically $ readTVar $ cdSubscribedChannels $ pscPChannelData ctrl+          forM_ (HM.lookup pattern pm) $ \c -> do+            void $ Core.callbackHook (PP.hooks rawConn) (\m -> mapM_ (\(_,x) -> x (msgChannel m) (msgMessage m)) c $> mempty) message+        Subscribed chan -> atomically $ modifyTVar (cdChannelsPendingSubscription $ pscChannelData ctrl) $ HS.delete chan+        PSubscribed chan -> atomically $ modifyTVar (cdChannelsPendingSubscription $ pscPChannelData ctrl) $ HS.delete chan+        Unsubscribed chan _ -> atomically $ modifyTVar (cdChannelsPendingRemoval $ pscChannelData ctrl) $ HS.delete chan+        PUnsubscribed chan _ -> atomically $ modifyTVar (cdChannelsPendingRemoval $ pscPChannelData ctrl) $ HS.delete chan++-- | Internal thread which sends subscription change requests.+-- This is the only thread which ever sends data on the underlying+-- 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 <https://hackage.haskell.org/package/retry retry> 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 -> pubSubForeverOnConn rawConn ctrl onInitialLoad+pubSubForever (Connection.ClusteredConnection _ pool) ctrl onInitialLoad = withResource pool $ \clusterConn -> do+    masterNodeConns <- Cluster.masterNodes clusterConn+    nodeConn <- case masterNodeConns of+      [] -> ioError $ userError "Hedis: clustered pubSubForever requires at least one master node"+      x:_ -> pure x+    rawConn <- PP.fromCtxWithHooks (Cluster.nodeConnectionContext nodeConn) (Cluster.hooks clusterConn)+    PP.beginReceiving rawConn+    pubSubForeverOnConn rawConn ctrl onInitialLoad++pubSubForeverOnConn :: PP.Connection -> PubSubController -> IO () -> IO ()+pubSubForeverOnConn rawConn ctrl onInitialLoad = 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+      channels <- fmap HM.keys $ readTVar $ cdSubscribedChannels $ pscChannelData ctrl+      patternChannels <- fmap HM.keys $ readTVar $ cdSubscribedChannels $ pscPChannelData ctrl+      let ps = subscribe channels `mappend` psubscribe patternChannels+      writeTBQueue (sendChanges ctrl) ps+      writeTVar (cdChannelsPendingSubscription $ pscChannelData ctrl) $ HS.fromList channels+      writeTVar (cdChannelsPendingSubscription $ pscPChannelData ctrl) $ HS.fromList patternChannels++    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 <$> do+              a <- readTVar $ cdChannelsPendingSubscription $ pscChannelData ctrl+              unless (HS.null a) retry+              b <- readTVar $ cdChannelsPendingSubscription $ pscPChannelData ctrl+              unless (HS.null b) retry)+        case mret of+          Right () -> onInitialLoad+          _ -> return () -- if there is an error, waitEitherCatch below will also see it++        -- 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++ ------------------------------------------------------------------------------ -- Helpers --@@ -212,17 +733,93 @@     case kind :: ByteString of         "message"      -> Msg <$> decodeMessage         "pmessage"     -> Msg <$> decodePMessage-        "subscribe"    -> return Subscribed-        "psubscribe"   -> return Subscribed-        "unsubscribe"  -> Unsubscribed <$> decodeCnt-        "punsubscribe" -> Unsubscribed <$> decodeCnt+        "subscribe"    -> Subscribed <$> decodeChan+        "psubscribe"   -> PSubscribed <$> decodeChan+        "unsubscribe"  -> Unsubscribed <$> decodeChan <*> decodeCnt+        "punsubscribe" -> PUnsubscribed <$> decodeChan <*> decodeCnt         _              -> errMsg r   where     decodeMessage  = Message  <$> decode r1 <*> decode r2     decodePMessage = PMessage <$> decode r1 <*> decode r2 <*> decode (head rs)     decodeCnt      = fromInteger <$> decode r2-        +    decodeChan     = decode r1+ decodeMsg r = errMsg r  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.+++-- $shortlivedexpl+-- Another approach to Pub/Sub that allows creating a short-lived Pub/Sub connection is to use 'withPubSub', which takes a callback that receives messages and returns when the callback returns. This is simpler than 'pubSubForever' but does not support changing subscriptions while it is running, so it is only useful for short-lived Pub/Sub connections. For example, you could use 'withPubSub'+-- to subscribe to a channel, consume a stream of messages, and then return. This approach is worth using when you want a few short-lived+-- subscriptions. However, each call to 'withPubSub' consumes a connection from the pool, so if you have a lot of short-lived subscriptions, it is more++-- |+-- Creates a subscription and automatically unsubscribes when callback returns, this function keeps+-- flow control in the callback, so it is useful for short-lived subscriptions, when the callback knows+-- when to exit. The function is quite simple and does not make any attempts to handle connection loss.+--+-- Note that this function does not support changing subscriptions while it is running, so it is only useful for short-lived Pub/Sub connections.+--+-- An example of usage, that is hard to implement with 'pubSubForever' is to subscribe to a channel:+--+-- @+-- withPubSub conn [\"mychannel\"] [] $ \\waitMsg -> do+--    d <- registerDelay 1000000 -- 1 second (requires -threaded runtime)+--    atomically $ asum [ readTVar >>= guard >> return Nothing+--                      , Just <$> waitMsg+--                      ]+-- @+--+-- In case if connection is lost, user callback will receive 'BlockedIndefinitelyOnSTM' exception.+withPubSub :: Connection.Connection -> [ByteString] -> [ByteString] -> (STM Message -> IO r) -> IO r+withPubSub (Connection.NonClusteredConnection pool) chans pchans f = withResource pool $ \rawConn -> do+    newTChanIO >>= \messageChan -> withPubSubOnConn messageChan chans pchans rawConn f+withPubSub (Connection.ClusteredConnection _ pool) chans pchans f = withResource pool $ \clusterConn -> do+    masterNodeConns <- Cluster.masterNodes clusterConn+    nodeConn <- case masterNodeConns of+      [] -> ioError $ userError "Hedis: clustered withPubSub requires at least one master node"+      x:_ -> pure x+    rawConn <- PP.fromCtxWithHooks (Cluster.nodeConnectionContext nodeConn) (Cluster.hooks clusterConn)+    PP.beginReceiving rawConn+    newTChanIO >>= \messageChan -> withPubSubOnConn messageChan chans pchans rawConn f++withPubSubOnConn :: TChan Message -> [ByteString] -> [ByteString] -> PP.Connection -> (STM Message -> IO r) -> IO r+withPubSubOnConn messageChan chans pchans rawConn f = do+    subscribeAll+    (_, r) <- concurrently lThread (f (readTChan messageChan) `finally` unsubscribeAll)+    pure r+  where+    subscribeAll = do+        forM_ (NE.nonEmpty chans) \ne_chans ->+            PP.send rawConn $ renderRequest ("SUBSCRIBE" : NE.toList ne_chans)+        forM_ (NE.nonEmpty pchans) \ne_pchans ->+            PP.send rawConn $ renderRequest ("PSUBSCRIBE" : NE.toList ne_pchans)+        PP.flush rawConn+    unsubscribeAll = do+        forM_ (NE.nonEmpty chans) \ne_chans ->+            PP.send rawConn $ renderRequest ("UNSUBSCRIBE" : NE.toList ne_chans)+        forM_ (NE.nonEmpty pchans) \ne_pchans ->+            PP.send rawConn $ renderRequest ("PUNSUBSCRIBE" : NE.toList ne_pchans)+        PP.flush rawConn+    lThread = fix \next -> do+        msg <- PP.recv rawConn+        case decodeMsg msg of+            Msg m -> do+                atomically (writeTChan messageChan m)+                next+            Unsubscribed _ 0 -> pure ()+            PUnsubscribed _ 0 -> pure ()+            _ -> next
+ src/Database/Redis/PubSub.hs-boot view
@@ -0,0 +1,8 @@+module Database.Redis.PubSub (+    Message,+    PubSub,+) where++data PubSub++data Message
+ src/Database/Redis/Sentinel.hs view
@@ -0,0 +1,225 @@+{-# 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: <https://redis.io/topics/sentinel>.+--+-- Example:+--+-- @+-- conn <- 'connect' 'SentinelConnectionInfo' (("localhost", 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 <https://gist.github.com/borsboom/681d37d273d5c4168723>+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, bracket)+import           Control.Monad.Except+import           Control.Monad.IO.Class+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.Unique+import qualified Network.Socket        as NS++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+                Redis.disconnect oldBaseConnection+                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 = connectAddr l == connectAddr 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 :: NS.HostName -> NS.PortNumber -> ExceptT (Redis.ConnectInfo, (NS.HostName, NS.PortNumber)) IO ()+    trySentinel sentinelHost sentinelPort = do+      -- bang to ensure exceptions from runRedis get thrown immediately.+      !replyE <- liftIO $ do+        bracket+          (Redis.connect $ Redis.defaultConnectInfo+            { connectAddr = ConnectAddrHostPort sentinelHost sentinelPort+            , connectMaxConnections = 1+            })+          Redis.disconnect+          $ \sentinelConn -> Redis.runRedis sentinelConn $ sendRequest+            ["SENTINEL", "get-master-addr-by-name", connectMasterName]++      case replyE of+        Right [host, port] ->+          throwError+            ( connectBaseInfo+              { connectAddr =+                  ConnectAddrHostPort+                    (BS8.unpack host)+                    (maybe+                      26379+                      (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 (NS.HostName, NS.PortNumber)+        -- ^ List of sentinels.+      , connectMasterName :: ByteString+        -- ^ Name of master to connect to.+      , connectBaseInfo   :: Redis.ConnectInfo+        -- ^ This is used to configure auth and other parameters for Redis connection,+        -- but 'Redis.connectAddr' is ignored.+      }+  deriving (Show)++-- | Exception thrown by "Database.Redis.Sentinel".+data RedisSentinelException+  = NoSentinels (NonEmpty (NS.HostName, NS.PortNumber))+    -- ^ Thrown if no sentinel can be reached.+  deriving (Show)++deriving instance Exception RedisSentinelException
src/Database/Redis/Transactions.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances, MultiParamTypeClasses,+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE CPP, OverloadedStrings, FlexibleInstances, MultiParamTypeClasses,     GeneralizedNewtypeDeriving #-}  module Database.Redis.Transactions (@@ -6,8 +7,12 @@     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, (!)) @@ -36,7 +41,7 @@         -- future index in EXEC result list         i <- get         put (i+1)-        return $ Queued (decode . (!i))+        return $ Queued (decode . (! i))  -- |A 'Queued' value represents the result of a command inside a transaction. It --  is a proxy object for the /actual/ result, which will only be available@@ -72,7 +77,9 @@     -- ^ Transaction aborted due to an earlier 'watch' command.     | TxError String     -- ^ At least one of the commands returned an 'Error' reply.-    deriving (Show, Eq)+    deriving (Show, Eq, Generic)++instance NFData a => NFData (TxResult a)  -- |Watch the given keys to determine execution of the MULTI\/EXEC block --  (<http://redis.io/commands/watch>).
src/Database/Redis/Types.hs view
@@ -1,12 +1,22 @@-{-# LANGUAGE FlexibleInstances, OverlappingInstances, TypeSynonymInstances,+{-# 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 Data.Int+import Control.DeepSeq import Data.ByteString.Char8 (ByteString, pack)-import qualified Data.ByteString.Lex.Fractional as F (readSigned, readDecimal)+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 @@ -29,16 +39,24 @@ instance RedisArg Integer where     encode = pack . show -instance RedisArg Double where+instance RedisArg Int64 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)+    deriving (Show, Eq, Generic) -data RedisType = None | String | Hash | List | Set | ZSet+instance NFData Status++data RedisType = None | String | Hash | List | Set | ZSet     deriving (Show, Eq)  instance RedisResult Reply where@@ -54,8 +72,13 @@     decode r           =         maybe (Left r) (Right . fst) . I.readSigned I.readDecimal =<< decode r +instance RedisResult Int64 where+    decode (Integer n) = Right (fromInteger n)+    decode r           =+        maybe (Left r) (Right . fst) . I.readSigned I.readDecimal =<< decode r+ instance RedisResult Double where-    decode r = maybe (Left r) (Right . fst) . F.readSigned F.readDecimal =<< decode r+    decode r = maybe (Left r) (Right . fst) . F.readSigned F.readExponential =<< decode r  instance RedisResult Status where     decode (SingleLine s) = Right $ case s of@@ -86,7 +109,11 @@     decode (MultiBulk Nothing) = Right Nothing     decode r                   = Just <$> decode r -instance (RedisResult a) => RedisResult [a] where+instance+#if __GLASGOW_HASKELL__ >= 710+    {-# OVERLAPPABLE #-}+#endif+    (RedisResult a) => RedisResult [a] where     decode (MultiBulk (Just rs)) = mapM decode rs     decode r                     = Left r
+ src/Database/Redis/URL.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+module Database.Redis.URL+    ( parseConnectInfo+    ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative ((<$>))+#endif+import qualified Data.ByteString.Char8 as C8+import Control.Error.Util (note)+#if __GLASGOW_HASKELL__ < 808+import Data.Monoid ((<>))+#endif+import Data.String (fromString)+import Database.Redis.Connection (ConnectInfo(..), defaultConnectInfo)+import qualified Database.Redis.ConnectionContext as CC+import Network.HTTP.Base+import Network.URI (parseURI, uriPath, uriScheme, uriQuery, URI)+import Network.TLS (defaultParamsClient)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Network.HTTP.Types (parseSimpleQuery)+import Text.Read (readMaybe)+++-- | Parse a @'ConnectInfo'@ from a URL according to the Rules in Redis client+--+-- Standalone Redis:+--+-- @+-- redis :// [[username :] password@] host [:port][/database]+-- @+--+-- >>> parseConnectInfo "redis://username:password@host:42/2"+-- Right (ConnInfo {connectAddr = ConnectAddrHostPort "host" 42, connectAuth = Just "password", connectUsername = Just "username", connectDatabase = 2, connectMaxConnections = 50, connectNumStripes = Just 1, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing, connectHooks = Hooks {...}, connectPoolLabel = ""})+--+-- >>> parseConnectInfo "redis://password@host:42/2"+-- Right (ConnInfo {connectAddr = ConnectAddrHostPort "host" 42, connectAuth = Just "password", connectUsername = Nothing, connectDatabase = 2, connectMaxConnections = 50, connectNumStripes = Just 1, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing, connectHooks = Hooks {...}, connectPoolLabel = ""})+--+-- TLS-enabled Redis:+--+-- @+-- rediss :// [[username :] password@] host [: port][/database]+-- @+--+-- Unix socket Redis:+--+-- @+-- redis-socket :// [[username :] password@]path [? [&database=database]+-- @+--+-- >>> parseConnectInfo "redis-socket://password@/tmp/redis.sock?database=2"+-- Right (ConnInfo {connectAddr = ConnectAddrUnixSocket "/tmp/redis.sock", connectAuth = Just "password", connectUsername = Nothing, connectDatabase = 2, connectMaxConnections = 50, connectNumStripes = Just 1, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing, connectHooks = Hooks {...}, connectPoolLabel = ""})+--+-- >>> parseConnectInfo "redis://username:password@host:42/db"+-- Left "Invalid port: db"+--+-- The scheme is validated, to prevent mixing up configurations:+--+-- >>> parseConnectInfo "postgres://"+-- Left "Wrong scheme postgres:"+--+-- Beyond that, all values are optional. Omitted values are taken from+-- @'defaultConnectInfo'@:+--+-- >>> parseConnectInfo "rediss://"+-- Right (ConnInfo {connectAddr = ConnectAddrHostPort "localhost" 6379, connectAuth = Nothing, connectUsername = Nothing, connectDatabase = 0, connectMaxConnections = 50, connectNumStripes = Just 1, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Just (ClientParams ...), connectHooks = Hooks {...}, connectPoolLabel = ""})+--+parseConnectInfo :: String -> Either String ConnectInfo+parseConnectInfo url = do+    uri <- note "Invalid URI" $ parseURI url+    let userScheme = uriScheme uri+    case userScheme of+        "redis:" -> parseSocket False uri+        "rediss:" -> parseSocket True uri+        "redis-socket:" -> parseUnix uri+        x -> Left ("Wrong scheme " ++ x)+    where+        parseSocket :: Bool -> URI -> Either String ConnectInfo+        parseSocket isSecure uri = do+            uriAuth <- note "Missing or invalid Authority"+                $ parseURIAuthority+                $ uriToAuthorityString uri++            let h = host uriAuth+                dbNumPart = dropWhile (== '/') (uriPath uri)++            db <- if null dbNumPart+              then return $ connectDatabase defaultConnectInfo+              else note ("Invalid port: " <> dbNumPart) $ readMaybe dbNumPart++            let finalHost = if null h+                    then case connectAddr defaultConnectInfo of+                      CC.ConnectAddrHostPort defaultHost _ -> defaultHost+                      CC.ConnectAddrUnixSocket _ -> "localhost"+                    else h++            let (finalUser, finalAuth) = case (T.pack <$> user uriAuth, T.pack <$> password uriAuth) of+                    (p, Nothing) -> (Nothing, p)+                    (p, fmap T.strip -> Just "") -> (Nothing, p)+                    (u, p) -> (u, p)++            return defaultConnectInfo+                { connectAddr =+                    CC.ConnectAddrHostPort+                      finalHost+                      (maybe defaultPort fromIntegral (port uriAuth))+                , connectAuth = T.encodeUtf8 <$> finalAuth+                , connectUsername = T.encodeUtf8 <$> finalUser+                , connectDatabase = db+                , connectTLSParams = case isSecure of+                     False -> Nothing+                     True -> Just $ defaultParamsClient finalHost ""+                }+          where+            defaultPort = case connectAddr defaultConnectInfo of+              CC.ConnectAddrHostPort _ portNum -> portNum+              CC.ConnectAddrUnixSocket _ -> 6379++        parseUnix :: URI -> Either String ConnectInfo+        parseUnix uri = do+            auth <- note "Missing or invalid Authority"+                $ parseURIAuthority+                $ uriToAuthorityString uri+            db <- case lookup "database" query of+                    Nothing -> return $ connectDatabase defaultConnectInfo+                    Just dbNumPart ->+                        note "Invalid database" $ readMaybe @Integer . T.unpack $ T.decodeUtf8 dbNumPart+            return defaultConnectInfo+                { connectAddr = CC.ConnectAddrUnixSocket (mkPath auth)+                , connectAuth = C8.pack <$> (user auth)+                , connectDatabase = (db :: Integer)+                }+            where+                mkPath auth =+                    case host auth <> uriPath uri of+                        ('/':_) -> host auth <> uriPath uri+                        _ -> '/' : host auth <> uriPath uri+                query = parseSimpleQuery (T.encodeUtf8 $ fromString $ uriQuery uri)
+ test/ClusterMain.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE LambdaCase #-}++module Main (main) where++import qualified Test.Framework as Test+import Data.ByteString (ByteString)+import Database.Redis+import Network.Socket (PortNumber)+import System.Environment (lookupEnv)+import Tests+import Text.Read (readMaybe)+import PubSubTest (testPubSubThreaded)++main :: IO ()+main = do++    redisPort <- ((readMaybe @PortNumber =<<) <$> lookupEnv "REDIS_PORT") >>= \case+            Just port -> return port+            _ -> return 6379+    redisHost <- lookupEnv "REDIS_HOST" >>= \case+        Just host -> return host+        Nothing -> return "localhost"+    -- We're looking for the cluster on a non-default port to support running+    -- this test in parallel witht the regular non-cluster tests. To quickly+    -- spin up a cluster on this port using docker you can run:+    --+    --     docker run -e "IP=0.0.0.0" -p 7000-7010:7000-7010 grokzen/redis-cluster:5.0.6+    conn <- connectCluster defaultConnectInfo { connectAddr = ConnectAddrHostPort redisHost redisPort }+    Test.defaultMain (tests redisHost redisPort conn)++tests :: String -> PortNumber -> Connection -> [Test.Test]+tests host port conn = map ($ conn) $ concat @[]+    [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog]+    , testsZSets, [testTransaction], [testScripting]+    , testsConnection host port, testsClient, testsServer, [testSScan, testHScan, testZScan], [testZrangelex]+    , [testXAddRead, testXReadGroup, testXRange, testXpending7, testXClaim, testXInfo, testXDel, testXTrim]+      -- should always be run last as connection gets closed after it+    , testPubSubThreaded+    , [testQuit]+    ]++testsClient :: [Test]+testsClient = [testClientId, testClientName]++testsServer :: [Test]+testsServer =+    [testBgrewriteaof, testFlushall, testSlowlog, testDebugObject]++testsConnection :: String -> PortNumber -> [Test]+testsConnection host port = [ testConnectAuthUnexpected host port, testEcho, testPing ]++testsKeys :: [Test]+testsKeys = [ testKeys, testExpireAt, testSortCluster, testGetType, testObject ]++testSortCluster :: Test+testSortCluster = testCase "sort" $ do+    lpush "{same}ids"     ["1"::ByteString,"2","3"]          >>=? 3+    sort "{same}ids" defaultSortOpts                         >>=? ["1","2","3"]+    sortStore "{same}ids" "{same}anotherKey" defaultSortOpts >>=? 3+    let opts = defaultSortOpts { sortOrder = Desc, sortAlpha = True+                               , sortLimit = (1,2)+                               , sortBy    = Nothing+                               , sortGet   = [] }+    sort "{same}ids" opts >>=? ["2", "1"]
+ test/Main.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE LambdaCase #-}+module Main (main) where++import qualified Test.Framework as Test+import Database.Redis+import Tests+import PubSubTest+import System.Environment+import Text.Read (readMaybe)+import Network.Socket (PortNumber)++main :: IO ()+main = do+    redisPort <- ((readMaybe @PortNumber =<<) <$> lookupEnv "REDIS_PORT") >>= \case+            Just port -> return port+            _ -> return 6379+    host <- lookupEnv "REDIS_HOST" >>= \case+        Just host -> return host+        Nothing -> return "localhost"+    conn <- connect defaultConnectInfo { connectAddr = ConnectAddrHostPort host redisPort }+    Test.defaultMain (tests host redisPort conn)++tests :: String -> PortNumber -> Connection -> [Test.Test]+tests host port conn = map ($ conn) $ concat+    [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog]+    , testsZSets, [testPubSub], [testTransaction], [testScripting]+    , testsConnection host port+    , testsClient, testsServer+    , [testScans, testSScan, testHScan, testZScan], [testZrangelex]+    , [testXAddRead, testXReadGroup, testXRange, testXpending, testXClaim, testXInfo, testXDel, testXTrim]+    , testPubSubThreaded+      -- should always be run last as connection gets closed after it+    , [testQuit]+    ]+++testsClient :: [Test]+testsClient = [testClientId, testClientName]++testsServer :: [Test]+testsServer =+    [testServer, testBgrewriteaof, testFlushall, testInfo, testConfig+    ,testSlowlog, testDebugObject]++testsConnection :: String -> PortNumber -> [Test]+testsConnection host port =+    [ testConnectAuth host port+    , testConnectAuthUnexpected host port+    , testConnectAuthAcl host port+    , testConnectDb host port+    , testConnectDbUnexisting host port+    , testEcho+    , testPing+    , testSelect+    ]++testsKeys :: [Test]+testsKeys = [ testKeys, testKeysNoncluster, testExpireAt, testSort, testGetType, testObject ]
+ test/MainHooks.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings #-}
+
+import qualified Test.Framework.Providers.HUnit as Test (testCase)
+import qualified Test.Framework as Test
+import Database.Redis
+import Data.IORef
+import qualified Test.HUnit as HUnit
+import Control.Monad.IO.Class (MonadIO(liftIO))
+
+main :: IO ()
+main = Test.defaultMain [testSetGet]
+
+data Counts =
+    Counts 
+        { sendRequestCount :: Word
+        , sendPubSubCount :: Word
+        , callbackCount :: Word
+        , sendCount :: Word
+        , receiveCount :: Word
+        }
+    deriving (Show, Eq)
+
+testCase :: String -> Counts -> Redis () -> Test.Test
+testCase name expected r = Test.testCase name $ do
+    ref <- newIORef $ Counts 0 0 0 0 0
+    conn <- connect defaultConnectInfo {connectHooks = hooks ref}
+    t <- runRedis conn $ flushdb >>=? Ok >> r
+    actual <- readIORef ref
+    HUnit.assertEqual "count" expected actual
+    return t
+
+hooks :: IORef Counts -> Hooks
+hooks ref =
+    defaultHooks
+        { sendRequestHook = \f message -> do
+            modifyIORef ref $ \c -> c {sendRequestCount = succ $ sendRequestCount c}
+            f message
+        , sendPubSubHook = \f message -> do
+            modifyIORef ref $ \c -> c {sendPubSubCount = succ $ sendPubSubCount c}
+            f message
+        , callbackHook = \f message -> do
+            modifyIORef ref $ \c -> c {callbackCount = succ $ callbackCount c}
+            f message
+        , sendHook = \f message -> do
+            modifyIORef ref $ \c -> c {sendCount = succ $ sendCount c}
+            f message
+        , receiveHook = \m -> do
+            modifyIORef ref $ \c -> c {receiveCount = succ $ receiveCount c}
+            m
+        }
+
+(>>=?) :: (Eq a, Show a) => Redis (Either Reply a) -> a -> Redis ()
+redis >>=? expected = redis >>@? (expected HUnit.@=?)
+
+(>>@?) :: (Eq a, Show a) => Redis (Either Reply a) -> (a -> HUnit.Assertion) -> Redis ()
+redis >>@? predicate = do
+    a <- redis
+    liftIO $ case a of
+        Left reply -> HUnit.assertFailure $ "Redis error: " ++ show reply
+        Right actual -> predicate actual
+
+testSetGet :: Test.Test
+testSetGet =
+    testCase
+        "set/get"
+        (Counts 3 0 0 3 3) $ do
+    set "{same}key" "value"     >>=? Ok
+    get "{same}key"             >>=? Just "value"
+ test/MainRedis7.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE LambdaCase #-}+module Main (main) where++import qualified Test.Framework as Test+import Database.Redis+import System.Environment (lookupEnv)+import Tests++main :: IO ()+main = do+    host <- lookupEnv "REDIS_HOST" >>= \case+        Just host -> return host+        Nothing -> return "localhost"+    conn <- connect defaultConnectInfo{ connectAddr = ConnectAddrHostPort host 6379 }+    Test.defaultMain (tests conn)++tests :: Connection -> [Test.Test]+tests conn = map ($ conn) $ [testXCreateGroup7, testXpending7, testXAutoClaim7, testQuit]
+ test/PubSubTest.hs view
@@ -0,0 +1,306 @@+{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE BlockArguments #-}+module PubSubTest (testPubSubThreaded) where++import Control.Concurrent+import Control.Monad+import Control.Concurrent.Async+import Control.Exception+import Data.Function (fix)+import qualified Data.List+import Data.Text (Text)+import Data.Typeable+import Data.ByteString+import Control.Concurrent.STM+import System.Timeout (timeout)+import qualified Test.Framework as Test+import qualified Test.Framework.Providers.HUnit as Test (testCase)+import qualified Test.HUnit as HUnit++import Database.Redis++testPubSubThreaded :: [Connection -> Test.Test]+testPubSubThreaded =+  [ removeAllTest+  , callbackErrorTest+  , removeFromUnregister+  , pendingChannelsTrackingTest+  , subscribeReplyDecodingTracksPendingSets+  , withPubSubTest+  , withPubSubTimeoutTest+  , withPubSubTestBoth+  ]++-- | 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)+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"++waitUntilPendingEmpty :: PubSubController -> IO ()+waitUntilPendingEmpty ctrl = do+  ret <- timeout (5 * 1000 * 1000) loop+  case ret of+    Nothing -> HUnit.assertFailure "Timed out waiting for pending PubSub channels to be cleared"+    Just _ -> return ()+  where+    loop = do+      pendingCh <- pendingChannels ctrl+      pendingPCh <- pendingPatternChannels ctrl+      unless (Prelude.null pendingCh && Prelude.null pendingPCh) $ do+        threadDelay (10 * 1000)+        loop++assertDoesNotHappen :: String -> IO a -> IO ()+assertDoesNotHappen label action = do+  ret <- timeout (700 * 1000) action+  case ret of+    Nothing -> return ()+    Just _ -> HUnit.assertFailure $ "Unexpectedly observed: " ++ label++-- | Verify exported pending sets track add/remove operations before Redis acknowledges requests.+pendingChannelsTrackingTest :: Connection -> Test.Test+pendingChannelsTrackingTest _ = Test.testCase "Multithreaded Pub/Sub - pending channels tracking" $ do+  msgVar <- newTVarIO []+  ctrl <- newPubSubController [] []++  _ <- addChannels ctrl+      [("pending:chan", handler "PendingChan" msgVar)]+      [("pending:*", phandler "PendingPattern" msgVar)]++  pendingCh <- pendingChannels ctrl+  pendingPCh <- pendingPatternChannels ctrl+  HUnit.assertBool "channel should be marked pending" ("pending:chan" `Prelude.elem` pendingCh)+  HUnit.assertBool "pattern channel should be marked pending" ("pending:*" `Prelude.elem` pendingPCh)++  removeChannels ctrl ["pending:chan"] ["pending:*"]++  pendingCh2 <- pendingChannels ctrl+  pendingPCh2 <- pendingPatternChannels ctrl+  HUnit.assertBool "removed channel should no longer be pending" (not $ "pending:chan" `Prelude.elem` pendingCh2)+  HUnit.assertBool "removed pattern channel should no longer be pending" (not $ "pending:*" `Prelude.elem` pendingPCh2)++-- | Exercise subscribe/unsubscribe decoding paths and ensure pending sets are drained per channel type.+subscribeReplyDecodingTracksPendingSets :: Connection -> Test.Test+subscribeReplyDecodingTracksPendingSets conn = Test.testCase "Multithreaded Pub/Sub - decode subscribe/unsubscribe replies" $ do+  msgVar <- newTVarIO []+  initialComplete <- newTVarIO False+  ctrl <- newPubSubController [] []++  withAsync (pubSubForever conn ctrl (atomically $ writeTVar initialComplete True)) $ \_ -> do+    atomically $ readTVar initialComplete >>= \b -> if b then return () else retry++    _ <- addChannels ctrl+        [("decode:chan", handler "DecodeChan" msgVar)]+        [("decode:*", phandler "DecodePattern" msgVar)]++    waitUntilPendingEmpty ctrl++    runRedis conn $ publish "decode:chan" "msg-1"+    waitForMessage msgVar "DecodeChan" "msg-1"++    runRedis conn $ publish "decode:abc" "msg-2"+    waitForPMessage msgVar "DecodePattern" "decode:abc" "msg-2"++    removeChannelsAndWait ctrl ["decode:chan"] ["decode:*"]++    waitUntilPendingEmpty ctrl++    runRedis conn $ publish "decode:chan" "msg-3"+    assertDoesNotHappen "channel callback after unsubscribe" $ waitForMessage msgVar "DecodeChan" "msg-3"++    runRedis conn $ publish "decode:def" "msg-4"+    assertDoesNotHappen "pattern callback after unsubscribe" $ waitForPMessage msgVar "DecodePattern" "decode:def" "msg-4"++withPubSubTest :: Connection -> Test.Test+withPubSubTest conn = Test.testCase "Multithreaded Pub/Sub - withPubSub" $ do+  lock <- newEmptyMVar+  _ <- forkIO $ do+    () <- takeMVar lock+    _ <- runRedis conn $ publish "foo9" "bar"+    pure ()+  result <- withPubSub conn ["foo9"] [] $ \messageSTM -> do+    putMVar lock ()+    atomically messageSTM+  case result of+    Message "foo9" "bar" -> pure ()+    x -> HUnit.assertFailure $ "Received unexpected message: " ++ show x++withPubSubTestBoth :: Connection -> Test.Test+withPubSubTestBoth conn = Test.testCase "Multithreaded Pub/Sub - withPubSub (both chan and pchan)" $ do+  lock <- newEmptyMVar+  _ <- forkIO $ do+    () <- takeMVar lock+    _ <- runRedis conn $ publish "foo100" "bar"+    _ <- runRedis conn $ publish "foo200" "bar"+    pure ()+  result <- withPubSub conn ["foo100"] ["foo2*"] $ \fetch -> do+    putMVar lock ()+    x <- timeout 1000000 $ do+      flip fix (False, False) \next (seenFoo100, seenFoo200) -> do+        unless (seenFoo100 && seenFoo200) do+          msg <- atomically fetch+          case msg of+            Message "foo100" "bar" -> putStrLn "A" >> next (True, seenFoo200)+            PMessage "foo2*" "foo200" "bar" -> putStrLn "B" >>next (seenFoo100, True)+            x -> HUnit.assertFailure $ "Received unexpected message: " ++ show x+    putStrLn "C"+    return x+  case result of+    Nothing -> HUnit.assertFailure $ "Messages were not received"+    Just{} -> pure ()++withPubSubTimeoutTest :: Connection -> Test.Test+withPubSubTimeoutTest conn = Test.testCase "Multithreaded Pub/Sub - withPubSub with timeout" $ do+  result <- withPubSub conn ["foo100"] [] $ \messageSTM -> do+    timeout (100000) $ atomically messageSTM+  case result of+    Nothing -> pure ()+    Just x -> HUnit.assertFailure $ "Expected to timeout without receiving a message, but received: " ++ show x
− test/Test.hs 
@@ -1,520 +0,0 @@-{-# LANGUAGE OverloadedStrings, RecordWildCards #-}-module Main (main) where--import Prelude hiding (catch)-import Control.Applicative-import Control.Concurrent-import Control.Monad-import Control.Monad.Trans-import Data.Monoid (mappend)-import Data.Time-import Data.Time.Clock.POSIX-import qualified Test.Framework as Test (Test, defaultMain)-import qualified Test.Framework.Providers.HUnit as Test (testCase)-import qualified Test.HUnit as HUnit--import Database.Redis------------------------------------------------------------------------------------ Main and helpers----main :: IO ()-main = do-    conn <- connect defaultConnectInfo-    Test.defaultMain (tests conn)--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----------------------------------------------------------------------------------- Tests----tests :: Connection -> [Test.Test]-tests conn = map ($conn) $ concat-    [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog]-    , testsZSets, [testPubSub], [testTransaction], [testScripting]-    , testsConnection, testsServer, [testQuit]-    ]----------------------------------------------------------------------------------- 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"-    -- 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 = 10-    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-        _ignored <- set "key" "value"-        (liftIO $ do-            threadDelay $ 10^(5::Int)-            mvar <- newEmptyMVar-            forkIO $ runRedis conn (get "key") >>= putMVar mvar-            takeMVar mvar)-          >>=? Just "value"----------------------------------------------------------------------------------- Keys----testsKeys :: [Test]-testsKeys = [ testKeys, testExpireAt, testSort, testGetType, testObject ]--testKeys :: Test-testKeys = testCase "keys" $ do-    set "key" "value"     >>=? Ok-    get "key"             >>=? Just "value"-    exists "key"          >>=? True-    keys "*"              >>=? ["key"]-    randomkey             >>=? Just "key"-    move "key" 13         >>=? True-    select 13             >>=? Ok-    expire "key" 1        >>=? True-    pexpire "key" 1000    >>=? True-    Right t <- ttl "key"-    assert $ t `elem` [0..1]-    Right pt <- pttl "key"-    assert $ pt `elem` [990..1000]-    persist "key"         >>=? True-    Right s <- dump "key"-    restore "key'" 0 s    >>=? Ok-    rename "key" "key'"   >>=? Ok-    renamenx "key'" "key" >>=? True-    del ["key"]           >>=? 1-    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")-         ]-    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"                >>=? True, 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-    Right _ <- objectEncoding "key"-    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 [("k1","v1"), ("k2","v2")]   >>=? Ok-    msetnx [("k1","v1"), ("k2","v2")] >>=? False-    mget ["key"]                      >>=? [Just "helloworld"]-    setex "key" 1 "42"                >>=? Ok-    psetex "key" 1000 "42"            >>=? Ok-    decr "key"                        >>=? 41-    decrby "key" 1                    >>=? 40-    incr "key"                        >>=? 41-    incrby "key" 1                    >>=? 42-    incrbyfloat "key" 1               >>=? 43-    del ["key"]                       >>=? 1-    setbit "key" 42 "1"               >>=? 0-    getbit "key" 42                   >>=? 1-    bitcount "key"                    >>=? 1-    bitcountRange "key" 0 (-1)        >>=? 1--testBitops :: Test-testBitops = testCase "bitops" $ do-    set "k1" "a"               >>=? Ok-    set "k2" "b"               >>=? Ok-    bitopAnd "k3" ["k1", "k2"] >>=? 1-    bitopOr "k3" ["k1", "k2"]  >>=? 1-    bitopXor "k3" ["k1", "k2"] >>=? 1-    bitopNot "k3" "k1"         >>=? 1----------------------------------------------------------------------------------- Hashes----testHashes :: Test-testHashes = testCase "hashes" $ do-    hset "key" "field" "value"   >>=? True-    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 "key" ["v3","v2","v1"] >>=? 3-    blpop ["key"] 1              >>=? Just ("key","v1")-    brpop ["key"] 1              >>=? Just ("key","v3")-    rpush "k1" ["v1","v2"]       >>=? 2-    brpoplpush "k1" "k2" 1       >>=? Just "v2"-    rpoplpush "k1" "k2"          >>=? Just "v1"----------------------------------------------------------------------------------- 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 "set" "set'" "member" >>=? False--testSetAlgebra :: Test-testSetAlgebra = testCase "set algebra" $ do-    sadd "s1" ["member"]          >>=? 1-    sdiff ["s1", "s2"]            >>=? ["member"]-    sunion ["s1", "s2"]           >>=? ["member"]-    sinter ["s1", "s2"]           >>=? []-    sdiffstore "s3" ["s1", "s2"]  >>=? 1-    sunionstore "s3" ["s1", "s2"] >>=? 1-    sinterstore "s3" ["s1", "s2"] >>=? 0----------------------------------------------------------------------------------- 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)]-    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 "k1" [(1, "v1"), (2, "v2")]-    zadd "k2" [(2, "v2"), (3, "v3")]-    zinterstore "newkey" ["k1","k2"] Sum                >>=? 1-    zinterstoreWeights "newkey" [("k1",1),("k2",2)] Max >>=? 1-    zunionstore "newkey" ["k1","k2"] Sum                >>=? 3-    zunionstoreWeights "newkey" [("k1",1),("k2",2)] Min >>=? 3----------------------------------------------------------------------------------- HyperLogLog-----testHyperLogLog :: Test-testHyperLogLog = testCase "hyperloglog" $ do-  -- test creation-  pfadd "hll1" ["a"]-  pfcount ["hll1"] >>=? 1-  -- test cardinality-  pfadd "hll1" ["a"]-  pfcount ["hll1"] >>=? 1-  pfadd "hll1" ["b", "c", "foo", "bar"]-  pfcount ["hll1"] >>=? 5-  -- test merge-  pfadd "hll2" ["1", "2", "3"]-  pfadd "hll3" ["4", "5", "6"]-  pfmerge "hll4" ["hll2", "hll3"]-  pfcount ["hll4"] >>=? 6-  -- test union cardinality-  pfcount ["hll2", "hll3"] >>=? 6----------------------------------------------------------------------------------- Pub/Sub----testPubSub :: Test-testPubSub conn = testCase "pubSub" go conn-  where-    go = do-        -- producer-        liftIO $ forkIO $ 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----------------------------------------------------------------------------------- Transaction----testTransaction :: Test-testTransaction = testCase "transaction" $ do-    watch ["k1", "k2"] >>=? Ok-    unwatch            >>=? Ok-    set "foo" "foo"-    set "bar" "bar"-    foobar <- multiExec $ do-        foo <- get "foo"-        bar <- get "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)-        Right scriptHash <- scriptLoad script-        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-        liftIO $ do-            forkIO $ runRedis conn $ do-                -- we must pattern match to block the thread-                Left _ <- eval "while true do end" [] []-                    :: Redis (Either Reply Integer)-                return ()-            threadDelay $ 10^(5 :: Int)-        scriptKill                              >>=? Ok----------------------------------------------------------------------------------- Connection----testsConnection :: [Test]-testsConnection = [ testEcho, testPing, testSelect ]--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----testsServer :: [Test]-testsServer =-    [testServer, testBgrewriteaof, testFlushall, testInfo, testConfig-    ,testSlowlog, testDebugObject]--testServer :: Test-testServer = testCase "server" $ do-    Right (_,_) <- time-    slaveof "no" "one" >>=? Ok-    return ()--testBgrewriteaof :: Test-testBgrewriteaof = testCase "bgrewriteaof/bgsave/save" $ do-    save >>=? Ok-    Right (Status _) <- bgsave-    -- Redis needs time to finish the bgsave-    liftIO $ threadDelay (10^(5 :: Int))-    Right (Status _) <- bgrewriteaof-    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-    Right _ <- info-    Right _ <- lastsave-    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-    Right _ <- debugObject "key"-    return ()
+ test/Tests.hs view
@@ -0,0 +1,1052 @@+{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, LambdaCase, OverloadedLists, TypeApplications #-}+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 Control.Monad.Trans.Except+import Data.ByteString (ByteString)+import Data.Either (isRight)+import qualified Data.List as L+import qualified Data.List.NonEmpty as NE+import Data.Time+import Data.Time.Clock.POSIX+import qualified Test.Framework as Test (Test)+import qualified Test.Framework.Providers.HUnit as Test (testCase)+import qualified Test.HUnit as HUnit+import qualified Test.HUnit.Lang as HUnit.Lang+import Network.Socket (PortNumber)++import Database.Redis+import Data.Either (fromRight)++------------------------------------------------------------------------------+-- helpers+--+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 = redis >>@? (expected HUnit.@=?)++(>>@?) :: (Eq a, Show a) => Redis (Either Reply a) -> (a -> HUnit.Assertion) -> Redis ()+redis >>@? predicate = do+    a <- redis+    liftIO $ case a of+        Left reply -> HUnit.assertFailure $ "Redis error: " ++ show reply+        Right actual -> predicate actual++(<|?>) :: HUnit.Assertion -> HUnit.Assertion -> HUnit.Assertion+a <|?> b = do+    resultA <- HUnit.Lang.performTestCase a+    case resultA of+        HUnit.Lang.Success        -> a+        HUnit.Lang.Failure _ errA -> tryB errA+        HUnit.Lang.Error   _ errA -> tryB errA+        where tryB errA = do+                        resultB <- HUnit.Lang.performTestCase b+                        case resultB of+                            HUnit.Lang.Success        -> b+                            HUnit.Lang.Failure _ errB -> concatErrors errA errB+                            HUnit.Lang.Error   _ errB -> concatErrors errA errB+              concatErrors errA errB = HUnit.Lang.assertFailure ("{" ++ errA ++ "\nOR\n" ++ errB ++ "\n}: Failed")+++assert :: Bool -> Redis ()+assert = liftIO . HUnit.assert++------------------------------------------------------------------------------+-- Miscellaneous+--+testsMisc :: [Test]+testsMisc =+    [ testConstantSpacePipelining, testForceErrorReply, testPipelining+    , testEvalReplies, testGeo+    ]++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-12" "value"+      result <- liftIO $ do+         threadDelay $ 10 ^ (5 :: Int)+         mvar <- newEmptyMVar+         _ <-+           (Async.wait =<< Async.async (runRedis conn (get "key-12"))) >>= putMVar mvar+         takeMVar mvar+      pure result >>=? Just "value"++testGeo :: Test+testGeo = testCase "geo" $ do+    geoadd "{geo}cities" [(13.361389, 38.115556, "Palermo"), (15.087269, 37.502669, "Catania")] >>=? 2+    geoaddOpts "{geo}cities"+        [(13.361389, 38.115556, "Palermo"), (12.496366, 41.902782, "Rome")]+        defaultGeoAddOpts { geoAddCondition = Just Nx, geoAddChange = True } >>=? 1+    geodist "{geo}cities" "Palermo" "Rome" (Just GeoKilometers) >>@? \actual ->+        case actual of+            Just dist -> HUnit.assertBool "Rome should have been inserted by GEOADD NX" (dist > 400)+            Nothing -> HUnit.assertFailure "GEODIST Palermo Rome returned Nothing"+    geoaddOpts "{geo}cities"+        [(9.1900, 45.4642, "Milan")]+        defaultGeoAddOpts { geoAddCondition = Just Xx } >>=? 0++    geodist "{geo}cities" "Palermo" "Catania" Nothing >>@? \actual ->+        case actual of+            Just dist -> HUnit.assertBool "unexpected GEODIST distance in meters" (abs (dist - 166274.1516) < 1000)+            Nothing -> HUnit.assertFailure "GEODIST returned Nothing"++    geopos "{geo}cities" ["Palermo", "Catania"] >>@? \positions ->+        case positions of+            [Just palermo, Just catania] -> do+                assertApprox "Palermo longitude" 13.361389 (geoLongitude palermo)+                assertApprox "Palermo latitude" 38.115556 (geoLatitude palermo)+                assertApprox "Catania longitude" 15.087269 (geoLongitude catania)+                assertApprox "Catania latitude" 37.502669 (geoLatitude catania)+            _ -> HUnit.assertFailure $ "Unexpected GEOPOS response: " ++ show positions++    let searchOpts = defaultGeoSearchOpts+            { geoSearchWithDist = True+            , geoSearchOrder = Just GeoAsc+            }++    geoSearch "{geo}cities" (GeoSearchFromMember "Palermo") (GeoSearchByRadius 200 GeoKilometers) searchOpts >>@? \locations ->+        case locations of+            [palermo, catania] -> do+                HUnit.assertEqual "GEOSEARCH center member" "Palermo" (geoLocationMember palermo)+                HUnit.assertBool "GEOSEARCH distance should be zero for center member" (maybe False (< 0.001) (geoLocationDist palermo))+                HUnit.assertEqual "GEOSEARCH second member" "Catania" (geoLocationMember catania)+            _ -> HUnit.assertFailure $ "Unexpected GEOSEARCH response: " ++ show locations++    geoSearchStore "{geo}near" "{geo}cities" (GeoSearchFromLonLat 15 37) (GeoSearchByRadius 200 GeoKilometers)+        (defaultGeoSearchStoreOpts { geoSearchStoreStoredist = True }) >>=? 2++    zrangeWithscores "{geo}near" 0 (-1) >>@? \members ->+        case members of+            [(firstCity, firstDistance), (secondCity, secondDistance)] -> do+                HUnit.assertEqual "closest stored city" "Catania" firstCity+                HUnit.assertEqual "second stored city" "Palermo" secondCity+                HUnit.assertBool "stored distances should be increasing" (firstDistance < secondDistance)+            _ -> HUnit.assertFailure $ "Unexpected GEOSEARCHSTORE response: " ++ show members+  where+    assertApprox label expected actual =+        HUnit.assertBool label (abs (expected - actual) < 0.0001)++------------------------------------------------------------------------------+-- 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 $ elem @[] t [0..1]+        pttl "{same}key" >>= \case+          Left _ -> error "error"+          Right pt -> do+            assert $ elem @[] pt [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 (NE.fromList ["{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 (NE.fromList ["key"])   >>=? 1+  where+    ts = [ (set "key" "value"                         >>=? Ok,   String)+         , (hset "key" [("field"::ByteString, "value"::ByteString)] >>=? 1,    Hash)+         , (lpush "key" ["value"]                     >>=? 1,    List)+         , (sadd "key" ["member"]                     >>=? 1,    Set)+         , (zadd "key" [(42,"member"),(12.3,"value")] >>=? 2,    ZSet)+         ]++testObject :: Test+testObject = testCase "object" $ do+    set "key" "value"    >>=? Ok+    objectRefcount "key" >>=? 1+    objectEncoding "key" >>= \case+       Left _ -> error "error"+       _ -> return ()+    objectIdletime "key" >>=? 0+    return ()++------------------------------------------------------------------------------+-- 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 (NE.fromList ["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"::ByteString, "another"::ByteString)] >>=? 1+    hset "key" [("field"::ByteString, "another"::ByteString)] >>=? 0+    hset "key" [("field"::ByteString, "value"::ByteString)]   >>=? 0+    hsetnx "key" "field" "value" >>=? False+    hexists "key" "field"        >>=? True+    hlen "key"                   >>=? 1+    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" ["-" :: ByteString] >>=? 0+    rpushx "notAKey" ["-" :: ByteString] >>=? 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+    del ("key" NE.:| [])+    -- keys are pushed sequentially so this will result in a list with value1, value2, value3+    lpush "key" ["value3", "value2", "value1"] >>=? 3+    lpopCount "key" 2 >>=? ["value1", "value2"]+    lpush "key" ["value2", "value1"] >>=? 3+    rpopCount "key" 2 >>=? ["value3", "value2"]+    del ("key" NE.:| [])+    lpush "key" ["value3", "value2", "value1"] >>=? 3+    lpopCount "key" 4 >>=? ["value1", "value2", "value3"]+    del ("key" NE.:| [])+    return ()++testBpop :: Test+testBpop = testCase "blocking push/pop" $ do+    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" (NE.fromList  ["member"]) >>=? 1+    sismember "set" "member"    >>=? True+    scard "set"                 >>=? 1+    smembers "set"              >>=? ["member"]+    srandmember "set"           >>=? Just "member"+    spop "set"                  >>=? Just "member"+    srem "set" (NE.fromList ["member"]) >>=? 0+    smove "{same}set" "{same}set'" "member" >>=? False+    _ <- sadd "set" (NE.fromList ["member1", "member2"])+    (fmap L.sort <$> spopN "set" 2) >>=? ["member1", "member2"]+    _ <- sadd "set" (NE.fromList ["member1", "member2"])+    (fmap L.sort <$> srandmemberN "set" 2) >>=? ["member1", "member2"]++testSetAlgebra :: Test+testSetAlgebra = testCase "set algebra" $ do+    sadd "{same}s1" (NE.fromList ["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" (NE.fromList ["v2"])                   >>=? 1+    zremrangebyscore "key" 10 100                     >>=? 1+    zremrangebyrank "key" 0 0                         >>=? 1++--  testZSets7 :: Test+--  testZSets7 = testCase "sorted sets: redis 7" $ do+--      zadd "key" [(2,"v1"),(0,"v2"),(40,"v3")]          >>=? 3+--      zrankWithScore "key" "v1"                         >>=? Just  (1, 2)++testZStore :: Test+testZStore = testCase "zunionstore/zinterstore" $ do+    zadd "{same}k1" [(1, "v1"), (2, "v2")] >>= \case+      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")++testSet7 :: Test+testSet7 = testCase "Set" $ do+    set "hello" "hi" >>=? Ok+    setOpts "hello" "hi" SetOpts{+        setSeconds           = Nothing,+        setMilliseconds      = Nothing,+        setUnixSeconds       = Just 2000,+        setUnixMilliseconds  = Nothing,+        setCondition         = Nothing,+        setKeepTTL           = False+    } >>=? Ok+    setOpts "hello" "hi" SetOpts{+        setSeconds           = Nothing,+        setMilliseconds      = Nothing,+        setUnixSeconds       = Nothing,+        setUnixMilliseconds  = Just 20000,+        setCondition         = Nothing,+        setKeepTTL           = False+    } >>=? Ok+    setOpts "hello" "hi" SetOpts{+        setSeconds           = Nothing,+        setMilliseconds      = Nothing,+        setUnixSeconds       = Nothing,+        setUnixMilliseconds  = Nothing,+        setCondition         = Nothing,+        setKeepTTL           = True+    } >>=? Ok+    setGet "hello" "henlo" >>=? "hi"+    setGetOpts "hello" "henlo2" SetOpts{+        setSeconds           = Nothing,+        setMilliseconds      = Nothing,+        setUnixSeconds       = Nothing,+        setUnixMilliseconds  = Nothing,+        setCondition         = Just Nx,+        setKeepTTL           = False+    } >>=? "henlo"+    return ()++testZAdd7 :: Test+testZAdd7 = testCase "ZADD" $ do+    zadd "set" [(42, "2")] >>=? 1+    zaddOpts "set" [(44, "6")] (defaultZaddOpts {zaddSizeCondition = Just CGT}) >>=? 1+    zaddOpts "set" [(46, "7")] (defaultZaddOpts {zaddSizeCondition = Just CLT}) >>=? 1+    return ()++------------------------------------------------------------------------------+-- Scripting+--+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 :: String -> PortNumber -> Test+testConnectAuth host port = testCase "connect/auth" $ do+    configSet "requirepass" "pass" >>=? Ok+    liftIO $ do+        c <- checkedConnect defaultConnectInfo { connectAuth = Just "pass", connectAddr = ConnectAddrHostPort host port }+        runRedis c (ping >>=? Pong)+    auth "pass"                    >>=? Ok+    configSet "requirepass" ""     >>=? Ok++testConnectAuthUnexpected :: String -> PortNumber -> Test+testConnectAuthUnexpected host port = testCase "connect/auth/unexpected" $ do+    liftIO $ do+        res <- try $ void $ checkedConnect connInfo+        HUnit.assertEqual "" err res++    where connInfo = defaultConnectInfo { connectAuth = Just "pass", connectAddr = ConnectAddrHostPort host port }+          err = Left $ ConnectAuthError $+                  Error "ERR AUTH <password> called without any password configured for the default user. Are you sure your configuration is correct?"+++testConnectAuthAcl :: String -> PortNumber -> Test+testConnectAuthAcl host port = testCase "connect/auth/acl" $ do+   liftIO $ do+      c <- checkedConnect defaultConnectInfo { connectAddr = ConnectAddrHostPort host port }+      runRedis c $ sendRequest  ["ACL", "SETUSER", "test", "on", ">pass", "~*", "&*", "+@all"] >>=? Ok+   liftIO $ do+      c <- checkedConnect defaultConnectInfo{connectAuth=Just "pass", connectUsername=Just "test", connectAddr = ConnectAddrHostPort host port}+      runRedis c (ping >>=? Pong)+   liftIO $ do+      res <- try $ void $ checkedConnect defaultConnectInfo{connectAuth=Just "pass", connectUsername=Just "test1", connectAddr = ConnectAddrHostPort host port}+      HUnit.assertEqual "" err res+   where+     err = Left $ ConnectAuthError $+             Error "WRONGPASS invalid username-password pair or user is disabled."++testConnectDb :: String -> PortNumber -> Test+testConnectDb host port = testCase "connect/db" $ do+    set "connect" "value" >>=? Ok+    liftIO $ void $ do+        c <- checkedConnect defaultConnectInfo { connectDatabase = 1, connectAddr = ConnectAddrHostPort host port }+        runRedis c (get "connect" >>=? Nothing)++testConnectDbUnexisting :: String -> PortNumber -> Test+testConnectDbUnexisting host port = 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, connectAddr = ConnectAddrHostPort host port }++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+++------------------------------------------------------------------------------+-- Client+--+testClientId :: Test+testClientId = testCase "client id" $ do+    clientId >>= assert . isRight++testClientName :: Test+testClientName = testCase "client {get,set}name" $ do+    clientGetname >>=? Nothing+    clientSetname "FooBar" >>=? Ok+    clientGetname >>=? Just "FooBar"+++------------------------------------------------------------------------------+-- Server+--+testServer :: Test+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++-- |Starting with Redis 7.0.0, the DEBUG command is disabled by default and must be enabled manually in the Redis Config file+testDebugObject :: Test+testDebugObject = testCase "debugObject/debugSegfault" $ do+    return ()+    -- set "key" "value" >>=? Ok+    -- debugObject "key" >>= \case+      -- Left _ -> error "error"+      -- _ -> return ()+    -- return ()++testScans :: Test+testScans = testCase "scans" $ do+    set "key" "value"       >>=? Ok+    scan cursor0            >>=? (cursor0, ["key"])+    scanOpts cursor0 sOpts1 Nothing >>=? (cursor0, ["key"])+    scanOpts cursor0 sOpts2 Nothing >>=? (cursor0, [])+    where sOpts1 = defaultScanOpts { scanMatch = Just "k*" }+          sOpts2 = defaultScanOpts { scanMatch = Just "not*"}++testSScan :: Test+testSScan = testCase "sscan" $ do+    sadd "set" (NE.fromList ["1"]) >>=? 1+    sscan "set" cursor0     >>=? (cursor0, ["1"])++testHScan :: Test+testHScan = testCase "hscan" $ do+    hset "hash" [("k"::ByteString, "v"::ByteString)] >>=? 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")]+        $ xaddTrimOpt (Just $ trimOpts (TrimMaxlen 1) TrimExact)+    xaddOpts "{same}thirdstream" "*" [("k", "v")]+        $ xaddTrimOpt (Just $ trimOpts (TrimMaxlen 1) (TrimApprox Nothing))+    xread [("{same}somestream", "0"), ("{same}otherstream", "0")] >>=? Just [+        XReadResponse {+            stream = "{same}somestream",+            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+    where xaddTrimOpt a = XAddOpts{+        xAddTrimOpts = a,+        xAddnoMkStream = False}++testXReadGroup ::Test+testXReadGroup = testCase "XGROUP */xreadgroup/xack" $ void $ runExceptT $ do+    ExceptT $ xadd "somestream" "123" [("key", "value")]+    ExceptT $ xgroupCreate "somestream" "somegroup" "0"+    readResult <- ExceptT $ xreadGroup "somegroup" "consumer1" [("somestream", ">")]+    liftIO $ readResult HUnit.@=? Just [+        XReadResponse {+            stream = "somestream",+            records = [StreamsRecord{recordId = "123-0", keyValues = [("key", "value")]}]+        }]+    noAcked <- ExceptT $ xack "somestream" "somegroup" ["123-0"]+    liftIO $ noAcked HUnit.@=? 1+    groupMessages <- ExceptT $ xreadGroup "somegroup" "consumer1" [("somestream", ">")]+    liftIO $ groupMessages HUnit.@=? Nothing+    setIdOk <- ExceptT $ xgroupSetId "somestream" "somegroup" "0"+    liftIO $ setIdOk HUnit.@=? Ok+    itemsLeft <- ExceptT $ xgroupDelConsumer "somestream" "somegroup" "consumer1"+    liftIO $ itemsLeft HUnit.@=? 0+    groupDestroyed <- ExceptT (xgroupDestroy "somestream" "somegroup")+    liftIO $ groupDestroyed HUnit.@=? True++testXCreateGroup7 ::Test+testXCreateGroup7 = testCase "XGROUP CREATE" $ do+    xgroupCreateOpts "somestream" "somegroup" "0" XGroupCreateOpts {xGroupCreateMkStream    = True,+                                                                    xGroupCreateEntriesRead = Just "1234"} >>=? Ok+    return ()++testXRange ::Test+testXRange = testCase "xrange/xrevrange" $ do+    xadd "somestream" "121" [("key1", "value1")]+    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" >>=? XPendingSummaryResponse {+        numPendingMessages = 4,+        smallestPendingMessageId = "121-0",+        largestPendingMessageId = "124-0",+        numPendingMessagesByconsumer = [("consumer1", 4)]+    }+    xpendingDetail "somestream" "somegroup" "121" "121" 10 defaultXPendingDetailOpts >>@? (\case+            [XPendingDetailRecord{..}] -> do+                messageId HUnit.@=? "121-0"+            bad -> HUnit.assertFailure $ "Unexpectedly got " ++ show bad+            )++testXpending7 ::Test+testXpending7 = testCase "xpending7" $ void $ runExceptT $ do+    ExceptT $ xadd "somestream" "121" [("key1", "value1")]+    ExceptT $ xadd "somestream" "122" [("key2", "value2")]+    ExceptT $ xadd "somestream" "123" [("key3", "value3")]+    ExceptT $ xadd "somestream" "124" [("key4", "value4")]+    ExceptT $ xgroupCreate "somestream" "somegroup" "0"+    ExceptT $ xgroupCreate "somestream" "somegroup2" "0"+    ExceptT $ xreadGroup "somegroup" "consumer1" [("somestream", ">")]+    ExceptT $ xreadGroup "somegroup2" "consumer2" [("somestream", ">")]+    ackedCount <- ExceptT $ xack "somestream" "somegroup" ["121", "122", "123"]+    liftIO $ ackedCount HUnit.@=? 3+    pendingDetails <- ExceptT $ xpendingDetail "somestream" "somegroup2" "123" "123" 10 XPendingDetailOpts+                    {xPendingDetailIdle     = Just 0,+                     xPendingDetailConsumer = Just "consumer2" }++    liftIO $ case pendingDetails of+        [XPendingDetailRecord{..}] -> do+            messageId HUnit.@=? "123-0"+        bad -> HUnit.assertFailure $ "Unexpectedly got " ++ show bad++testXClaim ::Test+testXClaim =+  testCase "xclaim" $ void $ runExceptT $ do+    storedKey1 <- ExceptT $ xadd "somestream" "121" [("key1", "value1")]+    liftIO $ storedKey1 HUnit.@=? "121-0"+    storedKey2 <- ExceptT $ xadd "somestream" "122" [("key2", "value2")]+    liftIO $ storedKey2 HUnit.@=? "122-0"+    groupCreated <- ExceptT $ xgroupCreate "somestream" "somegroup" "0"+    liftIO $ groupCreated HUnit.@=? Ok+    readResult <- ExceptT $ xreadGroupOpts+      "somegroup"+      "consumer1"+      [("somestream", ">")]+      (defaultXReadGroupOpts {xReadGroupCount = Just 2})+    liftIO $ readResult HUnit.@=? Just+        [ XReadResponse+            { stream = "somestream"+            , records =+                [ StreamsRecord+                    {recordId = "121-0", keyValues = [("key1", "value1")]}+                , StreamsRecord+                    {recordId = "122-0", keyValues = [("key2", "value2")]}+                ]+            }+        ]+    claimed <- ExceptT $ xclaim "somestream" "somegroup" "consumer2" 0 defaultXClaimOpts ["121-0"]+    liftIO $ claimed HUnit.@=? [StreamsRecord {recordId = "121-0", keyValues = [("key1", "value1")]}]+    claimedJustIds <- ExceptT $ xclaimJustIds+      "somestream"+      "somegroup"+      "consumer2"+      0+      defaultXClaimOpts+      ["122-0"]+    liftIO $ claimedJustIds HUnit.@=? ["122-0"]++testXAutoClaim7 ::Test+testXAutoClaim7 =+  testCase "xautoclaim" $ do+    xadd "somestream" "121" [("key1", "value1")] >>=? "121-0"+    xadd "somestream" "122" [("key2", "value2")] >>=? "122-0"+    xgroupCreate "somestream" "somegroup" "0" >>=? Ok+    xreadGroupOpts "somegroup" "consumer1" [("somestream", ">")] defaultXReadGroupOpts { xReadGroupCount = Just 2 }++    let opts = XAutoclaimOpts {+        xAutoclaimCount = Just 1+    }+    xautoclaimJustIdsOpts "somestream" "somegroup" "consumer2" 0 "0-0" opts  >>@? (\case+        XAutoclaimResult{..} -> do+            xAutoclaimClaimedMessages HUnit.@=? ["121-0"]+            xAutoclaimDeletedMessages HUnit.@=? []+            return ())++    xtrim "somestream" (trimOpts (TrimMaxlen 1) TrimExact) >>=? 1+    xautoclaim "somestream" "somegroup" "consumer2" 0 "0-0" >>@? (\case+        XAutoclaimResult{..} -> do+            xAutoclaimClaimedMessages HUnit.@=? [StreamsRecord {+                recordId = "122-0",+                keyValues = [("key2", "value2")]+            }]+            xAutoclaimDeletedMessages HUnit.@=? ["121-0"]+            return ()+        )+    return ()++testXInfo ::Test+-- This test does not work with pipelining because it relies on the certaino order of commands execution+-- and fails if commands reach different nodes.+testXInfo = testCase "xinfo" $ void $ runExceptT $ do+    _ <- ExceptT $ xadd "somestream" "121" [("key1", "value1")]+    _ <- ExceptT $ xadd "somestream" "122" [("key2", "value2")]+    _ <- ExceptT $ xgroupCreate "somestream" "somegroup" "0"+    _ <- ExceptT $ xreadGroupOpts "somegroup" "consumer1" [("somestream", ">")] defaultXReadGroupOpts { xReadGroupCount = Just 2 }++    z <- ExceptT $ xinfoConsumers "somestream" "somegroup"+    liftIO $ case z of+        [XInfoConsumersResponse{..}] -> do+            xinfoConsumerName HUnit.@=? "consumer1"+            xinfoConsumerNumPendingMessages HUnit.@=? 2++        bad -> HUnit.assertFailure $ "Unexpectedly got " ++ show bad++    x <- ExceptT $ xinfoGroups "somestream"+    liftIO $ case x of+        [XInfoGroupsResponse{..}] -> do+            xinfoGroupsGroupName              HUnit.@=? "somegroup"+            xinfoGroupsNumConsumers           HUnit.@=? 1+            xinfoGroupsNumPendingMessages     HUnit.@=? 2+            xinfoGroupsLastDeliveredMessageId HUnit.@=? "122-0"++            (do xinfoGroupsEntriesRead          HUnit.@=? Nothing -- Redis 6+                xinfoGroupsLag                  HUnit.@=? Nothing) <|?>+                (do xinfoGroupsEntriesRead          HUnit.@=? Just 2 -- Redis 7+                    xinfoGroupsLag                  HUnit.@=? Just 0)++        bad -> HUnit.assertFailure $ "Unexpectedly got " ++ show bad++    a <- ExceptT $ xinfoStream "somestream"+    liftIO $ case a of+        XInfoStreamResponse{..} -> do+            xinfoStreamLength         HUnit.@=? 2+            xinfoStreamRadixTreeKeys  HUnit.@=? 1+            xinfoStreamRadixTreeNodes HUnit.@=? 2+            xinfoStreamNumGroups      HUnit.@=? 1+            xinfoStreamLastEntryId    HUnit.@=? "122-0"+            xinfoStreamFirstEntry     HUnit.@=? StreamsRecord {+                                                      recordId = "121-0"+                                                    , keyValues = [("key1", "value1")]}+            xinfoStreamLastEntry      HUnit.@=? StreamsRecord {+                                                      recordId = "122-0"+                                                    , keyValues = [("key2", "value2")] }+            (do xinfoMaxDeletedEntryId    HUnit.@=? Nothing -- Redis 6.0+                xinfoEntriesAdded         HUnit.@=? Nothing+                xinfoRecordedFirstEntryId HUnit.@=? Nothing) <|?> -- Redis 7.0+                (do xinfoMaxDeletedEntryId    HUnit.@=? Just "0-0"+                    xinfoEntriesAdded         HUnit.@=? Just 2+                    xinfoRecordedFirstEntryId HUnit.@=? Just "121-0")+        bad -> HUnit.assertFailure $ "Unexpectedly got " ++ show bad+    return ()++testXDel ::Test+testXDel = testCase "xdel" $ do+    xadd "somestream" "121" [("key1", "value1")]+    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")]+    streamId <- fromRight "" <$> xadd "somestream" "124" [("key4", "value4")]+    xadd "somestream" "125" [("key5", "value5")]+    xtrim "somestream" (trimOpts (TrimMaxlen 3) TrimExact) >>=? 2+    xtrim "somestream" (trimOpts (TrimMinId streamId) TrimExact) >>=? 1