hedis 0.14.4 → 0.16.3
raw patch · 39 files changed
Files
- CHANGELOG +106/−2
- DocTest.hs +0/−6
- README.md +42/−0
- benchmark/Benchmark.hs +3/−2
- hedis.cabal +172/−78
- src/Database/Redis.hs +218/−143
- src/Database/Redis/Cluster.hs +140/−53
- src/Database/Redis/Cluster/Command.hs +36/−3
- src/Database/Redis/Cluster/HashSlot.hs +24/−5
- src/Database/Redis/Commands.hs +1876/−1095
- src/Database/Redis/Connection.hs +115/−55
- src/Database/Redis/ConnectionContext.hs +42/−33
- src/Database/Redis/Core.hs +18/−6
- src/Database/Redis/Core/Internal.hs +10/−2
- src/Database/Redis/Hooks.hs +104/−0
- src/Database/Redis/ManualCommands.hs +5827/−1392
- src/Database/Redis/ManualCommands/BF.hs +284/−0
- src/Database/Redis/ManualCommands/CF.hs +284/−0
- src/Database/Redis/ManualCommands/Cms.hs +161/−0
- src/Database/Redis/ManualCommands/FT.hs +1397/−0
- src/Database/Redis/ManualCommands/Function.hs +165/−0
- src/Database/Redis/ManualCommands/JSON.hs +621/−0
- src/Database/Redis/ManualCommands/Tdigest.hs +285/−0
- src/Database/Redis/ManualCommands/Topk.hs +144/−0
- src/Database/Redis/ManualCommands/Ts.hs +756/−0
- src/Database/Redis/ManualCommands/Wait.hs +52/−0
- src/Database/Redis/ProtocolPipelining.hs +23/−17
- src/Database/Redis/PubSub.hs +316/−130
- src/Database/Redis/PubSub.hs-boot +8/−0
- src/Database/Redis/Sentinel.hs +25/−21
- src/Database/Redis/Types.hs +17/−2
- src/Database/Redis/URL.hs +103/−26
- test/ClusterMain.hs +28/−10
- test/Main.hs +36/−10
- test/MainHooks.hs +68/−0
- test/MainRedis7.hs +32/−0
- test/MainRedis8.hs +28/−0
- test/PubSubTest.hs +137/−5
- test/Tests.hs +2231/−788
CHANGELOG view
@@ -1,5 +1,109 @@ # Changelog for Hedis +## 0.16.3++- Fix disconnect. Thanks to Andrey Prokopenko (and Chordify)++## 0.16.2++- Add support for Redis 8.8 commands: `arcount`, `ardel`, `argetrange`, `argrep`, `argrepOpts`, `argrepWithValues`, `argrepWithValuesOpts`, `arinfo`, `arinfoFull`, `arinsert`, `arlastitems`, `arlastitemsOpts`, `arlen`, `armget`, `arnext`, `aropValue`, `aropCount`, `arring`, `arscan`, `arscanOpts`, `arseek`, `arset`, `increx`, `xidmprecord`, `xcfgset`, `xnack`.+- Add support for Redis 8.6 commands: `commandList`, `hotkeysStart`, `hotkeysGet`, `hotkeysStartOpts`, `hotkeysStop`, `hotkeysReset`.+- Add support for Redis 8.4 commands: `DELEX`, `DIGEST`, `MSETEX`, `VRANGE`, and `CLUSTER MIGRATION`.+- Add support for Redis 8.2 stream and cluster commands: `XACKDEL`, `XDELEX`, and `CLUSTER SLOT-STATS`.+- Add support for additional Redis 6.2, 7.0, 8.0 commands (COPY, GETDEL/GETEX, HRANDFIELD, LMPOP/ZMPOP, SINTERCARD, FUNCTIONS, COMMAND LIST, etc.)+- Add support for Redis vector set commands+- Add support for RedisJSON commands including `jsonArrappend`, `jsonArrindex`, `jsonArrindexOpts`, `jsonArrlen`, `jsonArrlenAt`, `jsonArrinsert`, `jsonArrpop`, `jsonArrpopAt`, `jsonArrpopAtIndex`, `jsonArrtrim`, `jsonClear`, `jsonClearAt`, `jsonDebug`, `jsonDebugMemory`, `jsonDebugMemoryAt`, `jsonDel`, `jsonDelAt`, `jsonForget`, `jsonForgetAt`, `jsonGet`, `jsonGetOpts`, `jsonMerge`, `jsonMget`, `jsonMset`, `jsonNumincrby`, `jsonNummultby`, `jsonObjkeys`, `jsonObjkeysAt`, `jsonObjlen`, `jsonObjlenAt`, `jsonResp`, `jsonRespAt`, `jsonSet`, `jsonSetOpts`, `jsonStrappend`, `jsonStrappendAt`, `jsonToggle`, `jsonType`, and `jsonTypeAt`.+- Add support for Top-K sketch commands: `topkAdd`, `topkCount`, `topkIncrby`, `topkInfo`, `topkList`, `topkListWithCount`, `topkReserve`, and `topkQuery`.+- Add support for t-digest sketch commands: `tdigestAdd`, `tdigestByrank`, `tdigestByrevrank`, `tdigestCdf`, `tdigestCreate`, `tdigestCreateOpts`, `tdigestInfo`, `tdigestMax`, `tdigestMerge`, `tdigestMergeOpts`, `tdigestMin`, `tdigestQuantile`, `tdigestRank`, `tdigestReset`, `tdigestRevrank`, and `tdigestTrimmedMean`.+- Add support for RedisTimeSeries commands: `tsAdd`, `tsAddOpts`, `tsAlter`, `tsCreate`, `tsCreateOpts`, `tsCreaterule`, `tsCreateruleAlign`, `tsDecrby`, `tsDecrbyOpts`, `tsDel`, `tsDelrule`, `tsGet`, `tsGetOpts`, `tsIncrby`, `tsIncrbyOpts`, `tsInfo`, `tsInfoOpts`, `tsMadd`, `tsMget`, `tsMgetOpts`, `tsMrange`, `tsMrangeOpts`, `tsMrevrange`, `tsMrevrangeOpts`, `tsQueryindex`, `tsRange`, `tsRangeOpts`, `tsRevrange`, and `tsRevrangeOpts`.+- Add support for wait commands: `wait` and `waitaof`.+- Add a dedicated function command module reexporting `functionDelete`, `functionDump`, `functionFlush`, `functionFlushOpts`, `functionKill`, `functionLoad`, `functionLoadReplace`, `functionRestore`, `functionRestoreOpts`, and `functionStats`.++## 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@@ -156,7 +260,7 @@ ## 0.9.9 -* PR #90. set SO_KEEPALIVE option on underlying connection socket +* PR #90. set SO_KEEPALIVE option on underlying connection socket ## 0.9.8 @@ -211,7 +315,7 @@ ## 0.7.0 -* Enforce all replies being recieved in runRedis. Pipelining between runRedis +* Enforce all replies being recieved in runRedis. Pipelining between runRedis calls doesn't work now. ## 0.6.10
− DocTest.hs
@@ -1,6 +0,0 @@-module Main (main) where--import Test.DocTest--main :: IO ()-main = doctest ["-isrc", "src"]
+ README.md view
@@ -0,0 +1,42 @@+# Welcome to hedis++[](https://github.com/informatikr/hedis/actions/workflows/haskell-ci.yml)++This is a Redis client library for the Haskell programming language. Please consult the library's [Hackage page](http://hackage.haskell.org/package/hedis) for documentation.++# Testimonials++Ben Gamari+[writes](https://groups.google.com/forum/?fromgroups#!topic/redis-db/uJSp7ZcQTew):++> Having evaluated the options in this space, [Hedis] is in my opinion the best+> of the bunch with an active maintainer, a simple interface, excellent+> documentation, and superb performance.++Email from a user, regarding the 0.5 release (10.05.2012):++> The new multiExec function is really great. [...] We are using it in our+> commercial product at Janrain and are very happy!++Andrew Frederick Cowie [mentioned hedis](http://research.operationaldynamics.com/~andrew/talks/TheWebProblem,SolvingItInHaskell/TheWebProblem.html#Redirector introduction) in a talk:++> _Nice_ Haskell bindings.++# Join in!++We are happy to receive bug reports, fixes, documentation enhancements, and other improvements.++Please report bugs via the [github issue tracker](http://github.com/informatikr/hedis/issues).++Master [git repository](http://github.com/informatikr/hedis):++``` sh+git clone git://github.com/informatikr/hedis.git+```++# Authors++This library is written by Falko Peters <falko.peters@gmail.com>.+Ex-maintainer by Kostiantyn Rybnikov <k-bx@k-bx.com>.+Currently maintained by Alexander Vershilov <alexander.vershilov@tweag.io>+
benchmark/Benchmark.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, LambdaCase #-}+{-# LANGUAGE OverloadedStrings, LambdaCase, OverloadedLists #-} module Main where @@ -40,7 +40,8 @@ action liftIO $ putMVar done () - let timeAction name nActions action = do+ let+ timeAction name nActions action = do startT <- getCurrentTime -- each clients runs ACTION nRepetitions times let nRepetitions = nRequests `div` nClients `div` nActions
hedis.cabal view
@@ -1,5 +1,7 @@+cabal-version: 3.0+build-type: Simple name: hedis-version: 0.14.4+version: 0.16.3 synopsis: Client library for the Redis datastore: supports full command set, pipelining.@@ -7,47 +9,50 @@ Redis is an open source, advanced key-value store. It is often referred to as a data structure server since keys can contain strings, hashes, lists, sets and sorted sets. This library is a Haskell client for the Redis- datastore. Compared to other Haskell client libraries it has some+ datastore.++ Compared to other Haskell client libraries it has some advantages:- .- [Compatibility with Latest Stable Redis:] Hedis is intended- to be used with the latest stable version of Redis (currently 5.0).- Most redis commands (<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.- .- [Automatic Optimal Pipelining:] Commands are pipelined- (<http://redis.io/topics/pipelining>) as much as possible without any- work by the user. See- <http://informatikr.com/2012/redis-pipelining.html> for a- technical explanation of automatic optimal pipelining.- .- [Enforced Pub\/Sub semantics:] When subscribed to the Redis Pub\/Sub server- (<http://redis.io/topics/pubsub>), clients are not allowed to issue- commands other than subscribing to or unsubscribing from channels. This- library uses the type system to enforce the correct behavior.- .- [Connect via TCP or Unix Domain Socket:] TCP sockets are the default way to- connect to a Redis server. For connections to a server on the same- machine, Unix domain sockets offer higher performance than the standard- TCP connection.- .++ * __Compatibility with Latest Stable Redis:__ Hedis is intended to be used with any+ version of Redis starting with 5.0 to 8.8. But pay attention to the Since annotation+ that tells when the command was introduced in Redis. The library does not provide+ static checks and unsupported commands will result in a runtime error.+ 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.+ * __Automatic Optimal Pipelining:__ Commands are pipelined+ (<http://redis.io/topics/pipelining>) as much as possible without any+ work by the user. See+ <http://informatikr.com/2012/redis-pipelining.html> for a+ technical explanation of automatic optimal pipelining.+ * __Enforced Pub\/Sub semantics:__ When subscribed to the Redis Pub\/Sub server+ (<http://redis.io/topics/pubsub>), clients are not allowed to issue+ commands other than subscribing to or unsubscribing from channels. This+ library uses the type system to enforce the correct behavior.+ * __Connect via TCP or Unix Domain Socket:__ TCP sockets are the default way to+ connect to a Redis server. For connections to a server on the same+ machine, Unix domain sockets offer higher performance than the standard+ TCP connection.+ * __Cluster and multi-instance support:__ Hedis supports Redis Cluster and Redis Sentinel.+ For detailed documentation, see the "Database.Redis" module.- .-license: BSD3+license: BSD-3-Clause license-file: LICENSE author: Falko Peters <falko.peters@gmail.com>-maintainer: Kostiantyn Rybnikov <k-bx@k-bx.com>+maintainer: Kostiantyn Rybnikov <k-bx@k-bx.com>, Alexander Vershilov <alexander.vershilov@tweag.io> copyright: Copyright (c) 2011 Falko Peters category: Database-build-type: Simple-cabal-version: >=1.10 homepage: https://github.com/informatikr/hedis bug-reports: https://github.com/informatikr/hedis/issues-extra-source-files: CHANGELOG+extra-source-files:+ CHANGELOG,+ README.md +tested-with: GHC == { 9.6.7, 9.8.4, 9.10.3, 9.12.4, 9.14.1 }+ source-repository head type: git location: https://github.com/informatikr/hedis@@ -57,57 +62,77 @@ default: False manual: True +flag cluster+ description: enable it to run cluster tests if you have required setup+ default: False+ manual: True+ library default-language: Haskell2010 hs-source-dirs: src- ghc-options: -Wall -fwarn-tabs- if impl(ghc >= 8.6.0)- ghc-options: -Wno-warnings-deprecations+ ghc-options: -Wall -Wcompat+ if impl(ghc >= 9.8)+ ghc-options: -Wno-x-partial if flag(dev) ghc-options: -Werror if flag(dev) ghc-prof-options: -auto-all exposed-modules: Database.Redis- , Database.Redis.Sentinel+ , Database.Redis.Cluster+ , Database.Redis.Cluster.Command+ , Database.Redis.Cluster.HashSlot+ , Database.Redis.Commands+ , Database.Redis.Connection+ , Database.Redis.ConnectionContext+ , Database.Redis.Core , Database.Redis.Core.Internal- build-depends: scanner >= 0.2,- async >= 2.1,- base >= 4.8 && < 5,- bytestring >= 0.9,- bytestring-lexing >= 0.5,- exceptions,- unordered-containers,- containers,- text,- deepseq,- mtl >= 2,- network >= 2 && < 3.2,- resource-pool >= 0.2,- stm,- time,- tls >= 1.3,- vector >= 0.9,- HTTP,- errors,- network-uri+ , Database.Redis.Hooks+ , Database.Redis.ManualCommands+ , Database.Redis.ManualCommands.BF+ , Database.Redis.ManualCommands.CF+ , Database.Redis.ManualCommands.Cms+ , Database.Redis.ManualCommands.FT+ , Database.Redis.ManualCommands.Function+ , Database.Redis.ManualCommands.JSON+ , Database.Redis.ManualCommands.Tdigest+ , Database.Redis.ManualCommands.Ts+ , Database.Redis.ManualCommands.Topk+ , Database.Redis.ManualCommands.Wait+ , Database.Redis.Protocol+ , Database.Redis.ProtocolPipelining+ , Database.Redis.PubSub+ , Database.Redis.Sentinel+ , Database.Redis.Transactions+ , Database.Redis.Types+ , Database.Redis.URL+ build-depends: scanner >= 0.2 && <0.4,+ async >= 2.1 && <2.3,+ base >= 4.18 && < 5,+ bytestring >= 0.9 && <0.13,+ bytestring-lexing >= 0.5 && <0.6,+ exceptions >= 0.10 && <0.11,+ unordered-containers >= 0.2 && <0.3,+ containers >= 0.6 && <0.9,+ http-types >= 0.12 && <0.13,+ text >= 2.0 && <2.2,+ deepseq <1.6,+ mtl >= 2 && <3,+ network >= 2 && < 3.3,+ resource-pool >= 0.5 && <0.6,+ stm < 2.6,+ time < 1.17,+ tls >= 1.3 && <2.5,+ vector >= 0.9 && <0.14,+ HTTP < 4001,+ errors < 2.4,+ network-uri < 2.7,+ unliftio-core < 0.2.2,+ hashable <1.6 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.11 && < 0.19 - other-modules: Database.Redis.Core,- Database.Redis.Connection,- Database.Redis.Cluster,- Database.Redis.Cluster.HashSlot,- Database.Redis.Cluster.Command,- Database.Redis.ProtocolPipelining,- Database.Redis.Protocol,- Database.Redis.PubSub,- Database.Redis.Transactions,- Database.Redis.Types- Database.Redis.Commands,- Database.Redis.ManualCommands,- Database.Redis.URL,- Database.Redis.ConnectionContext+ other-extensions: StrictData benchmark hedis-benchmark default-language: Haskell2010@@ -118,7 +143,7 @@ mtl >= 2.0, hedis, time >= 1.2- ghc-options: -O2 -Wall -rtsopts+ ghc-options: -Wall -rtsopts if flag(dev) ghc-options: -Werror if flag(dev)@@ -140,9 +165,38 @@ stm, text, mtl == 2.*,+ network, test-framework, test-framework-hunit,+ transformers, time+ ghc-options: -Wall -rtsopts -fno-warn-unused-do-bind+ 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)@@ -150,11 +204,11 @@ if flag(dev) ghc-prof-options: -auto-all -test-suite hedis-test-cluster+test-suite redis8 default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test- main-is: ClusterMain.hs+ main-is: MainRedis8.hs other-modules: PubSubTest Tests build-depends:@@ -166,8 +220,10 @@ stm, text, mtl == 2.*,+ network, test-framework, test-framework-hunit,+ transformers, time -- We use -O0 here, since GHC takes *very* long to compile so many constants ghc-options: -O0 -Wall -rtsopts -fno-warn-unused-do-bind@@ -176,11 +232,49 @@ if flag(dev) ghc-prof-options: -auto-all -test-suite doctest+test-suite hedis-test-cluster default-language: Haskell2010 type: exitcode-stdio-1.0- main-is: DocTest.hs- ghc-options: -O0 -rtsopts+ hs-source-dirs: test+ main-is: ClusterMain.hs+ other-modules: PubSubTest+ Tests build-depends: base == 4.*,- doctest+ bytestring >= 0.10,+ hedis,+ HUnit,+ async,+ stm,+ text,+ mtl == 2.*,+ network,+ test-framework,+ test-framework-hunit,+ time,+ transformers+ -- We use -O0 here, since GHC takes *very* long to compile so many constants+ ghc-options: -O0 -Wall -rtsopts -fno-warn-unused-do-bind+ if flag(dev)+ ghc-options: -Werror+ ghc-prof-options: -auto-all+ if !flag(cluster)+ buildable: False++test-suite hedis-test-hooks+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: MainHooks.hs+ build-depends:+ base == 4.*,+ hedis,+ HUnit,+ test-framework,+ test-framework-hunit+ -- We use -O0 here, since GHC takes *very* long to compile so many constants+ ghc-options: -O0 -Wall -rtsopts -fno-warn-unused-do-bind -Wunused-packages+ if flag(dev)+ ghc-options: -Werror+ if flag(dev)+ ghc-prof-options: -auto-all
src/Database/Redis.hs view
@@ -1,86 +1,95 @@ module Database.Redis (- -- * How To Use This Module- -- |- -- Connect to a Redis server:- --- -- @- -- -- connects to localhost:6379- -- conn <- 'checkedConnect' 'defaultConnectInfo'- -- @+ -- * How To Use This Package+ -- $package-usage++ -- ** Managing connections+ -- $connection-management+ Connection,+ -- | To create a connection one need to contruct a 'ConnectInfo' record.+ -- The easiest way to do this is to use the 'parseConnectInfo' function, which takes a URL and returns a 'ConnectInfo' record.+ ConnectInfo(..),+ ConnectAddr(..),+ defaultConnectInfo, parseConnectInfo,+ disconnect, --- -- Connect to a Redis server using TLS:+ -- *** Single node --- -- @- -- -- connects to foobar.redis.cache.windows.net:6380- -- import Network.TLS- -- import Network.TLS.Extra.Cipher- -- import Data.X509.CertificateStore- -- import Data.Default.Class (def)- -- (Just certStore) <- readCertificateStore "azure-redis.crt"- -- let tlsParams = (defaultParamsClient "foobar.redis.cache.windows.net" "") { clientSupported = def { supportedCiphers = ciphersuite_strong }, clientShared = def { sharedCAStore = certStore } }- -- let redisConnInfo = defaultConnectInfo { connectHost = "foobar.redis.cache.windows.net", connectPort = PortNumber 6380, connectTLSParams = Just tlsParams, connectAuth = Just "Foobar!" }- -- conn <- checkedConnect redisConnInfo- -- @+ -- | If you are connecting to a single Redis node, use the 'connect' or 'checkedConnect' functions.+ connect,+ checkedConnect,+ withConnect,+ withCheckedConnect,+ ConnectError(..),+ -- *** Clustered --- -- Send commands to the server:+ -- | If you are connecting to a Redis cluster, use the 'connectCluster' or 'checkedConnectCluster' functions. --- -- @- -- {-\# LANGUAGE OverloadedStrings \#-}- -- ...- -- 'runRedis' conn $ do- -- 'set' \"hello\" \"hello\"- -- set \"world\" \"world\"- -- hello <- 'get' \"hello\"- -- world <- get \"world\"- -- liftIO $ print (hello,world)- -- @+ -- At this point, some functions are not supported in the cluster mode: --- -- disconnect all idle resources in the connection pool:+ -- * CONFIG+ -- * AUTH+ -- * SCAN+ -- * MOVE, SELECT+ -- * RESET+ connectCluster, checkedConnectCluster,+ ClusterConnectError (..),+ -- *** Sentinel+ -- | If you are connecting to a Redis sentinel, use functions from the "Database.Redis.Sentinel" module,+ -- such as 'Database.Redis.Sentinel.connect' or 'Database.Redis.Sentinel.checkedConnectSentinel'. --- -- @- -- 'disconnect' 'conn'- -- @+ -- Those functions live in a separate module to simplify move from the Single-node to Sentinel mode. - -- ** Command Type Signatures- -- |Redis commands behave differently when issued in- or outside of a- -- transaction. To make them work in both contexts, most command functions- -- have a type signature similar to the following:- --- -- @- -- 'echo' :: ('RedisCtx' m f) => ByteString -> m (f ByteString)- -- @- --- -- Here is how to interpret this type signature:- --- -- * The argument types are independent of the execution context. 'echo'- -- always takes a 'ByteString' parameter, whether in- or outside of a- -- transaction. This is true for all command functions.- --- -- * All Redis commands return their result wrapped in some \"container\".- -- The type @f@ of this container depends on the commands execution- -- context @m@. The 'ByteString' return type in the example is specific- -- to the 'echo' command. For other commands, it will often be another- -- type.+ -- ** Running Commands+ -- $command-type-signatures+ module Database.Redis.Commands,++ -- | It's important to understand several features that the library provides.++ -- *** Automatic Pipelining+ -- $pipelining++ -- *** Error Behavior+ -- |+ -- [Operations against keys holding the wrong kind of value:] Outside of a+ -- transaction, if the Redis server returns an 'Error', command functions+ -- will return 'Left' the 'Reply'. The library user can inspect the error+ -- message to gain information on what kind of error occured. --- -- * In the \"normal\" context 'Redis', outside of any transactions,- -- results are wrapped in an @'Either' 'Reply'@.+ -- [Connection to the server lost:] In case of a lost connection, command+ -- functions throw a 'ConnectionLostException'. It can only be caught+ -- outside of 'runRedis'. --- -- * Inside a transaction, in the 'RedisTx' context, results are wrapped in- -- a 'Queued'.+ -- [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. --- -- In short, you can view any command with a 'RedisCtx' constraint in the- -- type signature, to \"have two types\". For example 'echo' \"has both- -- types\":+ -- [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. --- -- @- -- echo :: ByteString -> Redis (Either Reply ByteString)- -- echo :: ByteString -> RedisTx (Queued ByteString)- -- @++ -- ** Transactions --- -- [Exercise] What are the types of 'expire' inside a transaction and- -- 'lindex' outside of a transaction? The solutions are at the very- -- bottom of this page.+ -- | 'hedis' supports Redis transactions. See "Database.Redis.Transactions" for more information.+ module Database.Redis.Transactions, + -- ** Pub\/Sub+ -- | 'hedis' supports Redis Pub/Sub. See "Database.Redis.PubSub" for more information.+ module Database.Redis.PubSub,++ -- * Advanced Usage++ -- ** The Redis Monad+ Redis(), runRedis, runRedisNonBlocking,+ unRedis, reRedis,+ RedisCtx(..), MonadRedis(..),++ -- ** Lua Scripting -- |Lua values returned from the 'eval' and 'evalsha' functions will be -- converted to Haskell values by the 'decode' function from the@@ -115,99 +124,34 @@ -- documents the exact semantics of the scripting commands and value -- conversion. - -- ** Automatic Pipelining- -- |Commands are automatically pipelined as much as possible. For example,- -- in the above \"hello world\" example, all four commands are pipelined.- -- Automatic pipelining makes use of Haskell's laziness. As long as a- -- previous reply is not evaluated, subsequent commands can be pipelined.- --- -- Automatic pipelining is limited to the scope of 'runRedis' call and- -- it is guaranteed that every reply expected as a part of 'runRedis'- -- execution gets received after 'runRedis` invocation.- --- -- To keep memory usage low, the number of requests \"in the pipeline\" is- -- limited (per connection) to 1000. After that number, the next command is- -- sent only when at least one reply has been received. That means, command- -- functions may block until there are less than 1000 outstanding replies.- ---- -- ** Error Behavior- -- |- -- [Operations against keys holding the wrong kind of value:] Outside of a- -- transaction, if the Redis server returns an 'Error', command functions- -- will return 'Left' the 'Reply'. The library user can inspect the error- -- message to gain information on what kind of error occured.- --- -- [Connection to the server lost:] In case of a lost connection, command- -- functions throw a 'ConnectionLostException'. It can only be caught- -- outside of 'runRedis'.- --- -- [Trying to connect to an unreachable server:] When trying to connect to- -- a server that does not exist or can't be reached, the connection pool- -- only starts the first connection when actually executing a call to- -- the server. This can lead to discovering very late that the server is- -- not available, for example when running a server that logs to Redis.- -- To prevent this, run a 'ping' command directly after connecting or- -- use the 'checkedConnect' function which encapsulates this behavior.- --- -- [Exceptions:] Any exceptions can only be caught /outside/ of 'runRedis'.- -- This way the connection pool can properly close the connection, making- -- sure it is not left in an unusable state, e.g. closed or inside a- -- transaction.- ---- -- * The Redis Monad- Redis(), runRedis,- unRedis, reRedis,- RedisCtx(..), MonadRedis(..),-- -- * Connection- Connection, ConnectError(..), connect, checkedConnect, disconnect,- withConnect, withCheckedConnect,- ConnectInfo(..), defaultConnectInfo, parseConnectInfo, connectCluster,- PortID(..),-- -- * Commands- module Database.Redis.Commands,-- -- * Transactions- module Database.Redis.Transactions,-- -- * Pub\/Sub- module Database.Redis.PubSub,+ -- ** Hooks+ Hooks(..), SendRequestHook, SendPubSubHook, CallbackHook, SendHook, ReceiveHook, defaultHooks, - -- * Low-Level Command API+ -- ** Low-Level Command API sendRequest,- Reply(..), Status(..), RedisResult(..), ConnectionLostException(..),+ Reply(..), Status(..), RedisArg(..), RedisResult(..), ConnectionLostException(..), ConnectTimeout(..),-- -- |[Solution to Exercise]- --- -- Type of 'expire' inside a transaction:- --- -- > expire :: ByteString -> Integer -> RedisTx (Queued Bool)- --- -- Type of 'lindex' outside of a transaction:- --- -- > lindex :: ByteString -> Integer -> Redis (Either Reply ByteString)- -- HashSlot, keyToSlot ) where import Database.Redis.Core import Database.Redis.Connection ( runRedis+ , runRedisNonBlocking , connectCluster , defaultConnectInfo , ConnectInfo(..) , disconnect , checkedConnect , connect+ , checkedConnectCluster+ , connectCluster , ConnectError(..)+ , ClusterConnectError(..) , Connection(..) , withConnect , withCheckedConnect)-import Database.Redis.ConnectionContext(PortID(..), ConnectionLostException(..), ConnectTimeout(..))+import Database.Redis.ConnectionContext(ConnectAddr(..), ConnectionLostException(..), ConnectTimeout(..)) import Database.Redis.PubSub import Database.Redis.Protocol import Database.Redis.Transactions@@ -216,3 +160,134 @@ import Database.Redis.Commands import Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot)++-- $package-usage+--+--+-- Simplest usage of this package is to connect to a Redis server and run commands against it and close connection when done:+--+-- Connect to a Redis server:+--+-- @+-- let Right ci = 'parseConnectInfo' "redis://localhost:6379"+-- conn <- 'checkedConnect' ci+-- @+--+-- 'connect' or 'checkedConnect' creates a connection pool under the hood. This poll manages reuse of the connections connection livetimes,+-- and connection restore in the case of the connection loss.+--+-- Send commands to the server:+--+-- @+-- {-\# LANGUAGE OverloadedStrings \#-}+-- ...+-- 'runRedis' conn $ do+-- 'set' \"hello\" \"hello\"+-- 'set' \"world\" \"world\"+-- hello <- 'get' \"hello\"+-- world <- 'get' \"world\"+-- liftIO $ 'print' (hello,world)+-- @+--+-- disconnect all idle resources in the connection pool, and destroy the pool:+--+-- @+-- 'disconnect' 'conn'+-- @+--++-- $connection-management+--+-- Redis connections are managed by a connection pool enclosed in the 'Connection' type, that keeps all required state.++--+-- @+-- -- 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+-- @+--+-- See following sections for more details on the connection options and command behavior.+--++-- $command-type-signatures+-- Redis commands behave differently when issued in- or outside of a+-- transaction. To make them work in both contexts, most command functions+-- have a type signature similar to the following:+--+-- @+-- 'echo' :: ('RedisCtx' m f) => ByteString -> m (f ByteString)+-- @+--+-- Here is how to interpret this type signature:+--+-- * The argument types are independent of the execution context. 'echo'+-- always takes a 'ByteString' parameter, whether in- or outside of a+-- transaction. This is true for all command functions.+--+-- * All Redis commands return their result wrapped in some \"container\".+-- The type @f@ of this container depends on the commands execution+-- context @m@. The 'ByteString' return type in the example is specific+-- to the 'echo' command. For other commands, it will often be another+-- type.+--+-- * In the \"normal\" context 'Redis', outside of any transactions,+-- results are wrapped in an @'Either' 'Reply'@.+--+-- * Inside a transaction, in the 'RedisTx' context, results are wrapped in+-- a 'Queued'.+--+-- In short, you can view any command with a 'RedisCtx' constraint in the+-- type signature, to \"have two types\". For example 'echo' \"has both+-- types\":+--+-- @+-- echo :: ByteString -> Redis (Either Reply ByteString)+-- echo :: ByteString -> RedisTx (Queued ByteString)+-- @+--+-- To see all commands refer to the "Database.Redis.Commands" module:++-- $pipelining+-- Commands are automatically pipelined as much as possible. For example,+-- in the above \"hello world\" example, all four commands are pipelined.+-- Automatic pipelining makes use of Haskell's laziness. As long as a+-- previous reply is not evaluated, subsequent commands can be pipelined.+--+-- Automatic pipelining is limited to the scope of 'runRedis' call and+-- it is guaranteed that every reply expected as a part of 'runRedis'+-- execution gets received after 'runRedis` invocation.+--+-- To keep memory usage low, the number of requests \"in the pipeline\" is+-- limited (per connection) to 1000. After that number, the next command is+-- sent only when at least one reply has been received. That means, command+-- functions may block until there are less than 1000 outstanding replies.+--+-- This feature has several implications. Consider the following example:+--+-- @+-- 'runRedis' conn $ do+-- 'set' "key1" "value1"+-- _ <- 'get' "nonexistingkey"+-- 'set' "key2" "value2"+-- @+--+-- Even the "nonexistingkey" does not exist and would return a error it does not+-- prevent commands from execution, so both @key1@ and @key2@ will be updated.+--+-- To enforce verification of the reply one could wrap commands in ExceptT:+--+-- @+-- 'runRedis' conn $ runExceptT $ do+-- ExceptT $ 'set' "key1" "value1"+-- _ <- ExceptT $'get' "nonexistingkey"+-- ExceptT $ 'set' "key2" "value2"+-- @+--+-- But this code will break the pipelining and second command will be sent only after first command reply is received.
src/Database/Redis/Cluster.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module Database.Redis.Cluster@@ -12,30 +13,37 @@ , HashSlot , Shard(..) , connect+ , connectWith , disconnect , requestPipelined , nodes+ , hooks+ , requestMasterNodes+ , masterNodes+ , getRandomConnection ) where import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as Char8 import qualified Data.IORef as IOR import Data.List(nub, sortBy, find)+import Data.Maybe(mapMaybe, fromMaybe) import Data.Map(fromListWith, assocs) import Data.Function(on)-import Control.Exception(Exception, throwIO, BlockedIndefinitelyOnMVar(..), catches, Handler(..))+import Control.Exception(Exception, throwIO, BlockedIndefinitelyOnMVar(..), catches, Handler(..), bracketOnError, uninterruptibleMask_) import Control.Concurrent.MVar(MVar, newMVar, readMVar, modifyMVar, modifyMVar_)-import Control.Monad(zipWithM, when, replicateM)+import Control.Monad(zipWithM, when, replicateM, forM_) import Database.Redis.Cluster.HashSlot(HashSlot, keyToSlot) import qualified Database.Redis.ConnectionContext as CC import qualified Data.HashMap.Strict as HM import qualified Data.IntMap.Strict as IntMap-import Data.Typeable import qualified Scanner import System.IO.Unsafe(unsafeInterleaveIO) -import Database.Redis.Protocol(Reply(Error), renderRequest, reply)+import Database.Redis.Protocol(Reply(..), renderRequest, reply) import qualified Database.Redis.Cluster.Command as CMD+import Database.Redis.Hooks (Hooks)+import Network.TLS (ClientParams (..)) -- This module implements a clustered connection whilst maintaining -- compatibility with the original Hedis codebase. In particular it still@@ -46,18 +54,28 @@ -- evaluated, execute the entire pipeline. If the pipeline is already executed -- then it just looks up it's response in the executed pipeline. --- | A connection to a redis cluster, it is compoesed of a map from Node IDs to+-- | A connection to a redis cluster, it is composed of a map from Node IDs to -- | 'NodeConnection's, a 'Pipeline', and a 'ShardMap'-data Connection = Connection (HM.HashMap NodeID NodeConnection) (MVar Pipeline) (MVar ShardMap) CMD.InfoMap+data Connection = Connection+ { connectionNodes :: HM.HashMap NodeID NodeConnection+ , connectionPipeline :: MVar Pipeline+ , connectionShardMap :: MVar ShardMap+ , connectionInfoMap :: CMD.InfoMap+ , connectionHooks :: Hooks+ } -- | A connection to a single node in the cluster, similar to 'ProtocolPipelining.Connection'-data NodeConnection = NodeConnection CC.ConnectionContext (IOR.IORef (Maybe B.ByteString)) NodeID+data NodeConnection = NodeConnection+ { nodeConnectionContext :: CC.ConnectionContext+ , nodeConnectionLastRecvRef :: IOR.IORef (Maybe B.ByteString)+ , nodeConnectionNodeId :: NodeID+ } instance Eq NodeConnection where- (NodeConnection _ _ id1) == (NodeConnection _ _ id2) = id1 == id2+ NodeConnection{nodeConnectionNodeId=id1} == NodeConnection{nodeConnectionNodeId=id2} = id1 == id2 instance Ord NodeConnection where- compare (NodeConnection _ _ id1) (NodeConnection _ _ id2) = compare id1 id2+ compare NodeConnection{nodeConnectionNodeId=id1} NodeConnection{nodeConnectionNodeId=id2} = compare id1 id2 data PipelineState = -- Nothing in the pipeline has been evaluated yet so nothing has been@@ -83,47 +101,88 @@ type Host = String type Port = Int type NodeID = B.ByteString-data Node = Node NodeID NodeRole Host Port deriving (Show, Eq, Ord) +-- | Represents a single node, note that this type does not include the+-- connection to the node because the shard map can be shared amongst multiple+-- connections+data Node = Node+ { nodeId :: NodeID+ , nodeRole :: NodeRole+ , nodeHost :: Host+ , nodePort :: Port+ } deriving (Show, Eq, Ord)+ type MasterNode = Node type SlaveNode = Node-data Shard = Shard MasterNode [SlaveNode] deriving (Show, Eq, Ord) +-- | A 'shard' is a master node and 0 or more slaves, (the 'master', 'slave'+-- terminology is unfortunate but I felt it better to follow the documentation+-- until it changes).+data Shard = Shard+ { shardMaster :: MasterNode+ , shardSlaves :: [SlaveNode]+ } deriving (Show, Eq, Ord)++-- | A map from hashslot to shards newtype ShardMap = ShardMap (IntMap.IntMap Shard) deriving (Show) -newtype MissingNodeException = MissingNodeException [B.ByteString] deriving (Show, Typeable)+newtype MissingNodeException = MissingNodeException [B.ByteString] deriving (Show) instance Exception MissingNodeException -newtype UnsupportedClusterCommandException = UnsupportedClusterCommandException [B.ByteString] deriving (Show, Typeable)+newtype UnsupportedClusterCommandException = UnsupportedClusterCommandException [B.ByteString] deriving (Show) instance Exception UnsupportedClusterCommandException -newtype CrossSlotException = CrossSlotException [[B.ByteString]] deriving (Show, Typeable)+newtype CrossSlotException = CrossSlotException [[B.ByteString]] deriving (Show) instance Exception CrossSlotException -connect :: [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> IO Connection-connect commandInfos shardMapVar timeoutOpt = do+data ClusterAuthError = ClusterAuthError Host Port Reply deriving (Show)+instance Exception ClusterAuthError++-- | Backwards compatible version of connect that can't provide authentication or TLS parameters.+{-# DEPRECATED connect "Use connectWith instead, passing Nothing for the parameters you don't need." #-}+connect :: [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> Hooks -> IO Connection+connect = connectWith Nothing Nothing Nothing++-- | Connects to cluster.+connectWith :: Maybe B.ByteString -> Maybe B.ByteString -> Maybe ClientParams -> [CMD.CommandInfo] -> MVar ShardMap -> Maybe Int -> Hooks -> IO Connection+connectWith mUsername mPassword mTlsParams commandInfos shardMapVar timeoutOpt hooks' = do shardMap <- readMVar shardMapVar stateVar <- newMVar $ Pending [] pipelineVar <- newMVar $ Pipeline stateVar nodeConns <- nodeConnections shardMap- return $ Connection nodeConns pipelineVar shardMapVar (CMD.newInfoMap commandInfos) where+ return $ Connection nodeConns pipelineVar shardMapVar (CMD.newInfoMap commandInfos) hooks' where nodeConnections :: ShardMap -> IO (HM.HashMap NodeID NodeConnection)- nodeConnections shardMap = HM.fromList <$> mapM connectNode (nub $ nodes shardMap)- connectNode :: Node -> IO (NodeID, NodeConnection)- connectNode (Node n _ host port) = do- ctx <- CC.connect host (CC.PortNumber $ toEnum port) timeoutOpt+ nodeConnections shardMap = HM.fromList <$> connectNodes (nub $ nodes shardMap)+ connectNodes :: [Node] -> IO [(NodeID, NodeConnection)]+ connectNodes [] = return []+ connectNodes (z@Node{nodeHost = host, nodePort = port}:ns) = do+ bracketOnError+ (CC.connect (CC.ConnectAddrHostPort host $ toEnum port) timeoutOpt mTlsParams)+ (CC.disconnect) $ \ctx0 -> do+ nodeConn <- connectNode z ctx0+ rest <- connectNodes ns+ return $ nodeConn : rest+ connectNode :: Node -> CC.ConnectionContext -> IO (NodeID, NodeConnection)+ connectNode Node{nodeId = n, nodeHost = host, nodePort = port} ctx0 = do ref <- IOR.newIORef Nothing- return (n, NodeConnection ctx ref n)+ let nodeConn = NodeConnection ctx0 ref n+ forM_ mPassword $ \password -> do+ let reqOpts = maybe [password] (:[password]) mUsername+ authReply <- requestNode1 nodeConn ( ["AUTH"] <> reqOpts )+ case authReply of+ SingleLine "OK" -> pure ()+ _ -> throwIO $ ClusterAuthError host port authReply+ return (n, nodeConn) disconnect :: Connection -> IO ()-disconnect (Connection nodeConnMap _ _ _) = mapM_ disconnectNode (HM.elems nodeConnMap) where+disconnect Connection{connectionNodes=nodeConnMap} = uninterruptibleMask_ $ mapM_ disconnectNode (HM.elems nodeConnMap) where disconnectNode (NodeConnection nodeCtx _ _) = CC.disconnect nodeCtx -- Add a request to the current pipeline for this connection. The pipeline will -- be executed implicitly as soon as any result returned from this function is -- evaluated. requestPipelined :: IO ShardMap -> Connection -> [B.ByteString] -> IO Reply-requestPipelined refreshAction conn@(Connection _ pipelineVar shardMapVar _) nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do+requestPipelined refreshAction conn@Connection{connectionPipeline=pipelineVar, connectionShardMap=shardMapVar} nextRequest = modifyMVar pipelineVar $ \(Pipeline stateVar) -> do (newStateVar, repliesIndex) <- hasLocked $ modifyMVar stateVar $ \case Pending requests | isMulti nextRequest -> do replies <- evaluatePipeline shardMapVar refreshAction conn requests@@ -228,7 +287,7 @@ -- there is one. case last replies of (Error errString) | B.isPrefixOf "MOVED" errString -> do- let (Connection _ _ _ infoMap) = conn+ let Connection{connectionInfoMap=infoMap} = conn keys <- mconcat <$> mapM (requestKeys infoMap) requests hashSlot <- hashSlotForKeys (CrossSlotException requests) keys nodeConn <- nodeConnForHashSlot shardMapVar conn (MissingNodeException (head requests)) hashSlot@@ -250,7 +309,7 @@ evaluateTransactionPipeline :: MVar ShardMap -> IO ShardMap -> Connection -> [[B.ByteString]] -> IO [Reply] evaluateTransactionPipeline shardMapVar refreshShardmapAction conn requests' = do let requests = reverse requests'- let (Connection _ _ _ infoMap) = conn+ let Connection{connectionInfoMap=infoMap} = conn keys <- mconcat <$> mapM (requestKeys infoMap) requests -- In cluster mode Redis expects commands in transactions to all work on the -- same hashslot. We find that hashslot here.@@ -296,12 +355,12 @@ nodeConnForHashSlot :: Exception e => MVar ShardMap -> Connection -> e -> HashSlot -> IO NodeConnection nodeConnForHashSlot shardMapVar conn exception hashSlot = do- let (Connection nodeConns _ _ _) = conn+ let Connection{connectionNodes=nodeConns} = conn (ShardMap shardMap) <- hasLocked $ readMVar shardMapVar node <- case IntMap.lookup (fromEnum hashSlot) shardMap of Nothing -> throwIO exception- Just (Shard master _) -> return master+ Just Shard{shardMaster = master} -> return master case HM.lookup (nodeId node) nodeConns of Nothing -> throwIO exception Just nodeConn' -> return nodeConn'@@ -339,12 +398,12 @@ nodeConnWithHostAndPort :: ShardMap -> Connection -> Host -> Port -> Maybe NodeConnection-nodeConnWithHostAndPort shardMap (Connection nodeConns _ _ _) host port = do+nodeConnWithHostAndPort shardMap Connection{connectionNodes=nodeConns} host port = do node <- nodeWithHostAndPort shardMap host port HM.lookup (nodeId node) nodeConns nodeConnectionForCommand :: Connection -> ShardMap -> [B.ByteString] -> IO [NodeConnection]-nodeConnectionForCommand conn@(Connection nodeConns _ _ infoMap) (ShardMap shardMap) request =+nodeConnectionForCommand conn@Connection{connectionNodes=nodeConns, connectionInfoMap=infoMap} (ShardMap shardMap) request = case request of ("FLUSHALL" : _) -> allNodes ("FLUSHDB" : _) -> allNodes@@ -355,7 +414,7 @@ hashSlot <- hashSlotForKeys (CrossSlotException [request]) keys node <- case IntMap.lookup (fromEnum hashSlot) shardMap of Nothing -> throwIO $ MissingNodeException request- Just (Shard master _) -> return master+ Just Shard{shardMaster = master} -> return master maybe (throwIO $ MissingNodeException request) (return . return) (HM.lookup (nodeId node) nodeConns) where allNodes =@@ -364,49 +423,77 @@ Just allNodes' -> return allNodes' allMasterNodes :: Connection -> ShardMap -> Maybe [NodeConnection]-allMasterNodes (Connection nodeConns _ _ _) (ShardMap shardMap) =- mapM (flip HM.lookup nodeConns . nodeId) masterNodes+allMasterNodes Connection{connectionNodes=nodeConns} (ShardMap shardMap) =+ mapM (flip HM.lookup nodeConns . nodeId) masters where- masterNodes = (\(Shard master _) -> master) <$> nub (IntMap.elems shardMap)+ masters = shardMaster <$> nub (IntMap.elems shardMap) requestNode :: NodeConnection -> [[B.ByteString]] -> IO [Reply]-requestNode (NodeConnection ctx lastRecvRef _) requests = do+requestNode nodeConn@(NodeConnection ctx _ _) requests = do mapM_ (sendNode . renderRequest) requests _ <- CC.flush ctx- replicateM (length requests) recvNode+ replicateM (length requests) $ recvNode nodeConn where sendNode :: B.ByteString -> IO () sendNode = CC.send ctx- recvNode :: IO Reply- recvNode = do- maybeLastRecv <- IOR.readIORef lastRecvRef- scanResult <- case maybeLastRecv of- Just lastRecv -> Scanner.scanWith (CC.recv ctx) reply lastRecv- Nothing -> Scanner.scanWith (CC.recv ctx) reply B.empty - case scanResult of- Scanner.Fail{} -> CC.errConnClosed- Scanner.More{} -> error "Hedis: parseWith returned Partial"- Scanner.Done rest' r -> do- IOR.writeIORef lastRecvRef (Just rest')- return r+requestNode1 :: NodeConnection -> [B.ByteString] -> IO Reply+requestNode1 nodeConn@NodeConnection{nodeConnectionContext=ctx} request = do+ CC.send ctx $ renderRequest request+ _ <- CC.flush ctx+ recvNode nodeConn +recvNode :: NodeConnection -> IO Reply+recvNode NodeConnection{nodeConnectionContext = ctx, nodeConnectionLastRecvRef = lastRecvRef} = do+ maybeLastRecv <- IOR.readIORef lastRecvRef+ scanResult <- case maybeLastRecv of+ Just lastRecv -> Scanner.scanWith (CC.recv ctx) reply lastRecv+ Nothing -> Scanner.scanWith (CC.recv ctx) reply B.empty++ case scanResult of+ Scanner.Fail{} -> CC.errConnClosed+ Scanner.More{} -> error "Hedis: parseWith returned Partial"+ Scanner.Done rest' r -> do+ IOR.writeIORef lastRecvRef (Just rest')+ return r+ nodes :: ShardMap -> [Node] nodes (ShardMap shardMap) = concatMap snd $ IntMap.toList $ fmap shardNodes shardMap where shardNodes :: Shard -> [Node]- shardNodes (Shard master slaves) = master:slaves+ shardNodes Shard{..} = shardMaster:shardSlaves nodeWithHostAndPort :: ShardMap -> Host -> Port -> Maybe Node-nodeWithHostAndPort shardMap host port = find (\(Node _ _ nodeHost nodePort) -> port == nodePort && host == nodeHost) (nodes shardMap)--nodeId :: Node -> NodeID-nodeId (Node theId _ _ _) = theId+nodeWithHostAndPort shardMap host port = find (\Node{nodeHost = h, nodePort = p} -> port == p && host == h) (nodes shardMap) hasLocked :: IO a -> IO a hasLocked action = action `catches` [ Handler $ \exc@BlockedIndefinitelyOnMVar -> throwIO exc ]++hooks :: Connection -> Hooks+hooks = connectionHooks++-- | Send a request to all master nodes in the cluster. This is useful for commands that need to be sent to all master nodes, such as `FLUSHALL` or `CONFIG SET`.+requestMasterNodes :: Connection -> [B.ByteString] -> IO [Reply]+requestMasterNodes conn req = do+ masterNodeConns <- masterNodes conn+ concat <$> mapM (`requestNode` [req]) masterNodeConns++-- | Get connection to a master nodes in the cluster.+-- This is useful for commands that need to be sent to all master nodes, such as `FLUSHALL` or `CONFIG SET`.+masterNodes :: Connection -> IO [NodeConnection]+masterNodes (Connection nodeConns _ shardMapVar _ _) = do+ (ShardMap shardMap) <- readMVar shardMapVar+ let masters = map shardMaster $ nub $ IntMap.elems shardMap+ let masterNodeIds = map nodeId masters+ return $ mapMaybe (`HM.lookup` nodeConns) masterNodeIds++-- | Get connection to a random node in the cluster that is not the same as the provided connection.+getRandomConnection :: NodeConnection -> Connection -> NodeConnection+getRandomConnection nc Connection{connectionNodes = hmn} =+ let conns = HM.elems hmn+ in fromMaybe (head conns) $ find (nc /= ) conns
src/Database/Redis/Cluster/Command.hs view
@@ -97,6 +97,20 @@ , MultiBulk _ -- ACL categories ])) = decode (MultiBulk (Just [name, arity, flags, firstPos, lastPos, step]))+ -- since redis 7.0+ decode (MultiBulk (Just+ [ name@(Bulk (Just _))+ , arity@(Integer _)+ , flags@(MultiBulk (Just _))+ , firstPos@(Integer _)+ , lastPos@(Integer _)+ , step@(Integer _)+ , MultiBulk _ -- ACL categories+ , MultiBulk _ -- Tips+ , MultiBulk _ -- Key specifications+ , MultiBulk _ -- Subcommands+ ])) =+ decode (MultiBulk (Just [name, arity, flags, firstPos, lastPos, step])) decode e = Left e @@ -111,6 +125,14 @@ keysForRequest _ ["QUIT"] = -- The `QUIT` command is not listed in the `COMMAND` output. Just []+keysForRequest _ ["OBJECT", "refcount", key] =+ Just [key]+keysForRequest _ ["OBJECT", "encoding", key] =+ Just [key]+keysForRequest _ ["OBJECT", "idletime", key] =+ Just [key]+keysForRequest _ ("XINFO":_:key:_) =+ Just [key] keysForRequest (InfoMap infoMap) request@(command:_) = do info <- HM.lookup (map toLower $ Char8.unpack command) infoMap keysForRequest' info request@@ -137,6 +159,17 @@ parseMovable ("SORT":key:_) = Just [key] parseMovable ("EVAL":_:rest) = readNumKeys rest parseMovable ("EVALSHA":_:rest) = readNumKeys rest+parseMovable ("FCALL":_:rest) = readNumKeys rest+parseMovable ("FCALL_RO":_:rest) = readNumKeys rest+parseMovable ("LMPOP":rest) = readNumKeys rest+parseMovable ("BLMPOP":_:rest) = readNumKeys rest+parseMovable ("ZMPOP":rest) = readNumKeys rest+parseMovable ("BZMPOP":_:rest) = readNumKeys rest+parseMovable ("SINTERCARD":rest) = readNumKeys rest+parseMovable ("ZDIFF":rest) = readNumKeys rest+parseMovable ("ZINTER":rest) = readNumKeys rest+parseMovable ("ZUNION":rest) = readNumKeys rest+parseMovable ("ZDIFFSTORE":_:rest) = readNumKeys rest parseMovable ("ZUNIONSTORE":_:rest) = readNumKeys rest parseMovable ("ZINTERSTORE":_:rest) = readNumKeys rest parseMovable ("XREAD":rest) = readXreadKeys rest@@ -150,9 +183,9 @@ readXreadKeys _ = Nothing readXreadgroupKeys :: [BS.ByteString] -> Maybe [BS.ByteString]-readXreadgroupKeys ("COUNT":_:rest) = readXreadKeys rest-readXreadgroupKeys ("BLOCK":_:rest) = readXreadKeys rest-readXreadgroupKeys ("NOACK":rest) = readXreadKeys rest+readXreadgroupKeys ("COUNT":_:rest) = readXreadgroupKeys rest+readXreadgroupKeys ("BLOCK":_:rest) = readXreadgroupKeys rest+readXreadgroupKeys ("NOACK":rest) = readXreadgroupKeys rest readXreadgroupKeys ("STREAMS":rest) = Just $ take (length rest `div` 2) rest readXreadgroupKeys _ = Nothing
src/Database/Redis/Cluster/HashSlot.hs view
@@ -5,24 +5,43 @@ import Data.Bits((.&.), xor, shiftL) import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString as BS+import Data.Maybe (fromMaybe) import Data.Word(Word8, Word16) +-- $setup+-- >>> :set -XOverloadedStrings+ newtype HashSlot = HashSlot Word16 deriving (Num, Eq, Ord, Real, Enum, Integral, Show) numHashSlots :: Word16 numHashSlots = 16384 -- | Compute the hashslot associated with a key+--+-- >>> keyToSlot "123"+-- HashSlot 5970+-- >>> keyToSlot "{123"+-- HashSlot 2872+-- >>> keyToSlot "{123}"+-- HashSlot 5970+-- >>> keyToSlot "{}123"+-- HashSlot 7640+-- >>> keyToSlot "{123}1{abc}"+-- HashSlot 5970+-- >>> keyToSlot "\00\01"+-- HashSlot 4129 keyToSlot :: BS.ByteString -> HashSlot keyToSlot = HashSlot . (.&.) (numHashSlots - 1) . crc16 . findSubKey -- | Find the section of a key to compute the slot for. findSubKey :: BS.ByteString -> BS.ByteString-findSubKey key = case Char8.break (=='{') key of- (whole, "") -> whole- (_, xs) -> case Char8.break (=='}') (Char8.tail xs) of- ("", _) -> key- (subKey, _) -> subKey+findSubKey key = fromMaybe key (go key) where+ go bs = case Char8.break (=='{') bs of+ (_, "") -> Nothing+ (_, xs) -> case Char8.break (=='}') (Char8.tail xs) of+ ("", _) -> go (Char8.tail xs)+ (_, "") -> Nothing+ (subKey, _) -> Just subKey crc16 :: BS.ByteString -> Word16 crc16 = BS.foldl (crc16Update 0x1021) 0
src/Database/Redis/Commands.hs view
@@ -1,1095 +1,1876 @@--- Generated by GenCmds.hs. DO NOT EDIT.--{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}--module Database.Redis.Commands (---- ** Connection-auth, -- |Authenticate to the server (<http://redis.io/commands/auth>). Since Redis 1.0.0-echo, -- |Echo the given string (<http://redis.io/commands/echo>). Since Redis 1.0.0-ping, -- |Ping the server (<http://redis.io/commands/ping>). Since Redis 1.0.0-quit, -- |Close the connection (<http://redis.io/commands/quit>). Since Redis 1.0.0-select, -- |Change the selected database for the current connection (<http://redis.io/commands/select>). Since Redis 1.0.0---- ** Keys-del, -- |Delete a key (<http://redis.io/commands/del>). Since Redis 1.0.0-dump, -- |Return a serialized version of the value stored at the specified key (<http://redis.io/commands/dump>). Since Redis 2.6.0-exists, -- |Determine if a key exists (<http://redis.io/commands/exists>). Since Redis 1.0.0-expire, -- |Set a key's time to live in seconds (<http://redis.io/commands/expire>). Since Redis 1.0.0-expireat, -- |Set the expiration for a key as a UNIX timestamp (<http://redis.io/commands/expireat>). Since Redis 1.2.0-keys, -- |Find all keys matching the given pattern (<http://redis.io/commands/keys>). Since Redis 1.0.0-MigrateOpts(..),-defaultMigrateOpts,-migrate, -- |Atomically transfer a key from a Redis instance to another one (<http://redis.io/commands/migrate>). The Redis command @MIGRATE@ is split up into 'migrate', 'migrateMultiple'. Since Redis 2.6.0-migrateMultiple, -- |Atomically transfer a key from a Redis instance to another one (<http://redis.io/commands/migrate>). The Redis command @MIGRATE@ is split up into 'migrate', 'migrateMultiple'. Since Redis 2.6.0-move, -- |Move a key to another database (<http://redis.io/commands/move>). Since Redis 1.0.0-objectRefcount, -- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3-objectEncoding, -- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3-objectIdletime, -- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3-persist, -- |Remove the expiration from a key (<http://redis.io/commands/persist>). Since Redis 2.2.0-pexpire, -- |Set a key's time to live in milliseconds (<http://redis.io/commands/pexpire>). Since Redis 2.6.0-pexpireat, -- |Set the expiration for a key as a UNIX timestamp specified in milliseconds (<http://redis.io/commands/pexpireat>). Since Redis 2.6.0-pttl, -- |Get the time to live for a key in milliseconds (<http://redis.io/commands/pttl>). Since Redis 2.6.0-randomkey, -- |Return a random key from the keyspace (<http://redis.io/commands/randomkey>). Since Redis 1.0.0-rename, -- |Rename a key (<http://redis.io/commands/rename>). Since Redis 1.0.0-renamenx, -- |Rename a key, only if the new key does not exist (<http://redis.io/commands/renamenx>). Since Redis 1.0.0-restore, -- |Create a key using the provided serialized value, previously obtained using DUMP (<http://redis.io/commands/restore>). The Redis command @RESTORE@ is split up into 'restore', 'restoreReplace'. Since Redis 2.6.0-restoreReplace, -- |Create a key using the provided serialized value, previously obtained using DUMP (<http://redis.io/commands/restore>). The Redis command @RESTORE@ is split up into 'restore', 'restoreReplace'. Since Redis 2.6.0-Cursor,-cursor0,-ScanOpts(..),-defaultScanOpts,-scan, -- |Incrementally iterate the keys space (<http://redis.io/commands/scan>). The Redis command @SCAN@ is split up into 'scan', 'scanOpts'. Since Redis 2.8.0-scanOpts, -- |Incrementally iterate the keys space (<http://redis.io/commands/scan>). The Redis command @SCAN@ is split up into 'scan', 'scanOpts'. Since Redis 2.8.0-SortOpts(..),-defaultSortOpts,-SortOrder(..),-sort, -- |Sort the elements in a list, set or sorted set (<http://redis.io/commands/sort>). The Redis command @SORT@ is split up into 'sort', 'sortStore'. Since Redis 1.0.0-sortStore, -- |Sort the elements in a list, set or sorted set (<http://redis.io/commands/sort>). The Redis command @SORT@ is split up into 'sort', 'sortStore'. Since Redis 1.0.0-ttl, -- |Get the time to live for a key (<http://redis.io/commands/ttl>). Since Redis 1.0.0-RedisType(..),-getType, -- |Determine the type stored at key (<http://redis.io/commands/type>). Since Redis 1.0.0-wait, -- |Wait for the synchronous replication of all the write commands sent in the context of the current connection (<http://redis.io/commands/wait>). Since Redis 3.0.0---- ** Hashes-hdel, -- |Delete one or more hash fields (<http://redis.io/commands/hdel>). Since Redis 2.0.0-hexists, -- |Determine if a hash field exists (<http://redis.io/commands/hexists>). Since Redis 2.0.0-hget, -- |Get the value of a hash field (<http://redis.io/commands/hget>). Since Redis 2.0.0-hgetall, -- |Get all the fields and values in a hash (<http://redis.io/commands/hgetall>). Since Redis 2.0.0-hincrby, -- |Increment the integer value of a hash field by the given number (<http://redis.io/commands/hincrby>). Since Redis 2.0.0-hincrbyfloat, -- |Increment the float value of a hash field by the given amount (<http://redis.io/commands/hincrbyfloat>). Since Redis 2.6.0-hkeys, -- |Get all the fields in a hash (<http://redis.io/commands/hkeys>). Since Redis 2.0.0-hlen, -- |Get the number of fields in a hash (<http://redis.io/commands/hlen>). Since Redis 2.0.0-hmget, -- |Get the values of all the given hash fields (<http://redis.io/commands/hmget>). Since Redis 2.0.0-hmset, -- |Set multiple hash fields to multiple values (<http://redis.io/commands/hmset>). Since Redis 2.0.0-hscan, -- |Incrementally iterate hash fields and associated values (<http://redis.io/commands/hscan>). The Redis command @HSCAN@ is split up into 'hscan', 'hscanOpts'. Since Redis 2.8.0-hscanOpts, -- |Incrementally iterate hash fields and associated values (<http://redis.io/commands/hscan>). The Redis command @HSCAN@ is split up into 'hscan', 'hscanOpts'. Since Redis 2.8.0-hset, -- |Set the string value of a hash field (<http://redis.io/commands/hset>). Since Redis 2.0.0-hsetnx, -- |Set the value of a hash field, only if the field does not exist (<http://redis.io/commands/hsetnx>). Since Redis 2.0.0-hstrlen, -- |Get the length of the value of a hash field (<http://redis.io/commands/hstrlen>). Since Redis 3.2.0-hvals, -- |Get all the values in a hash (<http://redis.io/commands/hvals>). Since Redis 2.0.0---- ** HyperLogLogs-pfadd, -- |Adds all the elements arguments to the HyperLogLog data structure stored at the variable name specified as first argument (<http://redis.io/commands/pfadd>). Since Redis 2.8.9-pfcount, -- |Return the approximated cardinality of the set(s) observed by the HyperLogLog at key(s) (<http://redis.io/commands/pfcount>). Since Redis 2.8.9-pfmerge, -- |Merge N different HyperLogLogs into a single one (<http://redis.io/commands/pfmerge>). Since Redis 2.8.9---- ** Lists-blpop, -- |Remove and get the first element in a list, or block until one is available (<http://redis.io/commands/blpop>). Since Redis 2.0.0-brpop, -- |Remove and get the last element in a list, or block until one is available (<http://redis.io/commands/brpop>). Since Redis 2.0.0-brpoplpush, -- |Pop a value from a list, push it to another list and return it; or block until one is available (<http://redis.io/commands/brpoplpush>). Since Redis 2.2.0-lindex, -- |Get an element from a list by its index (<http://redis.io/commands/lindex>). Since Redis 1.0.0-linsertBefore, -- |Insert an element before or after another element in a list (<http://redis.io/commands/linsert>). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'. Since Redis 2.2.0-linsertAfter, -- |Insert an element before or after another element in a list (<http://redis.io/commands/linsert>). The Redis command @LINSERT@ is split up into 'linsertBefore', 'linsertAfter'. Since Redis 2.2.0-llen, -- |Get the length of a list (<http://redis.io/commands/llen>). Since Redis 1.0.0-lpop, -- |Remove and get the first element in a list (<http://redis.io/commands/lpop>). Since Redis 1.0.0-lpush, -- |Prepend one or multiple values to a list (<http://redis.io/commands/lpush>). Since Redis 1.0.0-lpushx, -- |Prepend a value to a list, only if the list exists (<http://redis.io/commands/lpushx>). Since Redis 2.2.0-lrange, -- |Get a range of elements from a list (<http://redis.io/commands/lrange>). Since Redis 1.0.0-lrem, -- |Remove elements from a list (<http://redis.io/commands/lrem>). Since Redis 1.0.0-lset, -- |Set the value of an element in a list by its index (<http://redis.io/commands/lset>). Since Redis 1.0.0-ltrim, -- |Trim a list to the specified range (<http://redis.io/commands/ltrim>). Since Redis 1.0.0-rpop, -- |Remove and get the last element in a list (<http://redis.io/commands/rpop>). Since Redis 1.0.0-rpoplpush, -- |Remove the last element in a list, prepend it to another list and return it (<http://redis.io/commands/rpoplpush>). Since Redis 1.2.0-rpush, -- |Append one or multiple values to a list (<http://redis.io/commands/rpush>). Since Redis 1.0.0-rpushx, -- |Append a value to a list, only if the list exists (<http://redis.io/commands/rpushx>). Since Redis 2.2.0---- ** Scripting-eval, -- |Execute a Lua script server side (<http://redis.io/commands/eval>). Since Redis 2.6.0-evalsha, -- |Execute a Lua script server side (<http://redis.io/commands/evalsha>). Since Redis 2.6.0-DebugMode,-scriptDebug, -- |Set the debug mode for executed scripts (<http://redis.io/commands/script-debug>). Since Redis 3.2.0-scriptExists, -- |Check existence of scripts in the script cache (<http://redis.io/commands/script-exists>). Since Redis 2.6.0-scriptFlush, -- |Remove all the scripts from the script cache (<http://redis.io/commands/script-flush>). Since Redis 2.6.0-scriptKill, -- |Kill the script currently in execution (<http://redis.io/commands/script-kill>). Since Redis 2.6.0-scriptLoad, -- |Load the specified Lua script into the script cache (<http://redis.io/commands/script-load>). Since Redis 2.6.0---- ** Server-bgrewriteaof, -- |Asynchronously rewrite the append-only file (<http://redis.io/commands/bgrewriteaof>). Since Redis 1.0.0-bgsave, -- |Asynchronously save the dataset to disk (<http://redis.io/commands/bgsave>). Since Redis 1.0.0-clientGetname, -- |Get the current connection name (<http://redis.io/commands/client-getname>). Since Redis 2.6.9-clientList, -- |Get the list of client connections (<http://redis.io/commands/client-list>). Since Redis 2.4.0-clientPause, -- |Stop processing commands from clients for some time (<http://redis.io/commands/client-pause>). Since Redis 2.9.50-ReplyMode,-clientReply, -- |Instruct the server whether to reply to commands (<http://redis.io/commands/client-reply>). Since Redis 3.2-clientSetname, -- |Set the current connection name (<http://redis.io/commands/client-setname>). Since Redis 2.6.9-commandCount, -- |Get total number of Redis commands (<http://redis.io/commands/command-count>). Since Redis 2.8.13-commandInfo, -- |Get array of specific Redis command details (<http://redis.io/commands/command-info>). Since Redis 2.8.13-configGet, -- |Get the value of a configuration parameter (<http://redis.io/commands/config-get>). Since Redis 2.0.0-configResetstat, -- |Reset the stats returned by INFO (<http://redis.io/commands/config-resetstat>). Since Redis 2.0.0-configRewrite, -- |Rewrite the configuration file with the in memory configuration (<http://redis.io/commands/config-rewrite>). Since Redis 2.8.0-configSet, -- |Set a configuration parameter to the given value (<http://redis.io/commands/config-set>). Since Redis 2.0.0-dbsize, -- |Return the number of keys in the selected database (<http://redis.io/commands/dbsize>). Since Redis 1.0.0-debugObject, -- |Get debugging information about a key (<http://redis.io/commands/debug-object>). Since Redis 1.0.0-flushall, -- |Remove all keys from all databases (<http://redis.io/commands/flushall>). Since Redis 1.0.0-flushdb, -- |Remove all keys from the current database (<http://redis.io/commands/flushdb>). Since Redis 1.0.0-info, -- |Get information and statistics about the server (<http://redis.io/commands/info>). The Redis command @INFO@ is split up into 'info', 'infoSection'. Since Redis 1.0.0-infoSection, -- |Get information and statistics about the server (<http://redis.io/commands/info>). The Redis command @INFO@ is split up into 'info', 'infoSection'. Since Redis 1.0.0-lastsave, -- |Get the UNIX time stamp of the last successful save to disk (<http://redis.io/commands/lastsave>). Since Redis 1.0.0-save, -- |Synchronously save the dataset to disk (<http://redis.io/commands/save>). Since Redis 1.0.0-slaveof, -- |Make the server a slave of another instance, or promote it as master (<http://redis.io/commands/slaveof>). Since Redis 1.0.0-Slowlog(..),-slowlogGet, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12-slowlogLen, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12-slowlogReset, -- |Manages the Redis slow queries log (<http://redis.io/commands/slowlog>). The Redis command @SLOWLOG@ is split up into 'slowlogGet', 'slowlogLen', 'slowlogReset'. Since Redis 2.2.12-time, -- |Return the current server time (<http://redis.io/commands/time>). Since Redis 2.6.0---- ** Sets-sadd, -- |Add one or more members to a set (<http://redis.io/commands/sadd>). Since Redis 1.0.0-scard, -- |Get the number of members in a set (<http://redis.io/commands/scard>). Since Redis 1.0.0-sdiff, -- |Subtract multiple sets (<http://redis.io/commands/sdiff>). Since Redis 1.0.0-sdiffstore, -- |Subtract multiple sets and store the resulting set in a key (<http://redis.io/commands/sdiffstore>). Since Redis 1.0.0-sinter, -- |Intersect multiple sets (<http://redis.io/commands/sinter>). Since Redis 1.0.0-sinterstore, -- |Intersect multiple sets and store the resulting set in a key (<http://redis.io/commands/sinterstore>). Since Redis 1.0.0-sismember, -- |Determine if a given value is a member of a set (<http://redis.io/commands/sismember>). Since Redis 1.0.0-smembers, -- |Get all the members in a set (<http://redis.io/commands/smembers>). Since Redis 1.0.0-smove, -- |Move a member from one set to another (<http://redis.io/commands/smove>). Since Redis 1.0.0-spop, -- |Remove and return one or multiple random members from a set (<http://redis.io/commands/spop>). The Redis command @SPOP@ is split up into 'spop', 'spopN'. Since Redis 1.0.0-spopN, -- |Remove and return one or multiple random members from a set (<http://redis.io/commands/spop>). The Redis command @SPOP@ is split up into 'spop', 'spopN'. Since Redis 1.0.0-srandmember, -- |Get one or multiple random members from a set (<http://redis.io/commands/srandmember>). The Redis command @SRANDMEMBER@ is split up into 'srandmember', 'srandmemberN'. Since Redis 1.0.0-srandmemberN, -- |Get one or multiple random members from a set (<http://redis.io/commands/srandmember>). The Redis command @SRANDMEMBER@ is split up into 'srandmember', 'srandmemberN'. Since Redis 1.0.0-srem, -- |Remove one or more members from a set (<http://redis.io/commands/srem>). Since Redis 1.0.0-sscan, -- |Incrementally iterate Set elements (<http://redis.io/commands/sscan>). The Redis command @SSCAN@ is split up into 'sscan', 'sscanOpts'. Since Redis 2.8.0-sscanOpts, -- |Incrementally iterate Set elements (<http://redis.io/commands/sscan>). The Redis command @SSCAN@ is split up into 'sscan', 'sscanOpts'. Since Redis 2.8.0-sunion, -- |Add multiple sets (<http://redis.io/commands/sunion>). Since Redis 1.0.0-sunionstore, -- |Add multiple sets and store the resulting set in a key (<http://redis.io/commands/sunionstore>). Since Redis 1.0.0---- ** Sorted Sets-ZaddOpts(..),-defaultZaddOpts,-zadd, -- |Add one or more members to a sorted set, or update its score if it already exists (<http://redis.io/commands/zadd>). The Redis command @ZADD@ is split up into 'zadd', 'zaddOpts'. Since Redis 1.2.0-zaddOpts, -- |Add one or more members to a sorted set, or update its score if it already exists (<http://redis.io/commands/zadd>). The Redis command @ZADD@ is split up into 'zadd', 'zaddOpts'. Since Redis 1.2.0-zcard, -- |Get the number of members in a sorted set (<http://redis.io/commands/zcard>). Since Redis 1.2.0-zcount, -- |Count the members in a sorted set with scores within the given values (<http://redis.io/commands/zcount>). Since Redis 2.0.0-zincrby, -- |Increment the score of a member in a sorted set (<http://redis.io/commands/zincrby>). Since Redis 1.2.0-Aggregate(..),-zinterstore, -- |Intersect multiple sorted sets and store the resulting sorted set in a new key (<http://redis.io/commands/zinterstore>). The Redis command @ZINTERSTORE@ is split up into 'zinterstore', 'zinterstoreWeights'. Since Redis 2.0.0-zinterstoreWeights, -- |Intersect multiple sorted sets and store the resulting sorted set in a new key (<http://redis.io/commands/zinterstore>). The Redis command @ZINTERSTORE@ is split up into 'zinterstore', 'zinterstoreWeights'. Since Redis 2.0.0-zlexcount, -- |Count the number of members in a sorted set between a given lexicographical range (<http://redis.io/commands/zlexcount>). Since Redis 2.8.9-zrange, -- |Return a range of members in a sorted set, by index (<http://redis.io/commands/zrange>). The Redis command @ZRANGE@ is split up into 'zrange', 'zrangeWithscores'. Since Redis 1.2.0-zrangeWithscores, -- |Return a range of members in a sorted set, by index (<http://redis.io/commands/zrange>). The Redis command @ZRANGE@ is split up into 'zrange', 'zrangeWithscores'. Since Redis 1.2.0-RangeLex(..),-zrangebylex, zrangebylexLimit, -- |Return a range of members in a sorted set, by lexicographical range (<http://redis.io/commands/zrangebylex>). Since Redis 2.8.9-zrangebyscore, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5-zrangebyscoreWithscores, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5-zrangebyscoreLimit, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5-zrangebyscoreWithscoresLimit, -- |Return a range of members in a sorted set, by score (<http://redis.io/commands/zrangebyscore>). The Redis command @ZRANGEBYSCORE@ is split up into 'zrangebyscore', 'zrangebyscoreWithscores', 'zrangebyscoreLimit', 'zrangebyscoreWithscoresLimit'. Since Redis 1.0.5-zrank, -- |Determine the index of a member in a sorted set (<http://redis.io/commands/zrank>). Since Redis 2.0.0-zrem, -- |Remove one or more members from a sorted set (<http://redis.io/commands/zrem>). Since Redis 1.2.0-zremrangebylex, -- |Remove all members in a sorted set between the given lexicographical range (<http://redis.io/commands/zremrangebylex>). Since Redis 2.8.9-zremrangebyrank, -- |Remove all members in a sorted set within the given indexes (<http://redis.io/commands/zremrangebyrank>). Since Redis 2.0.0-zremrangebyscore, -- |Remove all members in a sorted set within the given scores (<http://redis.io/commands/zremrangebyscore>). Since Redis 1.2.0-zrevrange, -- |Return a range of members in a sorted set, by index, with scores ordered from high to low (<http://redis.io/commands/zrevrange>). The Redis command @ZREVRANGE@ is split up into 'zrevrange', 'zrevrangeWithscores'. Since Redis 1.2.0-zrevrangeWithscores, -- |Return a range of members in a sorted set, by index, with scores ordered from high to low (<http://redis.io/commands/zrevrange>). The Redis command @ZREVRANGE@ is split up into 'zrevrange', 'zrevrangeWithscores'. Since Redis 1.2.0-zrevrangebyscore, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (<http://redis.io/commands/zrevrangebyscore>). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0-zrevrangebyscoreWithscores, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (<http://redis.io/commands/zrevrangebyscore>). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0-zrevrangebyscoreLimit, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (<http://redis.io/commands/zrevrangebyscore>). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0-zrevrangebyscoreWithscoresLimit, -- |Return a range of members in a sorted set, by score, with scores ordered from high to low (<http://redis.io/commands/zrevrangebyscore>). The Redis command @ZREVRANGEBYSCORE@ is split up into 'zrevrangebyscore', 'zrevrangebyscoreWithscores', 'zrevrangebyscoreLimit', 'zrevrangebyscoreWithscoresLimit'. Since Redis 2.2.0-zrevrank, -- |Determine the index of a member in a sorted set, with scores ordered from high to low (<http://redis.io/commands/zrevrank>). Since Redis 2.0.0-zscan, -- |Incrementally iterate sorted sets elements and associated scores (<http://redis.io/commands/zscan>). The Redis command @ZSCAN@ is split up into 'zscan', 'zscanOpts'. Since Redis 2.8.0-zscanOpts, -- |Incrementally iterate sorted sets elements and associated scores (<http://redis.io/commands/zscan>). The Redis command @ZSCAN@ is split up into 'zscan', 'zscanOpts'. Since Redis 2.8.0-zscore, -- |Get the score associated with the given member in a sorted set (<http://redis.io/commands/zscore>). Since Redis 1.2.0-zunionstore, -- |Add multiple sorted sets and store the resulting sorted set in a new key (<http://redis.io/commands/zunionstore>). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'. Since Redis 2.0.0-zunionstoreWeights, -- |Add multiple sorted sets and store the resulting sorted set in a new key (<http://redis.io/commands/zunionstore>). The Redis command @ZUNIONSTORE@ is split up into 'zunionstore', 'zunionstoreWeights'. Since Redis 2.0.0---- ** Strings-append, -- |Append a value to a key (<http://redis.io/commands/append>). Since Redis 2.0.0-bitcount, -- |Count set bits in a string (<http://redis.io/commands/bitcount>). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'. Since Redis 2.6.0-bitcountRange, -- |Count set bits in a string (<http://redis.io/commands/bitcount>). The Redis command @BITCOUNT@ is split up into 'bitcount', 'bitcountRange'. Since Redis 2.6.0-bitopAnd, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0-bitopOr, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0-bitopXor, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0-bitopNot, -- |Perform bitwise operations between strings (<http://redis.io/commands/bitop>). The Redis command @BITOP@ is split up into 'bitopAnd', 'bitopOr', 'bitopXor', 'bitopNot'. Since Redis 2.6.0-bitpos, -- |Find first bit set or clear in a string (<http://redis.io/commands/bitpos>). Since Redis 2.8.7-decr, -- |Decrement the integer value of a key by one (<http://redis.io/commands/decr>). Since Redis 1.0.0-decrby, -- |Decrement the integer value of a key by the given number (<http://redis.io/commands/decrby>). Since Redis 1.0.0-get, -- |Get the value of a key (<http://redis.io/commands/get>). Since Redis 1.0.0-getbit, -- |Returns the bit value at offset in the string value stored at key (<http://redis.io/commands/getbit>). Since Redis 2.2.0-getrange, -- |Get a substring of the string stored at a key (<http://redis.io/commands/getrange>). Since Redis 2.4.0-getset, -- |Set the string value of a key and return its old value (<http://redis.io/commands/getset>). Since Redis 1.0.0-incr, -- |Increment the integer value of a key by one (<http://redis.io/commands/incr>). Since Redis 1.0.0-incrby, -- |Increment the integer value of a key by the given amount (<http://redis.io/commands/incrby>). Since Redis 1.0.0-incrbyfloat, -- |Increment the float value of a key by the given amount (<http://redis.io/commands/incrbyfloat>). Since Redis 2.6.0-mget, -- |Get the values of all the given keys (<http://redis.io/commands/mget>). Since Redis 1.0.0-mset, -- |Set multiple keys to multiple values (<http://redis.io/commands/mset>). Since Redis 1.0.1-msetnx, -- |Set multiple keys to multiple values, only if none of the keys exist (<http://redis.io/commands/msetnx>). Since Redis 1.0.1-psetex, -- |Set the value and expiration in milliseconds of a key (<http://redis.io/commands/psetex>). Since Redis 2.6.0-Condition(..),-SetOpts(..),-set, -- |Set the string value of a key (<http://redis.io/commands/set>). The Redis command @SET@ is split up into 'set', 'setOpts'. Since Redis 1.0.0-setOpts, -- |Set the string value of a key (<http://redis.io/commands/set>). The Redis command @SET@ is split up into 'set', 'setOpts'. Since Redis 1.0.0-setbit, -- |Sets or clears the bit at offset in the string value stored at key (<http://redis.io/commands/setbit>). Since Redis 2.2.0-setex, -- |Set the value and expiration of a key (<http://redis.io/commands/setex>). Since Redis 2.0.0-setnx, -- |Set the value of a key, only if the key does not exist (<http://redis.io/commands/setnx>). Since Redis 1.0.0-setrange, -- |Overwrite part of a string at key starting at the specified offset (<http://redis.io/commands/setrange>). Since Redis 2.2.0-strlen, -- |Get the length of the value stored in a key (<http://redis.io/commands/strlen>). Since Redis 2.2.0---- ** Streams-XReadOpts(..),-defaultXreadOpts,-XReadResponse(..),-StreamsRecord(..),-TrimOpts(..),-xadd, -- |Add a value to a stream (<https://redis.io/commands/xadd>). Since Redis 5.0.0-xaddOpts, -- |Add a value to a stream (<https://redis.io/commands/xadd>). The Redis command @XADD@ is split up into 'xadd', 'xaddOpts'. Since Redis 5.0.0-xread, -- |Read values from a stream (<https://redis.io/commands/xread>). The Redis command @XREAD@ is split up into 'xread', 'xreadOpts'. Since Redis 5.0.0-xreadOpts, -- |Read values from a stream (<https://redis.io/commands/xread>). The Redis command @XREAD@ is split up into 'xread', 'xreadOpts'. Since Redis 5.0.0-xreadGroup, -- |Read values from a stream as part of a consumer group (https://redis.io/commands/xreadgroup). The redis command @XREADGROUP@ is split up into 'xreadGroup' and 'xreadGroupOpts'. Since Redis 5.0.0-xreadGroupOpts, -- |Read values from a stream as part of a consumer group (https://redis.io/commands/xreadgroup). The redis command @XREADGROUP@ is split up into 'xreadGroup' and 'xreadGroupOpts'. Since Redis 5.0.0-xack, -- |Acknowledge receipt of a message as part of a consumer group. Since Redis 5.0.0-xgroupCreate, -- |Create a consumer group. The redis command @XGROUP@ is split up into 'xgroupCreate', 'xgroupSetId', 'xgroupDestroy', and 'xgroupDelConsumer'. Since Redis 5.0.0-xgroupSetId, -- |Set the id for a consumer group. The redis command @XGROUP@ is split up into 'xgroupCreate', 'xgroupSetId', 'xgroupDestroy', and 'xgroupDelConsumer'. Since Redis 5.0.0-xgroupDestroy, -- |Destroy a consumer group. The redis command @XGROUP@ is split up into 'xgroupCreate', 'xgroupSetId', 'xgroupDestroy', and 'xgroupDelConsumer'. Since Redis 5.0.0-xgroupDelConsumer, -- |Delete a consumer. The redis command @XGROUP@ is split up into 'xgroupCreate', 'xgroupSetId', 'xgroupDestroy', and 'xgroupDelConsumer'. Since Redis 5.0.0-xrange, -- |Read values from a stream within a range (https://redis.io/commands/xrange). Since Redis 5.0.0-xrevRange, -- |Read values from a stream within a range in reverse order (https://redis.io/commands/xrevrange). Since Redis 5.0.0-xlen, -- |Get the number of entries in a stream (https://redis.io/commands/xlen). Since Redis 5.0.0-XPendingSummaryResponse(..),-xpendingSummary, -- |Get information about pending messages (https://redis.io/commands/xpending). The Redis @XPENDING@ command is split into 'xpendingSummary' and 'xpendingDetail'. Since Redis 5.0.0-XPendingDetailRecord(..),-xpendingDetail, -- |Get detailed information about pending messages (https://redis.io/commands/xpending). The Redis @XPENDING@ command is split into 'xpendingSummary' and 'xpendingDetail'. Since Redis 5.0.0-XClaimOpts(..),-defaultXClaimOpts,-xclaim, -- |Change ownership of some messages to the given consumer, returning the updated messages. The Redis @XCLAIM@ command is split into 'xclaim' and 'xclaimJustIds'. Since Redis 5.0.0-xclaimJustIds, -- |Change ownership of some messages to the given consumer, returning only the changed message IDs. The Redis @XCLAIM@ command is split into 'xclaim' and 'xclaimJustIds'. Since Redis 5.0.0-XInfoConsumersResponse(..),-xinfoConsumers, -- |Get info about consumers in a group. The Redis command @XINFO@ is split into 'xinfoConsumers', 'xinfoGroups', and 'xinfoStream'. Since Redis 5.0.0-XInfoGroupsResponse(..),-xinfoGroups, -- |Get info about groups consuming from a stream. The Redis command @XINFO@ is split into 'xinfoConsumers', 'xinfoGroups', and 'xinfoStream'. Since Redis 5.0.0-XInfoStreamResponse(..),-xinfoStream, -- |Get info about a stream. The Redis command @XINFO@ is split into 'xinfoConsumers', 'xinfoGroups', and 'xinfoStream'. Since Redis 5.0.0-xdel, -- |Delete messages from a stream. Since Redis 5.0.0-xtrim, -- |Set the upper bound for number of messages in a stream. Since Redis 5.0.0-inf, -- |Constructor for `inf` Redis argument values-ClusterNodesResponse(..),-ClusterNodesResponseEntry(..),-ClusterNodesResponseSlotSpec(..),-clusterNodes,-ClusterSlotsResponse(..),-ClusterSlotsResponseEntry(..),-ClusterSlotsNode(..),-clusterSlots,-clusterSetSlotNode,-clusterSetSlotStable,-clusterSetSlotImporting,-clusterSetSlotMigrating,-clusterGetKeysInSlot,-command--- * Unimplemented Commands--- |These commands are not implemented, as of now. Library--- users can implement these or other commands from--- experimental Redis versions by using the 'sendRequest'--- function.------ * COMMAND (<http://redis.io/commands/command>)--------- * COMMAND GETKEYS (<http://redis.io/commands/command-getkeys>)--------- * ROLE (<http://redis.io/commands/role>)--------- * CLIENT KILL (<http://redis.io/commands/client-kill>)--------- * ZREVRANGEBYLEX (<http://redis.io/commands/zrevrangebylex>)--------- * ZRANGEBYSCORE (<http://redis.io/commands/zrangebyscore>)--------- * ZREVRANGEBYSCORE (<http://redis.io/commands/zrevrangebyscore>)--------- * MONITOR (<http://redis.io/commands/monitor>)--------- * SYNC (<http://redis.io/commands/sync>)--------- * SHUTDOWN (<http://redis.io/commands/shutdown>)--------- * DEBUG SEGFAULT (<http://redis.io/commands/debug-segfault>)----) where--import Prelude hiding (min,max)-import Data.ByteString (ByteString)-import Database.Redis.ManualCommands-import Database.Redis.Types-import Database.Redis.Core(sendRequest, RedisCtx)--ttl- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f Integer)-ttl key = sendRequest (["TTL"] ++ [encode key] )--setnx- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ value- -> m (f Bool)-setnx key value = sendRequest (["SETNX"] ++ [encode key] ++ [encode value] )--pttl- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f Integer)-pttl key = sendRequest (["PTTL"] ++ [encode key] )--commandCount- :: (RedisCtx m f)- => m (f Integer)-commandCount = sendRequest (["COMMAND","COUNT"] )--clientSetname- :: (RedisCtx m f)- => ByteString -- ^ connectionName- -> m (f ByteString)-clientSetname connectionName = sendRequest (["CLIENT","SETNAME"] ++ [encode connectionName] )--zrank- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ member- -> m (f (Maybe Integer))-zrank key member = sendRequest (["ZRANK"] ++ [encode key] ++ [encode member] )--zremrangebyscore- :: (RedisCtx m f)- => ByteString -- ^ key- -> Double -- ^ min- -> Double -- ^ max- -> m (f Integer)-zremrangebyscore key min max = sendRequest (["ZREMRANGEBYSCORE"] ++ [encode key] ++ [encode min] ++ [encode max] )--hkeys- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f [ByteString])-hkeys key = sendRequest (["HKEYS"] ++ [encode key] )--slaveof- :: (RedisCtx m f)- => ByteString -- ^ host- -> ByteString -- ^ port- -> m (f Status)-slaveof host port = sendRequest (["SLAVEOF"] ++ [encode host] ++ [encode port] )--rpushx- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ value- -> m (f Integer)-rpushx key value = sendRequest (["RPUSHX"] ++ [encode key] ++ [encode value] )--debugObject- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f ByteString)-debugObject key = sendRequest (["DEBUG","OBJECT"] ++ [encode key] )--bgsave- :: (RedisCtx m f)- => m (f Status)-bgsave = sendRequest (["BGSAVE"] )--hlen- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f Integer)-hlen key = sendRequest (["HLEN"] ++ [encode key] )--rpoplpush- :: (RedisCtx m f)- => ByteString -- ^ source- -> ByteString -- ^ destination- -> m (f (Maybe ByteString))-rpoplpush source destination = sendRequest (["RPOPLPUSH"] ++ [encode source] ++ [encode destination] )--brpop- :: (RedisCtx m f)- => [ByteString] -- ^ key- -> Integer -- ^ timeout- -> m (f (Maybe (ByteString,ByteString)))-brpop key timeout = sendRequest (["BRPOP"] ++ map encode key ++ [encode timeout] )--bgrewriteaof- :: (RedisCtx m f)- => m (f Status)-bgrewriteaof = sendRequest (["BGREWRITEAOF"] )--zincrby- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ increment- -> ByteString -- ^ member- -> m (f Double)-zincrby key increment member = sendRequest (["ZINCRBY"] ++ [encode key] ++ [encode increment] ++ [encode member] )--hgetall- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f [(ByteString,ByteString)])-hgetall key = sendRequest (["HGETALL"] ++ [encode key] )--hmset- :: (RedisCtx m f)- => ByteString -- ^ key- -> [(ByteString,ByteString)] -- ^ fieldValue- -> m (f Status)-hmset key fieldValue = sendRequest (["HMSET"] ++ [encode key] ++ concatMap (\(x,y) -> [encode x,encode y])fieldValue )--sinter- :: (RedisCtx m f)- => [ByteString] -- ^ key- -> m (f [ByteString])-sinter key = sendRequest (["SINTER"] ++ map encode key )--pfadd- :: (RedisCtx m f)- => ByteString -- ^ key- -> [ByteString] -- ^ value- -> m (f Integer)-pfadd key value = sendRequest (["PFADD"] ++ [encode key] ++ map encode value )--zremrangebyrank- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ start- -> Integer -- ^ stop- -> m (f Integer)-zremrangebyrank key start stop = sendRequest (["ZREMRANGEBYRANK"] ++ [encode key] ++ [encode start] ++ [encode stop] )--flushdb- :: (RedisCtx m f)- => m (f Status)-flushdb = sendRequest (["FLUSHDB"] )--sadd- :: (RedisCtx m f)- => ByteString -- ^ key- -> [ByteString] -- ^ member- -> m (f Integer)-sadd key member = sendRequest (["SADD"] ++ [encode key] ++ map encode member )--lindex- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ index- -> m (f (Maybe ByteString))-lindex key index = sendRequest (["LINDEX"] ++ [encode key] ++ [encode index] )--lpush- :: (RedisCtx m f)- => ByteString -- ^ key- -> [ByteString] -- ^ value- -> m (f Integer)-lpush key value = sendRequest (["LPUSH"] ++ [encode key] ++ map encode value )--hstrlen- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ field- -> m (f Integer)-hstrlen key field = sendRequest (["HSTRLEN"] ++ [encode key] ++ [encode field] )--smove- :: (RedisCtx m f)- => ByteString -- ^ source- -> ByteString -- ^ destination- -> ByteString -- ^ member- -> m (f Bool)-smove source destination member = sendRequest (["SMOVE"] ++ [encode source] ++ [encode destination] ++ [encode member] )--zscore- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ member- -> m (f (Maybe Double))-zscore key member = sendRequest (["ZSCORE"] ++ [encode key] ++ [encode member] )--configResetstat- :: (RedisCtx m f)- => m (f Status)-configResetstat = sendRequest (["CONFIG","RESETSTAT"] )--pfcount- :: (RedisCtx m f)- => [ByteString] -- ^ key- -> m (f Integer)-pfcount key = sendRequest (["PFCOUNT"] ++ map encode key )--hdel- :: (RedisCtx m f)- => ByteString -- ^ key- -> [ByteString] -- ^ field- -> m (f Integer)-hdel key field = sendRequest (["HDEL"] ++ [encode key] ++ map encode field )--incrbyfloat- :: (RedisCtx m f)- => ByteString -- ^ key- -> Double -- ^ increment- -> m (f Double)-incrbyfloat key increment = sendRequest (["INCRBYFLOAT"] ++ [encode key] ++ [encode increment] )--setbit- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ offset- -> ByteString -- ^ value- -> m (f Integer)-setbit key offset value = sendRequest (["SETBIT"] ++ [encode key] ++ [encode offset] ++ [encode value] )--flushall- :: (RedisCtx m f)- => m (f Status)-flushall = sendRequest (["FLUSHALL"] )--incrby- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ increment- -> m (f Integer)-incrby key increment = sendRequest (["INCRBY"] ++ [encode key] ++ [encode increment] )--time- :: (RedisCtx m f)- => m (f (Integer,Integer))-time = sendRequest (["TIME"] )--smembers- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f [ByteString])-smembers key = sendRequest (["SMEMBERS"] ++ [encode key] )--zlexcount- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ min- -> ByteString -- ^ max- -> m (f Integer)-zlexcount key min max = sendRequest (["ZLEXCOUNT"] ++ [encode key] ++ [encode min] ++ [encode max] )--sunion- :: (RedisCtx m f)- => [ByteString] -- ^ key- -> m (f [ByteString])-sunion key = sendRequest (["SUNION"] ++ map encode key )--sinterstore- :: (RedisCtx m f)- => ByteString -- ^ destination- -> [ByteString] -- ^ key- -> m (f Integer)-sinterstore destination key = sendRequest (["SINTERSTORE"] ++ [encode destination] ++ map encode key )--hvals- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f [ByteString])-hvals key = sendRequest (["HVALS"] ++ [encode key] )--configSet- :: (RedisCtx m f)- => ByteString -- ^ parameter- -> ByteString -- ^ value- -> m (f Status)-configSet parameter value = sendRequest (["CONFIG","SET"] ++ [encode parameter] ++ [encode value] )--scriptFlush- :: (RedisCtx m f)- => m (f Status)-scriptFlush = sendRequest (["SCRIPT","FLUSH"] )--dbsize- :: (RedisCtx m f)- => m (f Integer)-dbsize = sendRequest (["DBSIZE"] )--wait- :: (RedisCtx m f)- => Integer -- ^ numslaves- -> Integer -- ^ timeout- -> m (f Integer)-wait numslaves timeout = sendRequest (["WAIT"] ++ [encode numslaves] ++ [encode timeout] )--lpop- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f (Maybe ByteString))-lpop key = sendRequest (["LPOP"] ++ [encode key] )--clientPause- :: (RedisCtx m f)- => Integer -- ^ timeout- -> m (f Status)-clientPause timeout = sendRequest (["CLIENT","PAUSE"] ++ [encode timeout] )--expire- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ seconds- -> m (f Bool)-expire key seconds = sendRequest (["EXPIRE"] ++ [encode key] ++ [encode seconds] )--mget- :: (RedisCtx m f)- => [ByteString] -- ^ key- -> m (f [Maybe ByteString])-mget key = sendRequest (["MGET"] ++ map encode key )--bitpos- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ bit- -> Integer -- ^ start- -> Integer -- ^ end- -> m (f Integer)-bitpos key bit start end = sendRequest (["BITPOS"] ++ [encode key] ++ [encode bit] ++ [encode start] ++ [encode end] )--lastsave- :: (RedisCtx m f)- => m (f Integer)-lastsave = sendRequest (["LASTSAVE"] )--pexpire- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ milliseconds- -> m (f Bool)-pexpire key milliseconds = sendRequest (["PEXPIRE"] ++ [encode key] ++ [encode milliseconds] )--clientList- :: (RedisCtx m f)- => m (f [ByteString])-clientList = sendRequest (["CLIENT","LIST"] )--renamenx- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ newkey- -> m (f Bool)-renamenx key newkey = sendRequest (["RENAMENX"] ++ [encode key] ++ [encode newkey] )--pfmerge- :: (RedisCtx m f)- => ByteString -- ^ destkey- -> [ByteString] -- ^ sourcekey- -> m (f ByteString)-pfmerge destkey sourcekey = sendRequest (["PFMERGE"] ++ [encode destkey] ++ map encode sourcekey )--lrem- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ count- -> ByteString -- ^ value- -> m (f Integer)-lrem key count value = sendRequest (["LREM"] ++ [encode key] ++ [encode count] ++ [encode value] )--sdiff- :: (RedisCtx m f)- => [ByteString] -- ^ key- -> m (f [ByteString])-sdiff key = sendRequest (["SDIFF"] ++ map encode key )--get- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f (Maybe ByteString))-get key = sendRequest (["GET"] ++ [encode key] )--getrange- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ start- -> Integer -- ^ end- -> m (f ByteString)-getrange key start end = sendRequest (["GETRANGE"] ++ [encode key] ++ [encode start] ++ [encode end] )--sdiffstore- :: (RedisCtx m f)- => ByteString -- ^ destination- -> [ByteString] -- ^ key- -> m (f Integer)-sdiffstore destination key = sendRequest (["SDIFFSTORE"] ++ [encode destination] ++ map encode key )--zcount- :: (RedisCtx m f)- => ByteString -- ^ key- -> Double -- ^ min- -> Double -- ^ max- -> m (f Integer)-zcount key min max = sendRequest (["ZCOUNT"] ++ [encode key] ++ [encode min] ++ [encode max] )--scriptLoad- :: (RedisCtx m f)- => ByteString -- ^ script- -> m (f ByteString)-scriptLoad script = sendRequest (["SCRIPT","LOAD"] ++ [encode script] )--getset- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ value- -> m (f (Maybe ByteString))-getset key value = sendRequest (["GETSET"] ++ [encode key] ++ [encode value] )--dump- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f ByteString)-dump key = sendRequest (["DUMP"] ++ [encode key] )--keys- :: (RedisCtx m f)- => ByteString -- ^ pattern- -> m (f [ByteString])-keys pattern = sendRequest (["KEYS"] ++ [encode pattern] )--configGet- :: (RedisCtx m f)- => ByteString -- ^ parameter- -> m (f [(ByteString,ByteString)])-configGet parameter = sendRequest (["CONFIG","GET"] ++ [encode parameter] )--rpush- :: (RedisCtx m f)- => ByteString -- ^ key- -> [ByteString] -- ^ value- -> m (f Integer)-rpush key value = sendRequest (["RPUSH"] ++ [encode key] ++ map encode value )--randomkey- :: (RedisCtx m f)- => m (f (Maybe ByteString))-randomkey = sendRequest (["RANDOMKEY"] )--hsetnx- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ field- -> ByteString -- ^ value- -> m (f Bool)-hsetnx key field value = sendRequest (["HSETNX"] ++ [encode key] ++ [encode field] ++ [encode value] )--mset- :: (RedisCtx m f)- => [(ByteString,ByteString)] -- ^ keyValue- -> m (f Status)-mset keyValue = sendRequest (["MSET"] ++ concatMap (\(x,y) -> [encode x,encode y])keyValue )--setex- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ seconds- -> ByteString -- ^ value- -> m (f Status)-setex key seconds value = sendRequest (["SETEX"] ++ [encode key] ++ [encode seconds] ++ [encode value] )--psetex- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ milliseconds- -> ByteString -- ^ value- -> m (f Status)-psetex key milliseconds value = sendRequest (["PSETEX"] ++ [encode key] ++ [encode milliseconds] ++ [encode value] )--scard- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f Integer)-scard key = sendRequest (["SCARD"] ++ [encode key] )--scriptExists- :: (RedisCtx m f)- => [ByteString] -- ^ script- -> m (f [Bool])-scriptExists script = sendRequest (["SCRIPT","EXISTS"] ++ map encode script )--sunionstore- :: (RedisCtx m f)- => ByteString -- ^ destination- -> [ByteString] -- ^ key- -> m (f Integer)-sunionstore destination key = sendRequest (["SUNIONSTORE"] ++ [encode destination] ++ map encode key )--persist- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f Bool)-persist key = sendRequest (["PERSIST"] ++ [encode key] )--strlen- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f Integer)-strlen key = sendRequest (["STRLEN"] ++ [encode key] )--lpushx- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ value- -> m (f Integer)-lpushx key value = sendRequest (["LPUSHX"] ++ [encode key] ++ [encode value] )--hset- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ field- -> ByteString -- ^ value- -> m (f Integer)-hset key field value = sendRequest (["HSET"] ++ [encode key] ++ [encode field] ++ [encode value] )--brpoplpush- :: (RedisCtx m f)- => ByteString -- ^ source- -> ByteString -- ^ destination- -> Integer -- ^ timeout- -> m (f (Maybe ByteString))-brpoplpush source destination timeout = sendRequest (["BRPOPLPUSH"] ++ [encode source] ++ [encode destination] ++ [encode timeout] )--zrevrank- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ member- -> m (f (Maybe Integer))-zrevrank key member = sendRequest (["ZREVRANK"] ++ [encode key] ++ [encode member] )--scriptKill- :: (RedisCtx m f)- => m (f Status)-scriptKill = sendRequest (["SCRIPT","KILL"] )--setrange- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ offset- -> ByteString -- ^ value- -> m (f Integer)-setrange key offset value = sendRequest (["SETRANGE"] ++ [encode key] ++ [encode offset] ++ [encode value] )--del- :: (RedisCtx m f)- => [ByteString] -- ^ key- -> m (f Integer)-del key = sendRequest (["DEL"] ++ map encode key )--hincrbyfloat- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ field- -> Double -- ^ increment- -> m (f Double)-hincrbyfloat key field increment = sendRequest (["HINCRBYFLOAT"] ++ [encode key] ++ [encode field] ++ [encode increment] )--hincrby- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ field- -> Integer -- ^ increment- -> m (f Integer)-hincrby key field increment = sendRequest (["HINCRBY"] ++ [encode key] ++ [encode field] ++ [encode increment] )--zremrangebylex- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ min- -> ByteString -- ^ max- -> m (f Integer)-zremrangebylex key min max = sendRequest (["ZREMRANGEBYLEX"] ++ [encode key] ++ [encode min] ++ [encode max] )--rpop- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f (Maybe ByteString))-rpop key = sendRequest (["RPOP"] ++ [encode key] )--rename- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ newkey- -> m (f Status)-rename key newkey = sendRequest (["RENAME"] ++ [encode key] ++ [encode newkey] )--zrem- :: (RedisCtx m f)- => ByteString -- ^ key- -> [ByteString] -- ^ member- -> m (f Integer)-zrem key member = sendRequest (["ZREM"] ++ [encode key] ++ map encode member )--hexists- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ field- -> m (f Bool)-hexists key field = sendRequest (["HEXISTS"] ++ [encode key] ++ [encode field] )--clientGetname- :: (RedisCtx m f)- => m (f Status)-clientGetname = sendRequest (["CLIENT","GETNAME"] )--configRewrite- :: (RedisCtx m f)- => m (f Status)-configRewrite = sendRequest (["CONFIG","REWRITE"] )--decr- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f Integer)-decr key = sendRequest (["DECR"] ++ [encode key] )--hmget- :: (RedisCtx m f)- => ByteString -- ^ key- -> [ByteString] -- ^ field- -> m (f [Maybe ByteString])-hmget key field = sendRequest (["HMGET"] ++ [encode key] ++ map encode field )--lrange- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ start- -> Integer -- ^ stop- -> m (f [ByteString])-lrange key start stop = sendRequest (["LRANGE"] ++ [encode key] ++ [encode start] ++ [encode stop] )--decrby- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ decrement- -> m (f Integer)-decrby key decrement = sendRequest (["DECRBY"] ++ [encode key] ++ [encode decrement] )--llen- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f Integer)-llen key = sendRequest (["LLEN"] ++ [encode key] )--append- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ value- -> m (f Integer)-append key value = sendRequest (["APPEND"] ++ [encode key] ++ [encode value] )--incr- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f Integer)-incr key = sendRequest (["INCR"] ++ [encode key] )--hget- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ field- -> m (f (Maybe ByteString))-hget key field = sendRequest (["HGET"] ++ [encode key] ++ [encode field] )--pexpireat- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ millisecondsTimestamp- -> m (f Bool)-pexpireat key millisecondsTimestamp = sendRequest (["PEXPIREAT"] ++ [encode key] ++ [encode millisecondsTimestamp] )--ltrim- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ start- -> Integer -- ^ stop- -> m (f Status)-ltrim key start stop = sendRequest (["LTRIM"] ++ [encode key] ++ [encode start] ++ [encode stop] )--zcard- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f Integer)-zcard key = sendRequest (["ZCARD"] ++ [encode key] )--lset- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ index- -> ByteString -- ^ value- -> m (f Status)-lset key index value = sendRequest (["LSET"] ++ [encode key] ++ [encode index] ++ [encode value] )--expireat- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ timestamp- -> m (f Bool)-expireat key timestamp = sendRequest (["EXPIREAT"] ++ [encode key] ++ [encode timestamp] )--save- :: (RedisCtx m f)- => m (f Status)-save = sendRequest (["SAVE"] )--move- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ db- -> m (f Bool)-move key db = sendRequest (["MOVE"] ++ [encode key] ++ [encode db] )--getbit- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ offset- -> m (f Integer)-getbit key offset = sendRequest (["GETBIT"] ++ [encode key] ++ [encode offset] )--msetnx- :: (RedisCtx m f)- => [(ByteString,ByteString)] -- ^ keyValue- -> m (f Bool)-msetnx keyValue = sendRequest (["MSETNX"] ++ concatMap (\(x,y) -> [encode x,encode y])keyValue )--commandInfo- :: (RedisCtx m f)- => [ByteString] -- ^ commandName- -> m (f [ByteString])-commandInfo commandName = sendRequest (["COMMAND","INFO"] ++ map encode commandName )--quit- :: (RedisCtx m f)- => m (f Status)-quit = sendRequest (["QUIT"] )--blpop- :: (RedisCtx m f)- => [ByteString] -- ^ key- -> Integer -- ^ timeout- -> m (f (Maybe (ByteString,ByteString)))-blpop key timeout = sendRequest (["BLPOP"] ++ map encode key ++ [encode timeout] )--srem- :: (RedisCtx m f)- => ByteString -- ^ key- -> [ByteString] -- ^ member- -> m (f Integer)-srem key member = sendRequest (["SREM"] ++ [encode key] ++ map encode member )--echo- :: (RedisCtx m f)- => ByteString -- ^ message- -> m (f ByteString)-echo message = sendRequest (["ECHO"] ++ [encode message] )--sismember- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ member- -> m (f Bool)-sismember key member = sendRequest (["SISMEMBER"] ++ [encode key] ++ [encode member] )+{-# LANGUAGE OverloadedStrings, FlexibleContexts, OverloadedLists #-}++module Database.Redis.Commands (++-- * Connection++-- ** Auth+-- $auth+auth,+authOpts,+AuthOpts(..),+defaultAuthOpts,+-- ** Other commands+echo,+ping,+quit,+select,++-- * Generic keys+copy,+copyOpts,+CopyOpts(..),+defaultCopyOpts,+del,+dump,+exists,+expire,+expireOpts,+ExpireOpts(..),+expireat,+expireatOpts,+keys,+MigrateOpts(..),+defaultMigrateOpts,+migrate,+migrateMultiple,+move,+objectRefcount,+objectEncoding,+objectIdletime,+persist,+expiretime,+pexpire,+pexpiretime,+pexpireat,+pexpireatOpts,+pttl,+randomkey,+rename,+renamenx,+restore,+restoreReplace,+Cursor,+cursor0,+ScanOpts(..),+defaultScanOpts,+scan,+scanOpts,+SortOpts(..),+defaultSortOpts,+SortOrder(..),+sort,+sortStore,+ttl,+RedisType(..),+getType,+++-- * Hashes+hdel,+HashFieldExpirationStatus(..),+HashFieldExpirationInfo(..),+hexists,+hexpire,+hexpireOpts,+hexpireat,+hexpireatOpts,+hexpiretime,+hget,+hgetdel,+hgetex,+HGetExOpts(..),+defaultHGetExOpts,+hgetexOpts,+hgetall,+hincrby,+hincrbyfloat,+hkeys,+hlen,+hmget,+hmset,+hrandfield,+hrandfieldCount,+hrandfieldCountWithValues,+hscan,+hscanOpts,+hpexpire,+hpexpireOpts,+hpexpireat,+hpexpireatOpts,+hpexpiretime,+hpttl,+hset,+hsetex,+HSetExCondition(..),+HSetExOpts(..),+defaultHSetExOpts,+hsetexOpts,+hsetnx,+hstrlen,+httl,+hvals,++-- * HyperLogLogs+pfadd,+pfcount,+pfmerge,++-- * Lists+blpop,+blpopFloat,+blmpop,+blmpopCount,+blmove,+ListDirection(..),+brpop,+brpopFloat,+brpoplpush,+lindex,+linsertBefore,+linsertAfter,+llen,+lmpop,+lmpopCount,+lpos,+LPosOpts(..),+defaultLPosOpts,+lposOpts,+lposCount,+lposCountOpts,+lpop,+lpopCount,+lmove,+lpush,+lpushx,+lrange,+lrem,+lset,+ltrim,+rpop,+rpopCount,+rpoplpush,+rpush,+rpushx,++-- * Scripting+eval,+evalsha,+fcall,+fcallReadonly,+DebugMode,+functionHelp,+functionList,+FunctionListOpts(..),+defaultFunctionListOpts,+functionListOpts,+module Function,+scriptDebug,+scriptExists,+scriptFlush,+scriptKill,+scriptLoad,++-- * Server+bgrewriteaof,+bgsave,+bgsaveSchedule,+clientGetname,+clientId,+clientList,+clientPause,+ReplyMode,+clientReply,+clientUnpause,+clientSetname,+clientNoTouch,+clientSetinfo,++commandCount,+commandInfo,+commandList,+CommandListFilter(..),+commandListOpts,+HotkeysMetric(..),+HotkeysStartOpts(..),+defaultHotkeysStartOpts,+HotkeysSlotRange(..),+HotkeysGetResponse(..),+hotkeysGet,+hotkeysStart,+hotkeysStartOpts,+hotkeysStop,+hotkeysReset,+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,+sintercard,+SintercardOpts(..),+defaultSintercardOpts,+sintercardOpts,+sinterstore,+sismember,+smembers,+smismember,+smove,+spop,+spopN,+srandmember,+srandmemberN,+srem,+sscan,+sscanOpts,+sunion,+sunionstore,++-- * Sorted Sets+bzpopmax,+bzpopmin,+ZaddOpts(..),+defaultZaddOpts,+zadd,+zaddOpts,+zcard,+zcount,+zdiff,+zdiffWithscores,+zdiffstore,+SizeCondition(..),+zincrby,+Aggregate(..),+ZPopMinMax(..),+ZPopResponse(..),+zmpop,+zmpopCount,+bzmpop,+bzmpopCount,+ZAggregateOpts(..),+defaultZAggregateOpts,+zinter,+zinterWithscores,+zinterOpts,+zinterWithscoresOpts,+zinterstore,+zinterstoreWeights,+zlexcount,+zmscore,+zpopmin,+zpopmax,+zrandmember,+zrandmemberN,+zrandmemberWithscores,+zrange,+zrangeWithscores,+ZRangeStoreRange(..),+ZRangeStoreOpts(..),+defaultZRangeStoreOpts,+zrangestore,+zrangestoreOpts,+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,+zunion,+zunionWithscores,+zunionOpts,+zunionWithscoresOpts,+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++-- * Vector Sets+VAddQuantization(..),+VAddOpts(..),+defaultVAddOpts,+VQuantization(..),+VEmbRawResponse(..),+VInfoResponse(..),+VLinksResponse(..),+VLinksWithScoresResponse(..),+VSimQuery(..),+VSimOpts(..),+defaultVSimOpts,+VSimWithAttribsResult(..),+VSimWithAttribsResponse(..),+vadd,+vaddOpts,+vcard,+vdim,+vemb,+vembRaw,+vgetattr,+vinfo,+vismember,+vlinks,+vlinksWithScores,+vrandmember,+vrandmemberCount,+vrange,+vrangeCount,+vrem,+vsetattr,+vsim,+vsimOpts,+vsimWithScores,+vsimWithScoresOpts,+vsimWithScoresWithAttribs,+vsimWithScoresWithAttribsOpts,++-- * Arrays+ARGrepPredicate(..),+ARGrepCombine(..),+ARGrepOpts(..),+defaultARGrepOpts,+ARLastItemsOpts(..),+defaultARLastItemsOpts,+ARScanOpts(..),+defaultARScanOpts,+ARIndexValuePairsResponse(..),+ARInfoResponse(..),+AROpValue(..),+AROpCount(..),+arcount,+ardel,+argetrange,+argrep,+argrepOpts,+argrepWithValues,+argrepWithValuesOpts,+arinfo,+arinfoFull,+arinsert,+arlastitems,+arlastitemsOpts,+arlen,+armget,+arnext,+aropValue,+aropCount,+arring,+arscan,+arscanOpts,+arseek,+arset,++-- * 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,+delex,+DelexCondition(..),+delexWhen,+digest,+get,+getbit,+getdel,+getex,+IncrexExpiration(..),+IncrexOpts(..),+defaultIncrexOpts,+increx,+increxOpts,+increxBy,+increxByFloat,+GetExOpts(..),+defaultGetExOpts,+getexOpts,+getrange,+getset,+incr,+incrby,+incrbyfloat,+mget,+mset,+msetex,+msetexOpts,+msetnx,+psetex,+Condition(..),+SetOpts(..),+defaultSetOpts,+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,+substr,+++-- * Streams+XReadOpts(..),+defaultXreadOpts,+XReadResponse(..),+StreamsRecord(..),+xadd,+xaddOpts,+XAddOpts(..),+defaultXAddOpts,+TrimStrategy(..),+TrimType(..),+trimOpts,+xread,+xreadOpts,+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+xackdel,+xackdelOpts,+XRefPolicy(..),+XEntryDeletionOpts(..),+defaultXEntryDeletionOpts,+XEntryDeletionResult(..),+XCfgSetOpts(..),+defaultXCfgSetOpts,+xcfgset,+XNackMode(..),+XNackOpts(..),+defaultXNackOpts,+xidmprecord,+xnack,+xnackOpts,++-- $xgroupCreate+xgroupCreate,+xgroupCreateOpts,+XGroupCreateOpts(..),+defaultXGroupCreateOpts,++xgroupCreateConsumer,++-- $xgroupSetId+xgroupSetId,+xgroupSetIdOpts,+XGroupSetIdOpts(..),+defaultXGroupSetIdOpts,++xgroupDestroy,++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+xpendingSummary,+XPendingSummaryResponse(..),+XPendingDetailOpts(..),+defaultXPendingDetailOpts,+XPendingDetailRecord(..),+xpendingDetail,++XClaimOpts(..),+defaultXClaimOpts,+xclaim, -- |Change ownership of some messages to the given consumer, returning the updated messages. The Redis @XCLAIM@ command is split into 'xclaim' and 'xclaimJustIds'. Since Redis 5.0.0+xclaimJustIds, -- |Change ownership of some messages to the given consumer, returning only the changed message IDs. The Redis @XCLAIM@ command is split into 'xclaim' and 'xclaimJustIds'. Since Redis 5.0.0+-- $autoclaim+xautoclaim,+xautoclaimOpts,+XAutoclaimOpts(..),+XAutoclaimStreamsResult,+XAutoclaimResult(..),+xautoclaimJustIds,+xautoclaimJustIdsOpts,+XAutoclaimJustIdsResult,+XInfoConsumersResponse(..),+xinfoConsumers,+XInfoGroupsResponse(..),+xinfoGroups,+XInfoStreamResponse(..),+xinfoStream,+xdel,+xdelex,+xdelexOpts,+xtrim,++-- * Geo commands+GeoUnit(..),+GeoOrder(..),+GeoCoordinates(..),+GeoLocation(..),+GeoSearchFrom(..),+GeoSearchBy(..),+GeoSearchOpts(..),+defaultGeoSearchOpts,+GeoSearchStoreOpts(..),+defaultGeoSearchStoreOpts,+GeoAddOpts(..),+defaultGeoAddOpts,+geoadd,+geoaddOpts,+geodist,+geopos,+geoSearch,+geoSearchStore,++-- * Redis stack+-- ** Wait+module Wait,++-- ** Bloom Filters+module BF,++-- ** Cuckoo Filters+module CF,++-- ** Count-Min Sketches+module Cms,++-- ** Top-K+module Topk,++-- ** T-Digest+module Tdigest,++-- ** Time Series+module Ts,++-- ** Redis Indexes+module FT,++-- ** JSON+module JSON,++-- * Cluster commands+inf,+ClusterInfoResponse (..),+ClusterInfoResponseState (..),+clusterInfo,+clusterMyshardid,+ClusterNodesResponse(..),+ClusterNodesResponseEntry(..),+ClusterNodesResponseSlotSpec(..),+clusterNodes,+ClusterSlotsResponse(..),+ClusterSlotsResponseEntry(..),+ClusterSlotsNode(..),+clusterSlots,+ClusterSlotStatsMetric(..),+ClusterSlotStatsOrderByOpts(..),+defaultClusterSlotStatsOrderByOpts,+ClusterSlotStatsQuery(..),+ClusterSlotStatsResponse(..),+ClusterSlotStatsResponseEntry(..),+clusterSlotStats,+clusterSlotStatsSlotsRange,+clusterSlotStatsOrderBy,+clusterSlotStatsOrderByOpts,+ClusterMigrationSlotRange(..),+ClusterMigrationTask(..),+ClusterMigrationStatusResponse(..),+clusterMigrationImport,+clusterMigrationCancelId,+clusterMigrationCancelAll,+clusterMigrationStatus,+clusterMigrationStatusAll,+clusterMigrationStatusId,+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.BF as BF+import Database.Redis.ManualCommands.CF as CF+import Database.Redis.ManualCommands.Cms as Cms+import Database.Redis.ManualCommands.FT as FT+import Database.Redis.ManualCommands.Function as Function+import Database.Redis.ManualCommands.JSON as JSON+import Database.Redis.ManualCommands.Tdigest as Tdigest+import Database.Redis.ManualCommands.Ts as Ts+import Database.Redis.ManualCommands.Topk as Topk+import Database.Redis.ManualCommands.Wait as Wait+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])++-- |Remove and return the member with the highest score from one or more sorted sets, or block until one is available (<http://redis.io/commands/bzpopmax>).+--+-- Since Redis 5.0.0+bzpopmax+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ keys+ -> Double -- ^ timeout+ -> m (f (Maybe (ByteString, ByteString, Double)))+bzpopmax (key:|keys_) timeout = sendRequest $ "BZPOPMAX" : key : keys_ ++ [encode timeout]++-- |Remove and return the member with the lowest score from one or more sorted sets, or block until one is available (<http://redis.io/commands/bzpopmin>).+--+-- Since Redis 5.0.0+bzpopmin+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ keys+ -> Double -- ^ timeout+ -> m (f (Maybe (ByteString, ByteString, Double)))+bzpopmin (key:|keys_) timeout = sendRequest $ "BZPOPMIN" : key : keys_ ++ [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 and return the member with the lowest score in a sorted set (<http://redis.io/commands/zpopmin>).+--+-- Since Redis 5.0.0+zpopmin+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> m (f (Maybe (ByteString, Double)))+zpopmin key = sendRequest ["ZPOPMIN", key]++-- |Remove and return the member with the highest score in a sorted set (<http://redis.io/commands/zpopmax>).+--+-- Since Redis 5.0.0+zpopmax+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> m (f (Maybe (ByteString, Double)))+zpopmax key = sendRequest ["ZPOPMAX", key]++-- |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"]++-- |Remove and get the first element in a list (<http://redis.io/commands/lpop>). Since Redis 1.0.0+lpop+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> m (f (Maybe ByteString))+lpop key = sendRequest ["LPOP", encode key]++-- |+-- Remove and get the first element in a list (<http://redis.io/commands/lpop>).+-- The reply will consist of up to count elements, depending on the list's length.+-- Since Redis 1.0.0+lpopCount+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer+ -> m (f [ByteString])+lpopCount key count = sendRequest ["LPOP", key, encode count]++-- |Stop processing commands from clients for some time (<http://redis.io/commands/client-pause>).+-- Since Redis 2.9.50+clientPause+ :: (RedisCtx m f)+ => Integer -- ^ timeout+ -> m (f Status)+clientPause timeout = sendRequest ["CLIENT","PAUSE", encode timeout]++-- |Set a key's time to live in seconds (<http://redis.io/commands/expire>). Since Redis 1.0.0+expire+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer -- ^ seconds+ -> m (f Bool)+expire key seconds = sendRequest ["EXPIRE", key, encode seconds]++-- |Get the values of all the given keys (<http://redis.io/commands/mget>).+-- Since Redis 1.0.0+mget+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ key+ -> m (f [Maybe ByteString])+mget (key:|keys_) = sendRequest ("MGET":key:keys_)++-- |+-- Find first bit set or clear in a string (<http://redis.io/commands/bitpos>).+-- Since Redis 2.8.7+bitpos+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer -- ^ bit+ -> Integer -- ^ start+ -> Integer -- ^ end+ -> m (f Integer)+bitpos key bit start end = sendRequest ["BITPOS", key, encode bit, encode start, encode end]++lastsave+ :: (RedisCtx m f)+ => m (f Integer)+lastsave = sendRequest (["LASTSAVE"] )++-- | Set a key's time to live in milliseconds (<http://redis.io/commands/pexpire>).+-- Since Redis 2.6.0+pexpire+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer -- ^ milliseconds+ -> m (f Bool)+pexpire key milliseconds = sendRequest ["PEXPIRE", key, encode milliseconds]++-- |Get the list of client connections (<http://redis.io/commands/client-list>). Since Redis 2.4.0+clientList+ :: (RedisCtx m f)+ => m (f [ByteString])+clientList = sendRequest (["CLIENT","LIST"] )++-- |Rename a key, only if the new key does not exist (<http://redis.io/commands/renamenx>). Since Redis 1.0.0+renamenx+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> ByteString -- ^ newkey+ -> m (f Bool)+renamenx key newkey = sendRequest ["RENAMENX", key, newkey]++-- |Merge N different HyperLogLogs into a single one (<http://redis.io/commands/pfmerge>). Since Redis 2.8.9+pfmerge+ :: (RedisCtx m f)+ => ByteString -- ^ destkey+ -> [ByteString] -- ^ sourcekey+ -> m (f ByteString)+pfmerge destkey sourcekey = sendRequest ("PFMERGE": destkey: sourcekey)++-- | Remove elements from a list (<http://redis.io/commands/lrem>). Since Redis 1.0.0+lrem+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer -- ^ count+ -> ByteString -- ^ value+ -> m (f Integer)+lrem key count value = sendRequest ["LREM", key, encode count, value]++-- |Subtract multiple sets (<http://redis.io/commands/sdiff>). Since Redis 1.0.0+sdiff+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ key+ -> m (f [ByteString])+sdiff (key_:|keys_) = sendRequest ("SDIFF":key_:keys_)++-- |Get the value of a key (<http://redis.io/commands/get>). Since Redis 1.0.0+get+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> m (f (Maybe ByteString))+get key = sendRequest (["GET"] ++ [encode key] )++-- |Get a substring of the string stored at a key (<http://redis.io/commands/getrange>).+-- Since Redis 2.4.0+getrange+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer -- ^ start+ -> Integer -- ^ end+ -> m (f ByteString)+getrange key start end = sendRequest ["GETRANGE", key, encode start, encode end]++-- |Subtract multiple sets and store the resulting set in a key (<http://redis.io/commands/sdiffstore>). Since Redis 1.0.0+sdiffstore+ :: (RedisCtx m f)+ => ByteString -- ^ destination+ -> NonEmpty ByteString -- ^ key+ -> m (f Integer)+sdiffstore destination (key_:|keys_) = sendRequest ("SDIFFSTORE": destination: key_: keys_)++-- |Count the members in a sorted set with scores within the given values (<http://redis.io/commands/zcount>). Since Redis 2.0.0+zcount+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Double -- ^ min+ -> Double -- ^ max+ -> m (f Integer)+zcount key min max = sendRequest ["ZCOUNT", key, encode min, encode max]++-- |Load the specified Lua script into the script cache (<http://redis.io/commands/script-load>). Since Redis 2.6.0+scriptLoad+ :: (RedisCtx m f)+ => ByteString -- ^ script+ -> m (f ByteString)+scriptLoad script = sendRequest ["SCRIPT","LOAD", encode script]++-- |Set the string value of a key and return its old value (<http://redis.io/commands/getset>). Since Redis 1.0.0+getset+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> ByteString -- ^ value+ -> m (f (Maybe ByteString))+getset key value = sendRequest ["GETSET", key, value]++-- |Return a serialized version of the value stored at the specified key (<http://redis.io/commands/dump>). Since Redis 2.6.0+dump+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> m (f ByteString)+dump key = sendRequest ["DUMP", key]++-- |Find all keys matching the given pattern (<http://redis.io/commands/keys>). Since Redis 1.0.0+keys+ :: (RedisCtx m f)+ => ByteString -- ^ pattern+ -> m (f [ByteString])+keys pattern = sendRequest ["KEYS", pattern]++-- |Get the value of a configuration parameter (<http://redis.io/commands/config-get>). Since Redis 2.0.0+configGet+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ parameter+ -> m (f [(ByteString,ByteString)])+configGet (parameter:|parameters) = sendRequest ("CONFIG":"GET":parameter:parameters)++-- |Append one or multiple values to a list (<http://redis.io/commands/rpush>). Since Redis 1.0.0+rpush+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> NonEmpty ByteString -- ^ value+ -> m (f Integer)+rpush key (value:|values) = sendRequest ("RPUSH": encode key:value:values)++-- |Return a random key from the keyspace (<http://redis.io/commands/randomkey>). Since Redis 1.0.0+randomkey+ :: (RedisCtx m f)+ => m (f (Maybe ByteString))+randomkey = sendRequest ["RANDOMKEY"]++-- |Set the value of a hash field, only if the field does not exist (<http://redis.io/commands/hsetnx>). Since Redis 2.0.0+hsetnx+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> ByteString -- ^ field+ -> ByteString -- ^ value+ -> m (f Bool)+hsetnx key field value = sendRequest ["HSETNX", key, field, value]++-- |Set multiple keys to multiple values (<http://redis.io/commands/mset>). Since Redis 1.0.1+mset+ :: (RedisCtx m f)+ => NonEmpty (ByteString,ByteString) -- ^ keyValue+ -> m (f Status)+mset ((key_,value):|keyValue) =+ sendRequest ("MSET":key_:value: concatMap (\(x,y) -> [encode x,encode y]) keyValue)++-- |Set the value and expiration of a key (<http://redis.io/commands/setex>).+-- Regarded as deprected since 2.6 as it can be replaced by SET with the EX argument when+-- migrating or writing new code.+-- Since Redis 2.0.0+setex+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer -- ^ seconds+ -> ByteString -- ^ value+ -> m (f Status)+setex key seconds value = sendRequest ["SETEX", key, encode seconds, value]++-- |Set the value and expiration in milliseconds of a key (<http://redis.io/commands/psetex>).+-- Condidered deprecated since it can be replaced by SET with the PX argument when migrating or writing new code+-- Since Redis 2.6.0+psetex+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer -- ^ milliseconds+ -> ByteString -- ^ value+ -> m (f Status)+psetex key milliseconds value = sendRequest ["PSETEX", key, encode milliseconds, value]++-- |Get the number of members in a set (<http://redis.io/commands/scard>). Since Redis 1.0.0+scard+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> m (f Integer)+scard key = sendRequest ["SCARD", key]++-- |Check existence of scripts in the script cache (<http://redis.io/commands/script-exists>). Since Redis 2.6.0+scriptExists+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ script+ -> m (f [Bool])+scriptExists (script:|scripts) = sendRequest ("SCRIPT":"EXISTS":script:scripts)++-- |Add multiple sets and store the resulting set in a key (<http://redis.io/commands/sunionstore>). Since Redis 1.0.0+sunionstore+ :: (RedisCtx m f)+ => ByteString -- ^ destination+ -> NonEmpty ByteString -- ^ key+ -> m (f Integer)+sunionstore destination (key_:|keys_) =+ sendRequest ("SUNIONSTORE":destination:key_:keys_)++-- |Remove the expiration from a key (<http://redis.io/commands/persist>). Since Redis 2.2.0+persist+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> m (f Bool)+persist key = sendRequest ["PERSIST", key]++-- |Get the length of the value stored in a key (<http://redis.io/commands/strlen>). Since Redis 2.2.0+strlen+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> m (f Integer)+strlen key = sendRequest ["STRLEN", encode key]++-- |Prepend a value to a list, only if the list exists (<http://redis.io/commands/lpushx>). Since Redis 2.2.0+lpushx+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> NonEmpty ByteString -- ^ value+ -> m (f Integer)+lpushx key (value:|values) = sendRequest ("LPUSHX":key:value:values)++-- |Set the string value of a hash field (<http://redis.io/commands/hset>).+--+-- This command oveerides keys if they exist in the hash.+--+-- Since Redis 2.0.0+hset+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> NonEmpty (ByteString, ByteString) -- ^ Values.+ -> m (f Integer)+hset key ((field,value):|fieldValues) =+ sendRequest ("HSET":encode key:encode field:encode value:concatMap (\(f,v) ->[f,v]) fieldValues)++-- |Pop a value from a list, push it to another list and return it; or block until one is available (<http://redis.io/commands/brpoplpush>).+--+-- Since Redis 6.0 this command considered deprecated: it can be replaced by BLMOVE with the RIGHT and LEFT arguments when migrating or writing new code.+--+-- Since Redis 2.2.0+brpoplpush+ :: (RedisCtx m f)+ => ByteString -- ^ source+ -> ByteString -- ^ destination+ -> Integer -- ^ timeout+ -> m (f (Maybe ByteString))+brpoplpush source destination timeout =+ sendRequest ["BRPOPLPUSH", source, destination, encode timeout]++-- |Determine the index of a member in a sorted set, with scores ordered from high to low (<http://redis.io/commands/zrevrank>).+-- Since Redis 2.0.0+zrevrank+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> ByteString -- ^ member+ -> m (f (Maybe Integer))+zrevrank key member = sendRequest ["ZREVRANK", key, member]++zrevrankWithScore+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> ByteString -- ^ member+ -> m (f (Maybe (Integer, Double)))+zrevrankWithScore key member = sendRequest ["ZREVRANK", key, member]++-- |Kill the script currently in execution (<http://redis.io/commands/script-kill>). Since Redis 2.6.0+scriptKill+ :: (RedisCtx m f)+ => m (f Status)+scriptKill = sendRequest ["SCRIPT","KILL"]++-- |Overwrite part of a string at key starting at the specified offset (<http://redis.io/commands/setrange>).+--+-- Returns the lenght of the string after it was modified.+--+-- Since Redis 2.2.0+setrange+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer -- ^ offset+ -> ByteString -- ^ value+ -> m (f Integer)+setrange key offset value = sendRequest ["SETRANGE", key, encode offset, value]++-- | Delete a key (<http://redis.io/commands/del>).+-- Returns a number of keys that were removed.+-- Since Redis 1.0.0+del+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ List of keys to delete.+ -> m (f Integer)+del (key:|rest) = sendRequest ("DEL":key:rest)++-- |Increment the float value of a hash field by the given amount (<http://redis.io/commands/hincrbyfloat>).+-- Since Redis 2.6.0+hincrbyfloat+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> ByteString -- ^ field+ -> Double -- ^ increment+ -> m (f Double)+hincrbyfloat key field increment = sendRequest ["HINCRBYFLOAT", key, field, encode increment]++-- | Increment the integer value of a hash field by the given number (<http://redis.io/commands/hincrby>). Since Redis 2.0.0+hincrby+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> ByteString -- ^ field+ -> Int64 -- ^ increment+ -> m (f Int64)+hincrby key field increment = sendRequest ["HINCRBY", encode key, encode field, encode increment]++-- | O(log(N)+M) with @N@ being thee number of elements in thee sorted set and @M@ the number+-- of elements removed by the operation.+--+-- Remove all members in a sorted set between the given lexicographical range (<http://redis.io/commands/zremrangebylex>).+--+-- Returns number of elements that were removed.+--+-- Since Redis 2.8.9+zremrangebylex+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> ByteString -- ^ min+ -> ByteString -- ^ max+ -> m (f Integer)+zremrangebylex key min max = sendRequest (["ZREMRANGEBYLEX"] ++ [encode key] ++ [encode min] ++ [encode max] )++-- |Remove and get the last element in a list (<http://redis.io/commands/rpop>).+-- Since Redis 1.0.0+rpop+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> m (f (Maybe ByteString))+rpop key = sendRequest ["RPOP", encode key]++-- |Remove and get the last element in a list (<http://redis.io/commands/rpop>).+-- The reply will consist of up to count elements, depending on the list's length.+-- Result will have no more than @N@ arguments.+--+-- Since Redis 1.0.0+rpopCount+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer+ -> m (f [ByteString])+rpopCount key count = sendRequest (["RPOP",key, encode count] )++-- |Rename a key (<http://redis.io/commands/rename>). Since Redis 1.0.0+--+-- Does not return a error even if newkey existed.+rename+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> ByteString -- ^ newkey+ -> m (f Status)+rename key newkey = sendRequest ["RENAME", encode key, encode newkey]++-- | /O(M*log(N))/ with @N@ number of elements in the sorted set, @M@ number of elements to be+-- removed.+--+-- Removes one or more members from a sorted set (<http://redis.io/commands/zrem>).+--+-- Since Redis 1.2.0+zrem+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> NonEmpty ByteString -- ^ member+ -> m (f Integer)+zrem key (member:|members) = sendRequest ("ZREM":encode key:encode member:members)++-- |Determine if a hash field exists (<http://redis.io/commands/hexists>).+-- Since Redis 2.0.0+hexists+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> ByteString -- ^ field+ -> m (f Bool)+hexists key field = sendRequest ["HEXISTS", key, field]++-- |Get the current connection ID (<http://redis.io/commands/client-id>). Since Redis 5.0.0+clientId+ :: (RedisCtx m f)+ => m (f Integer)+clientId = sendRequest ["CLIENT","ID"]++-- |Get the current connection name (<http://redis.io/commands/client-getname>). Since Redis 2.6.9+clientGetname+ :: (RedisCtx m f)+ => m (f (Maybe ByteString))+clientGetname = sendRequest ["CLIENT","GETNAME"]++-- |Rewrite the configuration file with the in memory configuration (<http://redis.io/commands/config-rewrite>). Since Redis 2.8.0+configRewrite+ :: (RedisCtx m f)+ => m (f Status)+configRewrite = sendRequest ["CONFIG","REWRITE"]++-- |Decrement the integer value of a key by one (<http://redis.io/commands/decr>).+-- Since Redis 1.0.0+decr+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> m (f Integer)+decr key = sendRequest ["DECR", key]++-- |Get the values of all the given hash fields (<http://redis.io/commands/hmget>).+-- Since Redis 2.0.0+hmget+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> NonEmpty ByteString -- ^ field+ -> m (f [Maybe ByteString])+hmget key (field:|fields) = sendRequest ("HMGET":key:field:fields)++-- |Get a range of elements from a list (<http://redis.io/commands/lrange>). Since Redis 1.0.0+lrange+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer -- ^ start+ -> Integer -- ^ stop+ -> m (f [ByteString])+lrange key start stop = sendRequest ["LRANGE", key, encode start, encode stop]++-- |Decrement the integer value of a key by the given number (<http://redis.io/commands/decrby>).+-- Since Redis 1.0.0+decrby+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer -- ^ decrement+ -> m (f Integer)+decrby key decrement = sendRequest ["DECRBY",key, encode decrement]++-- |Get the length of a list (<http://redis.io/commands/llen>). Since Redis 1.0.0+llen+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> m (f Integer)+llen key = sendRequest ["LLEN", encode key]++-- | /O(1)/ Append a value to a key (<http://redis.io/commands/append>). Since Redis 2.0.0+append+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> ByteString -- ^ value+ -> m (f Integer)+append key value = sendRequest ["APPEND", key, value]++-- |Increment the integer value of a key by one (<http://redis.io/commands/incr>). Since Redis 1.0.0+incr+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> m (f Integer)+incr key = sendRequest ["INCR", key]++-- |Get the value of a hash field (<http://redis.io/commands/hget>). Since Redis 2.0.0+hget+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> ByteString -- ^ field+ -> m (f (Maybe ByteString))+hget key field = sendRequest ["HGET",key,field]++-- |Set the expiration for a key as a UNIX timestamp specified in milliseconds (<http://redis.io/commands/pexpireat>). Since Redis 2.6.0+pexpireat+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer -- ^ millisecondsTimestamp+ -> m (f Bool)+pexpireat key millisecondsTimestamp = sendRequest ["PEXPIREAT", key, encode millisecondsTimestamp]++-- | Trim a list to the specified range (<http://redis.io/commands/ltrim>).+-- Since Redis 1.0.0+ltrim+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer -- ^ start+ -> Integer -- ^ stop+ -> m (f Status)+ltrim key start stop = sendRequest ["LTRIM", key, encode start, encode stop]++-- | /O(1)/+-- Get the number of members in a sorted set (<http://redis.io/commands/zcard>).+-- Since Redis 1.2.0+zcard+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> m (f Integer)+zcard key = sendRequest ["ZCARD", key]++-- | Set the value of an element in a list by its index (<http://redis.io/commands/lset>).+-- Since Redis 1.0.0+lset+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer -- ^ index+ -> ByteString -- ^ value+ -> m (f Status)+lset key index value = sendRequest ["LSET", key, encode index, value]++-- | Set the expiration for a key as a UNIX timestamp (<http://redis.io/commands/expireat>).+-- Since Redis 1.2.0+expireat+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer -- ^ timestamp+ -> m (f Bool)+expireat key timestamp = sendRequest ["EXPIREAT", key, encode timestamp]++-- | Synchronously save the dataset to disk (<http://redis.io/commands/save>).+-- Since Redis 1.0.0+save+ :: (RedisCtx m f)+ => m (f Status)+save = sendRequest ["SAVE"]++-- |+-- Move a key to another database (<http://redis.io/commands/move>).+-- Since Redis 1.0.0+move+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer -- ^ db+ -> m (f Bool)+move key db = sendRequest ["MOVE", key, encode db]++-- |+-- Returns the bit value at offset in the string value stored at key (<http://redis.io/commands/getbit>). Since Redis 2.2.0+getbit+ :: (RedisCtx m f)+ => ByteString -- ^ Key.+ -> Integer -- ^ Offset.+ -> m (f Integer)+getbit key offset = sendRequest ["GETBIT", key, encode offset]++-- |Set multiple keys to multiple values, only if none of the keys exist (<http://redis.io/commands/msetnx>).+-- Since Redis 1.0.1+msetnx+ :: (RedisCtx m f)+ => NonEmpty (ByteString,ByteString) -- ^ keyValue+ -> m (f Bool)+msetnx ((key,value):|keysValues) =+ sendRequest ("MSETNX":key:value:concatMap (\(x,y) -> [encode x,encode y]) keysValues)++-- |Get array of specific Redis command details (<http://redis.io/commands/command-info>).+-- Since Redis 2.8.13+commandInfo+ :: (RedisCtx m f)+ => [ByteString] -- ^ commandName+ -> m (f [ByteString])+commandInfo commandName = sendRequest ("COMMAND":"INFO":map encode commandName )++-- | Close the connection (<http://redis.io/commands/quit>). Since Redis 1.0.0+quit+ :: (RedisCtx m f)+ => m (f Status)+quit = sendRequest ["QUIT"]++-- |Remove and get the first element in a list, or block until one is available (<http://redis.io/commands/blpop>). Since Redis 2.0.0+blpop+ :: (RedisCtx m f)+ => [ByteString] -- ^ key+ -> Integer -- ^ timeout+ -> m (f (Maybe (ByteString,ByteString)))+blpop keys_ timeout = sendRequest ("BLPOP":keys_ ++ [encode timeout] )++-- |Remove and get the first element in a list, or block until one is available (<http://redis.io/commands/blpop>). Since Redis 6.0.0+blpopFloat+ :: (RedisCtx m f)+ => [ByteString] -- ^ key+ -> Integer -- ^ timeout+ -> m (f (Maybe (ByteString,ByteString)))+blpopFloat keys_ timeout = sendRequest ("BLPOP":keys_ ++ [encode timeout] )++-- | /O(N)/ where @N@ is the number of members to be removed.+-- Remove one or more members from a set (<http://redis.io/commands/srem>).+--+-- Returns the number of members that were removed from the seet, not including non+-- existing elements.+--+-- Since Redis 1.0.0+srem+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the set.+ -> NonEmpty ByteString -- ^ List of members to be removed.+ -> m (f Integer)+srem key (member:|members) = sendRequest ("SREM":key:member:members)++-- |Echo the given string (<http://redis.io/commands/echo>). Since Redis 1.0.0+echo+ :: (RedisCtx m f)+ => ByteString -- ^ message+ -> m (f ByteString)+echo message = sendRequest ["ECHO", encode message]++-- |Determine if a given value is a member of a set (<http://redis.io/commands/sismember>).+-- Since Redis 1.0.0+sismember+ :: (RedisCtx m f)+ => ByteString -- ^ Key.+ -> ByteString -- ^ member+ -> m (f Bool)+sismember key member = sendRequest ["SISMEMBER",key, member]++-- $autoclaim+--+-- Family of the commands related to the autoclaim command in redis, they provide an+-- ability to claim messages that are not processed for a long time.+--+-- Transfers ownership of pending stream entries that match+-- the specified criteria. The message should be pending for more than \<min-idle-time\>+-- milliseconds and ID should be greater than \<start\>.+--+-- Redis @xautoclaim@ command is split info `xautoclaim`, `xautoclaimOpts`, `xautoclaimJustIds`+-- `xautoclaimJustIdsOpt` functions.+--+-- All commands are available since Redis 7.0++-- $xpending+-- The Redis @XPENDING@ command is split into 'xpendingSummary' and 'xpendingDetail'.++-- $xgroupCreate+-- Create a consumer group. The redis command @XGROUP CREATE@ is split up into 'xgroupCreate', 'xgroupCreateOpts'.++-- $xgroupSetId+-- Sets last delivered ID for a consumer group. The redis command @XGROUP SETID@ is split up into 'xgroupSetId' and 'xgroupSetIdOpts' methods.+++-- $auth+-- Authenticate to the server (<http://redis.io/commands/auth>). Since Redis 1.0.0
src/Database/Redis/Connection.hs view
@@ -6,32 +6,35 @@ import Control.Exception import qualified Control.Monad.Catch as Catch import Control.Monad.IO.Class(liftIO, MonadIO)-import Control.Monad(when)+import Control.Monad(when, forM_) import Control.Concurrent.MVar(MVar, newMVar) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as Char8 import Data.Functor(void) import qualified Data.IntMap.Strict as IntMap-import Data.Pool(Pool, withResource, createPool, destroyAllResources)-import Data.Typeable+import Data.Pool import qualified Data.Time as Time import Network.TLS (ClientParams)-import qualified Network.Socket as NS import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T import qualified Database.Redis.ProtocolPipelining as PP-import Database.Redis.Core(Redis, runRedisInternal, runRedisClusteredInternal)+import Database.Redis.Core(Redis, Hooks, runRedisInternal, runRedisClusteredInternal, defaultHooks) import Database.Redis.Protocol(Reply(..)) import Database.Redis.Cluster(ShardMap(..), Node, Shard(..)) import qualified Database.Redis.Cluster as Cluster import qualified Database.Redis.ConnectionContext as CC---import qualified Database.Redis.Cluster.Pipeline as ClusterPipeline import Database.Redis.Commands ( ping , select- , auth+ , authOpts+ , defaultAuthOpts+ , AuthOpts(..)+ , clusterInfo , clusterSlots , command+ , ClusterInfoResponseState (..)+ , ClusterInfoResponse (..) , ClusterSlotsResponse(..) , ClusterSlotsResponseEntry(..) , ClusterSlotsNode(..))@@ -58,81 +61,91 @@ -- myConnectInfo = defaultConnectInfo {connectAuth = Just \"secret\"} -- @ --+-- Or better yet, use 'parseConnectInfo' to parse a URL.+-- data ConnectInfo = ConnInfo- { connectHost :: NS.HostName- , connectPort :: CC.PortID- , connectAuth :: Maybe B.ByteString+ { 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.- , connectDatabase :: Integer+ , 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+ , connectMaxConnections :: !Int -- ^ Maximum number of connections to keep open. The smallest acceptable -- value is 1.- , connectMaxIdleTime :: Time.NominalDiffTime+ , 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+ , 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+ , connectTLSParams :: !(Maybe ClientParams) -- ^ Optional TLS parameters. TLS will be enabled if this is provided.+ , connectHooks :: !Hooks+ -- ^ Connection hooks. See "Database.Redis.Hooks" for usage and examples.+ , connectPoolLabel :: !T.Text+ -- ^ Label of the connection pool for instrumentation. } deriving Show data ConnectError = ConnectAuthError Reply | ConnectSelectError Reply- deriving (Eq, Show, Typeable)+ deriving (Eq, Show) instance Exception ConnectError -- |Default information for connecting: -- -- @--- connectHost = \"localhost\"--- connectPort = PortNumber 6379 -- Redis default port+-- connectAddr = ConnectAddrHostPort \"localhost\" 6379 -- Redis default port -- connectAuth = Nothing -- No password+-- connectUsername = Nothing -- No user -- connectDatabase = 0 -- SELECT database 0 -- connectMaxConnections = 50 -- Up to 50 connections+-- connectNumStripes = Just 1 -- A single stripe -- connectMaxIdleTime = 30 -- Keep open for 30 seconds -- connectTimeout = Nothing -- Don't add timeout logic -- connectTLSParams = Nothing -- Do not use TLS+-- connectHooks = defaultHooks -- Do nothing+-- connectPoolLabel = "" -- no label -- @ -- defaultConnectInfo :: ConnectInfo defaultConnectInfo = ConnInfo- { connectHost = "localhost"- , connectPort = CC.PortNumber 6379+ { connectAddr = CC.ConnectAddrHostPort "localhost" 6379 , connectAuth = Nothing+ , connectUsername = Nothing , connectDatabase = 0 , connectMaxConnections = 50+ , connectNumStripes = Just 1 , connectMaxIdleTime = 30 , connectTimeout = Nothing , connectTLSParams = Nothing+ , connectHooks = defaultHooks+ , connectPoolLabel = "" } createConnection :: ConnectInfo -> IO PP.Connection createConnection ConnInfo{..} = do let timeoutOptUs = round . (1000000 *) <$> connectTimeout- conn <- PP.connect connectHost connectPort timeoutOptUs- conn' <- case connectTLSParams of- Nothing -> return conn- Just tlsParams -> PP.enableTLS tlsParams conn+ conn' <- PP.connectWithHooks connectAddr timeoutOptUs connectTLSParams connectHooks PP.beginReceiving conn' runRedisInternal conn' $ do -- AUTH- case connectAuth of- Nothing -> return ()- Just pass -> do- resp <- auth pass- case resp of- Left r -> liftIO $ throwIO $ ConnectAuthError r- _ -> return ()+ forM_ connectAuth $ \pass -> do+ resp <- authOpts pass defaultAuthOpts{ authOptsUsername = connectUsername}+ case resp of+ Left r -> liftIO $ throwIO $ ConnectAuthError r+ _ -> return () -- SELECT when (connectDatabase /= 0) $ do resp <- select connectDatabase@@ -141,16 +154,19 @@ _ -> 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.+-- | Constructs a 'Connection' pool to a Redis server designated by the+-- given 'ConnectInfo'.+--+-- The function always succeeds, because the first connection is not actually established+-- until the first call to the server. connect :: ConnectInfo -> IO Connection connect cInfo@ConnInfo{..} = NonClusteredConnection <$>- createPool (createConnection cInfo) PP.disconnect 1 connectMaxIdleTime connectMaxConnections+ 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+--+-- Throws an 'ConnectError' exception if the connection to the Redis server can't be -- established. checkedConnect :: ConnectInfo -> IO Connection checkedConnect connInfo = do@@ -158,7 +174,27 @@ runRedis conn $ void ping return conn --- |Destroy all idle resources in the pool.+-- |Constructs a 'Connection' pool to a Redis cluster designated by the+-- given 'ConnectInfo', then tests if the server is actually there.+--+-- Throws an 'ClusterConnectError' 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, works for all types of the connection. disconnect :: Connection -> IO () disconnect (NonClusteredConnection pool) = destroyAllResources pool disconnect (ClusteredConnection _ pool) = destroyAllResources pool@@ -178,12 +214,23 @@ -- while all connections from the pool are in use. runRedis :: Connection -> Redis a -> IO a runRedis (NonClusteredConnection pool) redis =- withResource pool $ \conn -> runRedisInternal conn redis+ withResource pool $ \conn -> runRedisInternal conn redis runRedis (ClusteredConnection _ pool) redis = withResource pool $ \conn -> runRedisClusteredInternal conn (refreshShardMap conn) redis +-- |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, Typeable)+ deriving (Eq, Show) instance Exception ClusterConnectError @@ -194,22 +241,35 @@ -- - CONFIG, AUTH -- - SCAN -- - MOVE, SELECT--- - PUBLISH, SUBSCRIBE, PSUBSCRIBE, UNSUBSCRIBE, PUNSUBSCRIBE, RESET+-- - RESET connectCluster :: ConnectInfo -> IO Connection connectCluster bootstrapConnInfo = do- conn <- createConnection bootstrapConnInfo- slotsResponse <- runRedisInternal conn clusterSlots- shardMapVar <- case slotsResponse of- Left e -> throwIO $ ClusterConnectError e- Right slots -> do- shardMap <- shardMapFromClusterSlotsResponse slots- newMVar shardMap- commandInfos <- runRedisInternal conn command- case commandInfos of- Left e -> throwIO $ ClusterConnectError e- Right infos -> do- pool <- createPool (Cluster.connect infos shardMapVar Nothing) Cluster.disconnect 1 (connectMaxIdleTime bootstrapConnInfo) (connectMaxConnections bootstrapConnInfo)- return $ ClusteredConnection shardMapVar pool+ bracket (createConnection bootstrapConnInfo) PP.disconnect $ \conn -> do+ slotsResponse <- runRedisInternal conn clusterSlots+ shardMapVar <- case slotsResponse of+ Left e -> throwIO $ ClusterConnectError e+ Right slots -> do+ shardMap <- shardMapFromClusterSlotsResponse slots+ newMVar shardMap+ commandInfos <- runRedisInternal conn command+ let timeoutOptUs =+ round . (1000000 *) <$> connectTimeout bootstrapConnInfo+ case commandInfos of+ Left e -> throwIO $ ClusterConnectError e+ Right infos -> do+ pool <- newPool (setPoolLabel (connectPoolLabel bootstrapConnInfo)+ $ setNumStripes (connectNumStripes bootstrapConnInfo)+ $ defaultPoolConfig+ (Cluster.connectWith+ (connectUsername bootstrapConnInfo)+ (connectAuth bootstrapConnInfo)+ (connectTLSParams bootstrapConnInfo)+ infos shardMapVar timeoutOptUs+ $ connectHooks bootstrapConnInfo)+ Cluster.disconnect+ (realToFrac $ connectMaxIdleTime bootstrapConnInfo)+ (connectMaxConnections bootstrapConnInfo))+ return $ ClusteredConnection shardMapVar pool shardMapFromClusterSlotsResponse :: ClusterSlotsResponse -> IO ShardMap shardMapFromClusterSlotsResponse ClusterSlotsResponse{..} = ShardMap <$> foldr mkShardMap (pure IntMap.empty) clusterSlotsResponseEntries where@@ -229,8 +289,8 @@ Cluster.Node clusterSlotsNodeID role hostname (toEnum clusterSlotsNodePort) refreshShardMap :: Cluster.Connection -> IO ShardMap-refreshShardMap (Cluster.Connection nodeConns _ _ _) = do- let (Cluster.NodeConnection ctx _ _) = head $ HM.elems nodeConns+refreshShardMap Cluster.Connection{connectionNodes=nodeConns} = do+ let Cluster.NodeConnection{nodeConnectionContext=ctx} = head $ HM.elems nodeConns pipelineConn <- PP.fromCtx ctx _ <- PP.beginReceiving pipelineConn slotsResponse <- runRedisInternal pipelineConn clusterSlots
src/Database/Redis/ConnectionContext.hs view
@@ -6,7 +6,7 @@ ConnectionContext(..) , ConnectTimeout(..) , ConnectionLostException(..)- , PortID(..)+ , ConnectAddr(..) , connect , disconnect , send@@ -17,26 +17,25 @@ , ioErrorToConnLost ) where -import Control.Concurrent (threadDelay)-import Control.Concurrent.Async (race) import Control.Monad(when) import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString.Lazy as LB import qualified Data.IORef as IOR import Control.Concurrent.MVar(newMVar, readMVar, swapMVar)-import Control.Exception(bracketOnError, Exception, throwIO, try)-import Data.Typeable+import Control.Exception(bracketOnError, Exception, throwIO, try, finally, uninterruptibleMask_) import Data.Functor(void) import qualified Network.Socket as NS import qualified Network.TLS as TLS import System.IO(Handle, hSetBinaryMode, hClose, IOMode(..), hFlush, hIsOpen) import System.IO.Error(catchIOError)+import System.Timeout (timeout) -data ConnectionContext = NormalHandle Handle | TLSContext TLS.Context+data ConnectionContext = NormalHandle Handle | TLSContext TLS.Context Handle instance Show ConnectionContext where show (NormalHandle _) = "NormalHandle"- show (TLSContext _) = "TLSContext"+ show (TLSContext _ _) = "TLSContext" data Connection = Connection { ctx :: ConnectionContext@@ -52,22 +51,33 @@ deriving (Show) newtype ConnectTimeout = ConnectTimeout ConnectPhase- deriving (Show, Typeable)+ deriving (Show) instance Exception ConnectTimeout data ConnectionLostException = ConnectionLost deriving Show instance Exception ConnectionLostException -data PortID = PortNumber NS.PortNumber- | UnixSocket String- deriving (Eq, Show)+data ConnectAddr+ = ConnectAddrHostPort NS.HostName NS.PortNumber+ | ConnectAddrUnixSocket String+ deriving (Eq, Show) -connect :: NS.HostName -> PortID -> Maybe Int -> IO ConnectionContext-connect hostName portId timeoutOpt =+connect :: ConnectAddr -> Maybe Int -> Maybe TLS.ClientParams -> IO ConnectionContext+connect connectAddr timeoutOpt mTlsParams = bracketOnError hConnect hClose $ \h -> do hSetBinaryMode h True- return $ NormalHandle h+ case (mTlsParams, connectAddr) of+ (Just defaultTlsParams, ConnectAddrHostPort host port) -> do+ -- The defaultTlsParams are used to connect to the first+ -- host in the cluster, other hosts have different+ -- hostnames and so require a different server+ -- identification params+ let tlsParams = defaultTlsParams {+ TLS.clientServerIdentification = (host, Char8.pack $ show port)+ }+ enableTLS tlsParams (NormalHandle h)+ _ -> return $ NormalHandle h where hConnect = do phaseMVar <- newMVar PhaseUnknown@@ -75,10 +85,10 @@ case timeoutOpt of Nothing -> doConnect Just micros -> do- result <- race doConnect (threadDelay micros)+ result <- timeout micros doConnect case result of- Left h -> return h- Right () -> do+ Just h -> return h+ Nothing -> do phase <- readMVar phaseMVar errConnectTimeout phase hConnect' mvar = bracketOnError createSock NS.close $ \sock -> do@@ -87,18 +97,17 @@ void $ swapMVar mvar PhaseOpenSocket NS.socketToHandle sock ReadWriteMode where- createSock = case portId of- PortNumber portNumber -> do+ createSock = case connectAddr of+ ConnectAddrHostPort hostName portNumber -> do addrInfo <- getHostAddrInfo hostName portNumber connectSocket addrInfo- UnixSocket addr -> bracketOnError+ ConnectAddrUnixSocket addr -> bracketOnError (NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol) NS.close (\sock -> NS.connect sock (NS.SockAddrUnix addr) >> return sock) getHostAddrInfo :: NS.HostName -> NS.PortNumber -> IO [NS.AddrInfo]-getHostAddrInfo hostname port =- NS.getAddrInfo (Just hints) (Just hostname) (Just $ show port)+getHostAddrInfo hostname port = NS.getAddrInfo (Just hints) (Just hostname) (Just $ show port) where hints = NS.defaultHints { NS.addrSocketType = NS.Stream }@@ -126,13 +135,13 @@ send :: ConnectionContext -> B.ByteString -> IO () send (NormalHandle h) requestData =- ioErrorToConnLost (B.hPut h requestData)-send (TLSContext ctx) requestData =- ioErrorToConnLost (TLS.sendData ctx (LB.fromStrict requestData))+ ioErrorToConnLost (B.hPut h requestData)+send (TLSContext ctx _) requestData =+ ioErrorToConnLost (TLS.sendData ctx (LB.fromStrict requestData)) recv :: ConnectionContext -> IO B.ByteString recv (NormalHandle h) = ioErrorToConnLost $ B.hGetSome h 4096-recv (TLSContext ctx) = TLS.recvData ctx+recv (TLSContext ctx _) = TLS.recvData ctx ioErrorToConnLost :: IO a -> IO a@@ -146,17 +155,17 @@ enableTLS tlsParams (NormalHandle h) = do ctx <- TLS.contextNew h tlsParams TLS.handshake ctx- return $ TLSContext ctx-enableTLS _ c@(TLSContext _) = return c+ return $! TLSContext ctx h+enableTLS _ c@(TLSContext _ _) = return c + disconnect :: ConnectionContext -> IO ()-disconnect (NormalHandle h) = do+disconnect (NormalHandle h) = uninterruptibleMask_ $ do open <- hIsOpen h when open $ hClose h-disconnect (TLSContext ctx) = do- TLS.bye ctx- TLS.contextClose ctx+disconnect (TLSContext ctx h) =+ TLS.bye ctx `finally` TLS.contextClose ctx `finally` (hIsOpen h >>= \open -> when open $ hClose h) flush :: ConnectionContext -> IO () flush (NormalHandle h) = hFlush h-flush (TLSContext c) = TLS.contextFlush c+flush (TLSContext ctx _) = TLS.contextFlush ctx
src/Database/Redis/Core.hs view
@@ -1,13 +1,15 @@ {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, RecordWildCards, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, CPP,- DeriveDataTypeable, StandaloneDeriving #-}+ DeriveDataTypeable, StandaloneDeriving, UndecidableInstances #-} module Database.Redis.Core ( Redis(), unRedis, reRedis, RedisCtx(..), MonadRedis(..),+ Hooks(..), SendRequestHook, SendPubSubHook, CallbackHook, SendHook, ReceiveHook, send, recv, sendRequest, runRedisInternal, runRedisClusteredInternal,+ defaultHooks, RedisEnv(..), ) where @@ -24,6 +26,7 @@ import Database.Redis.Types import Database.Redis.Cluster(ShardMap) import qualified Database.Redis.Cluster as Cluster+import Database.Redis.Hooks -------------------------------------------------------------------------------- -- The Redis Monad@@ -40,6 +43,12 @@ class (Monad m) => MonadRedis m where liftRedis :: Redis a -> m a +instance {-# OVERLAPPABLE #-}+ ( MonadTrans t+ , MonadRedis m+ , Monad (t m)+ ) => MonadRedis (t m) where+ liftRedis = lift . liftRedis instance RedisCtx Redis (Either Reply) where returnDecode = return . decode@@ -74,9 +83,9 @@ runRedisClusteredInternal :: Cluster.Connection -> IO ShardMap -> Redis a -> IO a runRedisClusteredInternal connection refreshShardmapAction (Redis redis) = do- r <- runReaderT redis (ClusteredEnv refreshShardmapAction connection)- r `seq` return ()- return r+ ref <- newIORef (SingleLine "no reply yet")+ r <- runReaderT redis (ClusteredEnv refreshShardmapAction connection ref)+ r `seq` return r setLastReply :: Reply -> ReaderT RedisEnv IO () setLastReply r = do@@ -112,8 +121,11 @@ env <- ask case env of NonClusteredEnv{..} -> do- r <- liftIO $ PP.request envConn (renderRequest req)+ r <- liftIO $ sendRequestHook (PP.hooks envConn) (PP.request envConn . renderRequest) req setLastReply r return r- ClusteredEnv{..} -> liftIO $ Cluster.requestPipelined refreshAction connection req+ ClusteredEnv{..} -> do+ r <- liftIO $ sendRequestHook (Cluster.hooks connection) (Cluster.requestPipelined refreshAction connection) req+ setLastReply r+ return r returnDecode r'
src/Database/Redis/Core/Internal.hs view
@@ -1,14 +1,17 @@ {-# 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 @@ -19,13 +22,18 @@ -- possibility of Redis returning an 'Error' reply. newtype Redis a = Redis (ReaderT RedisEnv IO a)- deriving (Monad, MonadIO, Functor, Applicative)+ deriving (Monad, MonadIO, Functor, Applicative, MonadUnliftIO, MonadThrow, MonadCatch, MonadMask) #if __GLASGOW_HASKELL__ > 711 deriving instance MonadFail Redis #endif data RedisEnv- = NonClusteredEnv { envConn :: PP.Connection, envLastReply :: IORef Reply }+ = NonClusteredEnv { envConn :: PP.Connection, nonClusteredLastReply :: IORef Reply } | ClusteredEnv { refreshAction :: IO Cluster.ShardMap , connection :: Cluster.Connection+ , clusteredLastReply :: IORef Reply }++envLastReply :: RedisEnv -> IORef Reply+envLastReply NonClusteredEnv{..} = nonClusteredLastReply+envLastReply ClusteredEnv{..} = clusteredLastReply
+ src/Database/Redis/Hooks.hs view
@@ -0,0 +1,104 @@+-- |Hooks for observing or wrapping Redis I/O.+--+-- Hooks are installed through @connect defaultConnectInfo { connectHooks = ... }@+-- and wrap the low-level actions used by hedis:+--+-- * 'sendRequestHook' wraps regular command execution.+-- * 'sendPubSubHook' wraps pub/sub command sending.+-- * 'callbackHook' wraps invocation of pub/sub callbacks.+-- * 'sendHook' wraps raw bytes sent to the server.+-- * 'receiveHook' wraps reply reception.+--+-- The common pattern is to start from 'defaultHooks' and override only the+-- hook(s) you need. Each hook receives the original action and is expected to+-- call it after performing any extra work such as logging, tracing, metrics,+-- or timing.+--+-- Hooks can be used to alter existing behavior, or used to add metrics or telemetry+-- to the redis application.+--+-- Example:+--+-- @+-- import Data.IORef+-- import Database.Redis+--+-- data Counts = Counts+-- { sendRequestCount :: Word+-- , sendCount :: Word+-- , receiveCount :: Word+-- }+--+-- hooks :: IORef Counts -> Hooks+-- hooks ref =+-- defaultHooks+-- { sendRequestHook = \\run argv -> do+-- modifyIORef ref $ \\c -> c { sendRequestCount = sendRequestCount c + 1 }+-- run argv+-- , sendHook = \\sendBytes bytes -> do+-- modifyIORef ref $ \\c -> c { sendCount = sendCount c + 1 }+-- sendBytes bytes+-- , receiveHook = \\recvReply -> do+-- modifyIORef ref $ \\c -> c { receiveCount = receiveCount c + 1 }+-- recvReply+-- }+--+-- main :: IO ()+-- main = do+-- ref <- newIORef (Counts 0 0 0)+-- conn <- connect defaultConnectInfo { connectHooks = hooks ref }+-- _ <- runRedis conn $ set "key" "value"+-- readIORef ref >>= print+-- @+module Database.Redis.Hooks where++import Data.ByteString (ByteString)+import Database.Redis.Protocol (Reply)+import {-# SOURCE #-} Database.Redis.PubSub (Message, PubSub)++-- |A collection of hook functions used by a connection.+data Hooks =+ Hooks+ { sendRequestHook :: SendRequestHook+ , sendPubSubHook :: SendPubSubHook+ , callbackHook :: CallbackHook+ , sendHook :: SendHook+ , receiveHook :: ReceiveHook+ }++-- |A hook for sending commands to the server and receiving replies from the server.+--+-- This wraps the command-level request path used by most Redis commands.+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 sending raw bytes to the server.+--+-- This sits below request rendering and can be used to observe the exact wire+-- payload sent on the socket.+type SendHook = (ByteString -> IO ()) -> ByteString -> IO ()++-- |A hook for receiving replies from the server.+type ReceiveHook = IO Reply -> IO Reply++-- |The default hooks.+--+-- Every hook is the identity function, so installing 'defaultHooks' has no+-- effect on behavior.+defaultHooks :: Hooks+defaultHooks =+ Hooks+ { sendRequestHook = id+ , sendPubSubHook = id+ , callbackHook = id+ , sendHook = id+ , receiveHook = id+ }++instance Show Hooks where+ show _ = "Hooks {sendRequestHook = _, sendPubSubHook = _, callbackHook = _, sendHook = _, receiveHook = _}"
src/Database/Redis/ManualCommands.hs view
@@ -6,1395 +6,5830 @@ import Data.ByteString (ByteString, empty, append) import qualified Data.ByteString.Char8 as Char8 import qualified Data.ByteString as BS-import Data.Maybe (maybeToList, catMaybes)-#if __GLASGOW_HASKELL__ < 808-import Data.Semigroup ((<>))-#endif-import Database.Redis.Core-import Database.Redis.Protocol-import Database.Redis.Types-import qualified Database.Redis.Cluster.Command as CMD---objectRefcount- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f Integer)-objectRefcount key = sendRequest ["OBJECT", "refcount", encode key]--objectIdletime- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f Integer)-objectIdletime key = sendRequest ["OBJECT", "idletime", encode key]--objectEncoding- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f ByteString)-objectEncoding key = sendRequest ["OBJECT", "encoding", encode key]--linsertBefore- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ pivot- -> ByteString -- ^ value- -> m (f Integer)-linsertBefore key pivot value =- sendRequest ["LINSERT", encode key, "BEFORE", encode pivot, encode value]--linsertAfter- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ pivot- -> ByteString -- ^ value- -> m (f Integer)-linsertAfter key pivot value =- sendRequest ["LINSERT", encode key, "AFTER", encode pivot, encode value]--getType- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f RedisType)-getType key = sendRequest ["TYPE", encode key]---- |A single entry from the slowlog.-data Slowlog = Slowlog- { slowlogId :: Integer- -- ^ A unique progressive identifier for every slow log entry.- , slowlogTimestamp :: Integer- -- ^ The unix timestamp at which the logged command was processed.- , slowlogMicros :: Integer- -- ^ The amount of time needed for its execution, in microseconds.- , slowlogCmd :: [ByteString]- -- ^ The command and it's arguments.- , slowlogClientIpAndPort :: Maybe ByteString- , slowlogClientName :: Maybe ByteString- } deriving (Show, Eq)--instance RedisResult Slowlog where- decode (MultiBulk (Just [logId,timestamp,micros,cmd])) = do- slowlogId <- decode logId- slowlogTimestamp <- decode timestamp- slowlogMicros <- decode micros- slowlogCmd <- decode cmd- let slowlogClientIpAndPort = Nothing- slowlogClientName = Nothing- return Slowlog{..}- decode (MultiBulk (Just [logId,timestamp,micros,cmd,ip,cname])) = do- slowlogId <- decode logId- slowlogTimestamp <- decode timestamp- slowlogMicros <- decode micros- slowlogCmd <- decode cmd- slowlogClientIpAndPort <- Just <$> decode ip- slowlogClientName <- Just <$> decode cname- return Slowlog{..}- decode r = Left r--slowlogGet- :: (RedisCtx m f)- => Integer -- ^ cnt- -> m (f [Slowlog])-slowlogGet n = sendRequest ["SLOWLOG", "GET", encode n]--slowlogLen :: (RedisCtx m f) => m (f Integer)-slowlogLen = sendRequest ["SLOWLOG", "LEN"]--slowlogReset :: (RedisCtx m f) => m (f Status)-slowlogReset = sendRequest ["SLOWLOG", "RESET"]--zrange- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ start- -> Integer -- ^ stop- -> m (f [ByteString])-zrange key start stop =- sendRequest ["ZRANGE", encode key, encode start, encode stop]--zrangeWithscores- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ start- -> Integer -- ^ stop- -> m (f [(ByteString, Double)])-zrangeWithscores key start stop =- sendRequest ["ZRANGE", encode key, encode start, encode stop, "WITHSCORES"]--zrevrange- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ start- -> Integer -- ^ stop- -> m (f [ByteString])-zrevrange key start stop =- sendRequest ["ZREVRANGE", encode key, encode start, encode stop]--zrevrangeWithscores- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ start- -> Integer -- ^ stop- -> m (f [(ByteString, Double)])-zrevrangeWithscores key start stop =- sendRequest ["ZREVRANGE", encode key, encode start, encode stop- ,"WITHSCORES"]--zrangebyscore- :: (RedisCtx m f)- => ByteString -- ^ key- -> Double -- ^ min- -> Double -- ^ max- -> m (f [ByteString])-zrangebyscore key min max =- sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max]--zrangebyscoreWithscores- :: (RedisCtx m f)- => ByteString -- ^ key- -> Double -- ^ min- -> Double -- ^ max- -> m (f [(ByteString, Double)])-zrangebyscoreWithscores key min max =- sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max- ,"WITHSCORES"]--zrangebyscoreLimit- :: (RedisCtx m f)- => ByteString -- ^ key- -> Double -- ^ min- -> Double -- ^ max- -> Integer -- ^ offset- -> Integer -- ^ count- -> m (f [ByteString])-zrangebyscoreLimit key min max offset count =- sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max- ,"LIMIT", encode offset, encode count]--zrangebyscoreWithscoresLimit- :: (RedisCtx m f)- => ByteString -- ^ key- -> Double -- ^ min- -> Double -- ^ max- -> Integer -- ^ offset- -> Integer -- ^ count- -> m (f [(ByteString, Double)])-zrangebyscoreWithscoresLimit key min max offset count =- sendRequest ["ZRANGEBYSCORE", encode key, encode min, encode max- ,"WITHSCORES","LIMIT", encode offset, encode count]--zrevrangebyscore- :: (RedisCtx m f)- => ByteString -- ^ key- -> Double -- ^ max- -> Double -- ^ min- -> m (f [ByteString])-zrevrangebyscore key min max =- sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max]--zrevrangebyscoreWithscores- :: (RedisCtx m f)- => ByteString -- ^ key- -> Double -- ^ max- -> Double -- ^ min- -> m (f [(ByteString, Double)])-zrevrangebyscoreWithscores key min max =- sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max- ,"WITHSCORES"]--zrevrangebyscoreLimit- :: (RedisCtx m f)- => ByteString -- ^ key- -> Double -- ^ max- -> Double -- ^ min- -> Integer -- ^ offset- -> Integer -- ^ count- -> m (f [ByteString])-zrevrangebyscoreLimit key min max offset count =- sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max- ,"LIMIT", encode offset, encode count]--zrevrangebyscoreWithscoresLimit- :: (RedisCtx m f)- => ByteString -- ^ key- -> Double -- ^ max- -> Double -- ^ min- -> Integer -- ^ offset- -> Integer -- ^ count- -> m (f [(ByteString, Double)])-zrevrangebyscoreWithscoresLimit key min max offset count =- sendRequest ["ZREVRANGEBYSCORE", encode key, encode min, encode max- ,"WITHSCORES","LIMIT", encode offset, encode count]---- |Options for the 'sort' command.-data SortOpts = SortOpts- { sortBy :: Maybe ByteString- , sortLimit :: (Integer,Integer)- , sortGet :: [ByteString]- , sortOrder :: SortOrder- , sortAlpha :: Bool- } deriving (Show, Eq)---- |Redis default 'SortOpts'. Equivalent to omitting all optional parameters.------ @--- SortOpts--- { sortBy = Nothing -- omit the BY option--- , sortLimit = (0,-1) -- return entire collection--- , sortGet = [] -- omit the GET option--- , sortOrder = Asc -- sort in ascending order--- , sortAlpha = False -- sort numerically, not lexicographically--- }--- @----defaultSortOpts :: SortOpts-defaultSortOpts = SortOpts- { sortBy = Nothing- , sortLimit = (0,-1)- , sortGet = []- , sortOrder = Asc- , sortAlpha = False- }--data SortOrder = Asc | Desc deriving (Show, Eq)--sortStore- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ destination- -> SortOpts- -> m (f Integer)-sortStore key dest = sortInternal key (Just dest)--sort- :: (RedisCtx m f)- => ByteString -- ^ key- -> SortOpts- -> m (f [ByteString])-sort key = sortInternal key Nothing--sortInternal- :: (RedisResult a, RedisCtx m f)- => ByteString -- ^ key- -> Maybe ByteString -- ^ destination- -> SortOpts- -> m (f a)-sortInternal key destination SortOpts{..} = sendRequest $- concat [["SORT", encode key], by, limit, get, order, alpha, store]- where- by = maybe [] (\pattern -> ["BY", pattern]) sortBy- limit = let (off,cnt) = sortLimit in ["LIMIT", encode off, encode cnt]- get = concatMap (\pattern -> ["GET", pattern]) sortGet- order = case sortOrder of Desc -> ["DESC"]; Asc -> ["ASC"]- alpha = ["ALPHA" | sortAlpha]- store = maybe [] (\dest -> ["STORE", dest]) destination---data Aggregate = Sum | Min | Max deriving (Show,Eq)--zunionstore- :: (RedisCtx m f)- => ByteString -- ^ destination- -> [ByteString] -- ^ keys- -> Aggregate- -> m (f Integer)-zunionstore dest keys =- zstoreInternal "ZUNIONSTORE" dest keys []--zunionstoreWeights- :: (RedisCtx m f)- => ByteString -- ^ destination- -> [(ByteString,Double)] -- ^ weighted keys- -> Aggregate- -> m (f Integer)-zunionstoreWeights dest kws =- let (keys,weights) = unzip kws- in zstoreInternal "ZUNIONSTORE" dest keys weights--zinterstore- :: (RedisCtx m f)- => ByteString -- ^ destination- -> [ByteString] -- ^ keys- -> Aggregate- -> m (f Integer)-zinterstore dest keys =- zstoreInternal "ZINTERSTORE" dest keys []--zinterstoreWeights- :: (RedisCtx m f)- => ByteString -- ^ destination- -> [(ByteString,Double)] -- ^ weighted keys- -> Aggregate- -> m (f Integer)-zinterstoreWeights dest kws =- let (keys,weights) = unzip kws- in zstoreInternal "ZINTERSTORE" dest keys weights--zstoreInternal- :: (RedisCtx m f)- => ByteString -- ^ cmd- -> ByteString -- ^ destination- -> [ByteString] -- ^ keys- -> [Double] -- ^ weights- -> Aggregate- -> m (f Integer)-zstoreInternal cmd dest keys weights aggregate = sendRequest $- concat [ [cmd, dest, encode . toInteger $ length keys], keys- , if null weights then [] else "WEIGHTS" : map encode weights- , ["AGGREGATE", aggregate']- ]- where- aggregate' = case aggregate of- Sum -> "SUM"- Min -> "MIN"- Max -> "MAX"--eval- :: (RedisCtx m f, RedisResult a)- => ByteString -- ^ script- -> [ByteString] -- ^ keys- -> [ByteString] -- ^ args- -> m (f a)-eval script keys args =- sendRequest $ ["EVAL", script, encode numkeys] ++ keys ++ args- where- numkeys = toInteger (length keys)---- | Works like 'eval', but sends the SHA1 hash of the script instead of the script itself.--- Fails if the server does not recognise the hash, in which case, 'eval' should be used instead.-evalsha- :: (RedisCtx m f, RedisResult a)- => ByteString -- ^ base16-encoded sha1 hash of the script- -> [ByteString] -- ^ keys- -> [ByteString] -- ^ args- -> m (f a)-evalsha script keys args =- sendRequest $ ["EVALSHA", script, encode numkeys] ++ keys ++ args- where- numkeys = toInteger (length keys)--bitcount- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f Integer)-bitcount key = sendRequest ["BITCOUNT", key]--bitcountRange- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ start- -> Integer -- ^ end- -> m (f Integer)-bitcountRange key start end =- sendRequest ["BITCOUNT", key, encode start, encode end]--bitopAnd- :: (RedisCtx m f)- => ByteString -- ^ destkey- -> [ByteString] -- ^ srckeys- -> m (f Integer)-bitopAnd dst srcs = bitop "AND" (dst:srcs)--bitopOr- :: (RedisCtx m f)- => ByteString -- ^ destkey- -> [ByteString] -- ^ srckeys- -> m (f Integer)-bitopOr dst srcs = bitop "OR" (dst:srcs)--bitopXor- :: (RedisCtx m f)- => ByteString -- ^ destkey- -> [ByteString] -- ^ srckeys- -> m (f Integer)-bitopXor dst srcs = bitop "XOR" (dst:srcs)--bitopNot- :: (RedisCtx m f)- => ByteString -- ^ destkey- -> ByteString -- ^ srckey- -> m (f Integer)-bitopNot dst src = bitop "NOT" [dst, src]--bitop- :: (RedisCtx m f)- => ByteString -- ^ operation- -> [ByteString] -- ^ keys- -> m (f Integer)-bitop op ks = sendRequest $ "BITOP" : op : ks---- setRange--- ::--- setRange = sendRequest (["SET"] ++ [encode key] ++ [encode value] ++ )--migrate- :: (RedisCtx m f)- => ByteString -- ^ host- -> ByteString -- ^ port- -> ByteString -- ^ key- -> Integer -- ^ destinationDb- -> Integer -- ^ timeout- -> m (f Status)-migrate host port key destinationDb timeout =- sendRequest ["MIGRATE", host, port, key, encode destinationDb, encode timeout]----- |Options for the 'migrate' command.-data MigrateOpts = MigrateOpts- { migrateCopy :: Bool- , migrateReplace :: Bool- } deriving (Show, Eq)---- |Redis default 'MigrateOpts'. Equivalent to omitting all optional parameters.------ @--- MigrateOpts--- { migrateCopy = False -- remove the key from the local instance--- , migrateReplace = False -- don't replace existing key on the remote instance--- }--- @----defaultMigrateOpts :: MigrateOpts-defaultMigrateOpts = MigrateOpts- { migrateCopy = False- , migrateReplace = False- }--migrateMultiple- :: (RedisCtx m f)- => ByteString -- ^ host- -> ByteString -- ^ port- -> Integer -- ^ destinationDb- -> Integer -- ^ timeout- -> MigrateOpts- -> [ByteString] -- ^ keys- -> m (f Status)-migrateMultiple host port destinationDb timeout MigrateOpts{..} keys =- sendRequest $- concat [["MIGRATE", host, port, empty, encode destinationDb, encode timeout],- copy, replace, keys]- where- copy = ["COPY" | migrateCopy]- replace = ["REPLACE" | migrateReplace]---restore- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ timeToLive- -> ByteString -- ^ serializedValue- -> m (f Status)-restore key timeToLive serializedValue =- sendRequest ["RESTORE", key, encode timeToLive, serializedValue]---restoreReplace- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ timeToLive- -> ByteString -- ^ serializedValue- -> m (f Status)-restoreReplace key timeToLive serializedValue =- sendRequest ["RESTORE", key, encode timeToLive, serializedValue, "REPLACE"]---set- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ value- -> m (f Status)-set key value = sendRequest ["SET", key, value]---data Condition = Nx | Xx deriving (Show, Eq)---instance RedisArg Condition where- encode Nx = "NX"- encode Xx = "XX"---data SetOpts = SetOpts- { setSeconds :: Maybe Integer- , setMilliseconds :: Maybe Integer- , setCondition :: Maybe Condition- } deriving (Show, Eq)---setOpts- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ value- -> SetOpts- -> m (f Status)-setOpts key value SetOpts{..} =- sendRequest $ concat [["SET", key, value], ex, px, condition]- where- ex = maybe [] (\s -> ["EX", encode s]) setSeconds- px = maybe [] (\s -> ["PX", encode s]) setMilliseconds- condition = map encode $ maybeToList setCondition---data DebugMode = Yes | Sync | No deriving (Show, Eq)---instance RedisArg DebugMode where- encode Yes = "YES"- encode Sync = "SYNC"- encode No = "NO"---scriptDebug- :: (RedisCtx m f)- => DebugMode- -> m (f Bool)-scriptDebug mode =- sendRequest ["SCRIPT DEBUG", encode mode]---zadd- :: (RedisCtx m f)- => ByteString -- ^ key- -> [(Double,ByteString)] -- ^ scoreMember- -> m (f Integer)-zadd key scoreMembers =- zaddOpts key scoreMembers defaultZaddOpts---data ZaddOpts = ZaddOpts- { zaddCondition :: Maybe Condition- , zaddChange :: Bool- , zaddIncrement :: Bool- } deriving (Show, Eq)----- |Redis default 'ZaddOpts'. Equivalent to omitting all optional parameters.------ @--- ZaddOpts--- { zaddCondition = Nothing -- omit NX and XX options--- , zaddChange = False -- don't modify the return value from the number of new elements added, to the total number of elements changed--- , zaddIncrement = False -- don't add like ZINCRBY--- }--- @----defaultZaddOpts :: ZaddOpts-defaultZaddOpts = ZaddOpts- { zaddCondition = Nothing- , zaddChange = False- , zaddIncrement = False- }---zaddOpts- :: (RedisCtx m f)- => ByteString -- ^ key- -> [(Double,ByteString)] -- ^ scoreMember- -> ZaddOpts -- ^ options- -> m (f Integer)-zaddOpts key scoreMembers ZaddOpts{..} =- sendRequest $ concat [["ZADD", key], condition, change, increment, scores]- where- scores = concatMap (\(x,y) -> [encode x,encode y]) scoreMembers- condition = map encode $ maybeToList zaddCondition- change = ["CH" | zaddChange]- increment = ["INCR" | zaddIncrement]---data ReplyMode = On | Off | Skip deriving (Show, Eq)---instance RedisArg ReplyMode where- encode On = "ON"- encode Off = "OFF"- encode Skip = "SKIP"---clientReply- :: (RedisCtx m f)- => ReplyMode- -> m (f Bool)-clientReply mode =- sendRequest ["CLIENT REPLY", encode mode]---srandmember- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f (Maybe ByteString))-srandmember key = sendRequest ["SRANDMEMBER", key]---srandmemberN- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ count- -> m (f [ByteString])-srandmemberN key count = sendRequest ["SRANDMEMBER", key, encode count]---spop- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f (Maybe ByteString))-spop key = sendRequest ["SPOP", key]---spopN- :: (RedisCtx m f)- => ByteString -- ^ key- -> Integer -- ^ count- -> m (f [ByteString])-spopN key count = sendRequest ["SPOP", key, encode count]---info- :: (RedisCtx m f)- => m (f ByteString)-info = sendRequest ["INFO"]---infoSection- :: (RedisCtx m f)- => ByteString -- ^ section- -> m (f ByteString)-infoSection section = sendRequest ["INFO", section]---exists- :: (RedisCtx m f)- => ByteString -- ^ key- -> m (f Bool)-exists key = sendRequest ["EXISTS", key]--newtype Cursor = Cursor ByteString deriving (Show, Eq)---instance RedisArg Cursor where- encode (Cursor c) = encode c---instance RedisResult Cursor where- decode (Bulk (Just s)) = Right $ Cursor s- decode r = Left r---cursor0 :: Cursor-cursor0 = Cursor "0"---scan- :: (RedisCtx m f)- => Cursor- -> m (f (Cursor, [ByteString])) -- ^ next cursor and values-scan cursor = scanOpts cursor defaultScanOpts---data ScanOpts = ScanOpts- { scanMatch :: Maybe ByteString- , scanCount :: Maybe Integer- } deriving (Show, Eq)----- |Redis default 'ScanOpts'. Equivalent to omitting all optional parameters.------ @--- ScanOpts--- { scanMatch = Nothing -- don't match any pattern--- , scanCount = Nothing -- don't set any requirements on number elements returned (works like value @COUNT 10@)--- }--- @----defaultScanOpts :: ScanOpts-defaultScanOpts = ScanOpts- { scanMatch = Nothing- , scanCount = Nothing- }---scanOpts- :: (RedisCtx m f)- => Cursor- -> ScanOpts- -> m (f (Cursor, [ByteString])) -- ^ next cursor and values-scanOpts cursor opts = sendRequest $ addScanOpts ["SCAN", encode cursor] opts---addScanOpts- :: [ByteString] -- ^ main part of scan command- -> ScanOpts- -> [ByteString]-addScanOpts cmd ScanOpts{..} =- concat [cmd, match, count]- where- prepend x y = [x, y]- match = maybe [] (prepend "MATCH") scanMatch- count = maybe [] ((prepend "COUNT").encode) scanCount--sscan- :: (RedisCtx m f)- => ByteString -- ^ key- -> Cursor- -> m (f (Cursor, [ByteString])) -- ^ next cursor and values-sscan key cursor = sscanOpts key cursor defaultScanOpts---sscanOpts- :: (RedisCtx m f)- => ByteString -- ^ key- -> Cursor- -> ScanOpts- -> m (f (Cursor, [ByteString])) -- ^ next cursor and values-sscanOpts key cursor opts = sendRequest $ addScanOpts ["SSCAN", key, encode cursor] opts---hscan- :: (RedisCtx m f)- => ByteString -- ^ key- -> Cursor- -> m (f (Cursor, [(ByteString, ByteString)])) -- ^ next cursor and values-hscan key cursor = hscanOpts key cursor defaultScanOpts---hscanOpts- :: (RedisCtx m f)- => ByteString -- ^ key- -> Cursor- -> ScanOpts- -> m (f (Cursor, [(ByteString, ByteString)])) -- ^ next cursor and values-hscanOpts key cursor opts = sendRequest $ addScanOpts ["HSCAN", key, encode cursor] opts---zscan- :: (RedisCtx m f)- => ByteString -- ^ key- -> Cursor- -> m (f (Cursor, [(ByteString, Double)])) -- ^ next cursor and values-zscan key cursor = zscanOpts key cursor defaultScanOpts---zscanOpts- :: (RedisCtx m f)- => ByteString -- ^ key- -> Cursor- -> ScanOpts- -> m (f (Cursor, [(ByteString, Double)])) -- ^ next cursor and values-zscanOpts key cursor opts = sendRequest $ addScanOpts ["ZSCAN", key, encode cursor] opts--data RangeLex a = Incl a | Excl a | Minr | Maxr--instance RedisArg a => RedisArg (RangeLex a) where- encode (Incl bs) = "[" `append` encode bs- encode (Excl bs) = "(" `append` encode bs- encode Minr = "-"- encode Maxr = "+"--zrangebylex::(RedisCtx m f) =>- ByteString -- ^ key- -> RangeLex ByteString -- ^ min- -> RangeLex ByteString -- ^ max- -> m (f [ByteString])-zrangebylex key min max =- sendRequest ["ZRANGEBYLEX", encode key, encode min, encode max]--zrangebylexLimit- ::(RedisCtx m f)- => ByteString -- ^ key- -> RangeLex ByteString -- ^ min- -> RangeLex ByteString -- ^ max- -> Integer -- ^ offset- -> Integer -- ^ count- -> m (f [ByteString])-zrangebylexLimit key min max offset count =- sendRequest ["ZRANGEBYLEX", encode key, encode min, encode max,- "LIMIT", encode offset, encode count]--data TrimOpts = NoArgs | Maxlen Integer | ApproxMaxlen Integer--xaddOpts- :: (RedisCtx m f)- => ByteString -- ^ key- -> ByteString -- ^ id- -> [(ByteString, ByteString)] -- ^ (field, value)- -> TrimOpts- -> m (f ByteString)-xaddOpts key entryId fieldValues opts = sendRequest $- ["XADD", key] ++ optArgs ++ [entryId] ++ fieldArgs- where- fieldArgs = concatMap (\(x,y) -> [x,y]) fieldValues- optArgs = case opts of- NoArgs -> []- Maxlen max -> ["MAXLEN", encode max]- ApproxMaxlen max -> ["MAXLEN", "~", encode max]--xadd- :: (RedisCtx m f)- => ByteString -- ^ stream- -> ByteString -- ^ id- -> [(ByteString, ByteString)] -- ^ (field, value)- -> m (f ByteString)-xadd key entryId fieldValues = xaddOpts key entryId fieldValues NoArgs--data StreamsRecord = StreamsRecord- { recordId :: ByteString- , keyValues :: [(ByteString, ByteString)]- } deriving (Show, Eq)--instance RedisResult StreamsRecord where- decode (MultiBulk (Just [Bulk (Just recordId), MultiBulk (Just rawKeyValues)])) = do- keyValuesList <- mapM decode rawKeyValues- let keyValues = decodeKeyValues keyValuesList- return StreamsRecord{..}- where- decodeKeyValues :: [ByteString] -> [(ByteString, ByteString)]- decodeKeyValues bs = map (\[x,y] -> (x,y)) $ chunksOfTwo bs- chunksOfTwo (x:y:rest) = [x,y]:chunksOfTwo rest- chunksOfTwo _ = []- decode a = Left a--data XReadOpts = XReadOpts- { block :: Maybe Integer- , recordCount :: Maybe Integer- } deriving (Show, Eq)---- |Redis default 'XReadOpts'. Equivalent to omitting all optional parameters.------ @--- XReadOpts--- { block = Nothing -- Don't block waiting for more records--- , recordCount = Nothing -- no record count--- }--- @----defaultXreadOpts :: XReadOpts-defaultXreadOpts = XReadOpts { block = Nothing, recordCount = Nothing }--data XReadResponse = XReadResponse- { stream :: ByteString- , records :: [StreamsRecord]- } deriving (Show, Eq)--instance RedisResult XReadResponse where- decode (MultiBulk (Just [Bulk (Just stream), MultiBulk (Just rawRecords)])) = do- records <- mapM decode rawRecords- return XReadResponse{..}- decode a = Left a--xreadOpts- :: (RedisCtx m f)- => [(ByteString, ByteString)] -- ^ (stream, id) pairs- -> XReadOpts -- ^ Options- -> m (f (Maybe [XReadResponse]))-xreadOpts streamsAndIds opts = sendRequest $- ["XREAD"] ++ (internalXreadArgs streamsAndIds opts)--internalXreadArgs :: [(ByteString, ByteString)] -> XReadOpts -> [ByteString]-internalXreadArgs streamsAndIds XReadOpts{..} =- concat [blockArgs, countArgs, ["STREAMS"], streams, recordIds]- where- blockArgs = maybe [] (\blockMillis -> ["BLOCK", encode blockMillis]) block- countArgs = maybe [] (\countRecords -> ["COUNT", encode countRecords]) recordCount- streams = map (\(stream, _) -> stream) streamsAndIds- recordIds = map (\(_, recordId) -> recordId) streamsAndIds---xread- :: (RedisCtx m f)- => [(ByteString, ByteString)] -- ^ (stream, id) pairs- -> m( f (Maybe [XReadResponse]))-xread streamsAndIds = xreadOpts streamsAndIds defaultXreadOpts--xreadGroupOpts- :: (RedisCtx m f)- => ByteString -- ^ group name- -> ByteString -- ^ consumer name- -> [(ByteString, ByteString)] -- ^ (stream, id) pairs- -> XReadOpts -- ^ Options- -> m (f (Maybe [XReadResponse]))-xreadGroupOpts groupName consumerName streamsAndIds opts = sendRequest $- ["XREADGROUP", "GROUP", groupName, consumerName] ++ (internalXreadArgs streamsAndIds opts)--xreadGroup- :: (RedisCtx m f)- => ByteString -- ^ group name- -> ByteString -- ^ consumer name- -> [(ByteString, ByteString)] -- ^ (stream, id) pairs- -> m (f (Maybe [XReadResponse]))-xreadGroup groupName consumerName streamsAndIds = xreadGroupOpts groupName consumerName streamsAndIds defaultXreadOpts--xgroupCreate- :: (RedisCtx m f)- => ByteString -- ^ stream- -> ByteString -- ^ group name- -> ByteString -- ^ start ID- -> m (f Status)-xgroupCreate stream groupName startId = sendRequest $ ["XGROUP", "CREATE", stream, groupName, startId]--xgroupSetId- :: (RedisCtx m f)- => ByteString -- ^ stream- -> ByteString -- ^ group- -> ByteString -- ^ id- -> m (f Status)-xgroupSetId stream group messageId = sendRequest ["XGROUP", "SETID", stream, group, messageId]--xgroupDelConsumer- :: (RedisCtx m f)- => ByteString -- ^ stream- -> ByteString -- ^ group- -> ByteString -- ^ consumer- -> m (f Integer)-xgroupDelConsumer stream group consumer = sendRequest ["XGROUP", "DELCONSUMER", stream, group, consumer]--xgroupDestroy- :: (RedisCtx m f)- => ByteString -- ^ stream- -> ByteString -- ^ group- -> m (f Bool)-xgroupDestroy stream group = sendRequest ["XGROUP", "DESTROY", stream, group]--xack- :: (RedisCtx m f)- => ByteString -- ^ stream- -> ByteString -- ^ group name- -> [ByteString] -- ^ message IDs- -> m (f Integer)-xack stream groupName messageIds = sendRequest $ ["XACK", stream, groupName] ++ messageIds--xrange- :: (RedisCtx m f)- => ByteString -- ^ stream- -> ByteString -- ^ start- -> ByteString -- ^ end- -> Maybe Integer -- ^ COUNT- -> m (f [StreamsRecord])-xrange stream start end count = sendRequest $ ["XRANGE", stream, start, end] ++ countArgs- where countArgs = maybe [] (\c -> ["COUNT", encode c]) count--xrevRange- :: (RedisCtx m f)- => ByteString -- ^ stream- -> ByteString -- ^ end- -> ByteString -- ^ start- -> Maybe Integer -- ^ COUNT- -> m (f [StreamsRecord])-xrevRange stream end start count = sendRequest $ ["XREVRANGE", stream, end, start] ++ countArgs- where countArgs = maybe [] (\c -> ["COUNT", encode c]) count--xlen- :: (RedisCtx m f)- => ByteString -- ^ stream- -> m (f Integer)-xlen stream = sendRequest ["XLEN", stream]--data XPendingSummaryResponse = XPendingSummaryResponse- { numPendingMessages :: Integer- , smallestPendingMessageId :: ByteString- , largestPendingMessageId :: ByteString- , numPendingMessagesByconsumer :: [(ByteString, Integer)]- } deriving (Show, Eq)--instance RedisResult XPendingSummaryResponse where- decode (MultiBulk (Just [- Integer numPendingMessages,- Bulk (Just smallestPendingMessageId),- Bulk (Just largestPendingMessageId),- MultiBulk (Just [MultiBulk (Just rawGroupsAndCounts)])])) = do- let groupsAndCounts = chunksOfTwo rawGroupsAndCounts- numPendingMessagesByconsumer <- decodeGroupsAndCounts groupsAndCounts- return XPendingSummaryResponse{..}- where- decodeGroupsAndCounts :: [(Reply, Reply)] -> Either Reply [(ByteString, Integer)]- decodeGroupsAndCounts bs = sequence $ map decodeGroupCount bs- decodeGroupCount :: (Reply, Reply) -> Either Reply (ByteString, Integer)- decodeGroupCount (x, y) = do- decodedX <- decode x- decodedY <- decode y- return (decodedX, decodedY)- chunksOfTwo (x:y:rest) = (x,y):chunksOfTwo rest- chunksOfTwo _ = []- decode a = Left a--xpendingSummary- :: (RedisCtx m f)- => ByteString -- ^ stream- -> ByteString -- ^ group- -> Maybe ByteString -- ^ consumer- -> m (f XPendingSummaryResponse)-xpendingSummary stream group consumer = sendRequest $ ["XPENDING", stream, group] ++ consumerArg- where consumerArg = maybe [] (\c -> [c]) consumer--data XPendingDetailRecord = XPendingDetailRecord- { messageId :: ByteString- , consumer :: ByteString- , millisSinceLastDelivered :: Integer- , numTimesDelivered :: Integer- } deriving (Show, Eq)--instance RedisResult XPendingDetailRecord where- decode (MultiBulk (Just [- Bulk (Just messageId) ,- Bulk (Just consumer),- Integer millisSinceLastDelivered,- Integer numTimesDelivered])) = Right XPendingDetailRecord{..}- decode a = Left a--xpendingDetail- :: (RedisCtx m f)- => ByteString -- ^ stream- -> ByteString -- ^ group- -> ByteString -- ^ startId- -> ByteString -- ^ endId- -> Integer -- ^ count- -> Maybe ByteString -- ^ consumer- -> m (f [XPendingDetailRecord])-xpendingDetail stream group startId endId count consumer = sendRequest $- ["XPENDING", stream, group, startId, endId, encode count] ++ consumerArg- where consumerArg = maybe [] (\c -> [c]) consumer--data XClaimOpts = XClaimOpts- { xclaimIdle :: Maybe Integer- , xclaimTime :: Maybe Integer- , xclaimRetryCount :: Maybe Integer- , xclaimForce :: Bool- } deriving (Show, Eq)--defaultXClaimOpts :: XClaimOpts-defaultXClaimOpts = XClaimOpts- { xclaimIdle = Nothing- , xclaimTime = Nothing- , xclaimRetryCount = Nothing- , xclaimForce = False- }----- |Format a request for XCLAIM.-xclaimRequest- :: ByteString -- ^ stream- -> ByteString -- ^ group- -> ByteString -- ^ consumer- -> Integer -- ^ min idle time- -> XClaimOpts -- ^ optional arguments- -> [ByteString] -- ^ message IDs- -> [ByteString]-xclaimRequest stream group consumer minIdleTime XClaimOpts{..} messageIds =- ["XCLAIM", stream, group, consumer, encode minIdleTime] ++ ( map encode messageIds ) ++ optArgs- where optArgs = idleArg ++ timeArg ++ retryCountArg ++ forceArg- idleArg = optArg "IDLE" xclaimIdle- timeArg = optArg "TIME" xclaimTime- retryCountArg = optArg "RETRYCOUNT" xclaimRetryCount- forceArg = if xclaimForce then ["FORCE"] else []- optArg name maybeArg = maybe [] (\x -> [name, encode x]) maybeArg--xclaim- :: (RedisCtx m f)- => ByteString -- ^ stream- -> ByteString -- ^ group- -> ByteString -- ^ consumer- -> Integer -- ^ min idle time- -> XClaimOpts -- ^ optional arguments- -> [ByteString] -- ^ message IDs- -> m (f [StreamsRecord])-xclaim stream group consumer minIdleTime opts messageIds = sendRequest $- xclaimRequest stream group consumer minIdleTime opts messageIds--xclaimJustIds- :: (RedisCtx m f)- => ByteString -- ^ stream- -> ByteString -- ^ group- -> ByteString -- ^ consumer- -> Integer -- ^ min idle time- -> XClaimOpts -- ^ optional arguments- -> [ByteString] -- ^ message IDs- -> m (f [ByteString])-xclaimJustIds stream group consumer minIdleTime opts messageIds = sendRequest $- (xclaimRequest stream group consumer minIdleTime opts messageIds) ++ ["JUSTID"]--data XInfoConsumersResponse = XInfoConsumersResponse- { xinfoConsumerName :: ByteString- , xinfoConsumerNumPendingMessages :: Integer- , xinfoConsumerIdleTime :: Integer- } deriving (Show, Eq)--instance RedisResult XInfoConsumersResponse where- decode (MultiBulk (Just [- Bulk (Just "name"),- Bulk (Just xinfoConsumerName),- Bulk (Just "pending"),- Integer xinfoConsumerNumPendingMessages,- Bulk (Just "idle"),- Integer xinfoConsumerIdleTime])) = Right XInfoConsumersResponse{..}- decode a = Left a--xinfoConsumers- :: (RedisCtx m f)- => ByteString -- ^ stream- -> ByteString -- ^ group- -> m (f [XInfoConsumersResponse])-xinfoConsumers stream group = sendRequest $ ["XINFO", "CONSUMERS", stream, group]--data XInfoGroupsResponse = XInfoGroupsResponse- { xinfoGroupsGroupName :: ByteString- , xinfoGroupsNumConsumers :: Integer- , xinfoGroupsNumPendingMessages :: Integer- , xinfoGroupsLastDeliveredMessageId :: ByteString- } deriving (Show, Eq)--instance RedisResult XInfoGroupsResponse where- decode (MultiBulk (Just [- Bulk (Just "name"),Bulk (Just xinfoGroupsGroupName),- Bulk (Just "consumers"),Integer xinfoGroupsNumConsumers,- Bulk (Just "pending"),Integer xinfoGroupsNumPendingMessages,- Bulk (Just "last-delivered-id"),Bulk (Just xinfoGroupsLastDeliveredMessageId)])) = Right XInfoGroupsResponse{..}- decode a = Left a--xinfoGroups- :: (RedisCtx m f)- => ByteString -- ^ stream- -> m (f [XInfoGroupsResponse])-xinfoGroups stream = sendRequest ["XINFO", "GROUPS", stream]--data XInfoStreamResponse = XInfoStreamResponse- { xinfoStreamLength :: Integer- , xinfoStreamRadixTreeKeys :: Integer- , xinfoStreamRadixTreeNodes :: Integer- , xinfoStreamNumGroups :: Integer- , xinfoStreamLastEntryId :: ByteString- , xinfoStreamFirstEntry :: StreamsRecord- , xinfoStreamLastEntry :: StreamsRecord- } deriving (Show, Eq)--instance RedisResult XInfoStreamResponse where- decode = decodeRedis5 <> decodeRedis6- where- decodeRedis5 (MultiBulk (Just [- Bulk (Just "length"),Integer xinfoStreamLength,- Bulk (Just "radix-tree-keys"),Integer xinfoStreamRadixTreeKeys,- Bulk (Just "radix-tree-nodes"),Integer xinfoStreamRadixTreeNodes,- Bulk (Just "groups"),Integer xinfoStreamNumGroups,- Bulk (Just "last-generated-id"),Bulk (Just xinfoStreamLastEntryId),- Bulk (Just "first-entry"), rawFirstEntry ,- Bulk (Just "last-entry"), rawLastEntry ])) = do- xinfoStreamFirstEntry <- decode rawFirstEntry- xinfoStreamLastEntry <- decode rawLastEntry- return XInfoStreamResponse{..}- decodeRedis5 a = Left a-- decodeRedis6 (MultiBulk (Just [- Bulk (Just "length"),Integer xinfoStreamLength,- Bulk (Just "radix-tree-keys"),Integer xinfoStreamRadixTreeKeys,- Bulk (Just "radix-tree-nodes"),Integer xinfoStreamRadixTreeNodes,- Bulk (Just "last-generated-id"),Bulk (Just xinfoStreamLastEntryId),- Bulk (Just "groups"),Integer xinfoStreamNumGroups,- Bulk (Just "first-entry"), rawFirstEntry ,- Bulk (Just "last-entry"), rawLastEntry ])) = do- xinfoStreamFirstEntry <- decode rawFirstEntry- xinfoStreamLastEntry <- decode rawLastEntry- return XInfoStreamResponse{..}- decodeRedis6 a = Left a--xinfoStream- :: (RedisCtx m f)- => ByteString -- ^ stream- -> m (f XInfoStreamResponse)-xinfoStream stream = sendRequest ["XINFO", "STREAM", stream]--xdel- :: (RedisCtx m f)- => ByteString -- ^ stream- -> [ByteString] -- ^ message IDs- -> m (f Integer)-xdel stream messageIds = sendRequest $ ["XDEL", stream] ++ messageIds--xtrim- :: (RedisCtx m f)- => ByteString -- ^ stream- -> TrimOpts- -> m (f Integer)-xtrim stream opts = sendRequest $ ["XTRIM", stream] ++ optArgs- where- optArgs = case opts of- NoArgs -> []- Maxlen max -> ["MAXLEN", encode max]- ApproxMaxlen max -> ["MAXLEN", "~", encode max]--inf :: RealFloat a => a-inf = 1 / 0--auth- :: RedisCtx m f- => ByteString -- ^ password- -> m (f Status)-auth password = sendRequest ["AUTH", password]---- the select command. used in 'connect'.-select- :: RedisCtx m f- => Integer -- ^ index- -> m (f Status)-select ix = sendRequest ["SELECT", encode ix]---- the ping command. used in 'checkedconnect'.-ping- :: (RedisCtx m f)- => m (f Status)-ping = sendRequest (["PING"] )--data ClusterNodesResponse = ClusterNodesResponse- { clusterNodesResponseEntries :: [ClusterNodesResponseEntry]- } deriving (Show, Eq)--data ClusterNodesResponseEntry = ClusterNodesResponseEntry { clusterNodesResponseNodeId :: ByteString- , clusterNodesResponseNodeIp :: ByteString- , clusterNodesResponseNodePort :: Integer- , clusterNodesResponseNodeFlags :: [ByteString]- , clusterNodesResponseMasterId :: Maybe ByteString- , clusterNodesResponsePingSent :: Integer- , clusterNodesResponsePongReceived :: Integer- , clusterNodesResponseConfigEpoch :: Integer- , clusterNodesResponseLinkState :: ByteString- , clusterNodesResponseSlots :: [ClusterNodesResponseSlotSpec]- } deriving (Show, Eq)--data ClusterNodesResponseSlotSpec- = ClusterNodesResponseSingleSlot Integer- | ClusterNodesResponseSlotRange Integer Integer- | ClusterNodesResponseSlotImporting Integer ByteString- | ClusterNodesResponseSlotMigrating Integer ByteString deriving (Show, Eq)---instance RedisResult ClusterNodesResponse where- decode r@(Bulk (Just bulkData)) = maybe (Left r) Right $ do- infos <- mapM parseNodeInfo $ Char8.lines bulkData- return $ ClusterNodesResponse infos where- parseNodeInfo :: ByteString -> Maybe ClusterNodesResponseEntry- parseNodeInfo line = case Char8.words line of- (nodeId : hostNamePort : flags : masterNodeId : pingSent : pongRecv : epoch : linkState : slots) ->- case Char8.split ':' hostNamePort of- [hostName, port] -> ClusterNodesResponseEntry <$> pure nodeId- <*> pure hostName- <*> readInteger port- <*> pure (Char8.split ',' flags)- <*> pure (readMasterNodeId masterNodeId)- <*> readInteger pingSent- <*> readInteger pongRecv- <*> readInteger epoch- <*> pure linkState- <*> (pure . catMaybes $ map readNodeSlot slots)- _ -> Nothing- _ -> Nothing- readInteger :: ByteString -> Maybe Integer- readInteger = fmap fst . Char8.readInteger-- readMasterNodeId :: ByteString -> Maybe ByteString- readMasterNodeId "-" = Nothing- readMasterNodeId nodeId = Just nodeId-- readNodeSlot :: ByteString -> Maybe ClusterNodesResponseSlotSpec- readNodeSlot slotSpec = case '[' `Char8.elem` slotSpec of- True -> readSlotImportMigrate slotSpec- False -> case '-' `Char8.elem` slotSpec of- True -> readSlotRange slotSpec- False -> ClusterNodesResponseSingleSlot <$> readInteger slotSpec- readSlotImportMigrate :: ByteString -> Maybe ClusterNodesResponseSlotSpec- readSlotImportMigrate slotSpec = case BS.breakSubstring "->-" slotSpec of- (_, "") -> case BS.breakSubstring "-<-" slotSpec of- (_, "") -> Nothing- (leftPart, rightPart) -> ClusterNodesResponseSlotImporting- <$> (readInteger $ Char8.drop 1 leftPart)- <*> (pure $ BS.take (BS.length rightPart - 1) rightPart)- (leftPart, rightPart) -> ClusterNodesResponseSlotMigrating- <$> (readInteger $ Char8.drop 1 leftPart)- <*> (pure $ BS.take (BS.length rightPart - 1) rightPart)- readSlotRange :: ByteString -> Maybe ClusterNodesResponseSlotSpec- readSlotRange slotSpec = case BS.breakSubstring "-" slotSpec of- (_, "") -> Nothing- (leftPart, rightPart) -> ClusterNodesResponseSlotRange- <$> readInteger leftPart- <*> (readInteger $ BS.drop 1 rightPart)-- decode r = Left r--clusterNodes- :: (RedisCtx m f)- => m (f ClusterNodesResponse)-clusterNodes = sendRequest $ ["CLUSTER", "NODES"]--data ClusterSlotsResponse = ClusterSlotsResponse { clusterSlotsResponseEntries :: [ClusterSlotsResponseEntry] } deriving (Show)--data ClusterSlotsNode = ClusterSlotsNode- { clusterSlotsNodeIP :: ByteString- , clusterSlotsNodePort :: Int- , clusterSlotsNodeID :: ByteString- } deriving (Show)--data ClusterSlotsResponseEntry = ClusterSlotsResponseEntry- { clusterSlotsResponseEntryStartSlot :: Int- , clusterSlotsResponseEntryEndSlot :: Int- , clusterSlotsResponseEntryMaster :: ClusterSlotsNode- , clusterSlotsResponseEntryReplicas :: [ClusterSlotsNode]- } deriving (Show)--instance RedisResult ClusterSlotsResponse where- decode (MultiBulk (Just bulkData)) = do- clusterSlotsResponseEntries <- mapM decode bulkData- return ClusterSlotsResponse{..}- decode a = Left a--instance RedisResult ClusterSlotsResponseEntry where- decode (MultiBulk (Just- ((Integer startSlot):(Integer endSlot):masterData:replicas))) = do- clusterSlotsResponseEntryMaster <- decode masterData- clusterSlotsResponseEntryReplicas <- mapM decode replicas- let clusterSlotsResponseEntryStartSlot = fromInteger startSlot- let clusterSlotsResponseEntryEndSlot = fromInteger endSlot- return ClusterSlotsResponseEntry{..}- decode a = Left a--instance RedisResult ClusterSlotsNode where- decode (MultiBulk (Just ((Bulk (Just clusterSlotsNodeIP)):(Integer port):(Bulk (Just clusterSlotsNodeID)):_))) = Right ClusterSlotsNode{..}- where clusterSlotsNodePort = fromInteger port- decode a = Left a---clusterSlots- :: (RedisCtx m f)- => m (f ClusterSlotsResponse)-clusterSlots = sendRequest $ ["CLUSTER", "SLOTS"]--clusterSetSlotImporting- :: (RedisCtx m f)- => Integer- -> ByteString- -> m (f Status)-clusterSetSlotImporting slot sourceNodeId = sendRequest $ ["CLUSTER", "SETSLOT", (encode slot), "IMPORTING", sourceNodeId]--clusterSetSlotMigrating- :: (RedisCtx m f)- => Integer- -> ByteString- -> m (f Status)-clusterSetSlotMigrating slot destinationNodeId = sendRequest $ ["CLUSTER", "SETSLOT", (encode slot), "MIGRATING", destinationNodeId]--clusterSetSlotStable- :: (RedisCtx m f)- => Integer- -> m (f Status)-clusterSetSlotStable slot = sendRequest $ ["CLUSTER", "SETSLOT", "STABLE", (encode slot)]--clusterSetSlotNode- :: (RedisCtx m f)- => Integer- -> ByteString- -> m (f Status)-clusterSetSlotNode slot node = sendRequest ["CLUSTER", "SETSLOT", (encode slot), "NODE", node]--clusterGetKeysInSlot- :: (RedisCtx m f)- => Integer- -> Integer- -> m (f [ByteString])-clusterGetKeysInSlot slot count = sendRequest ["CLUSTER", "GETKEYSINSLOT", (encode slot), (encode count)]--command :: (RedisCtx m f) => m (f [CMD.CommandInfo])-command = sendRequest ["COMMAND"]+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (maybeToList, catMaybes, fromMaybe)+#if __GLASGOW_HASKELL__ < 808+import Data.Semigroup ((<>))+#endif++++import Database.Redis.Core+import Database.Redis.Protocol+import Database.Redis.Types+import qualified Database.Redis.Cluster.Command as CMD++-- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3+objectRefcount+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> m (f Integer)+objectRefcount key = sendRequest ["OBJECT", "refcount", key]++-- |Inspect the internals of Redis objects (<http://redis.io/commands/object>). The Redis command @OBJECT@ is split up into 'objectRefcount', 'objectEncoding', 'objectIdletime'. Since Redis 2.2.3+objectIdletime+ :: (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]++data ListDirection = ListLeft | ListRight deriving (Show, Eq)++instance RedisArg ListDirection where+ encode ListLeft = "LEFT"+ encode ListRight = "RIGHT"++data LPosOpts = LPosOpts+ { lposRank :: Maybe Integer+ , lposMaxlen :: Maybe Integer+ } deriving (Show, Eq)++defaultLPosOpts :: LPosOpts+defaultLPosOpts = LPosOpts+ { lposRank = Nothing -- ^ The RANK option specifies the "rank" of the first element to return, in case there are multiple matches. A rank of 1 means to return the first match, 2 to return the second match, and so forth.+ , lposMaxlen = Nothing -- ^ The MAXLEN option limits the number of elements to examine, which can improve performance for large lists.+ }++-- |Returns the index of the first matching element in a list (<https://redis.io/commands/lpos>).+--+-- /O(N)/ where /N/ is the number of elements in the list, for the average case. When searching for elements near the head or the tail of the list, or when the MAXLEN option is provided, the command may run in constant time.+--+-- Since Redis 6.0.6+lpos+ :: (RedisCtx m f)+ => ByteString+ -> ByteString+ -> m (f (Maybe Integer))+lpos key element = lposOpts key element defaultLPosOpts++-- |Returns the index of the first matching element in a list (<https://redis.io/commands/lpos>).+--+-- /O(N)/ where /N/ is the number of elements in the list, for the average case. When searching for elements near the head or the tail of the list, or when the MAXLEN option is provided, the command may run in constant time.+--+-- Since Redis 6.0.6+lposOpts+ :: (RedisCtx m f)+ => ByteString+ -> ByteString+ -> LPosOpts+ -> m (f (Maybe Integer))+lposOpts key element opts =+ sendRequest $ ["LPOS", key, element] ++ lposOptsToArgs opts++-- |Returns the indexes of matching elements in a list (<https://redis.io/commands/lpos>).+--+-- /O(N)/ where /N/ is the number of elements in the list, for the average case. When searching for elements near the head or the tail of the list, or when the MAXLEN option is provided, the command may run in constant time.+--+-- Since Redis 6.0.6+lposCount+ :: (RedisCtx m f)+ => ByteString+ -> ByteString+ -> Integer+ -> m (f [Integer])+lposCount key element count = lposCountOpts key element count defaultLPosOpts++-- |Returns the indexes of matching elements in a list (<https://redis.io/commands/lpos>).+--+-- /O(N)/ where /N/ is the number of elements in the list, for the average case. When searching for elements near the head or the tail of the list, or when the MAXLEN option is provided, the command may run in constant time.+--+-- Since Redis 6.0.6+lposCountOpts+ :: (RedisCtx m f)+ => ByteString+ -> ByteString+ -> Integer+ -> LPosOpts+ -> m (f [Integer])+lposCountOpts key element count opts =+ sendRequest $ ["LPOS", key, element] ++ rankArg ++ ["COUNT", encode count] ++ maxlenArg+ where+ (rankArg, maxlenArg) = lposOptsParts opts++lposOptsToArgs :: LPosOpts -> [ByteString]+lposOptsToArgs opts =+ rankArg ++ maxlenArg+ where+ (rankArg, maxlenArg) = lposOptsParts opts++lposOptsParts :: LPosOpts -> ([ByteString], [ByteString])+lposOptsParts LPosOpts{..} =+ ( rankArg+ , maxlenArg+ )+ where+ rankArg = maybe [] (\rank -> ["RANK", encode rank]) lposRank+ maxlenArg = maybe [] (\maxlen -> ["MAXLEN", encode maxlen]) lposMaxlen++-- |Move an element after taking it from one list and pushing it to another (<https://redis.io/commands/lmove>).+--+-- In clustered environments source and destination keys must be in the same hash slot, which can be ensured by using hash tags (e.g. @{tag}source@ and @{tag}destination@).+-- /O(1)/+--+-- Since Redis 6.2.0+lmove+ :: (RedisCtx m f)+ => ByteString -- ^ Source+ -> ByteString -- ^ Destination+ -> ListDirection -- ^ Direction where to get the element from in the source list+ -> ListDirection -- ^ Direction where to push the element to in the destination list+ -> m (f (Maybe ByteString))+lmove source destination from to =+ sendRequest ["LMOVE", source, destination, encode from, encode to]++-- |Move an element after taking it from one list and pushing it to another, or blocks until one is available (<https://redis.io/commands/blmove>).+--+-- In clustered environments source and destination keys must be in the same hash slot, which can be ensured by using hash tags (e.g. @{tag}source@ and @{tag}destination@).+--+-- /O(1)/+--+-- Since Redis 6.2.0+blmove+ :: (RedisCtx m f)+ => ByteString -- ^ Source+ -> ByteString -- ^ Destination+ -> ListDirection -- ^ Direction where to get the element from in the source list+ -> ListDirection -- ^ Direction where to push the element to in the destination list+ -> Integer+ -> m (f (Maybe ByteString))+blmove source destination from to timeout =+ sendRequest ["BLMOVE", source, destination, encode from, encode to, encode timeout]++-- |Pops one or more elements from the first non-empty list from a list of keys (<https://redis.io/commands/lmpop>).+--+-- /O(N+M)/ where /N/ is the number of provided keys and /M/ is the number of elements returned.+--+-- Since Redis 7.0.0+lmpop+ :: (RedisCtx m f)+ => NonEmpty ByteString+ -> ListDirection+ -> m (f (Maybe (ByteString, [ByteString])))+lmpop keys direction = lmpopCount keys direction 1++-- |Pops one or more elements from the first non-empty list from a list of keys (<https://redis.io/commands/lmpop>).+--+-- /O(N+M)/ where /N/ is the number of provided keys and /M/ is the number of elements returned.+--+-- Since Redis 7.0.0+lmpopCount+ :: (RedisCtx m f)+ => NonEmpty ByteString+ -> ListDirection+ -> Integer+ -> m (f (Maybe (ByteString, [ByteString])))+lmpopCount keys direction count =+ sendRequest $ ["LMPOP", encode (toInteger $ NE.length keys)] ++ NE.toList keys ++ [encode direction, "COUNT", encode count]++-- |Pops one or more elements from the first non-empty list from a list of keys, or blocks until one is available (<https://redis.io/commands/blmpop>).+--+-- /O(N+M)/ where /N/ is the number of provided keys and /M/ is the number of elements returned.+--+-- Since Redis 7.0.0+blmpop+ :: (RedisCtx m f)+ => Double+ -> NonEmpty ByteString+ -> ListDirection+ -> m (f (Maybe (ByteString, [ByteString])))+blmpop timeout keys direction = blmpopCount timeout keys direction 1++-- |Pops one or more elements from the first non-empty list from a list of keys, or blocks until one is available (<https://redis.io/commands/blmpop>).+--+-- /O(N+M)/ where /N/ is the number of provided keys and /M/ is the number of elements returned.+--+-- Since Redis 7.0.0+blmpopCount+ :: (RedisCtx m f)+ => Double+ -> NonEmpty ByteString+ -> ListDirection+ -> Integer+ -> m (f (Maybe (ByteString, [ByteString])))+blmpopCount timeout keys direction count =+ sendRequest $ ["BLMPOP", encode timeout, encode (toInteger $ NE.length keys)] ++ NE.toList keys ++ [encode direction, "COUNT", encode count]++-- |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"++-- |Returns the difference between multiple sorted sets (<https://redis.io/commands/zdiff>).+--+-- /O(L + (N - K)\log(N))/ worst case where $L$ is the total number of elements in all the sorted sets, /N/ is the size of the first sorted set, and /K/ is the size of the result set.+--+-- In clustered environment, commands must operate on keys within the same hash slot.+--+-- Since Redis 6.2.0+zdiff+ :: (RedisCtx m f)+ => NonEmpty ByteString+ -> m (f [ByteString])+zdiff keys = sendRequest $ zAggregateKeysArgs "ZDIFF" keys++-- |Returns the difference between multiple sorted sets with scores (<https://redis.io/commands/zdiff>).+--+-- /O(L + (N - K)\log(N))/ worst case where $L$ is the total number of elements in all the sorted sets, /N/ is the size of the first sorted set, and /K/ is the size of the result set.+--+-- In clustered environment, commands must operate on keys within the same hash slot.+--+-- Since Redis 6.2.0+zdiffWithscores+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ Sorted set keys.+ -> m (f [(ByteString, Double)])+zdiffWithscores keys = sendRequest $ zAggregateKeysArgs "ZDIFF" keys ++ ["WITHSCORES"]++-- |Stores the difference of multiple sorted sets in a key (<https://redis.io/commands/zdiffstore>).+--+-- /O(L + (N - K)\log(N))/ worst case where $L$ is the total number of elements in all the sorted sets, /N/ is the size of the first sorted set, and /K/ is the size of the result set.+--+-- In clustered environment, commands must operate on keys within the same hash slot.+--+-- Keys that do not exist are considered to be empty sets.+--+-- If destination already exists, it is overwritten.+--+-- Since Redis 6.2.0+zdiffstore+ :: (RedisCtx m f)+ => ByteString -- ^ Destination key.+ -> NonEmpty ByteString -- ^ Sorted set keys.+ -> m (f Integer)+zdiffstore destination keys =+ sendRequest $ ["ZDIFFSTORE", destination] ++ tail (zAggregateKeysArgs "ZDIFF" keys)++-- |Returns the intersection of multiple sorted sets (<https://redis.io/commands/zinter>).+--+-- /O(NK) + O(M\log(M))/ worst case with /N/ being the smallest input sorted set, /K/ being the number of input sorted sets and /M/ being the number of elements in the resulting sorted set.+--+-- In clustered environment, commands must operate on keys within the same hash slot.+--+-- Since Redis 6.2.0+zinter+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ Sorted set keys.+ -> m (f [ByteString])+zinter keys = zinterOpts keys defaultZAggregateOpts+++data ZAggregateOpts = ZAggregateOpts+ { zAggregateWeights :: [Double] -- ^ WEIGHTS option, it is possible to specify a multiplication factor for each input sorted set. Each element's score is multiplied by its corresponding weight before aggregation. When WEIGHTS is not given, the multiplication factors default to 1.+ , zAggregateAggregate :: Aggregate -- ^ AGGREGATE option, it is possible to specify how the results of the union are aggregated+ } deriving (Show, Eq)++defaultZAggregateOpts :: ZAggregateOpts+defaultZAggregateOpts = ZAggregateOpts+ { zAggregateWeights = []+ , zAggregateAggregate = Sum+ }++-- |Returns the intersection of multiple sorted sets with scores (<https://redis.io/commands/zinter>).+--+-- /O(NK) + O(M\log(M))/ worst case with /N/ being the smallest input sorted set, /K/ being the number of input sorted sets and /M/ being the number of elements in the resulting sorted set.+--+-- In clustered environment, commands must operate on keys within the same hash slot.+--+-- Since Redis 6.2.0+zinterWithscores+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ Sorted set keys.+ -> m (f [(ByteString, Double)])+zinterWithscores keys = zinterWithscoresOpts keys defaultZAggregateOpts++-- |Returns the intersection of multiple sorted sets (<https://redis.io/commands/zinter>).+--+-- /O(NK) + O(M\log(M))/ worst case with /N/ being the smallest input sorted set, /K/ being the number of input sorted sets and /M/ being the number of elements in the resulting sorted set.+--+-- In clustered environment, commands must operate on keys within the same hash slot.+--+-- Since Redis 6.2.0+zinterOpts+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ Sorted set keys.+ -> ZAggregateOpts+ -> m (f [ByteString])+zinterOpts keys opts = sendRequest $ zAggregateInternalArgs "ZINTER" keys opts False++-- |Returns the intersection of multiple sorted sets with scores (<https://redis.io/commands/zinter>).+--+-- /O(NK) + O(M\log(M))/ worst case with /N/ being the smallest input sorted set, /K/ being the number of input sorted sets and /M/ being the number of elements in the resulting sorted set.+--+-- In clustered environment, commands must operate on keys within the same hash slot.+--+-- Since Redis 6.2.0+zinterWithscoresOpts+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ Sorted set keys.+ -> ZAggregateOpts+ -> m (f [(ByteString, Double)])+zinterWithscoresOpts keys opts = sendRequest $ zAggregateInternalArgs "ZINTER" keys opts True++-- |Returns the union of multiple sorted sets (<https://redis.io/commands/zunion>).+--+-- /O(N) + O(M\log(M))/ with /N/ being the sum of the sizes of the input sorted sets, and /M/ being the number of elements in the resulting sorted set.+--+-- Since Redis 6.2.0+zunion+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ Sorted set keys.+ -> m (f [ByteString])+zunion keys = zunionOpts keys defaultZAggregateOpts++-- |Returns the union of multiple sorted sets with scores (<https://redis.io/commands/zunion>).+--+-- /O(N) + O(M\log(M))/ with /N/ being the sum of the sizes of the input sorted sets, and /M/ being the number of elements in the resulting sorted set.+--+-- Since Redis 6.2.0+zunionWithscores+ :: (RedisCtx m f)+ => NonEmpty ByteString+ -> m (f [(ByteString, Double)])+zunionWithscores keys = zunionWithscoresOpts keys defaultZAggregateOpts++-- |Returns the union of multiple sorted sets (<https://redis.io/commands/zunion>).+--+-- /O(N) + O(M\log(M))/ with /N/ being the sum of the sizes of the input sorted sets, and /M/ being the number of elements in the resulting sorted set.+--+-- Since Redis 6.2.0+zunionOpts+ :: (RedisCtx m f)+ => NonEmpty ByteString+ -> ZAggregateOpts+ -> m (f [ByteString])+zunionOpts keys opts = sendRequest $ zAggregateInternalArgs "ZUNION" keys opts False++-- |Returns the union of multiple sorted sets with scores (<https://redis.io/commands/zunion>).+--+-- /O(N) + O(M\log(M))/ with /N/ being the sum of the sizes of the input sorted sets, and /M/ being the number of elements in the resulting sorted set.+--+-- Since Redis 6.2.0+zunionWithscoresOpts+ :: (RedisCtx m f)+ => NonEmpty ByteString+ -> ZAggregateOpts+ -> m (f [(ByteString, Double)])+zunionWithscoresOpts keys opts = sendRequest $ zAggregateInternalArgs "ZUNION" keys opts True++zAggregateKeysArgs :: ByteString -> NonEmpty ByteString -> [ByteString]+zAggregateKeysArgs cmd keys =+ [cmd, encode . toInteger $ NE.length keys] ++ NE.toList keys++zAggregateInternalArgs :: ByteString -> NonEmpty ByteString -> ZAggregateOpts -> Bool -> [ByteString]+zAggregateInternalArgs cmd keys ZAggregateOpts{..} withScores =+ zAggregateKeysArgs cmd keys ++ weightsArg ++ aggregateArg ++ withScoresArg+ where+ weightsArg = ["WEIGHTS" | not (null zAggregateWeights)] ++ map encode zAggregateWeights+ aggregateArg = ["AGGREGATE", aggregateValue zAggregateAggregate]+ withScoresArg = ["WITHSCORES" | withScores]+ aggregateValue Sum = "SUM"+ aggregateValue Min = "MIN"+ aggregateValue 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)++-- |Invokes a function (<https://redis.io/commands/fcall>).+--+-- Complexity depends on the function that is executed.+--+-- Since Redis 7.0.0+fcall+ :: (RedisCtx m f, RedisResult a)+ => ByteString+ -> [ByteString]+ -> [ByteString]+ -> m (f a)+fcall functionName keys args =+ sendRequest $ ["FCALL", functionName, encode numkeys] ++ keys ++ args+ where+ numkeys = toInteger (length keys)++-- |Invokes a read-only function (<https://redis.io/commands/fcall_ro>).+--+-- Complexity depends on the function that is executed.+--+-- Since Redis 7.0.0+fcallReadonly+ :: (RedisCtx m f, RedisResult a)+ => ByteString+ -> [ByteString]+ -> [ByteString]+ -> m (f a)+fcallReadonly functionName keys args =+ sendRequest $ ["FCALL_RO", functionName, encode numkeys] ++ keys ++ args+ where+ numkeys = toInteger (length keys)++data FunctionListOpts = FunctionListOpts+ { functionListLibraryName :: Maybe ByteString+ , functionListWithCode :: Bool+ } deriving (Show, Eq)++defaultFunctionListOpts :: FunctionListOpts+defaultFunctionListOpts = FunctionListOpts+ { functionListLibraryName = Nothing+ , functionListWithCode = False+ }++data FunctionRestorePolicy+ = FunctionRestoreAppend+ | FunctionRestoreFlush+ | FunctionRestoreReplace+ deriving (Show, Eq)++instance RedisArg FunctionRestorePolicy where+ encode FunctionRestoreAppend = "APPEND"+ encode FunctionRestoreFlush = "FLUSH"+ encode FunctionRestoreReplace = "REPLACE"++-- |Deletes a library and its functions (<https://redis.io/commands/function-delete>).+--+-- /O(1)/+--+-- Since Redis 7.0.0+functionDelete+ :: (RedisCtx m f)+ => ByteString+ -> m (f Status)+functionDelete libraryName = sendRequest ["FUNCTION", "DELETE", libraryName]++-- |Dumps all libraries into a serialized binary payload (<https://redis.io/commands/function-dump>).+--+-- /O(N)/ where /N/ is the number of functions.+--+-- Since Redis 7.0.0+functionDump+ :: (RedisCtx m f)+ => m (f ByteString)+functionDump = sendRequest ["FUNCTION", "DUMP"]++-- |Deletes all libraries and functions (<https://redis.io/commands/function-flush>).+--+-- /O(N)/ where /N/ is the number of functions deleted.+--+-- Since Redis 7.0.0+functionFlush+ :: (RedisCtx m f)+ => m (f Status)+functionFlush = sendRequest ["FUNCTION", "FLUSH"]++-- |Deletes all libraries and functions (<https://redis.io/commands/function-flush>).+--+-- /O(N)/ where /N/ is the number of functions deleted.+--+-- Since Redis 7.0.0+functionFlushOpts+ :: (RedisCtx m f)+ => FlushOpts+ -> m (f Status)+functionFlushOpts opts = sendRequest ["FUNCTION", "FLUSH", encode opts]++-- |Returns helpful text about FUNCTION subcommands (<https://redis.io/commands/function-help>).+--+-- /O(1)/+--+-- Since Redis 7.0.0+functionHelp+ :: (RedisCtx m f)+ => m (f [ByteString])+functionHelp = sendRequest ["FUNCTION", "HELP"]++-- |Terminates a function during execution (<https://redis.io/commands/function-kill>).+--+-- /O(1)/+--+-- Since Redis 7.0.0+functionKill+ :: (RedisCtx m f)+ => m (f Status)+functionKill = sendRequest ["FUNCTION", "KILL"]++-- |Returns information about all libraries (<https://redis.io/commands/function-list>).+--+-- /O(N)/ where /N/ is the number of functions.+--+-- Since Redis 7.0.0+functionList+ :: (RedisCtx m f)+ => m (f Reply)+functionList = functionListOpts defaultFunctionListOpts++-- |Returns information about all libraries (<https://redis.io/commands/function-list>).+--+-- /O(N)/ where /N/ is the number of functions.+--+-- Since Redis 7.0.0+functionListOpts+ :: (RedisCtx m f)+ => FunctionListOpts+ -> m (f Reply)+functionListOpts FunctionListOpts{..} =+ sendRequest $ ["FUNCTION", "LIST"] ++ libraryArg ++ withCodeArg+ where+ libraryArg = maybe [] (\libraryName -> ["LIBRARYNAME", libraryName]) functionListLibraryName+ withCodeArg = ["WITHCODE" | functionListWithCode]++-- |Creates a library (<https://redis.io/commands/function-load>).+--+-- /O(N)/ where /N/ is the number of bytes in the function's source code.+--+-- Since Redis 7.0.0+functionLoad+ :: (RedisCtx m f)+ => ByteString+ -> m (f ByteString)+functionLoad libraryCode = sendRequest ["FUNCTION", "LOAD", libraryCode]++-- |Creates a library, replacing an existing one with the same name (<https://redis.io/commands/function-load>).+--+-- /O(N)/ where /N/ is the number of bytes in the function's source code.+--+-- Since Redis 7.0.0+functionLoadReplace+ :: (RedisCtx m f)+ => ByteString+ -> m (f ByteString)+functionLoadReplace libraryCode = sendRequest ["FUNCTION", "LOAD", "REPLACE", libraryCode]++-- |Restores all libraries from a payload (<https://redis.io/commands/function-restore>).+--+-- /O(N)/ where /N/ is the number of functions restored.+--+-- Since Redis 7.0.0+functionRestore+ :: (RedisCtx m f)+ => ByteString+ -> Maybe FunctionRestorePolicy+ -> m (f Status)+functionRestore payload restorePolicy =+ sendRequest $ ["FUNCTION", "RESTORE", payload] ++ maybe [] (\policy -> [encode policy]) restorePolicy++-- |Returns information about a function during execution (<https://redis.io/commands/function-stats>).+--+-- /O(1)/+--+-- Since Redis 7.0.0+functionStats+ :: (RedisCtx m f)+ => m (f Reply)+functionStats = sendRequest ["FUNCTION", "STATS"]++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++data VAddQuantization+ = VAddNoQuant+ | VAddQ8+ | VAddBin+ deriving (Show, Eq)++instance RedisArg VAddQuantization where+ encode VAddNoQuant = "NOQUANT"+ encode VAddQ8 = "Q8"+ encode VAddBin = "BIN"++data VAddOpts = VAddOpts+ { vAddReduceDim :: Maybe Integer+ , vAddCas :: Bool+ , vAddQuantization :: Maybe VAddQuantization+ , vAddBuildExplorationFactor :: Maybe Integer+ , vAddAttributes :: Maybe ByteString+ , vAddNumLinks :: Maybe Integer+ } deriving (Show, Eq)++data VQuantization+ = VQuantizationFP32+ | VQuantizationBin+ | VQuantizationQ8+ deriving (Show, Eq)++instance RedisArg VQuantization where+ encode VQuantizationFP32 = "FP32"+ encode VQuantizationBin = "BIN"+ encode VQuantizationQ8 = "Q8"++instance RedisResult VQuantization where+ decode (SingleLine "fp32") = Right VQuantizationFP32+ decode (SingleLine "f32") = Right VQuantizationFP32+ decode (SingleLine "bin") = Right VQuantizationBin+ decode (SingleLine "q8") = Right VQuantizationQ8+ decode (SingleLine "int8") = Right VQuantizationQ8+ decode (Bulk (Just "fp32")) = Right VQuantizationFP32+ decode (Bulk (Just "f32")) = Right VQuantizationFP32+ decode (Bulk (Just "bin")) = Right VQuantizationBin+ decode (Bulk (Just "q8")) = Right VQuantizationQ8+ decode (Bulk (Just "int8")) = Right VQuantizationQ8+ decode r = Left r++data VEmbRawResponse = VEmbRawResponse+ { vEmbRawQuantization :: VQuantization+ , vEmbRawData :: ByteString+ , vEmbRawNorm :: Double+ , vEmbRawRange :: Maybe Double+ } deriving (Show, Eq)++instance RedisResult VEmbRawResponse where+ decode (MultiBulk (Just [quantizationReply, rawDataReply, normReply])) =+ VEmbRawResponse+ <$> decode quantizationReply+ <*> decode rawDataReply+ <*> decode normReply+ <*> pure Nothing+ decode (MultiBulk (Just [quantizationReply, rawDataReply, normReply, rangeReply])) =+ VEmbRawResponse+ <$> decode quantizationReply+ <*> decode rawDataReply+ <*> decode normReply+ <*> (Just <$> decode rangeReply)+ decode r = Left r++data VInfoResponse = VInfoResponse+ { vInfoQuantization :: Maybe ByteString+ , vInfoVectorDim :: Maybe Integer+ , vInfoSize :: Maybe Integer+ , vInfoMaxLevel :: Maybe Integer+ , vInfoUid :: Maybe Integer+ , vInfoHnswMaxNodeUid :: Maybe Integer+ } deriving (Show, Eq)++instance RedisResult VInfoResponse where+ decode r@(MultiBulk (Just replies)) =+ parsePairs replies >>= buildInfo+ where+ parsePairs [] = Right []+ parsePairs (keyReply:valueReply:rest) =+ (:) <$> ((,) <$> decode keyReply <*> pure valueReply) <*> parsePairs rest+ parsePairs _ = Left r++ buildInfo pairs = Right VInfoResponse+ { vInfoQuantization = lookupDecoded "quant-type" pairs+ , vInfoVectorDim = lookupDecoded "vector-dim" pairs+ , vInfoSize = lookupDecoded "size" pairs+ , vInfoMaxLevel = lookupDecoded "max-level" pairs+ , vInfoUid = lookupDecoded "vset-uid" pairs+ , vInfoHnswMaxNodeUid = lookupDecoded "hnsw-max-node-uid" pairs+ }++ lookupDecoded :: RedisResult a => ByteString -> [(ByteString, Reply)] -> Maybe a+ lookupDecoded key pairs = lookup key pairs >>= either (const Nothing) Just . decode+ decode r = Left r++newtype VLinksResponse = VLinksResponse+ { vLinksLayers :: [[ByteString]]+ } deriving (Show, Eq)++instance RedisResult VLinksResponse where+ decode (MultiBulk (Just layers)) = VLinksResponse <$> mapM decode layers+ decode r = Left r++newtype VLinksWithScoresResponse = VLinksWithScoresResponse+ { vLinksWithScoresLayers :: [[(ByteString, Double)]]+ } deriving (Show, Eq)++instance RedisResult VLinksWithScoresResponse where+ decode r@(MultiBulk (Just layers)) =+ VLinksWithScoresResponse <$> mapM decodeLayer layers+ where+ decodeLayer (MultiBulk (Just entries)) = pairs entries+ decodeLayer badReply = Left badReply++ pairs [] = Right []+ pairs (nameReply:scoreReply:rest) =+ (:) <$> ((,) <$> decode nameReply <*> decode scoreReply) <*> pairs rest+ pairs _ = Left r+ decode r = Left r++data VSimQuery+ = VSimByElement ByteString+ | VSimByFp32 ByteString+ | VSimByValues (NonEmpty Double)+ deriving (Show, Eq)++data VSimOpts = VSimOpts+ { vSimCount :: Maybe Integer+ , vSimEpsilon :: Maybe Double+ , vSimEf :: Maybe Integer+ , vSimFilter :: Maybe ByteString+ , vSimFilterEf :: Maybe Integer+ , vSimTruth :: Bool+ , vSimNoThread :: Bool+ } deriving (Show, Eq)++defaultVSimOpts :: VSimOpts+defaultVSimOpts = VSimOpts+ { vSimCount = Nothing+ , vSimEpsilon = Nothing+ , vSimEf = Nothing+ , vSimFilter = Nothing+ , vSimFilterEf = Nothing+ , vSimTruth = False+ , vSimNoThread = False+ }++data VSimWithAttribsResult = VSimWithAttribsResult+ { vSimResultElement :: ByteString+ , vSimResultScore :: Double+ , vSimResultAttributes :: Maybe ByteString+ } deriving (Show, Eq)++instance RedisResult VSimWithAttribsResult where+ decode (MultiBulk (Just [elementReply, scoreReply, Bulk Nothing])) =+ VSimWithAttribsResult+ <$> decode elementReply+ <*> decode scoreReply+ <*> pure Nothing+ decode (MultiBulk (Just [elementReply, scoreReply, attributesReply])) =+ VSimWithAttribsResult+ <$> decode elementReply+ <*> decode scoreReply+ <*> (Just <$> decode attributesReply)+ decode r = Left r++newtype VSimWithAttribsResponse = VSimWithAttribsResponse+ { vSimWithAttribsResults :: [VSimWithAttribsResult]+ } deriving (Show, Eq)++instance RedisResult VSimWithAttribsResponse where+ decode r@(MultiBulk (Just replies)) =+ VSimWithAttribsResponse <$> triples replies+ where+ triples [] = Right []+ triples (elementReply:scoreReply:Bulk Nothing:rest) = do+ result <- VSimWithAttribsResult+ <$> decode elementReply+ <*> decode scoreReply+ <*> pure Nothing+ (result :) <$> triples rest+ triples (elementReply:scoreReply:attributesReply:rest) = do+ result <- VSimWithAttribsResult+ <$> decode elementReply+ <*> decode scoreReply+ <*> (Just <$> decode attributesReply)+ (result :) <$> triples rest+ triples _ = Left r+ decode r = Left r++-- |Redis default 'VAddOpts'. Equivalent to omitting all optional parameters.+defaultVAddOpts :: VAddOpts+defaultVAddOpts = VAddOpts+ { vAddReduceDim = Nothing+ , vAddCas = False+ , vAddQuantization = Nothing+ , vAddBuildExplorationFactor = Nothing+ , vAddAttributes = Nothing+ , vAddNumLinks = Nothing+ }++-- |Adds a new element to a vector set, or updates its vector if it already exists (<https://redis.io/commands/vadd>).+--+-- /O(log(N))/ for each element added, where /N/ is the number of elements in the vector set.+--+-- Since Redis 8.0.0+vadd+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that will hold the vector set data.+ -> NonEmpty Double+ {- ^ The vector values as floating point numbers.++ This uses the `VALUES` argument form and automatically supplies the number of vector elements.+ -}+ -> ByteString -- ^ The name of the element that is being added to the vector set.+ -> m (f Bool)+vadd key vector element = vaddOpts key vector element defaultVAddOpts++-- |Adds a new element to a vector set, or updates its vector if it already exists (<https://redis.io/commands/vadd>).+--+-- /O(log(N))/ for each element added, where /N/ is the number of elements in the vector set.+--+-- Since Redis 8.0.0+vaddOpts+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that will hold the vector set data.+ -> NonEmpty Double -- ^ The vector values as floating point numbers.+ -> ByteString -- ^ The name of the element that is being added to the vector set.+ -> VAddOpts+ {- ^ Additional parameters.++ `REDUCE dim` reduces the dimensionality of the vector using random projection.+ `CAS` performs the slow neighbor candidate collection in the background.+ `NOQUANT`, `Q8`, and `BIN` control quantization and are mutually exclusive.+ `EF` sets the build exploration factor.+ `SETATTR` associates attributes with the entry.+ `M` sets the maximum number of graph links per node.+ -}+ -> m (f Bool)+vaddOpts key vector element VAddOpts{..} =+ sendRequest $+ ["VADD", key]+ ++ reduceArg+ ++ ["VALUES", encode (toInteger $ NE.length vector)]+ ++ map encode (NE.toList vector)+ ++ [element]+ ++ casArg+ ++ quantizationArg+ ++ efArg+ ++ attributesArg+ ++ numLinksArg+ where+ reduceArg = maybe [] (\dim -> ["REDUCE", encode dim]) vAddReduceDim+ casArg = ["CAS" | vAddCas]+ quantizationArg = maybe [] (\quantization -> [encode quantization]) vAddQuantization+ efArg = maybe [] (\ef -> ["EF", encode ef]) vAddBuildExplorationFactor+ attributesArg = maybe [] (\attributes -> ["SETATTR", attributes]) vAddAttributes+ numLinksArg = maybe [] (\numLinks -> ["M", encode numLinks]) vAddNumLinks++-- |Return the number of elements in the specified vector set (<https://redis.io/commands/vcard>).+--+-- /O(1)/+--+-- Since Redis 8.0.0+vcard+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set.+ -> m (f Integer)+vcard key = sendRequest ["VCARD", key]++-- |Return the number of dimensions of the vectors in the specified vector set (<https://redis.io/commands/vdim>).+--+-- /O(1)/+--+-- Since Redis 8.0.0+vdim+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set.+ -> m (f Integer)+vdim key = sendRequest ["VDIM", key]++-- |Return the approximate vector associated with a given element in the vector set (<https://redis.io/commands/vemb>).+--+-- /O(1)/+--+-- Since Redis 8.0.0+vemb+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set.+ -> ByteString -- ^ The name of the element whose vector you want to retrieve.+ -> m (f [Double])+vemb key element = sendRequest ["VEMB", key, element]++-- |Return the raw internal representation of the vector associated with a given element in the vector set (<https://redis.io/commands/vemb>).+--+-- /O(1)/+--+-- Since Redis 8.0.0+vembRaw+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set.+ -> ByteString -- ^ The name of the element whose vector you want to retrieve.+ -> m (f (Maybe VEmbRawResponse))+vembRaw key element = sendRequest ["VEMB", key, element, "RAW"]++-- |Retrieve the JSON attributes of an element in a vector set (<https://redis.io/commands/vgetattr>).+--+-- /O(1)/+--+-- Since Redis 8.0.0+vgetattr+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set.+ -> ByteString -- ^ The name of the element whose attributes you want to retrieve.+ -> m (f (Maybe ByteString))+vgetattr key element = sendRequest ["VGETATTR", key, element]++-- |Return metadata and internal details about a vector set (<https://redis.io/commands/vinfo>).+--+-- /O(1)/+--+-- Since Redis 8.0.0+vinfo+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set.+ -> m (f (Maybe VInfoResponse))+vinfo key = sendRequest ["VINFO", key]++-- |Check if an element exists in a vector set (<https://redis.io/commands/vismember>).+--+-- /O(1)/+--+-- Since Redis 8.0.0+vismember+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set.+ -> ByteString -- ^ The name of the element to check.+ -> m (f Bool)+vismember key element = sendRequest ["VISMEMBER", key, element]++-- |Return the neighbors of a specified element in a vector set (<https://redis.io/commands/vlinks>).+--+-- /O(1)/+--+-- Since Redis 8.0.0+vlinks+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set.+ -> ByteString -- ^ The name of the element whose HNSW neighbors you want to inspect.+ -> m (f (Maybe VLinksResponse))+vlinks key element = sendRequest ["VLINKS", key, element]++-- |Return the neighbors of a specified element in a vector set together with their similarity scores (<https://redis.io/commands/vlinks>).+--+-- /O(1)/+--+-- Since Redis 8.0.0+vlinksWithScores+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set.+ -> ByteString -- ^ The name of the element whose HNSW neighbors you want to inspect.+ -> m (f (Maybe VLinksWithScoresResponse))+vlinksWithScores key element = sendRequest ["VLINKS", key, element, "WITHSCORES"]++-- |Return one random element from a vector set (<https://redis.io/commands/vrandmember>).+--+-- /O(N)/ where /N/ is the absolute value of the count argument.+--+-- Since Redis 8.0.0+vrandmember+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set.+ -> m (f (Maybe ByteString))+vrandmember key = sendRequest ["VRANDMEMBER", key]++-- |Return one or multiple random elements from a vector set (<https://redis.io/commands/vrandmember>).+--+-- /O(N)/ where /N/ is the absolute value of the count argument.+--+-- Since Redis 8.0.0+vrandmemberCount+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set.+ -> Integer+ {- ^ The number of elements to return.++ Positive values return distinct elements; negative values allow duplicates.+ -}+ -> m (f [ByteString])+vrandmemberCount key count = sendRequest ["VRANDMEMBER", key, encode count]++-- |Returns elements in a lexicographical range (<https://redis.io/commands/vrange>).+--+-- /O(log(K)+M)/ where /K/ is the number of elements in the start prefix, and /M/ is the number of elements returned. In practical terms, the command is just /O(M)/.+--+-- Since Redis 8.4.0+vrange+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the vector set key from which to retrieve elements.+ -> ByteString+ {- ^ The starting point of the lexicographical range.++ Use a value prefixed with `[` for an inclusive bound, a value prefixed with `(` for an exclusive bound, or `-` for the minimum element.+ -}+ -> ByteString+ {- ^ The ending point of the lexicographical range.++ Use a value prefixed with `[` for an inclusive bound, a value prefixed with `(` for an exclusive bound, or `+` for the maximum element.+ -}+ -> m (f [ByteString])+vrange key start end = sendRequest ["VRANGE", key, start, end]++-- |Returns elements in a lexicographical range (<https://redis.io/commands/vrange>).+--+-- /O(log(K)+M)/ where /K/ is the number of elements in the start prefix, and /M/ is the number of elements returned. In practical terms, the command is just /O(M)/.+--+-- Since Redis 8.4.0+vrangeCount+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the vector set key from which to retrieve elements.+ -> ByteString -- ^ The starting point of the lexicographical range.+ -> ByteString -- ^ The ending point of the lexicographical range.+ -> Integer+ {- ^ The maximum number of elements to return.++ If `count` is negative, the command returns all elements in the specified range.+ -}+ -> m (f [ByteString])+vrangeCount key start end count =+ sendRequest ["VRANGE", key, start, end, encode count]++-- |Remove an element from a vector set (<https://redis.io/commands/vrem>).+--+-- /O(log(N))/ for each element removed, where /N/ is the number of elements in the vector set.+--+-- Since Redis 8.0.0+vrem+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set.+ -> ByteString -- ^ The name of the element to remove from the vector set.+ -> m (f Bool)+vrem key element = sendRequest ["VREM", key, element]++-- |Associate or remove the JSON attributes of an element in a vector set (<https://redis.io/commands/vsetattr>).+--+-- /O(1)/+--+-- Since Redis 8.0.0+vsetattr+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set.+ -> ByteString -- ^ The name of the element in the vector set.+ -> ByteString+ {- ^ The attributes as a JSON object string.++ Use the empty string to remove existing attributes.+ -}+ -> m (f Bool)+vsetattr key element attributes = sendRequest ["VSETATTR", key, element, attributes]++-- |Return elements similar to a given vector or element (<https://redis.io/commands/vsim>).+--+-- /O(log(N))/ where /N/ is the number of elements in the vector set.+--+-- Since Redis 8.0.0+vsim+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set data.+ -> VSimQuery+ {- ^ Query vector source.++ Use `VSimByElement` to refer to an existing element, `VSimByFp32` for binary float format, or `VSimByValues` for a list of float values.+ -}+ -> m (f [ByteString])+vsim key query = vsimOpts key query defaultVSimOpts++-- |Return elements similar to a given vector or element (<https://redis.io/commands/vsim>).+--+-- /O(log(N))/ where /N/ is the number of elements in the vector set.+--+-- Since Redis 8.0.0+vsimOpts+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set data.+ -> VSimQuery -- ^ Query vector source.+ -> VSimOpts+ {- ^ Additional search options.++ `COUNT` limits the number of returned results.+ `EPSILON` filters out elements that are too far from the query vector.+ `EF` controls the exploration factor.+ `FILTER` applies a filtering expression and `FILTER-EF` limits filtering effort.+ `TRUTH` forces an exact linear scan.+ `NOTHREAD` executes the search in the main thread.+ -}+ -> m (f [ByteString])+vsimOpts key query opts =+ sendRequest $ ["VSIM", key] ++ vSimQueryArgs query ++ vSimOptsArgs opts++-- |Return elements similar to a given vector or element together with their similarity scores (<https://redis.io/commands/vsim>).+--+-- /O(log(N))/ where /N/ is the number of elements in the vector set.+--+-- Since Redis 8.0.0+vsimWithScores+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set data.+ -> VSimQuery -- ^ Query vector source.+ -> m (f [(ByteString, Double)])+vsimWithScores key query = vsimWithScoresOpts key query defaultVSimOpts++-- |Return elements similar to a given vector or element together with their similarity scores (<https://redis.io/commands/vsim>).+--+-- /O(log(N))/ where /N/ is the number of elements in the vector set.+--+-- Since Redis 8.0.0+vsimWithScoresOpts+ :: (RedisCtx m f)+ => ByteString+ -> VSimQuery+ -> VSimOpts+ -> m (f [(ByteString, Double)])+vsimWithScoresOpts key query opts =+ sendRequest $ ["VSIM", key] ++ vSimQueryArgs query ++ ["WITHSCORES"] ++ vSimOptsArgs opts++-- |Return elements similar to a given vector or element together with their similarity scores and JSON attributes (<https://redis.io/commands/vsim>).+--+-- /O(log(N))/ where /N/ is the number of elements in the vector set.+--+-- Since Redis 8.2.0+vsimWithScoresWithAttribs+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key that holds the vector set data.+ -> VSimQuery -- ^ Query vector source.+ -> m (f VSimWithAttribsResponse)+vsimWithScoresWithAttribs key query =+ vsimWithScoresWithAttribsOpts key query defaultVSimOpts++-- |Return elements similar to a given vector or element together with their similarity scores and JSON attributes (<https://redis.io/commands/vsim>).+--+-- /O(log(N))/ where /N/ is the number of elements in the vector set.+--+-- Since Redis 8.2.0+vsimWithScoresWithAttribsOpts+ :: (RedisCtx m f)+ => ByteString+ -> VSimQuery+ -> VSimOpts+ -> m (f VSimWithAttribsResponse)+vsimWithScoresWithAttribsOpts key query opts =+ sendRequest $ ["VSIM", key] ++ vSimQueryArgs query ++ ["WITHSCORES", "WITHATTRIBS"] ++ vSimOptsArgs opts++vSimQueryArgs :: VSimQuery -> [ByteString]+vSimQueryArgs query =+ case query of+ VSimByElement element -> ["ELE", element]+ VSimByFp32 rawVector -> ["FP32", rawVector]+ VSimByValues values ->+ ["VALUES", encode (toInteger $ NE.length values)] ++ map encode (NE.toList values)++vSimOptsArgs :: VSimOpts -> [ByteString]+vSimOptsArgs VSimOpts{..} =+ countArg ++ epsilonArg ++ efArg ++ filterArg ++ filterEfArg ++ truthArg ++ noThreadArg+ where+ countArg = maybe [] (\count -> ["COUNT", encode count]) vSimCount+ epsilonArg = maybe [] (\epsilon -> ["EPSILON", encode epsilon]) vSimEpsilon+ efArg = maybe [] (\ef -> ["EF", encode ef]) vSimEf+ filterArg = maybe [] (\expression -> ["FILTER", expression]) vSimFilter+ filterEfArg = maybe [] (\filterEf -> ["FILTER-EF", encode filterEf]) vSimFilterEf+ truthArg = ["TRUTH" | vSimTruth]+ noThreadArg = ["NOTHREAD" | vSimNoThread]++-- |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_, copyArg, replace, keys]+ where+ copyArg = ["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"]++-- | Options for the 'copy' command.+data CopyOpts = CopyOpts+ { copyDestinationDb :: Maybe Integer -- ^ Destination database number.+ , copyReplace :: Bool -- ^ Replace the destination key if it already exists.+ } deriving (Show, Eq)++-- | Redis default 'CopyOpts'. Equivalent to omitting all optional parameters.+defaultCopyOpts :: CopyOpts+defaultCopyOpts = CopyOpts+ { copyDestinationDb = Nothing+ , copyReplace = False+ }++-- |Copies the value of a key to a new key (<https://redis.io/commands/copy>).+--+-- /O(N)/ worst case for collections, where @N@ is the number of nested items. /O(1)/ for string values.+--+-- Since Redis 6.2.0+copy+ :: (RedisCtx m f)+ => ByteString -- ^ Source key+ -> ByteString -- ^ Destination key+ -> m (f Bool)+copy source destination = copyOpts source destination defaultCopyOpts++-- |Copies the value of a key to a new key (<https://redis.io/commands/copy>).+--+-- /O(N)/ worst case for collections, where /N/ is the number of nested items. /O(1)/ for string values.+--+-- Since Redis 6.2.0+copyOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Source key+ -> ByteString -- ^ Destination key+ -> CopyOpts -- ^ Copy options+ -> m (f Bool)+copyOpts source destination CopyOpts{..} =+ sendRequest $ ["COPY", source, destination] ++ dbArg ++ replaceArg+ where+ dbArg = maybe [] (\destinationDb -> ["DB", encode destinationDb]) copyDestinationDb+ replaceArg = ["REPLACE" | copyReplace]++-- |Returns the expiration time of a key as a Unix timestamp (<https://redis.io/commands/expiretime>).+--+-- Returns @-2@ if the key does not exist; @-1@ if the key exists but has no associated expiration.+--+-- /O(1)/. Since Redis 7.0.0+expiretime+ :: (RedisCtx m f)+ => ByteString+ -> m (f Integer)+expiretime key = sendRequest ["EXPIRETIME", key]++-- |Returns the expiration time of a key as a Unix timestamp in milliseconds (<https://redis.io/commands/pexpiretime>).+--+-- Returns @-2@ if the key does not exist; @-1@ if the key exists but has no associated expiration.+--+-- /O(1)/. Since Redis 7.0.0+pexpiretime+ :: (RedisCtx m f)+ => ByteString+ -> m (f Integer)+pexpiretime key = sendRequest ["PEXPIRETIME", key]+++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)++-- |Redis default 'SetOpts'. Equivalent to omitting all optional parameters.+defaultSetOpts :: SetOpts+defaultSetOpts = SetOpts+ { setSeconds = Nothing+ , setMilliseconds = Nothing+ , setUnixSeconds = Nothing+ , setUnixMilliseconds = Nothing+ , setCondition = Nothing+ , setKeepTTL = False+ }++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++-- |Atomically sets multiple string keys with an optional shared expiration in a single operation (<https://redis.io/commands/msetex>).+--+-- /O(N)/ where /N/ is the number of keys to set.+--+-- Since Redis 8.4.0+msetex+ :: (RedisCtx m f)+ => NonEmpty (ByteString, ByteString) -- ^ A series of key/value pairs.+ -> m (f Bool)+msetex keyValues = msetexOpts keyValues defaultSetOpts++-- |Atomically sets multiple string keys with an optional shared expiration in a single operation (<https://redis.io/commands/msetex>).+--+-- /O(N)/ where /N/ is the number of keys to set.+--+-- Since Redis 8.4.0+msetexOpts+ :: (RedisCtx m f)+ => NonEmpty (ByteString, ByteString) -- ^ A series of key/value pairs.+ -> SetOpts+ {- ^ Shared condition and expiration flags.++ The `MSETEX` command supports a set of options that modify its behavior:+ `NX` sets the keys and their expiration time only if none of the specified keys exist.+ `XX` sets the keys and their expiration time only if all of the specified keys already exist.+ `EX`/`PX`/`EXAT`/`PXAT` set the shared expiration for the specified keys.+ `KEEPTTL` retains the time to live associated with the keys.+ -}+ -> m (f Bool)+msetexOpts keyValues opts =+ sendRequest $+ ["MSETEX", encode (toInteger $ NE.length keyValues)]+ ++ concatMap (\(key, value) -> [key, value]) (NE.toList keyValues)+ ++ internalSetOptsToArgs opts++data GetExOpts = GetExOpts+ { getExSeconds :: Maybe Integer+ , getExMilliseconds :: Maybe Integer+ , getExUnixSeconds :: Maybe Integer+ , getExUnixMilliseconds :: Maybe Integer+ , getExPersist :: Bool+ } deriving (Show, Eq)++defaultGetExOpts :: GetExOpts+defaultGetExOpts = GetExOpts+ { getExSeconds = Nothing+ , getExMilliseconds = Nothing+ , getExUnixSeconds = Nothing+ , getExUnixMilliseconds = Nothing+ , getExPersist = False+ }++-- |Returns the string value of a key after deleting the key (<https://redis.io/commands/getdel>).+--+-- /O(1)/+--+-- Since Redis 6.2.0+getdel+ :: (RedisCtx m f)+ => ByteString+ -> m (f (Maybe ByteString))+getdel key = sendRequest ["GETDEL", key]++data DelexCondition+ = DelexIfEq ByteString+ | DelexIfNe ByteString+ | DelexIfDigestEq ByteString+ | DelexIfDigestNe ByteString+ deriving (Show, Eq)++delexConditionToArgs :: DelexCondition -> [ByteString]+delexConditionToArgs condition =+ case condition of+ DelexIfEq value -> ["IFEQ", value]+ DelexIfNe value -> ["IFNE", value]+ DelexIfDigestEq digestValue -> ["IFDEQ", digestValue]+ DelexIfDigestNe digestValue -> ["IFDNE", digestValue]++-- |Conditionally removes the specified key based on value or hash digest comparison (<https://redis.io/commands/delex>).+--+-- /O(1)/ for /IFEQ/ and /IFNE/. /O(N)/ for /IFDEQ/ and /IFDNE/, where /N/ is the length of the string value.+--+-- Since Redis 8.4.0+delex+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the string.+ -> m (f Bool)+delex key = sendRequest ["DELEX", key]++-- |Conditionally removes the specified key based on value or hash digest comparison (<https://redis.io/commands/delex>).+--+-- /O(1)/ for /IFEQ/ and /IFNE/. /O(N)/ for /IFDEQ/ and /IFDNE/, where /N/ is the length of the string value.+--+-- Since Redis 8.4.0+delexWhen+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the string.+ -> DelexCondition+ {- ^ Condition to enforce.++ The `DELEX` command supports a set of options that modify its behavior.+ Only one option can be specified:+ `IFEQ` removes the key if the value is equal to the specified value.+ `IFNE` removes the key if the value is not equal to the specified value.+ `IFDEQ` removes the key if its hash digest is equal to the specified hash digest.+ `IFDNE` removes the key if its hash digest is not equal to the specified hash digest.+ -}+ -> m (f Bool)+delexWhen key condition =+ sendRequest $ ["DELEX", key] ++ delexConditionToArgs condition++-- |Returns the hash digest of a string value (<https://redis.io/commands/digest>).+--+-- /O(N)/ where /N/ is the length of the string value.+--+-- Since Redis 8.4.0+digest+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the string.+ -> m (f (Maybe ByteString))+digest key = sendRequest ["DIGEST", key]++-- |Returns the string value of a key after setting its expiration time (<https://redis.io/commands/getex>).+--+-- /O(1)/+--+-- Since Redis 6.2.0+getex+ :: (RedisCtx m f)+ => ByteString+ -> m (f (Maybe ByteString))+getex key = getexOpts key defaultGetExOpts++-- |Returns the string value of a key after setting its expiration time (<https://redis.io/commands/getex>).+--+-- /O(1)/+--+-- Since Redis 6.2.0+getexOpts+ :: (RedisCtx m f)+ => ByteString+ -> GetExOpts+ -> m (f (Maybe ByteString))+getexOpts key GetExOpts{..} =+ sendRequest $ ["GETEX", key] ++ exArg ++ pxArg ++ exatArg ++ pxatArg ++ persistArg+ where+ exArg = maybe [] (\seconds -> ["EX", encode seconds]) getExSeconds+ pxArg = maybe [] (\milliseconds -> ["PX", encode milliseconds]) getExMilliseconds+ exatArg = maybe [] (\seconds -> ["EXAT", encode seconds]) getExUnixSeconds+ pxatArg = maybe [] (\milliseconds -> ["PXAT", encode milliseconds]) getExUnixMilliseconds+ persistArg = ["PERSIST" | getExPersist]++data HGetExOpts = HGetExOpts+ { hGetExSeconds :: Maybe Integer+ , hGetExMilliseconds :: Maybe Integer+ , hGetExUnixSeconds :: Maybe Integer+ , hGetExUnixMilliseconds :: Maybe Integer+ , hGetExPersist :: Bool+ } deriving (Show, Eq)++defaultHGetExOpts :: HGetExOpts+defaultHGetExOpts = HGetExOpts+ { hGetExSeconds = Nothing+ , hGetExMilliseconds = Nothing+ , hGetExUnixSeconds = Nothing+ , hGetExUnixMilliseconds = Nothing+ , hGetExPersist = False+ }++-- |Returns the values associated with the specified fields in a hash and optionally updates the key expiration (<https://redis.io/commands/hgetex>).+--+-- /O(N)/ where /N/ is the number of specified fields.+--+-- Since Redis 8.0.0+hgetex+ :: (RedisCtx m f)+ => ByteString+ -> NonEmpty ByteString+ -> m (f [Maybe ByteString])+hgetex key fields = hgetexOpts key fields defaultHGetExOpts++-- |Returns the values associated with the specified fields in a hash and optionally updates the key expiration (<https://redis.io/commands/hgetex>).+--+-- /O(N)/ where /N/ is the number of specified fields.+--+-- Since Redis 8.0.0+hgetexOpts+ :: (RedisCtx m f)+ => ByteString+ -> NonEmpty ByteString+ -> HGetExOpts+ -> m (f [Maybe ByteString])+hgetexOpts key fields HGetExOpts{..} =+ sendRequest $ ["HGETEX", key] ++ exArg ++ pxArg ++ exatArg ++ pxatArg ++ persistArg ++ hashFieldArgs fields+ where+ exArg = maybe [] (\seconds -> ["EX", encode seconds]) hGetExSeconds+ pxArg = maybe [] (\milliseconds -> ["PX", encode milliseconds]) hGetExMilliseconds+ exatArg = maybe [] (\seconds -> ["EXAT", encode seconds]) hGetExUnixSeconds+ pxatArg = maybe [] (\milliseconds -> ["PXAT", encode milliseconds]) hGetExUnixMilliseconds+ persistArg = ["PERSIST" | hGetExPersist]++-- |Returns the values associated with the specified fields in a hash and deletes those fields (<https://redis.io/commands/hgetdel>).+--+-- /O(N)/ where /N/ is the number of specified fields.+--+-- Since Redis 8.0.0+hgetdel+ :: (RedisCtx m f)+ => ByteString+ -> NonEmpty ByteString+ -> m (f [Maybe ByteString])+hgetdel key fields =+ sendRequest $ ["HGETDEL", key] ++ hashFieldArgs fields++data HSetExCondition = HSetExFnx | HSetExFxx deriving (Show, Eq)++instance RedisArg HSetExCondition where+ encode HSetExFnx = "FNX"+ encode HSetExFxx = "FXX"++data HSetExOpts = HSetExOpts+ { hSetExSeconds :: Maybe Integer+ , hSetExMilliseconds :: Maybe Integer+ , hSetExUnixSeconds :: Maybe Integer+ , hSetExUnixMilliseconds :: Maybe Integer+ , hSetExCondition :: Maybe HSetExCondition+ , hSetExKeepTTL :: Bool+ } deriving (Show, Eq)++defaultHSetExOpts :: HSetExOpts+defaultHSetExOpts = HSetExOpts+ { hSetExSeconds = Nothing+ , hSetExMilliseconds = Nothing+ , hSetExUnixSeconds = Nothing+ , hSetExUnixMilliseconds = Nothing+ , hSetExCondition = Nothing+ , hSetExKeepTTL = False+ }++-- |Sets fields in a hash and optionally updates the key expiration (<https://redis.io/commands/hsetex>).+--+-- /O(N)/ where /N/ is the number of fields set.+--+-- Since Redis 8.0.0+hsetex+ :: (RedisCtx m f)+ => ByteString+ -> NonEmpty (ByteString, ByteString)+ -> m (f Bool)+hsetex key fieldValues = hsetexOpts key fieldValues defaultHSetExOpts++-- |Sets fields in a hash and optionally updates the key expiration (<https://redis.io/commands/hsetex>).+--+-- /O(N)/ where /N/ is the number of fields set.+--+-- Since Redis 8.0.0+hsetexOpts+ :: (RedisCtx m f)+ => ByteString+ -> NonEmpty (ByteString, ByteString)+ -> HSetExOpts+ -> m (f Bool)+hsetexOpts key fieldValues HSetExOpts{..} =+ sendRequest $ ["HSETEX", key] ++ conditionArg ++ exArg ++ pxArg ++ exatArg ++ pxatArg ++ keepTTLArg ++ ["FIELDS", encode (toInteger $ NE.length fieldValues)] ++ concatMap (\(field, value) -> [field, value]) (NE.toList fieldValues)+ where+ conditionArg = maybe [] (\condition -> [encode condition]) hSetExCondition+ exArg = maybe [] (\seconds -> ["EX", encode seconds]) hSetExSeconds+ pxArg = maybe [] (\milliseconds -> ["PX", encode milliseconds]) hSetExMilliseconds+ exatArg = maybe [] (\seconds -> ["EXAT", encode seconds]) hSetExUnixSeconds+ pxatArg = maybe [] (\milliseconds -> ["PXAT", encode milliseconds]) hSetExUnixMilliseconds+ keepTTLArg = ["KEEPTTL" | hSetExKeepTTL]++data HashFieldExpirationStatus+ = HashFieldExpirationNoSuchField+ | HashFieldExpirationConditionNotMet+ | HashFieldExpirationSet+ | HashFieldExpirationDeleted+ deriving (Show, Eq)++instance RedisResult HashFieldExpirationStatus where+ decode r = do+ value <- decode r :: Either Reply Integer+ case value of+ -2 -> Right HashFieldExpirationNoSuchField+ 0 -> Right HashFieldExpirationConditionNotMet+ 1 -> Right HashFieldExpirationSet+ 2 -> Right HashFieldExpirationDeleted+ _ -> Left r++data HashFieldExpirationInfo+ = HashFieldExpirationInfoNoSuchField+ | HashFieldExpirationInfoNoExpiration+ | HashFieldExpirationInfo Integer+ deriving (Show, Eq)++instance RedisResult HashFieldExpirationInfo where+ decode r = do+ value <- decode r :: Either Reply Integer+ case value of+ -2 -> Right HashFieldExpirationInfoNoSuchField+ -1 -> Right HashFieldExpirationInfoNoExpiration+ n -> Right (HashFieldExpirationInfo n)++hashFieldExpirationOptsToArgs :: ExpireOpts -> [ByteString]+hashFieldExpirationOptsToArgs opts =+ [encode opts]++hashFieldArgs :: NonEmpty ByteString -> [ByteString]+hashFieldArgs fields =+ ["FIELDS", encode (toInteger $ NE.length fields)] ++ NE.toList fields++-- |Sets expiration for hash fields using relative time to expire in seconds (<https://redis.io/commands/hexpire>).+--+-- /O(N)/ where /N/ is the number of specified fields.+--+-- Set an expiration (TTL or time to live) on one or more fields of a given hash key. You must specify at least one field. Field(s) will automatically be deleted from the hash key when their TTLs expire.+--+-- Field expirations will only be cleared by commands that delete or overwrite the contents of the hash fields, including HDEL and HSET commands. This means that all the operations that conceptually alter the value stored at a hash key's field without replacing it with a new one will leave the TTL untouched.+--+-- You can clear the TTL using the 'hpersist' command, which turns the hash field back into a persistent field.+--+-- Note that calling 'hexpire'/'hpexpire' with a zero TTL or 'hexpireat'/'hpexpireat' with a time in the past will result in the hash field being deleted.+--+-- Since Redis 7.4.0+hexpire+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the hash.+ -> Integer -- ^ Seconds until expiration.+ -> NonEmpty ByteString -- ^ List of fields to set expiration for.+ -> m (f [HashFieldExpirationStatus])+hexpire key seconds fields =+ sendRequest $ ["HEXPIRE", key, encode seconds] ++ hashFieldArgs fields++-- |Sets expiration for hash fields using relative time to expire in seconds (<https://redis.io/commands/hexpire>).+--+-- /O(N)/ where /N/ is the number of specified fields.+--+-- Since Redis 7.4.0+hexpireOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the hash.+ -> Integer -- ^ Seconds until expiration.+ -> NonEmpty ByteString -- ^ List of fields to set expiration for.+ -> ExpireOpts -- ^ Expiration options.+ -> m (f [HashFieldExpirationStatus])+hexpireOpts key seconds fields opts =+ sendRequest $ ["HEXPIRE", key, encode seconds] ++ hashFieldExpirationOptsToArgs opts ++ hashFieldArgs fields++-- |Sets expiration for hash fields using relative time to expire in milliseconds (<https://redis.io/commands/hpexpire>).+--+-- /O(N)/ where /N/ is the number of specified fields.+--+-- Since Redis 7.4.0+hpexpire+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the hash.+ -> Integer -- ^ Milliseconds until expiration.+ -> NonEmpty ByteString -- ^ List of fields to set expiration for.+ -> m (f [HashFieldExpirationStatus])+hpexpire key milliseconds fields =+ sendRequest $ ["HPEXPIRE", key, encode milliseconds] ++ hashFieldArgs fields++-- |Sets expiration for hash fields using relative time to expire in milliseconds (<https://redis.io/commands/hpexpire>).+--+-- /O(N)/ where /N/ is the number of specified fields.+--+-- Since Redis 7.4.0+hpexpireOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the hash.+ -> Integer -- ^ Milliseconds until expiration.+ -> NonEmpty ByteString -- ^ List of fields to set expiration for.+ -> ExpireOpts -- ^ Expiration options.+ -> m (f [HashFieldExpirationStatus])+hpexpireOpts key milliseconds fields opts =+ sendRequest $ ["HPEXPIRE", key, encode milliseconds] ++ hashFieldExpirationOptsToArgs opts ++ hashFieldArgs fields++-- |Sets expiration for hash fields using an absolute Unix timestamp in seconds (<https://redis.io/commands/hexpireat>).+--+-- /O(N)/ where /N/ is the number of specified fields.+--+-- Since Redis 7.4.0+hexpireat+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the hash.+ -> Integer -- ^ Absolute Unix timestamp in seconds at which the hash fields will expire.+ -> NonEmpty ByteString -- ^ List of fields to set expiration for.+ -> m (f [HashFieldExpirationStatus])+hexpireat key unixTimeSeconds fields =+ sendRequest $ ["HEXPIREAT", key, encode unixTimeSeconds] ++ hashFieldArgs fields++-- |Sets expiration for hash fields using an absolute Unix timestamp in seconds (<https://redis.io/commands/hexpireat>).+--+-- /O(N)/ where /N/ is the number of specified fields.+--+-- Since Redis 7.4.0+hexpireatOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the hash.+ -> Integer -- ^ Absolute Unix timestamp in seconds at which the hash fields will expire.+ -> NonEmpty ByteString -- ^ List of fields to set expiration for.+ -> ExpireOpts -- ^ Expiration options.+ -> m (f [HashFieldExpirationStatus])+hexpireatOpts key unixTimeSeconds fields opts =+ sendRequest $ ["HEXPIREAT", key, encode unixTimeSeconds] ++ hashFieldExpirationOptsToArgs opts ++ hashFieldArgs fields++-- |Sets expiration for hash fields using an absolute Unix timestamp in milliseconds (<https://redis.io/commands/hpexpireat>).+--+-- /O(N)/ where /N/ is the number of specified fields.+--+-- Since Redis 7.4.0+hpexpireat+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the hash.+ -> Integer -- ^ Absolute Unix timestamp in milliseconds at which the hash fields will expire.+ -> NonEmpty ByteString -- ^ List of fields to set expiration for.+ -> m (f [HashFieldExpirationStatus])+hpexpireat key unixTimeMilliseconds fields =+ sendRequest $ ["HPEXPIREAT", key, encode unixTimeMilliseconds] ++ hashFieldArgs fields++-- |Sets expiration for hash fields using an absolute Unix timestamp in milliseconds (<https://redis.io/commands/hpexpireat>).+--+-- /O(N)/ where /N/ is the number of specified fields.+--+-- Since Redis 7.4.0+hpexpireatOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the hash.+ -> Integer -- ^ Absolute Unix timestamp in milliseconds at which the hash fields will expire.+ -> NonEmpty ByteString -- ^ List of fields to set expiration for.+ -> ExpireOpts -- ^ Expiration options.+ -> m (f [HashFieldExpirationStatus])+hpexpireatOpts key unixTimeMilliseconds fields opts =+ sendRequest $ ["HPEXPIREAT", key, encode unixTimeMilliseconds] ++ hashFieldExpirationOptsToArgs opts ++ hashFieldArgs fields++-- |Returns the TTL in seconds of hash fields (<https://redis.io/commands/httl>).+--+-- /O(N)/ where /N/ is the number of specified fields.+--+-- Since Redis 7.4.0+httl+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the hash.+ -> NonEmpty ByteString -- ^ List of fields to get TTL for.+ -> m (f [HashFieldExpirationInfo])+httl key fields =+ sendRequest $ ["HTTL", key] ++ hashFieldArgs fields++-- |Returns the TTL in milliseconds of hash fields (<https://redis.io/commands/hpttl>).+--+-- /O(N)/ where /N/ is the number of specified fields.+--+-- Since Redis 7.4.0+hpttl+ :: (RedisCtx m f)+ => ByteString+ -> NonEmpty ByteString+ -> m (f [HashFieldExpirationInfo])+hpttl key fields =+ sendRequest $ ["HPTTL", key] ++ hashFieldArgs fields++-- |Returns the expiration time of hash fields as a Unix timestamp in seconds (<https://redis.io/commands/hexpiretime>).+--+-- /O(N)/ where /N/ is the number of specified fields.+--+-- Since Redis 7.4.0+hexpiretime+ :: (RedisCtx m f)+ => ByteString+ -> NonEmpty ByteString+ -> m (f [HashFieldExpirationInfo])+hexpiretime key fields =+ sendRequest $ ["HEXPIRETIME", key] ++ hashFieldArgs fields++-- |Returns the expiration time of hash fields as a Unix timestamp in milliseconds (<https://redis.io/commands/hpexpiretime>).+--+-- /O(N)/ where /N/ is the number of specified fields.+--+-- Since Redis 7.4.0+hpexpiretime+ :: (RedisCtx m f)+ => ByteString+ -> NonEmpty ByteString+ -> m (f [HashFieldExpirationInfo])+hpexpiretime key fields =+ sendRequest $ ["HPEXPIRETIME", key] ++ hashFieldArgs fields+++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+-- , zaddSizeCondition = Nothing -- omit GT and LT options+-- }+-- @+--+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]++-- |Resumes processing commands from paused clients (<https://redis.io/commands/client-unpause>).+--+-- /O(N)/ where /N/ is the number of paused clients.+--+-- Since Redis 6.2.0+clientUnpause+ :: (RedisCtx m f)+ => m (f Status)+clientUnpause = sendRequest ["CLIENT", "UNPAUSE"]++-- | The CLIENT NO-TOUCH command controls whether commands sent by the client will alter the LRU/LFU of the keys they access (<https://redis.io/commands/client-notouch>).+--+-- When turned on, the current client will not change LFU/LRU stats, unless it sends the TOUCH command.+--+-- When turned off, the client touches LFU/LRU stats just as a normal client.+--+-- /O(1)/+--+-- Since Redis 7.2.0+clientNoTouch+ :: (RedisCtx m f)+ => Bool+ -> m (f Status)+clientNoTouch flag = sendRequest ["CLIENT NO-TOUCH", encodedFlag] where+ encodedFlag = if flag then "ON" else "OFF"++data ClientSetInfoOpts+ = ClientSetInfoLibName ByteString+ | ClientSetInfoLibVer ByteString+ deriving (Show, Eq)++-- | The CLIENT SETINFO command assigns various info attributes to the current connection which are displayed in the output of CLIENT LIST and CLIENT INFO (<https://redis.io/commands/client-setinfo>).+--+-- /O(1)/+--+-- Since Redis 7.2.0+clientSetinfo+ :: (RedisCtx m f)+ => ClientSetInfoOpts+ -> m (f Status)+clientSetinfo info_ = sendRequest $ "CLIENT": "SETINFO": clientSetInfoArg+ where+ clientSetInfoArg = case info_ of+ ClientSetInfoLibName s -> ["LIB-NAME", encode s]+ ClientSetInfoLibVer s -> ["LIB-VER", encode s]++-- |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]++-- |Determines whether multiple members belong to a set (<https://redis.io/commands/smismember>).+--+-- /O(N)/ where /N/ is the number of elements being checked for membership.+--+-- Since Redis 6.2.0+smismember+ :: (RedisCtx m f)+ => ByteString+ -> NonEmpty ByteString+ -> m (f [Bool])+smismember key (member:|members) = sendRequest ("SMISMEMBER" : key : member : members)++data SintercardOpts = SintercardOpts+ { sintercardLimit :: Maybe Integer+ } deriving (Show, Eq)++defaultSintercardOpts :: SintercardOpts+defaultSintercardOpts = SintercardOpts+ { sintercardLimit = Nothing+ }++-- |Returns the cardinality of the intersection of multiple sets (<https://redis.io/commands/sintercard>).+--+-- /O(N*M)/ worst case where /N/ is the cardinality of the smallest set and /M/ is the number of sets.+--+-- In clustered environment, commands must operate on keys within the same hash slot.+--+-- Since Redis 7.0.0+sintercard+ :: (RedisCtx m f)+ => NonEmpty ByteString+ -> m (f Integer)+sintercard keys = sintercardOpts keys defaultSintercardOpts++-- |Returns the cardinality of the intersection of multiple sets (<https://redis.io/commands/sintercard>).+--+-- /O(N*M)/ worst case where /N/ is the cardinality of the smallest set and /M/ is the number of sets.+--+-- In clustered environment, commands must operate on keys within the same hash slot.+--+-- Since Redis 7.0.0+sintercardOpts+ :: (RedisCtx m f)+ => NonEmpty ByteString+ -> SintercardOpts+ -> m (f Integer)+sintercardOpts keys SintercardOpts{..} =+ sendRequest $ ["SINTERCARD", encode (toInteger $ NE.length keys)] ++ NE.toList keys ++ limitArg+ where+ limitArg = maybe [] (\limit -> ["LIMIT", encode limit]) sintercardLimit++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++-- |Returns a random field from a hash (<https://redis.io/commands/hrandfield>).+--+-- /O(1)/+--+-- Since Redis 6.2.0+hrandfield+ :: (RedisCtx m f)+ => ByteString+ -> m (f (Maybe ByteString))+hrandfield key = sendRequest ["HRANDFIELD", key]++-- |Returns one or more random fields from a hash (<https://redis.io/commands/hrandfield>).+--+-- /O(N)/ where /N/ is the number of fields returned.+--+-- If the provided count argument is positive, return an array of distinct fields. The array's length is either count or the hash's number of fields (HLEN), whichever is lower.+--+-- If called with a negative count, the behavior changes and the command is allowed to return the same field multiple times. In this case, the number of returned fields is the absolute value of the specified count.+--+-- Since Redis 6.2.0+hrandfieldCount+ :: (RedisCtx m f)+ => ByteString+ -> Integer+ -> m (f [ByteString])+hrandfieldCount key count = sendRequest ["HRANDFIELD", key, encode count]++-- |Returns one or more random fields and their values from a hash (<https://redis.io/commands/hrandfield>).+--+-- /O(N)/ where /N/ is the number of fields returned.+--+-- If the provided count argument is positive, return an array of distinct fields. The array's length is either count or the hash's number of fields (HLEN), whichever is lower.+--+-- If called with a negative count, the behavior changes and the command is allowed to return the same field multiple times. In this case, the number of returned fields is the absolute value of the specified count.+--+-- Since Redis 6.2.0+hrandfieldCountWithValues+ :: (RedisCtx m f)+ => ByteString+ -> Integer+ -> m (f [(ByteString, ByteString)])+hrandfieldCountWithValues key count =+ sendRequest ["HRANDFIELD", key, encode count, "WITHVALUES"]+++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 deriving (Show, Eq)++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]++data ZPopMinMax = ZPopMin | ZPopMax deriving (Show, Eq)++instance RedisArg ZPopMinMax where+ encode ZPopMin = "MIN"+ encode ZPopMax = "MAX"++data ZPopResponse = ZPopResponse+ { zPopResponseKey :: Maybe ByteString+ , zPopResponseValues :: [(ByteString, Double)]+ } deriving (Show, Eq)++instance RedisResult ZPopResponse where+ decode (MultiBulk (Just [Bulk (Just key), MultiBulk (Just values)])) =+ ZPopResponse (Just key) <$> mapM decode values+ decode r = Left r++-- |Removes and returns member-score pairs from the first non-empty sorted set from a list of keys (<https://redis.io/commands/zmpop>).+--+-- /O(K) + O(M\log(N))/ where /K/ is the number of provided keys, /N/ is the number of elements in the sorted set, and /M/ is the number of elements popped.+--+-- In clustered environment, commands must operate on keys within the same hash slot.+--+-- Since Redis 7.0.0+zmpop+ :: (RedisCtx m f)+ => NonEmpty ByteString+ -> ZPopMinMax+ -> m (f (Maybe ZPopResponse))+zmpop keys where_ = zmpopCount keys where_ 1++-- |Removes and returns member-score pairs from the first non-empty sorted set from a list of keys (<https://redis.io/commands/zmpop>).+--+-- /O(K) + O(M\log(N))/ where /K/ is the number of provided keys, /N/ is the number of elements in the sorted set, and /M/ is the number of elements popped.+--+-- In clustered environment, commands must operate on keys within the same hash slot.+--+-- Since Redis 7.0.0+zmpopCount+ :: (RedisCtx m f)+ => NonEmpty ByteString+ -> ZPopMinMax+ -> Integer+ -> m (f (Maybe ZPopResponse))+zmpopCount keys where_ count =+ sendRequest $ ["ZMPOP", encode (toInteger $ NE.length keys)] ++ NE.toList keys ++ [encode where_, "COUNT", encode count]++-- |Removes and returns member-score pairs from the first non-empty sorted set from a list of keys, or blocks until one is available (<https://redis.io/commands/bzmpop>).+--+-- /O(K) + O(M\log(N))/ where /K/ is the number of provided keys, /N/ is the number of elements in the sorted set, and /M/ is the number of elements popped.+--+-- In clustered environment, commands must operate on keys within the same hash slot.+--+-- Since Redis 7.0.0+bzmpop+ :: (RedisCtx m f)+ => Double+ -> NonEmpty ByteString+ -> ZPopMinMax+ -> m (f (Maybe ZPopResponse))+bzmpop timeout keys where_ = bzmpopCount timeout keys where_ 1++-- |Removes and returns member-score pairs from the first non-empty sorted set from a list of keys, or blocks until one is available (<https://redis.io/commands/bzmpop>).+--+-- /O(K) + O(M\log(N))/ where /K/ is the number of provided keys, /N/ is the number of elements in the sorted set, and /M/ is the number of elements popped.+--+-- In clustered environment, commands must operate on keys within the same hash slot.+--+-- Since Redis 7.0.0+bzmpopCount+ :: (RedisCtx m f)+ => Double+ -> NonEmpty ByteString+ -> ZPopMinMax+ -> Integer+ -> m (f (Maybe ZPopResponse))+bzmpopCount timeout keys where_ count =+ sendRequest $ ["BZMPOP", encode timeout, encode (toInteger $ NE.length keys)] ++ NE.toList keys ++ [encode where_, "COUNT", encode count]++-- |Returns the score of one or more members in a sorted set (<https://redis.io/commands/zmscore>).+--+-- /O(N)/ where /N/ is the number of members being requested.+--+-- Since Redis 6.2.0+zmscore+ :: (RedisCtx m f)+ => ByteString+ -> NonEmpty ByteString+ -> m (f [Maybe Double])+zmscore key (member:|members) = sendRequest ("ZMSCORE" : key : member : members)++-- |Returns a random member from a sorted set (<https://redis.io/commands/zrandmember>).+--+-- /O(1)/ without the optional count argument.+--+-- Since Redis 6.2.0+zrandmember+ :: (RedisCtx m f)+ => ByteString+ -> m (f (Maybe ByteString))+zrandmember key = sendRequest ["ZRANDMEMBER", key]++-- |Returns one or more random members from a sorted set (<https://redis.io/commands/zrandmember>).+--+-- /O(N)/ where /N/ is the number of members returned.+--+-- Since Redis 6.2.0+zrandmemberN+ :: (RedisCtx m f)+ => ByteString+ -> Integer+ -> m (f [ByteString])+zrandmemberN key count = sendRequest ["ZRANDMEMBER", key, encode count]++-- |Returns one or more random members and their scores from a sorted set (<https://redis.io/commands/zrandmember>).+--+-- /O(N)/ where /N/ is the number of members returned.+--+-- Since Redis 6.2.0+zrandmemberWithscores+ :: (RedisCtx m f)+ => ByteString+ -> Integer+ -> m (f [(ByteString, Double)])+zrandmemberWithscores key count =+ sendRequest ["ZRANDMEMBER", key, encode count, "WITHSCORES"]++data ZRangeStoreRange+ = ZRangeStoreByIndex Integer Integer+ | ZRangeStoreByScore Double Double+ | ZRangeStoreByLex (RangeLex ByteString) (RangeLex ByteString)+ deriving (Show, Eq)++data ZRangeStoreOpts = ZRangeStoreOpts+ { zRangeStoreRev :: Bool+ , zRangeStoreLimit :: Maybe (Integer, Integer)+ } deriving (Show, Eq)++defaultZRangeStoreOpts :: ZRangeStoreOpts+defaultZRangeStoreOpts = ZRangeStoreOpts+ { zRangeStoreRev = False+ , zRangeStoreLimit = Nothing+ }++-- |Stores a range of members from a sorted set in a destination key (<https://redis.io/commands/zrangestore>).+--+-- /O(\log(N) + M)/ with /N/ being the number of elements in the sorted set and /M/ the number of elements stored into the destination key.+--+-- Since Redis 6.2.0+zrangestore+ :: (RedisCtx m f)+ => ByteString+ -> ByteString+ -> Integer+ -> Integer+ -> m (f Integer)+zrangestore destination source start stop =+ zrangestoreOpts destination source (ZRangeStoreByIndex start stop) defaultZRangeStoreOpts++-- |Stores a range of members from a sorted set in a destination key (<https://redis.io/commands/zrangestore>).+--+-- /O(\log(N) + M)/ with /N/ being the number of elements in the sorted set and /M/ the number of elements stored into the destination key.+--+-- Since Redis 6.2.0+zrangestoreOpts+ :: (RedisCtx m f)+ => ByteString+ -> ByteString+ -> ZRangeStoreRange+ -> ZRangeStoreOpts+ -> m (f Integer)+zrangestoreOpts destination source range opts =+ sendRequest $ ["ZRANGESTORE", destination, source] ++ zRangeStoreRangeArgs range ++ zRangeStoreOptsArgs opts++zRangeStoreRangeArgs :: ZRangeStoreRange -> [ByteString]+zRangeStoreRangeArgs range = case range of+ ZRangeStoreByIndex start stop ->+ [encode start, encode stop]+ ZRangeStoreByScore minScore maxScore ->+ [encode minScore, encode maxScore, "BYSCORE"]+ ZRangeStoreByLex minMember maxMember ->+ [encode minMember, encode maxMember, "BYLEX"]++zRangeStoreOptsArgs :: ZRangeStoreOpts -> [ByteString]+zRangeStoreOptsArgs ZRangeStoreOpts{..} =+ revArg ++ limitArg+ where+ revArg = ["REV" | zRangeStoreRev]+ limitArg = maybe [] (\(offset, count) -> ["LIMIT", encode offset, encode count]) zRangeStoreLimit++-- | 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++-- |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+ :: (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++-- |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+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]++data XRefPolicy+ = XRefPolicyKeepRef -- ^ Deletes the specified entries from the stream, but preserves existing references to these entries in all consumer groups+ | XRefPolicyDelRef -- ^ Deletes the specified entries from the stream and also removes all references to these entries from all consumer groups' pending entry lists, effectively cleaning up all traces of the messages. If an entry ID is not in the stream, but there are dangling references, XDELEX with DELREF would still remove all those references.+ | XRefPolicyAcked -- ^ Deletes the specified entries from the stream only if they have been acknowledged by all consumer groups.+ deriving (Show, Eq)++instance RedisArg XRefPolicy where+ encode XRefPolicyKeepRef = "KEEPREF"+ encode XRefPolicyDelRef = "DELREF"+ encode XRefPolicyAcked = "ACKED"++data XEntryDeletionOpts = XEntryDeletionOpts+ { xEntryDeletionRefPolicy :: XRefPolicy+ } deriving (Show, Eq)++defaultXEntryDeletionOpts :: XEntryDeletionOpts+defaultXEntryDeletionOpts = XEntryDeletionOpts+ { xEntryDeletionRefPolicy = XRefPolicyKeepRef+ }++data XCfgSetOpts = XCfgSetOpts+ { xCfgSetIdmpDuration :: Maybe Integer+ -- ^ The duration in seconds that each idempotent ID is retained.+ , xCfgSetIdmpMaxsize :: Maybe Integer+ -- ^ The maximum number of idempotent IDs tracked per producer.+ } deriving (Show, Eq)++-- |Redis default 'XCfgSetOpts'. Equivalent to omitting all optional parameters.+--+-- At least one field must be set before calling 'xcfgset'.+defaultXCfgSetOpts :: XCfgSetOpts+defaultXCfgSetOpts = XCfgSetOpts+ { xCfgSetIdmpDuration = Nothing+ , xCfgSetIdmpMaxsize = Nothing+ }++data XNackMode+ = XNackSilent+ | XNackFail+ | XNackFatal+ deriving (Show, Eq)++instance RedisArg XNackMode where+ encode XNackSilent = "SILENT"+ encode XNackFail = "FAIL"+ encode XNackFatal = "FATAL"++data XNackOpts = XNackOpts+ { xNackRetryCount :: Maybe Integer+ , xNackForce :: Bool+ } deriving (Show, Eq)++-- |Redis default 'XNackOpts'. Equivalent to omitting all optional parameters.+defaultXNackOpts :: XNackOpts+defaultXNackOpts = XNackOpts+ { xNackRetryCount = Nothing+ , xNackForce = False+ }++data XEntryDeletionResult+ = XEntryDeletionResultNotFound+ | XEntryDeletionResultDeleted+ | XEntryDeletionResultNotDeleted+ deriving (Show, Eq)++instance RedisResult XEntryDeletionResult where+ decode r = do+ result <- decode r :: Either Reply Integer+ case result of+ -1 -> Right XEntryDeletionResultNotFound+ 1 -> Right XEntryDeletionResultDeleted+ 2 -> Right XEntryDeletionResultNotDeleted+ _ -> Left r++xEntryDeletionOptsToArgs :: XEntryDeletionOpts -> [ByteString]+xEntryDeletionOptsToArgs XEntryDeletionOpts{..} =+ [encode xEntryDeletionRefPolicy]++xEntryIdsBlockArgs :: NonEmpty ByteString -> [ByteString]+xEntryIdsBlockArgs messageIds =+ ["IDS", encode (toInteger $ NE.length messageIds)] ++ NE.toList messageIds++xack+ :: (RedisCtx m f)+ => ByteString -- ^ stream+ -> ByteString -- ^ group name+ -> [ByteString] -- ^ message IDs+ -> m (f Integer)+xack stream groupName messageIds = sendRequest $ ["XACK", stream, groupName] ++ messageIds++-- |Acknowledges and conditionally deletes entries for a consumer group (<https://redis.io/commands/xackdel>).+--+-- /O(1)/ for each entry ID processed.+--+-- Since Redis 8.2.0+xackdel+ :: (RedisCtx m f)+ => ByteString -- ^ Stream name.+ -> ByteString -- ^ Consumer group name.+ -> NonEmpty ByteString -- ^ Entry IDs.+ -> m (f [XEntryDeletionResult])+xackdel stream groupName messageIds =+ xackdelOpts stream groupName messageIds defaultXEntryDeletionOpts++-- |Acknowledges and conditionally deletes entries for a consumer group (<https://redis.io/commands/xackdel>).+--+-- /O(1)/ for each entry ID processed.+--+-- Since Redis 8.2.0+xackdelOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Stream name.+ -> ByteString -- ^ Consumer group name.+ -> NonEmpty ByteString -- ^ Entry IDs.+ -> XEntryDeletionOpts -- ^ Additional options.+ -> m (f [XEntryDeletionResult])+xackdelOpts stream groupName messageIds opts =+ sendRequest $ ["XACKDEL", stream, groupName]+ ++ xEntryDeletionOptsToArgs opts+ ++ xEntryIdsBlockArgs 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)++-- |Conditionally deletes entries from a stream (<https://redis.io/commands/xdelex>).+--+-- /O(1)/ for each entry ID processed.+--+-- Since Redis 8.2.0+xdelex+ :: (RedisCtx m f)+ => ByteString -- ^ Stream name.+ -> NonEmpty ByteString -- ^ Entry IDs.+ -> m (f [XEntryDeletionResult])+xdelex stream messageIds =+ xdelexOpts stream messageIds defaultXEntryDeletionOpts++-- |Conditionally deletes entries from a stream (<https://redis.io/commands/xdelex>).+--+-- /O(1)/ for each entry ID processed.+--+-- Since Redis 8.2.0+xdelexOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Stream name.+ -> NonEmpty ByteString -- ^ Entry IDs.+ -> XEntryDeletionOpts -- ^ Additional options.+ -> m (f [XEntryDeletionResult])+xdelexOpts stream messageIds opts =+ sendRequest $ ["XDELEX", stream]+ ++ xEntryDeletionOptsToArgs opts+ ++ xEntryIdsBlockArgs messageIds++-- |Sets the IDMP configuration parameters for a stream (<https://redis.io/commands/xcfgset>).+--+-- /O(1)/+--+-- Since Redis 8.6.0+xcfgset+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the stream key. The stream must already exist.+ -> XCfgSetOpts+ {- ^ Configuration parameters.++ At least one of `xCfgSetIdmpDuration` or `xCfgSetIdmpMaxsize` must be specified.+ Calling `XCFGSET` clears all existing producer IDMP maps for the stream.+ -}+ -> m (f Status)+xcfgset key XCfgSetOpts{..} =+ sendRequest $+ ["XCFGSET", key]+ ++ maybe [] (\duration -> ["IDMP-DURATION", encode duration]) xCfgSetIdmpDuration+ ++ maybe [] (\maxsize -> ["IDMP-MAXSIZE", encode maxsize]) xCfgSetIdmpMaxsize++-- |Sets IDMP metadata on an existing stream message (<https://redis.io/commands/xidmprecord>).+--+-- This is an internal command used during AOF loading.+--+-- /O(1)/+--+-- Since Redis 8.6.2+xidmprecord+ :: (RedisCtx m f)+ => ByteString -- ^ Stream key.+ -> ByteString -- ^ Producer ID.+ -> ByteString -- ^ Idempotency ID.+ -> ByteString -- ^ Existing stream entry ID.+ -> m (f Status)+xidmprecord key producerId idempotencyId streamId =+ sendRequest ["XIDMPRECORD", key, producerId, idempotencyId, streamId]++-- |Releases claimed messages back to the group's PEL without acknowledging them (<https://redis.io/commands/xnack>).+--+-- /O(1)/ for each message ID processed.+--+-- Since Redis 8.8.0+xnack+ :: (RedisCtx m f)+ => ByteString -- ^ Stream key.+ -> ByteString -- ^ Consumer group name.+ -> XNackMode -- ^ Release strategy.+ -> NonEmpty ByteString -- ^ Stream entry IDs.+ -> m (f Integer)+xnack key groupName mode messageIds =+ xnackOpts key groupName mode messageIds defaultXNackOpts++-- |Releases claimed messages back to the group's PEL without acknowledging them (<https://redis.io/commands/xnack>).+--+-- /O(1)/ for each message ID processed.+--+-- Since Redis 8.8.0+xnackOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Stream key.+ -> ByteString -- ^ Consumer group name.+ -> XNackMode -- ^ Release strategy.+ -> NonEmpty ByteString -- ^ Stream entry IDs.+ -> XNackOpts -- ^ Additional options.+ -> m (f Integer)+xnackOpts key groupName mode messageIds XNackOpts{..} =+ sendRequest $+ ["XNACK", key, groupName, encode mode]+ ++ xEntryIdsBlockArgs messageIds+ ++ maybe [] (\retryCount -> ["RETRYCOUNT", encode retryCount]) xNackRetryCount+ ++ ["FORCE" | xNackForce]++-- |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"]++-- |Returns the shard ID of a node (<https://redis.io/commands/cluster-myshardid>).+--+-- /O(1)/+--+-- Since Redis 7.2.0+clusterMyshardid+ :: (RedisCtx m f)+ => m (f ByteString)+clusterMyshardid = sendRequest ["CLUSTER", "MYSHARDID"]++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"]++data ClusterSlotStatsMetric+ = ClusterSlotStatsKeyCount+ | ClusterSlotStatsCpuUsec+ | ClusterSlotStatsMemoryBytes+ | ClusterSlotStatsNetworkBytesIn+ | ClusterSlotStatsNetworkBytesOut+ deriving (Show, Eq)++instance RedisArg ClusterSlotStatsMetric where+ encode ClusterSlotStatsKeyCount = "KEY-COUNT"+ encode ClusterSlotStatsCpuUsec = "CPU-USEC"+ encode ClusterSlotStatsMemoryBytes = "MEMORY-BYTES"+ encode ClusterSlotStatsNetworkBytesIn = "NETWORK-BYTES-IN"+ encode ClusterSlotStatsNetworkBytesOut = "NETWORK-BYTES-OUT"++data ClusterSlotStatsOrderByOpts = ClusterSlotStatsOrderByOpts+ { clusterSlotStatsOrderByLimit :: Maybe Integer+ , clusterSlotStatsOrderByDirection :: SortOrder+ } deriving (Show, Eq)++defaultClusterSlotStatsOrderByOpts :: ClusterSlotStatsOrderByOpts+defaultClusterSlotStatsOrderByOpts = ClusterSlotStatsOrderByOpts+ { clusterSlotStatsOrderByLimit = Nothing+ , clusterSlotStatsOrderByDirection = Desc+ }++data ClusterSlotStatsQuery+ = ClusterSlotStatsSlotsRange Integer Integer+ | ClusterSlotStatsOrderBy ClusterSlotStatsMetric ClusterSlotStatsOrderByOpts+ deriving (Show, Eq)++data ClusterSlotStatsResponse = ClusterSlotStatsResponse+ { clusterSlotStatsResponseEntries :: [ClusterSlotStatsResponseEntry]+ } deriving (Show, Eq)++data ClusterSlotStatsResponseEntry = ClusterSlotStatsResponseEntry+ { clusterSlotStatsResponseEntrySlot :: Integer+ , clusterSlotStatsResponseEntryKeyCount :: Maybe Integer+ , clusterSlotStatsResponseEntryCpuUsec :: Maybe Integer+ , clusterSlotStatsResponseEntryMemoryBytes :: Maybe Integer+ , clusterSlotStatsResponseEntryNetworkBytesIn :: Maybe Integer+ , clusterSlotStatsResponseEntryNetworkBytesOut :: Maybe Integer+ } deriving (Show, Eq)++instance RedisResult ClusterSlotStatsResponse where+ decode (MultiBulk (Just entries)) =+ ClusterSlotStatsResponse <$> mapM decode entries+ decode r = Left r++instance RedisResult ClusterSlotStatsResponseEntry where+ decode r@(MultiBulk (Just entries)) =+ parseClusterSlotStatsEntry entries+ where+ parseClusterSlotStatsEntry :: [Reply] -> Either Reply ClusterSlotStatsResponseEntry+ parseClusterSlotStatsEntry ((Integer slot):statsReply:[]) =+ parseClusterSlotStatsFields slot =<< parseClusterSlotStatsMetricPairs statsReply+ parseClusterSlotStatsEntry fields =+ case parseClusterSlotStatsFieldPairs fields of+ Right kvs -> do+ slot <- maybe (Left r) Right (lookup "slot" kvs)+ parseClusterSlotStatsFields slot (filter ((/= "slot") . fst) kvs)+ Left _ -> Left r++ parseClusterSlotStatsMetricPairs :: Reply -> Either Reply [(ByteString, Integer)]+ parseClusterSlotStatsMetricPairs (MultiBulk (Just replies)) =+ case parseClusterSlotStatsFieldPairs replies of+ Right kvs -> Right kvs+ Left _ -> mapM parseNestedPair replies+ where+ parseNestedPair (MultiBulk (Just [keyReply, valueReply])) =+ (,) <$> decode keyReply <*> decode valueReply+ parseNestedPair nestedReply = Left nestedReply+ parseClusterSlotStatsMetricPairs reply' = Left reply'++ parseClusterSlotStatsFieldPairs :: [Reply] -> Either Reply [(ByteString, Integer)]+ parseClusterSlotStatsFieldPairs [] = Right []+ parseClusterSlotStatsFieldPairs (keyReply:valueReply:rest) =+ (:) <$> ((,) <$> decode keyReply <*> decode valueReply)+ <*> parseClusterSlotStatsFieldPairs rest+ parseClusterSlotStatsFieldPairs [badReply] = Left badReply++ parseClusterSlotStatsFields :: Integer -> [(ByteString, Integer)] -> Either Reply ClusterSlotStatsResponseEntry+ parseClusterSlotStatsFields slot fields =+ Right ClusterSlotStatsResponseEntry+ { clusterSlotStatsResponseEntrySlot = slot+ , clusterSlotStatsResponseEntryKeyCount = lookup "key-count" fields+ , clusterSlotStatsResponseEntryCpuUsec = lookup "cpu-usec" fields+ , clusterSlotStatsResponseEntryMemoryBytes = lookup "memory-bytes" fields+ , clusterSlotStatsResponseEntryNetworkBytesIn = lookup "network-bytes-in" fields+ , clusterSlotStatsResponseEntryNetworkBytesOut = lookup "network-bytes-out" fields+ }+ decode r = Left r++clusterSlotStats+ :: (RedisCtx m f)+ => ClusterSlotStatsQuery+ -> m (f ClusterSlotStatsResponse)+clusterSlotStats query = sendRequest $ ["CLUSTER", "SLOT-STATS"] ++ clusterSlotStatsQueryArgs query++clusterSlotStatsSlotsRange+ :: (RedisCtx m f)+ => Integer+ -> Integer+ -> m (f ClusterSlotStatsResponse)+clusterSlotStatsSlotsRange startSlot endSlot =+ clusterSlotStats (ClusterSlotStatsSlotsRange startSlot endSlot)++clusterSlotStatsOrderBy+ :: (RedisCtx m f)+ => ClusterSlotStatsMetric+ -> m (f ClusterSlotStatsResponse)+clusterSlotStatsOrderBy metric =+ clusterSlotStatsOrderByOpts metric defaultClusterSlotStatsOrderByOpts++clusterSlotStatsOrderByOpts+ :: (RedisCtx m f)+ => ClusterSlotStatsMetric+ -> ClusterSlotStatsOrderByOpts+ -> m (f ClusterSlotStatsResponse)+clusterSlotStatsOrderByOpts metric opts =+ clusterSlotStats (ClusterSlotStatsOrderBy metric opts)++clusterSlotStatsQueryArgs :: ClusterSlotStatsQuery -> [ByteString]+clusterSlotStatsQueryArgs query =+ case query of+ ClusterSlotStatsSlotsRange startSlot endSlot ->+ ["SLOTSRANGE", encode startSlot, encode endSlot]+ ClusterSlotStatsOrderBy metric ClusterSlotStatsOrderByOpts{..} ->+ ["ORDERBY", encode metric]+ ++ maybe [] (\limit -> ["LIMIT", encode limit]) clusterSlotStatsOrderByLimit+ ++ [case clusterSlotStatsOrderByDirection of+ Asc -> "ASC"+ Desc -> "DESC"+ ]++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)]++data ClusterMigrationSlotRange = ClusterMigrationSlotRange+ { clusterMigrationSlotRangeStart :: Integer+ , clusterMigrationSlotRangeEnd :: Integer+ } deriving (Show, Eq)++data ClusterMigrationTask = ClusterMigrationTask+ { clusterMigrationTaskId :: ByteString+ , clusterMigrationTaskSlots :: [ClusterMigrationSlotRange]+ , clusterMigrationTaskSource :: Maybe ByteString+ , clusterMigrationTaskDest :: Maybe ByteString+ , clusterMigrationTaskOperation :: Maybe ByteString+ , clusterMigrationTaskState :: Maybe ByteString+ , clusterMigrationTaskLastError :: Maybe ByteString+ , clusterMigrationTaskRetries :: Maybe Integer+ , clusterMigrationTaskCreateTime :: Maybe Integer+ , clusterMigrationTaskStartTime :: Maybe Integer+ , clusterMigrationTaskEndTime :: Maybe Integer+ , clusterMigrationTaskWritePauseMs :: Maybe Integer+ } deriving (Show, Eq)++newtype ClusterMigrationStatusResponse = ClusterMigrationStatusResponse+ { clusterMigrationStatusTasks :: [ClusterMigrationTask]+ } deriving (Show, Eq)++instance RedisResult ClusterMigrationStatusResponse where+ decode (MultiBulk (Just tasks)) =+ ClusterMigrationStatusResponse <$> mapM decode tasks+ decode r = Left r++instance RedisResult ClusterMigrationTask where+ decode r@(MultiBulk (Just replies)) = do+ pairs <- parsePairs replies+ clusterMigrationTaskId <- lookupRequired "id" pairs+ clusterMigrationTaskSlots <- maybe (Right []) parseSlotsReply (lookup "slots" pairs)+ let clusterMigrationTaskSource = lookupMaybeByteString "source" pairs+ let clusterMigrationTaskDest = lookupMaybeByteString "dest" pairs+ let clusterMigrationTaskOperation = lookupMaybeByteString "operation" pairs+ let clusterMigrationTaskState = lookupMaybeByteString "state" pairs+ let clusterMigrationTaskLastError = lookupMaybeByteString "last_error" pairs+ let clusterMigrationTaskRetries = lookupInteger "retries" pairs+ let clusterMigrationTaskCreateTime = lookupInteger "create_time" pairs+ let clusterMigrationTaskStartTime = lookupInteger "start_time" pairs+ let clusterMigrationTaskEndTime = lookupInteger "end_time" pairs+ let clusterMigrationTaskWritePauseMs = lookupInteger "write_pause_ms" pairs+ Right ClusterMigrationTask{..}+ where+ parsePairs :: [Reply] -> Either Reply [(ByteString, Reply)]+ parsePairs [] = Right []+ parsePairs (keyReply:valueReply:rest) =+ (:) <$> ((,) <$> decode keyReply <*> pure valueReply) <*> parsePairs rest+ parsePairs [nestedReply] =+ case nestedReply of+ MultiBulk (Just nestedReplies) -> parseNestedPairs nestedReplies+ _ -> Left nestedReply++ parseNestedPairs :: [Reply] -> Either Reply [(ByteString, Reply)]+ parseNestedPairs nestedReplies = mapM parseNestedPair nestedReplies++ parseNestedPair :: Reply -> Either Reply (ByteString, Reply)+ parseNestedPair (MultiBulk (Just [keyReply, valueReply])) =+ (,) <$> decode keyReply <*> pure valueReply+ parseNestedPair nestedReply = Left nestedReply++ lookupRequired :: RedisResult a => ByteString -> [(ByteString, Reply)] -> Either Reply a+ lookupRequired key pairs =+ maybe (Left r) decode (lookup key pairs)++ lookupMaybeByteString :: ByteString -> [(ByteString, Reply)] -> Maybe ByteString+ lookupMaybeByteString key pairs =+ case lookup key pairs of+ Just (Bulk (Just "")) -> Nothing+ Just valueReply -> either (const Nothing) id (decode valueReply)+ Nothing -> Nothing++ lookupInteger :: ByteString -> [(ByteString, Reply)] -> Maybe Integer+ lookupInteger key pairs =+ case lookup key pairs of+ Just valueReply -> either (const Nothing) Just (decode valueReply)+ Nothing -> Nothing++ parseSlotsReply :: Reply -> Either Reply [ClusterMigrationSlotRange]+ parseSlotsReply (Bulk (Just slotRanges)) =+ mapM parseSlotToken (Char8.words $ Char8.map normalizeDelimiter slotRanges)+ where+ normalizeDelimiter ',' = ' '+ normalizeDelimiter c = c+ parseSlotsReply (MultiBulk (Just slotReplies))+ | all isIntegerReply slotReplies = parseIntegerPairs slotReplies+ | otherwise = mapM parseNestedRange slotReplies+ where+ isIntegerReply (Integer _) = True+ isIntegerReply _ = False++ parseIntegerPairs :: [Reply] -> Either Reply [ClusterMigrationSlotRange]+ parseIntegerPairs [] = Right []+ parseIntegerPairs (Integer startSlot:Integer endSlot:rest) =+ (ClusterMigrationSlotRange startSlot endSlot :) <$> parseIntegerPairs rest+ parseIntegerPairs badReplies = Left $ MultiBulk (Just badReplies)++ parseNestedRange :: Reply -> Either Reply ClusterMigrationSlotRange+ parseNestedRange (MultiBulk (Just [Integer startSlot, Integer endSlot])) =+ Right $ ClusterMigrationSlotRange startSlot endSlot+ parseNestedRange nestedReply = Left nestedReply+ parseSlotsReply badReply = Left badReply++ parseSlotToken :: ByteString -> Either Reply ClusterMigrationSlotRange+ parseSlotToken token =+ case Char8.break (== '-') token of+ (startPart, endPart)+ | BS.null endPart -> do+ startSlot <- parseIntegerToken token+ Right $ ClusterMigrationSlotRange startSlot startSlot+ | otherwise -> do+ startSlot <- parseIntegerToken startPart+ endSlot <- parseIntegerToken (Char8.drop 1 endPart)+ Right $ ClusterMigrationSlotRange startSlot endSlot++ parseIntegerToken :: ByteString -> Either Reply Integer+ parseIntegerToken token =+ maybe (Left r) Right (fst <$> Char8.readInteger token)+ decode r = Left r++-- |Starts an atomic slot migration import task on the current node (<https://redis.io/commands/cluster-migration>).+--+-- /O(N)/ where /N/ is the total number of slots between the specified start and end slot arguments.+--+-- Since Redis 8.4.0+clusterMigrationImport+ :: (RedisCtx m f)+ => NonEmpty (Integer, Integer)+ {- ^ Slot ranges to import.++ Execute this subcommand on the destination master. It accepts multiple slot ranges and returns a task ID that can later be used to monitor the migration.+ -}+ -> m (f ByteString)+clusterMigrationImport slotRanges =+ sendRequest $ ["CLUSTER", "MIGRATION", "IMPORT"]+ ++ concatMap (\(startSlot, endSlot) -> [encode startSlot, encode endSlot]) (NE.toList slotRanges)++-- |Cancels an ongoing migration task by task ID (<https://redis.io/commands/cluster-migration>).+--+-- /O(N)/ where /N/ is the total number of slots between the specified start and end slot arguments.+--+-- Since Redis 8.4.0+clusterMigrationCancelId+ :: (RedisCtx m f)+ => ByteString -- ^ Task identifier.+ -> m (f Integer)+clusterMigrationCancelId taskId =+ sendRequest ["CLUSTER", "MIGRATION", "CANCEL", "ID", taskId]++-- |Cancels all ongoing migration tasks (<https://redis.io/commands/cluster-migration>).+--+-- /O(N)/ where /N/ is the total number of slots between the specified start and end slot arguments.+--+-- Since Redis 8.4.0+clusterMigrationCancelAll+ :: (RedisCtx m f)+ => m (f Integer)+clusterMigrationCancelAll =+ sendRequest ["CLUSTER", "MIGRATION", "CANCEL", "ALL"]++-- |Returns the status of current and completed atomic slot migration tasks (<https://redis.io/commands/cluster-migration>).+--+-- /O(N)/ where /N/ is the total number of slots between the specified start and end slot arguments.+--+-- Since Redis 8.4.0+clusterMigrationStatus+ :: (RedisCtx m f)+ => m (f ClusterMigrationStatusResponse)+clusterMigrationStatus =+ sendRequest ["CLUSTER", "MIGRATION", "STATUS"]++-- |Returns the status of all current and completed atomic slot migration tasks (<https://redis.io/commands/cluster-migration>).+--+-- /O(N)/ where /N/ is the total number of slots between the specified start and end slot arguments.+--+-- Since Redis 8.4.0+clusterMigrationStatusAll+ :: (RedisCtx m f)+ => m (f ClusterMigrationStatusResponse)+clusterMigrationStatusAll =+ sendRequest ["CLUSTER", "MIGRATION", "STATUS", "ALL"]++-- |Returns the status of a specific atomic slot migration task (<https://redis.io/commands/cluster-migration>).+--+-- /O(N)/ where /N/ is the total number of slots between the specified start and end slot arguments.+--+-- Since Redis 8.4.0+clusterMigrationStatusId+ :: (RedisCtx m f)+ => ByteString -- ^ Task identifier.+ -> m (f ClusterMigrationStatusResponse)+clusterMigrationStatusId taskId =+ sendRequest ["CLUSTER", "MIGRATION", "STATUS", "ID", taskId]++command :: (RedisCtx m f) => m (f [CMD.CommandInfo])+command = sendRequest ["COMMAND"]++-- |Returns a list of command names (<https://redis.io/commands/command-list>).+--+-- /O(N)/ where /N/ is the total number of Redis commands.+--+-- Since Redis 7.0.0+commandList+ :: (RedisCtx m f)+ => m (f [ByteString])+commandList = commandListOpts Nothing++data CommandListFilter+ = CommandListFilterByModule ByteString+ | CommandListFilterByAclCat ByteString+ | CommandListFilterByPattern ByteString+ deriving (Show, Eq)++-- |Returns a list of command names (<https://redis.io/commands/command-list>).+--+-- /O(N)/ where /N/ is the total number of Redis commands.+--+-- Since Redis 7.0.0+commandListOpts+ :: (RedisCtx m f)+ => Maybe CommandListFilter+ {- ^ Optional filtering mode.++ `CommandListFilterByModule` keeps only commands that belong to the given module.+ `CommandListFilterByAclCat` keeps only commands from the given ACL category.+ `CommandListFilterByPattern` keeps only commands whose names match the specified glob-style pattern.+ -}+ -> m (f [ByteString])+commandListOpts commandFilter =+ sendRequest $ ["COMMAND", "LIST"] ++ filterArgs+ where+ filterArgs =+ case commandFilter of+ Nothing -> []+ Just (CommandListFilterByModule moduleName) ->+ ["FILTERBY", "MODULE", moduleName]+ Just (CommandListFilterByAclCat category) ->+ ["FILTERBY", "ACLCAT", category]+ Just (CommandListFilterByPattern pattern_) ->+ ["FILTERBY", "PATTERN", pattern_]++data IncrexExpiration+ = IncrexSeconds Integer+ | IncrexMilliseconds Integer+ | IncrexUnixSeconds Integer+ | IncrexUnixMilliseconds Integer+ | IncrexPersist+ deriving (Show, Eq)++data IncrexOpts a = IncrexOpts+ { increxLowerBound :: Maybe a+ , increxUpperBound :: Maybe a+ , increxSaturate :: Bool+ , increxExpiration :: Maybe IncrexExpiration+ , increxExpirationIfNotExists :: Bool+ } deriving (Show, Eq)++-- |Redis default 'IncrexOpts'. Equivalent to omitting all optional parameters.+defaultIncrexOpts :: IncrexOpts a+defaultIncrexOpts = IncrexOpts+ { increxLowerBound = Nothing+ , increxUpperBound = Nothing+ , increxSaturate = False+ , increxExpiration = Nothing+ , increxExpirationIfNotExists = False+ }++-- |Increments the numeric value of a key by one and optionally updates its expiration (<https://redis.io/commands/increx>).+--+-- /O(1)/+--+-- Since Redis 8.8.0+increx+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key to increment.+ -> m (f (Integer, Integer))+increx key = increxOpts key defaultIncrexOpts++-- |Increments the numeric value of a key by one and optionally updates its expiration (<https://redis.io/commands/increx>).+--+-- /O(1)/+--+-- Since Redis 8.8.0+increxOpts+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key to increment.+ -> IncrexOpts Integer+ {- ^ Bound and expiration options.++ `LBOUND` and `UBOUND` constrain the result.+ `SATURATE` clips out-of-bounds values instead of rejecting the increment.+ `EX`/`PX`/`EXAT`/`PXAT`/`PERSIST` control the key expiration.+ `ENX` only sets the expiration when the key currently has no TTL.+ -}+ -> m (f (Integer, Integer))+increxOpts key opts =+ sendRequest $ ["INCREX", key] ++ increxCommonArgs opts++-- |Increments the integer value of a key by a specific amount and optionally updates its expiration (<https://redis.io/commands/increx>).+--+-- /O(1)/+--+-- Since Redis 8.8.0+increxBy+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key to increment.+ -> Integer -- ^ The integer increment to apply.+ -> IncrexOpts Integer -- ^ Bound and expiration options.+ -> m (f (Integer, Integer))+increxBy key increment opts =+ sendRequest $ ["INCREX", key, "BYINT", encode increment] ++ increxCommonArgs opts++-- |Increments the floating-point value of a key by a specific amount and optionally updates its expiration (<https://redis.io/commands/increx>).+--+-- /O(1)/+--+-- Since Redis 8.8.0+increxByFloat+ :: (RedisCtx m f)+ => ByteString -- ^ The name of the key to increment.+ -> Double -- ^ The floating-point increment to apply.+ -> IncrexOpts Double -- ^ Bound and expiration options.+ -> m (f (Double, Double))+increxByFloat key increment opts =+ sendRequest $ ["INCREX", key, "BYFLOAT", encode increment] ++ increxCommonArgs opts++increxCommonArgs :: RedisArg a => IncrexOpts a -> [ByteString]+increxCommonArgs IncrexOpts{..} =+ lowerBoundArg ++ upperBoundArg ++ saturateArg ++ expirationArg ++ enxArg+ where+ lowerBoundArg = maybe [] (\bound -> ["LBOUND", encode bound]) increxLowerBound+ upperBoundArg = maybe [] (\bound -> ["UBOUND", encode bound]) increxUpperBound+ saturateArg = ["SATURATE" | increxSaturate]+ expirationArg =+ case increxExpiration of+ Nothing -> []+ Just (IncrexSeconds seconds) -> ["EX", encode seconds]+ Just (IncrexMilliseconds milliseconds) -> ["PX", encode milliseconds]+ Just (IncrexUnixSeconds seconds) -> ["EXAT", encode seconds]+ Just (IncrexUnixMilliseconds milliseconds) -> ["PXAT", encode milliseconds]+ Just IncrexPersist -> ["PERSIST"]+ enxArg = ["ENX" | increxExpirationIfNotExists]++data ARGrepPredicate+ = ARGrepExact ByteString+ | ARGrepMatch ByteString+ | ARGrepGlob ByteString+ | ARGrepRegex ByteString+ deriving (Show, Eq)++data ARGrepCombine+ = ARGrepAnd+ | ARGrepOr+ deriving (Show, Eq)++data ARGrepOpts = ARGrepOpts+ { arGrepCombine :: Maybe ARGrepCombine+ , arGrepLimit :: Maybe Integer+ , arGrepNoCase :: Bool+ } deriving (Show, Eq)++-- |Redis default 'ARGrepOpts'. Equivalent to omitting all optional parameters.+defaultARGrepOpts :: ARGrepOpts+defaultARGrepOpts = ARGrepOpts+ { arGrepCombine = Nothing+ , arGrepLimit = Nothing+ , arGrepNoCase = False+ }++data ARLastItemsOpts = ARLastItemsOpts+ { arLastItemsReverse :: Bool+ } deriving (Show, Eq)++-- |Redis default 'ARLastItemsOpts'. Equivalent to omitting all optional parameters.+defaultARLastItemsOpts :: ARLastItemsOpts+defaultARLastItemsOpts = ARLastItemsOpts+ { arLastItemsReverse = False+ }++data ARScanOpts = ARScanOpts+ { arScanLimit :: Maybe Integer+ } deriving (Show, Eq)++-- |Redis default 'ARScanOpts'. Equivalent to omitting all optional parameters.+defaultARScanOpts :: ARScanOpts+defaultARScanOpts = ARScanOpts+ { arScanLimit = Nothing+ }++newtype ARIndexValuePairsResponse = ARIndexValuePairsResponse+ { arIndexValuePairs :: [(Integer, ByteString)]+ } deriving (Show, Eq)++instance RedisResult ARIndexValuePairsResponse where+ decode r@(MultiBulk (Just replies)) =+ ARIndexValuePairsResponse <$> decodePairs replies+ where+ decodePairs [] = Right []+ decodePairs (MultiBulk (Just [indexReply, valueReply]):rest) =+ (:) <$> ((,) <$> decode indexReply <*> decode valueReply) <*> decodePairs rest+ decodePairs (indexReply:valueReply:rest) =+ (:) <$> ((,) <$> decode indexReply <*> decode valueReply) <*> decodePairs rest+ decodePairs _ = Left r+ decode r = Left r++data ARInfoResponse = ARInfoResponse+ { arInfoCount :: Integer+ , arInfoLength :: Integer+ , arInfoNextInsertIndex :: Integer+ , arInfoSlices :: Integer+ , arInfoDirectorySize :: Integer+ , arInfoSuperDirEntries :: Integer+ , arInfoSliceSize :: Integer+ , arInfoDenseSlices :: Maybe Integer+ , arInfoSparseSlices :: Maybe Integer+ , arInfoAvgDenseSize :: Maybe Double+ , arInfoAvgDenseFill :: Maybe Double+ , arInfoAvgSparseSize :: Maybe Double+ } deriving (Show, Eq)++instance RedisResult ARInfoResponse where+ decode r@(MultiBulk (Just replies)) = do+ pairs <- parsePairs replies+ ARInfoResponse+ <$> required "count" pairs+ <*> required "len" pairs+ <*> required "next-insert-index" pairs+ <*> required "slices" pairs+ <*> required "directory-size" pairs+ <*> required "super-dir-entries" pairs+ <*> required "slice-size" pairs+ <*> pure (optional "dense-slices" pairs)+ <*> pure (optional "sparse-slices" pairs)+ <*> pure (optional "avg-dense-size" pairs)+ <*> pure (optional "avg-dense-fill" pairs)+ <*> pure (optional "avg-sparse-size" pairs)+ where+ parsePairs [] = Right []+ parsePairs (keyReply:valueReply:rest) =+ (:) <$> ((,) <$> decode keyReply <*> pure valueReply) <*> parsePairs rest+ parsePairs _ = Left r++ required :: RedisResult a => ByteString -> [(ByteString, Reply)] -> Either Reply a+ required key pairs = maybe (Left r) decode (lookup key pairs)++ optional :: RedisResult a => ByteString -> [(ByteString, Reply)] -> Maybe a+ optional key pairs = lookup key pairs >>= either (const Nothing) Just . decode+ decode r = Left r++data AROpValue+ = AROpSum+ | AROpMin+ | AROpMax+ deriving (Show, Eq)++data AROpCount+ = AROpAnd+ | AROpOr+ | AROpXor+ | AROpMatch ByteString+ | AROpUsed+ deriving (Show, Eq)++argrepPredicateArgs :: ARGrepPredicate -> [ByteString]+argrepPredicateArgs predicate =+ case predicate of+ ARGrepExact value -> ["EXACT", value]+ ARGrepMatch value -> ["MATCH", value]+ ARGrepGlob pattern_ -> ["GLOB", pattern_]+ ARGrepRegex pattern_ -> ["RE", pattern_]++argrepOptsArgs :: ARGrepOpts -> [ByteString]+argrepOptsArgs ARGrepOpts{..} =+ combineArg ++ limitArg ++ nocaseArg+ where+ combineArg =+ case arGrepCombine of+ Nothing -> []+ Just ARGrepAnd -> ["AND"]+ Just ARGrepOr -> ["OR"]+ limitArg = maybe [] (\limit -> ["LIMIT", encode limit]) arGrepLimit+ nocaseArg = ["NOCASE" | arGrepNoCase]++aropValueArg :: AROpValue -> ByteString+aropValueArg operation =+ case operation of+ AROpSum -> "SUM"+ AROpMin -> "MIN"+ AROpMax -> "MAX"++aropCountArgs :: AROpCount -> [ByteString]+aropCountArgs operation =+ case operation of+ AROpAnd -> ["AND"]+ AROpOr -> ["OR"]+ AROpXor -> ["XOR"]+ AROpMatch value -> ["MATCH", value]+ AROpUsed -> ["USED"]++-- |Returns the number of non-empty elements in an array (<https://redis.io/commands/arcount>).+--+-- /O(1)/+--+-- Since Redis 8.8.0+arcount+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> m (f Integer)+arcount key = sendRequest ["ARCOUNT", key]++-- |Deletes elements at the specified indices in an array (<https://redis.io/commands/ardel>).+--+-- /O(N)/ where /N/ is the number of indices to delete.+--+-- Since Redis 8.8.0+ardel+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> NonEmpty Integer -- ^ One or more zero-based indices to delete.+ -> m (f Integer)+ardel key indices =+ sendRequest $ ["ARDEL", key] ++ map encode (NE.toList indices)++-- |Gets values in a range of indices (<https://redis.io/commands/argetrange>).+--+-- /O(N)/ where /N/ is the range length.+--+-- Since Redis 8.8.0+argetrange+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> Integer -- ^ Start index.+ -> Integer -- ^ End index, inclusive.+ -> m (f [Maybe ByteString])+argetrange key start end =+ sendRequest ["ARGETRANGE", key, encode start, encode end]++-- |Searches array elements in a range using textual predicates (<https://redis.io/commands/argrep>).+--+-- /O(P * C)/ where /P/ is the number of visited positions and /C/ is the cost of evaluating predicates.+--+-- Since Redis 8.8.0+argrep+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> ByteString -- ^ Start index or `-` for the first array index.+ -> ByteString -- ^ End index or `+` for the last array index.+ -> NonEmpty ARGrepPredicate -- ^ One or more predicates to apply.+ -> m (f [Integer])+argrep key start end predicates =+ argrepOpts key start end predicates defaultARGrepOpts++-- |Searches array elements in a range using textual predicates (<https://redis.io/commands/argrep>).+--+-- /O(P * C)/ where /P/ is the number of visited positions and /C/ is the cost of evaluating predicates.+--+-- Since Redis 8.8.0+argrepOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> ByteString -- ^ Start index or `-` for the first array index.+ -> ByteString -- ^ End index or `+` for the last array index.+ -> NonEmpty ARGrepPredicate -- ^ One or more predicates to apply.+ -> ARGrepOpts -- ^ Additional predicate options.+ -> m (f [Integer])+argrepOpts key start end predicates opts =+ sendRequest $+ ["ARGREP", key, start, end]+ ++ concatMap argrepPredicateArgs (NE.toList predicates)+ ++ argrepOptsArgs opts++-- |Searches array elements in a range and returns matching index-value pairs (<https://redis.io/commands/argrep>).+--+-- /O(P * C)/ where /P/ is the number of visited positions and /C/ is the cost of evaluating predicates.+--+-- Since Redis 8.8.0+argrepWithValues+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> ByteString -- ^ Start index or `-` for the first array index.+ -> ByteString -- ^ End index or `+` for the last array index.+ -> NonEmpty ARGrepPredicate -- ^ One or more predicates to apply.+ -> m (f ARIndexValuePairsResponse)+argrepWithValues key start end predicates =+ argrepWithValuesOpts key start end predicates defaultARGrepOpts++-- |Searches array elements in a range and returns matching index-value pairs (<https://redis.io/commands/argrep>).+--+-- /O(P * C)/ where /P/ is the number of visited positions and /C/ is the cost of evaluating predicates.+--+-- Since Redis 8.8.0+argrepWithValuesOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> ByteString -- ^ Start index or `-` for the first array index.+ -> ByteString -- ^ End index or `+` for the last array index.+ -> NonEmpty ARGrepPredicate -- ^ One or more predicates to apply.+ -> ARGrepOpts -- ^ Additional predicate options.+ -> m (f ARIndexValuePairsResponse)+argrepWithValuesOpts key start end predicates opts =+ sendRequest $+ ["ARGREP", key, start, end]+ ++ concatMap argrepPredicateArgs (NE.toList predicates)+ ++ ["WITHVALUES"]+ ++ argrepOptsArgs opts++-- |Returns metadata about an array (<https://redis.io/commands/arinfo>).+--+-- /O(1)/, or /O(N)/ with `FULL` where /N/ is the number of slices.+--+-- Since Redis 8.8.0+arinfo+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> m (f ARInfoResponse)+arinfo key = sendRequest ["ARINFO", key]++-- |Returns extended metadata about an array (<https://redis.io/commands/arinfo>).+--+-- /O(N)/ where /N/ is the number of slices.+--+-- Since Redis 8.8.0+arinfoFull+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> m (f ARInfoResponse)+arinfoFull key = sendRequest ["ARINFO", key, "FULL"]++-- |Inserts one or more values at consecutive indices (<https://redis.io/commands/arinsert>).+--+-- /O(N)/ where /N/ is the number of values.+--+-- Since Redis 8.8.0+arinsert+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> NonEmpty ByteString -- ^ Values to insert at the current insert cursor.+ -> m (f Integer)+arinsert key values =+ sendRequest $ ["ARINSERT", key] ++ NE.toList values++-- |Returns the most recently inserted elements (<https://redis.io/commands/arlastitems>).+--+-- /O(N)/ where /N/ is the count.+--+-- Since Redis 8.8.0+arlastitems+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> Integer -- ^ Maximum number of most recently inserted elements to return.+ -> m (f [Maybe ByteString])+arlastitems key count =+ arlastitemsOpts key count defaultARLastItemsOpts++-- |Returns the most recently inserted elements (<https://redis.io/commands/arlastitems>).+--+-- /O(N)/ where /N/ is the count.+--+-- Since Redis 8.8.0+arlastitemsOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> Integer -- ^ Maximum number of most recently inserted elements to return.+ -> ARLastItemsOpts -- ^ Additional options.+ -> m (f [Maybe ByteString])+arlastitemsOpts key count ARLastItemsOpts{..} =+ sendRequest $ ["ARLASTITEMS", key, encode count] ++ ["REV" | arLastItemsReverse]++-- |Returns the length of an array (max index + 1) (<https://redis.io/commands/arlen>).+--+-- /O(1)/+--+-- Since Redis 8.8.0+arlen+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> m (f Integer)+arlen key = sendRequest ["ARLEN", key]++-- |Gets values at multiple indices in an array (<https://redis.io/commands/armget>).+--+-- /O(N)/ where /N/ is the number of indices.+--+-- Since Redis 8.8.0+armget+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> NonEmpty Integer -- ^ One or more zero-based indices.+ -> m (f [Maybe ByteString])+armget key indices =+ sendRequest $ ["ARMGET", key] ++ map encode (NE.toList indices)++-- |Returns the next index that `ARINSERT` would use (<https://redis.io/commands/arnext>).+--+-- /O(1)/+--+-- Since Redis 8.8.0+arnext+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> m (f (Maybe Integer))+arnext key = sendRequest ["ARNEXT", key]++-- |Performs aggregate operations on array elements in a range and returns a string result (<https://redis.io/commands/arop>).+--+-- /O(P)/ where /P/ is the number of visited positions in touched slices.+--+-- Since Redis 8.8.0+aropValue+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> Integer -- ^ Start index.+ -> Integer -- ^ End index.+ -> AROpValue -- ^ Aggregate operation.+ -> m (f (Maybe ByteString))+aropValue key start end operation =+ sendRequest ["AROP", key, encode start, encode end, aropValueArg operation]++-- |Performs aggregate operations on array elements in a range and returns an integer result (<https://redis.io/commands/arop>).+--+-- /O(P)/ where /P/ is the number of visited positions in touched slices.+--+-- Since Redis 8.8.0+aropCount+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> Integer -- ^ Start index.+ -> Integer -- ^ End index.+ -> AROpCount -- ^ Aggregate operation.+ -> m (f (Maybe Integer))+aropCount key start end operation =+ sendRequest $ ["AROP", key, encode start, encode end] ++ aropCountArgs operation++-- |Inserts values into a ring buffer of specified size, wrapping and truncating as needed (<https://redis.io/commands/arring>).+--+-- /O(M)/ normally, or /O(N+M)/ on ring resize.+--+-- Since Redis 8.8.0+arring+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> Integer -- ^ Ring buffer size.+ -> NonEmpty ByteString -- ^ Values to insert.+ -> m (f Integer)+arring key size values =+ sendRequest $ ["ARRING", key, encode size] ++ NE.toList values++-- |Iterates existing elements in a range, returning index-value pairs (<https://redis.io/commands/arscan>).+--+-- /O(P)/ where /P/ is the number of visited positions in touched slices.+--+-- Since Redis 8.8.0+arscan+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> Integer -- ^ Start index.+ -> Integer -- ^ End index.+ -> m (f ARIndexValuePairsResponse)+arscan key start end =+ arscanOpts key start end defaultARScanOpts++-- |Iterates existing elements in a range, returning index-value pairs (<https://redis.io/commands/arscan>).+--+-- /O(P)/ where /P/ is the number of visited positions in touched slices.+--+-- Since Redis 8.8.0+arscanOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> Integer -- ^ Start index.+ -> Integer -- ^ End index.+ -> ARScanOpts -- ^ Additional options.+ -> m (f ARIndexValuePairsResponse)+arscanOpts key start end ARScanOpts{..} =+ sendRequest $+ ["ARSCAN", key, encode start, encode end]+ ++ maybe [] (\limit -> ["LIMIT", encode limit]) arScanLimit++-- |Sets the `ARINSERT` / `ARRING` cursor to a specific index (<https://redis.io/commands/arseek>).+--+-- /O(1)/+--+-- Since Redis 8.8.0+arseek+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> Integer -- ^ The new insert cursor position.+ -> m (f Bool)+arseek key index = sendRequest ["ARSEEK", key, encode index]++-- |Sets one or more contiguous values starting at an index in an array (<https://redis.io/commands/arset>).+--+-- /O(N)/ where /N/ is the number of values.+--+-- Since Redis 8.8.0+arset+ :: (RedisCtx m f)+ => ByteString -- ^ Array key.+ -> Integer -- ^ Start index.+ -> NonEmpty ByteString -- ^ One or more values to store at consecutive indices.+ -> m (f Integer)+arset key index values =+ sendRequest $ ["ARSET", key, encode index] ++ NE.toList values++data HotkeysMetric+ = HotkeysMetricCPU+ | HotkeysMetricNET+ deriving (Show, Eq)++instance RedisArg HotkeysMetric where+ encode HotkeysMetricCPU = "CPU"+ encode HotkeysMetricNET = "NET"++data HotkeysStartOpts = HotkeysStartOpts+ { hotkeysStartTopKCount :: Maybe Integer+ -- ^ The value of K for the top-K hotkeys tracking.+ , hotkeysStartDurationSeconds :: Maybe Integer+ -- ^ The number of seconds to keep tracking before it stops automatically.+ , hotkeysStartSampleRatio :: Maybe Integer+ -- ^ The probabilistic sampling ratio. Each key is sampled with probability @1/ratio@.+ , hotkeysStartSlots :: Maybe (NonEmpty Integer)+ -- ^ The hash slots to track in cluster mode.+ } deriving (Show, Eq)++-- |Redis default 'HotkeysStartOpts'. Equivalent to omitting all optional parameters.+defaultHotkeysStartOpts :: HotkeysStartOpts+defaultHotkeysStartOpts = HotkeysStartOpts+ { hotkeysStartTopKCount = Nothing+ , hotkeysStartDurationSeconds = Nothing+ , hotkeysStartSampleRatio = Nothing+ , hotkeysStartSlots = Nothing+ }++data HotkeysSlotRange = HotkeysSlotRange+ { hotkeysSlotRangeStart :: Integer+ , hotkeysSlotRangeEnd :: Integer+ } deriving (Show, Eq)++instance RedisResult HotkeysSlotRange where+ decode (MultiBulk (Just [Integer slot])) =+ Right HotkeysSlotRange+ { hotkeysSlotRangeStart = slot+ , hotkeysSlotRangeEnd = slot+ }+ decode (MultiBulk (Just [Integer start, Integer end])) =+ Right HotkeysSlotRange+ { hotkeysSlotRangeStart = start+ , hotkeysSlotRangeEnd = end+ }+ decode r = Left r++data HotkeysGetResponse = HotkeysGetResponse+ { hotkeysGetTrackingActive :: Bool+ , hotkeysGetSampleRatio :: Integer+ , hotkeysGetSelectedSlots :: [HotkeysSlotRange]+ , hotkeysGetAllCommandsAllSlotsUs :: Integer+ , hotkeysGetNetBytesAllCommandsAllSlots :: Integer+ , hotkeysGetCollectionStartTimeUnixMs :: Integer+ , hotkeysGetCollectionDurationMs :: Integer+ , hotkeysGetTotalCpuTimeUserMs :: Maybe Integer+ , hotkeysGetTotalCpuTimeSysMs :: Maybe Integer+ , hotkeysGetTotalNetBytes :: Maybe Integer+ , hotkeysGetByCpuTimeUs :: Maybe [(ByteString, Integer)]+ , hotkeysGetByNetBytes :: Maybe [(ByteString, Integer)]+ , hotkeysGetSampledCommandsSelectedSlotsUs :: Maybe Integer+ , hotkeysGetAllCommandsSelectedSlotsUs :: Maybe Integer+ , hotkeysGetNetBytesSampledCommandsSelectedSlots :: Maybe Integer+ , hotkeysGetNetBytesAllCommandsSelectedSlots :: Maybe Integer+ } deriving (Show, Eq)++instance RedisResult HotkeysGetResponse where+ decode (MultiBulk (Just [payload])) = decode payload+ decode r@(MultiBulk (Just replies)) = do+ pairs <- parsePairs replies+ hotkeysGetTrackingActive <- require "tracking-active" pairs+ hotkeysGetSampleRatio <- require "sample-ratio" pairs+ hotkeysGetSelectedSlots <- require "selected-slots" pairs+ hotkeysGetAllCommandsAllSlotsUs <- require "all-commands-all-slots-us" pairs+ hotkeysGetNetBytesAllCommandsAllSlots <- require "net-bytes-all-commands-all-slots" pairs+ hotkeysGetCollectionStartTimeUnixMs <- require "collection-start-time-unix-ms" pairs+ hotkeysGetCollectionDurationMs <- require "collection-duration-ms" pairs+ let hotkeysGetTotalCpuTimeUserMs = optional "total-cpu-time-user-ms" pairs+ hotkeysGetTotalCpuTimeSysMs = optional "total-cpu-time-sys-ms" pairs+ hotkeysGetTotalNetBytes = optional "total-net-bytes" pairs+ hotkeysGetByCpuTimeUs = optional "by-cpu-time-us" pairs+ hotkeysGetByNetBytes = optional "by-net-bytes" pairs+ hotkeysGetSampledCommandsSelectedSlotsUs = optional "sampled-commands-selected-slots-us" pairs+ hotkeysGetAllCommandsSelectedSlotsUs = optional "all-commands-selected-slots-us" pairs+ hotkeysGetNetBytesSampledCommandsSelectedSlots = optional "net-bytes-sampled-commands-selected-slots" pairs+ hotkeysGetNetBytesAllCommandsSelectedSlots = optional "net-bytes-all-commands-selected-slots" pairs+ pure HotkeysGetResponse{..}+ where+ parsePairs [] = Right []+ parsePairs (keyReply:valueReply:rest) =+ (:) <$> ((,) <$> decode keyReply <*> pure valueReply) <*> parsePairs rest+ parsePairs _ = Left r++ require :: RedisResult a => ByteString -> [(ByteString, Reply)] -> Either Reply a+ require key pairs =+ maybe (Left r) decode (lookup key pairs)++ optional :: RedisResult a => ByteString -> [(ByteString, Reply)] -> Maybe a+ optional key pairs = lookup key pairs >>= either (const Nothing) Just . decode+ decode r = Left r++-- |Starts hotkeys tracking (<https://redis.io/commands/hotkeys-start>).+--+-- /O(1)/+--+-- Since Redis 8.6.0+hotkeysStart+ :: (RedisCtx m f)+ => NonEmpty HotkeysMetric+ {- ^ The metrics to track.++ The command automatically derives the `METRICS count` argument from the number of provided metrics.+ At least one metric must be specified.+ -}+ -> m (f Status)+hotkeysStart metrics = hotkeysStartOpts metrics defaultHotkeysStartOpts++-- |Starts hotkeys tracking (<https://redis.io/commands/hotkeys-start>).+--+-- /O(1)/+--+-- Since Redis 8.6.0+hotkeysStartOpts+ :: (RedisCtx m f)+ => NonEmpty HotkeysMetric -- ^ The metrics to track.+ -> HotkeysStartOpts -- ^ Additional tracking options.+ -> m (f Status)+hotkeysStartOpts metrics HotkeysStartOpts{..} =+ sendRequest $+ ["HOTKEYS", "START", "METRICS", encode (toInteger $ NE.length metrics)]+ ++ map encode (NE.toList metrics)+ ++ maybe [] (\count -> ["COUNT", encode count]) hotkeysStartTopKCount+ ++ maybe [] (\duration -> ["DURATION", encode duration]) hotkeysStartDurationSeconds+ ++ maybe [] (\ratio -> ["SAMPLE", encode ratio]) hotkeysStartSampleRatio+ ++ maybe [] slotsArgs hotkeysStartSlots+ where+ slotsArgs slots = ["SLOTS", encode (toInteger $ NE.length slots)] ++ map encode (NE.toList slots)++-- |Returns tracking results and metadata from the current or most recent hotkeys tracking session (<https://redis.io/commands/hotkeys-get>).+--+-- /O(K)/ where /K/ is the number of hotkeys returned.+--+-- Since Redis 8.6.0+hotkeysGet+ :: (RedisCtx m f)+ => m (f HotkeysGetResponse)+hotkeysGet = sendRequest ["HOTKEYS", "GET"]++-- |Stops hotkeys tracking (<https://redis.io/commands/hotkeys-stop>).+--+-- /O(1)/+--+-- Since Redis 8.6.0+hotkeysStop+ :: (RedisCtx m f)+ => m (f Status)+hotkeysStop = sendRequest ["HOTKEYS", "STOP"]++-- |Release the resources used for hotkey tracking (<https://redis.io/commands/hotkeys-reset>).+--+-- /O(1)/+--+-- Since Redis 8.6.0+hotkeysReset+ :: (RedisCtx m f)+ => m (f Status)+hotkeysReset = sendRequest ["HOTKEYS", "RESET"]+++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]++-- |Get a substring of the string stored at a key (<http://redis.io/commands/substr>).+--+-- Deprecated in Redis. Use 'getrange' instead.+--+-- Since Redis 1.0.0+substr+ :: (RedisCtx m f)+ => ByteString -- ^ key+ -> Integer -- ^ start+ -> Integer -- ^ end+ -> m (f ByteString)+substr key start end = sendRequest ["SUBSTR", key, encode start, encode end]
+ src/Database/Redis/ManualCommands/BF.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Database.Redis.ManualCommands.BF where++import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE++import Database.Redis.Core+import Database.Redis.Types+import Database.Redis.Protocol++data BFInfo = BFInfo+ { bfInfoCapacity :: Integer+ -- ^ Number of unique items that can be stored before scaling is required.+ , bfInfoSize :: Integer+ -- ^ Number of bytes allocated for the Bloom filter.+ , bfInfoFilters :: Integer+ -- ^ Number of sub-filters.+ , bfInfoItems :: Integer+ -- ^ Number of unique inserted items detected by the filter.+ , bfInfoExpansion :: Integer+ -- ^ Expansion rate used when a new sub-filter is created.+ } deriving (Show, Eq)++instance RedisResult BFInfo where+ decode r = do+ fields <- decode r :: Either Reply [(ByteString, Integer)]+ bfInfoCapacity <- decodeField "Capacity" fields+ bfInfoSize <- decodeField "Size" fields+ bfInfoFilters <- decodeField "Number of filters" fields+ bfInfoItems <- decodeField "Number of items inserted" fields+ bfInfoExpansion <- decodeField "Expansion rate" fields+ pure BFInfo{..}+ where+ decodeField key fields = maybe (Left r) Right (lookup key fields)++data BFReserveOpts = BFReserveOpts+ { bfReserveExpansion :: Maybe Integer+ -- ^ Expansion rate for newly created sub-filters once capacity is reached.+ , bfReserveNonScaling :: Bool+ -- ^ Prevent creation of additional sub-filters when initial capacity is reached.+ } deriving (Show, Eq)++defaultBFReserveOpts :: BFReserveOpts+defaultBFReserveOpts = BFReserveOpts+ { bfReserveExpansion = Nothing+ , bfReserveNonScaling = False+ }++data BFInsertOpts = BFInsertOpts+ { bfInsertCapacity :: Maybe Integer+ -- ^ Initial capacity to use if a new filter is created.+ , bfInsertError :: Maybe Double+ -- ^ Desired false positive probability to use if a new filter is created.+ , bfInsertExpansion :: Maybe Integer+ -- ^ Expansion rate for additional sub-filters.+ , bfInsertNoCreate :: Bool+ -- ^ Return an error instead of creating the filter when the key does not exist.+ , bfInsertNonScaling :: Bool+ -- ^ Prevent creation of additional sub-filters when capacity is reached.+ } deriving (Show, Eq)++defaultBFInsertOpts :: BFInsertOpts+defaultBFInsertOpts = BFInsertOpts+ { bfInsertCapacity = Nothing+ , bfInsertError = Nothing+ , bfInsertExpansion = Nothing+ , bfInsertNoCreate = False+ , bfInsertNonScaling = False+ }++bfReserveOptsToArgs :: BFReserveOpts -> [ByteString]+bfReserveOptsToArgs BFReserveOpts{..} =+ expansionArg ++ nonScalingArg+ where+ expansionArg = maybe [] (\expansion -> ["EXPANSION", encode expansion]) bfReserveExpansion+ nonScalingArg = ["NONSCALING" | bfReserveNonScaling]++bfInsertOptsToArgs :: BFInsertOpts -> [ByteString]+bfInsertOptsToArgs BFInsertOpts{..} =+ capacityArg ++ errorArg ++ expansionArg ++ noCreateArg ++ nonScalingArg+ where+ capacityArg = maybe [] (\capacity -> ["CAPACITY", encode capacity]) bfInsertCapacity+ errorArg = maybe [] (\err -> ["ERROR", encode err]) bfInsertError+ expansionArg = maybe [] (\expansion -> ["EXPANSION", encode expansion]) bfInsertExpansion+ noCreateArg = ["NOCREATE" | bfInsertNoCreate]+ nonScalingArg = ["NONSCALING" | bfInsertNonScaling]++-- |Adds an item to a Bloom filter (<https://redis.io/commands/bf.add>).+--+-- A filter is created automatically if the key does not exist.+--+-- /O(k)/, where /k/ is the number of hash functions used by the last sub-filter.+--+-- Since RedisBloom 1.0.0+bfadd+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Bloom filter.+ -> ByteString -- ^ Item to add to the Bloom filter.+ -> m (f Bool)+bfadd key item = sendRequest ["BF.ADD", key, item]++-- |Returns the cardinality of a Bloom filter (<https://redis.io/commands/bf.card>).+--+-- Returns @0@ when the key does not exist.+--+-- /O(1)/+--+-- Since RedisBloom 2.4.4+bfcard+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Bloom filter.+ -> m (f Integer)+bfcard key = sendRequest ["BF.CARD", key]++-- |Determines whether an item was added to a Bloom filter (<https://redis.io/commands/bf.exists>).+--+-- Returns 'False' when the key does not exist or the item was definitely not added.+--+-- /O(k)/, where $k$ is the number of hash functions used by the last sub-filter.+--+-- Since RedisBloom 1.0.0+bfexists+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Bloom filter.+ -> ByteString -- ^ Item to check.+ -> m (f Bool)+bfexists key item = sendRequest ["BF.EXISTS", key, item]++-- |Returns information about a Bloom filter (<https://redis.io/commands/bf.info>).+--+-- /O(1)/+--+-- Since RedisBloom 1.0.0+bfinfo+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Bloom filter.+ -> m (f BFInfo)+bfinfo key = sendRequest ["BF.INFO", key]++-- |Returns the configured capacity of a Bloom filter (<https://redis.io/commands/bf.info>).+--+-- /O(1)/+--+-- Since RedisBloom 1.0.0+bfinfoCapacity+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Bloom filter.+ -> m (f [Integer])+bfinfoCapacity key = sendRequest ["BF.INFO", key, "CAPACITY"]++-- |Returns the size in bytes of a Bloom filter (<https://redis.io/commands/bf.info>).+--+-- /O(1)/+--+-- Since RedisBloom 1.0.0+bfinfoSize+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Bloom filter.+ -> m (f [Integer])+bfinfoSize key = sendRequest ["BF.INFO", key, "SIZE"]++-- |Returns the number of sub-filters in a Bloom filter (<https://redis.io/commands/bf.info>).+--+-- /O(1)/+--+-- Since RedisBloom 1.0.0+bfinfoFilters+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Bloom filter.+ -> m (f [Integer])+bfinfoFilters key = sendRequest ["BF.INFO", key, "FILTERS"]++-- |Returns the number of unique inserted items detected by a Bloom filter (<https://redis.io/commands/bf.info>).+--+-- /O(1)/+--+-- Since RedisBloom 1.0.0+bfinfoItems+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Bloom filter.+ -> m (f [Integer])+bfinfoItems key = sendRequest ["BF.INFO", key, "ITEMS"]++-- |Returns the expansion rate of a Bloom filter (<https://redis.io/commands/bf.info>).+--+-- /O(1)/+--+-- Returns Nothing for the non scaling filters.+--+-- Since RedisBloom 1.0.0+bfinfoExpansion+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Bloom filter.+ -> m (f [Maybe Integer])+bfinfoExpansion key = sendRequest ["BF.INFO", key, "EXPANSION"]++-- |Adds one or more items to a Bloom filter, creating it when needed (<https://redis.io/commands/bf.insert>).+--+-- This is equivalent to inserting with default options and automatic creation enabled.+--+-- /O(kn)/, where /k/ is the number of hash functions and /n/ is the number of items.+--+-- Since RedisBloom 1.0.0+bfinsert+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Bloom filter.+ -> NonEmpty ByteString -- ^ Items to add.+ -> m (f [Bool])+bfinsert key items = bfinsertOpts key items defaultBFInsertOpts++-- |Adds one or more items to a Bloom filter, creating it when needed (<https://redis.io/commands/bf.insert>).+--+-- /O(kn)/, where /k/ is the number of hash functions and /n/ is the number of items.+--+-- Since RedisBloom 1.0.0+bfinsertOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Bloom filter.+ -> NonEmpty ByteString -- ^ Items to add.+ -> BFInsertOpts -- ^ Optional creation and scaling parameters.+ -> m (f [Bool])+bfinsertOpts key items opts =+ sendRequest $ ["BF.INSERT", key] ++ bfInsertOptsToArgs opts ++ ["ITEMS"] ++ NE.toList items++-- |Adds one or more items to a Bloom filter (<https://redis.io/commands/bf.madd>).+--+-- A filter is created automatically if the key does not exist.+--+-- /O(kn)/, where /k/ is the number of hash functions and /n/ is the number of items.+--+-- Since RedisBloom 1.0.0+bfmadd+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Bloom filter.+ -> NonEmpty ByteString -- ^ Items to add.+ -> m (f [Bool])+bfmadd key items = sendRequest $ ["BF.MADD", key] ++ NE.toList items++-- |Checks whether one or more items were added to a Bloom filter (<https://redis.io/commands/bf.mexists>).+--+-- A 'False' result means the item is definitely absent, or the key does not exist.+--+-- /O(kn)/, where /k/ is the number of hash functions and /n/ is the number of items.+--+-- Since RedisBloom 1.0.0+bfmexists+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Bloom filter.+ -> NonEmpty ByteString -- ^ Items to check.+ -> m (f [Bool])+bfmexists key items = sendRequest $ ["BF.MEXISTS", key] ++ NE.toList items++-- |Creates an empty Bloom filter (<https://redis.io/commands/bf.reserve>).+--+-- The filter will fail if the key already exists.+--+-- /O(1)/+--+-- Since RedisBloom 1.0.0+bfreserve+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Bloom filter to create.+ -> Double -- ^ Desired false positive probability, between @0@ and @1@.+ -> Integer -- ^ Initial capacity.+ -> m (f Status)+bfreserve key errorRate capacity = bfreserveOpts key errorRate capacity defaultBFReserveOpts++-- |Creates an empty Bloom filter (<https://redis.io/commands/bf.reserve>).+--+-- /O(1)/+--+-- Since RedisBloom 1.0.0+bfreserveOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Bloom filter to create.+ -> Double -- ^ Desired false positive probability, between @0@ and @1@.+ -> Integer -- ^ Initial capacity.+ -> BFReserveOpts -- ^ Scaling options for the reserved filter.+ -> m (f Status)+bfreserveOpts key errorRate capacity opts =+ sendRequest $ ["BF.RESERVE", key, encode errorRate, encode capacity] ++ bfReserveOptsToArgs opts
+ src/Database/Redis/ManualCommands/CF.hs view
@@ -0,0 +1,284 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Database.Redis.ManualCommands.CF where++import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE++import Database.Redis.Core+import Database.Redis.Protocol+import Database.Redis.Types++data CFInfo = CFInfo+ { cfInfoSize :: Integer+ -- ^ Number of bytes allocated for the Cuckoo filter.+ , cfInfoBuckets :: Integer+ -- ^ Number of buckets in the filter.+ , cfInfoFilters :: Integer+ -- ^ Number of sub-filters.+ , cfInfoItemsInserted :: Integer+ -- ^ Number of inserted items tracked by the filter.+ , cfInfoItemsDeleted :: Integer+ -- ^ Number of deleted items tracked by the filter.+ , cfInfoBucketSize :: Integer+ -- ^ Number of entries per bucket.+ , cfInfoExpansion :: Integer+ -- ^ Expansion rate used when additional sub-filters are created.+ , cfInfoMaxIterations :: Integer+ -- ^ Maximum number of displacement attempts during insertion.+ } deriving (Show, Eq)++instance RedisResult CFInfo where+ decode r = do+ fields <- decode r :: Either Reply [(ByteString, Integer)]+ cfInfoSize <- decodeField "Size" fields+ cfInfoBuckets <- decodeField "Number of buckets" fields+ cfInfoFilters <- decodeField "Number of filters" fields+ cfInfoItemsInserted <- decodeField "Number of items inserted" fields+ cfInfoItemsDeleted <- decodeField "Number of items deleted" fields+ cfInfoBucketSize <- decodeField "Bucket size" fields+ cfInfoExpansion <- decodeField "Expansion rate" fields+ cfInfoMaxIterations <- decodeField "Max iterations" fields+ pure CFInfo{..}+ where+ decodeField key fields = maybe (Left r) Right (lookup key fields)++data CFReserveOpts = CFReserveOpts+ { cfReserveBucketSize :: Maybe Integer+ -- ^ Number of entries per bucket.+ , cfReserveMaxIterations :: Maybe Integer+ -- ^ Maximum number of displacement attempts during insertion.+ , cfReserveExpansion :: Maybe Integer+ -- ^ Expansion rate for newly created sub-filters.+ } deriving (Show, Eq)++defaultCFReserveOpts :: CFReserveOpts+defaultCFReserveOpts = CFReserveOpts+ { cfReserveBucketSize = Nothing+ , cfReserveMaxIterations = Nothing+ , cfReserveExpansion = Nothing+ }++data CFInsertOpts = CFInsertOpts+ { cfInsertCapacity :: Maybe Integer+ -- ^ Initial capacity to use if a new filter is created.+ , cfInsertNoCreate :: Bool+ -- ^ Return an error instead of creating the filter when the key does not exist.+ } deriving (Show, Eq)++defaultCFInsertOpts :: CFInsertOpts+defaultCFInsertOpts = CFInsertOpts+ { cfInsertCapacity = Nothing+ , cfInsertNoCreate = False+ }++data CFInsertResult+ = CFInsertAdded+ | CFInsertAlreadyExists+ | CFInsertFilterFull+ deriving (Show, Eq)++instance RedisResult CFInsertResult where+ decode r = do+ result <- decode r :: Either Reply Integer+ case result of+ 1 -> Right CFInsertAdded+ 0 -> Right CFInsertAlreadyExists+ -1 -> Right CFInsertFilterFull+ _ -> Left r++cfReserveOptsToArgs :: CFReserveOpts -> [ByteString]+cfReserveOptsToArgs CFReserveOpts{..} =+ bucketSizeArg ++ maxIterationsArg ++ expansionArg+ where+ bucketSizeArg = maybe [] (\bucketSize -> ["BUCKETSIZE", encode bucketSize]) cfReserveBucketSize+ maxIterationsArg = maybe [] (\iterations -> ["MAXITERATIONS", encode iterations]) cfReserveMaxIterations+ expansionArg = maybe [] (\expansion -> ["EXPANSION", encode expansion]) cfReserveExpansion++cfInsertOptsToArgs :: CFInsertOpts -> [ByteString]+cfInsertOptsToArgs CFInsertOpts{..} =+ capacityArg ++ noCreateArg+ where+ capacityArg = maybe [] (\capacity -> ["CAPACITY", encode capacity]) cfInsertCapacity+ noCreateArg = ["NOCREATE" | cfInsertNoCreate]++-- |Adds an item to a Cuckoo filter (<https://redis.io/commands/cf.add>).+--+-- A filter is created automatically if the key does not exist.+--+-- /O(k + i)/, where /k/ is the number of sub-filters and /i/ is maxIterations.+--+-- Since RedisBloom 1.0.0+cfadd+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Cuckoo filter.+ -> ByteString -- ^ Item to add.+ -> m (f Bool)+cfadd key item = sendRequest ["CF.ADD", key, item]++-- |Adds an item to a Cuckoo filter only if it did not already exist (<https://redis.io/commands/cf.addnx>).+--+-- A filter is created automatically if the key does not exist.+--+-- /O(k + i)/, where /k/ is the number of sub-filters and /i/ is maxIterations.+--+-- Since RedisBloom 1.0.0+cfaddnx+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Cuckoo filter.+ -> ByteString -- ^ Item to add.+ -> m (f Bool)+cfaddnx key item = sendRequest ["CF.ADDNX", key, item]++-- |Returns the number of times an item might appear in a Cuckoo filter (<https://redis.io/commands/cf.count>).+--+-- Returns @0@ when the key does not exist or the item was not found.+--+-- /O(k)/, where /k/ is the number of sub-filters.+--+-- Since RedisBloom 1.0.0+cfcount+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Cuckoo filter.+ -> ByteString -- ^ Item to count.+ -> m (f Integer)+cfcount key item = sendRequest ["CF.COUNT", key, item]++-- |Deletes an item from a Cuckoo filter (<https://redis.io/commands/cf.del>).+--+-- Returns 'False' when the key does not exist or the item was not found.+--+-- /O(k)/, where /k/ is the number of sub-filters.+--+-- Since RedisBloom 1.0.0+cfdel+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Cuckoo filter.+ -> ByteString -- ^ Item to delete.+ -> m (f Bool)+cfdel key item = sendRequest ["CF.DEL", key, item]++-- |Checks whether an item may exist in a Cuckoo filter (<https://redis.io/commands/cf.exists>).+--+-- Returns 'False' when the key does not exist or the item is definitely absent.+--+-- /O(k)/, where /k/ is the number of sub-filters.+--+-- Since RedisBloom 1.0.0+cfexists+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Cuckoo filter.+ -> ByteString -- ^ Item to check.+ -> m (f Bool)+cfexists key item = sendRequest ["CF.EXISTS", key, item]++-- |Returns information about a Cuckoo filter (<https://redis.io/commands/cf.info>).+--+-- /O(1)/+--+-- Since RedisBloom 1.0.0+cfinfo+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Cuckoo filter.+ -> m (f CFInfo)+cfinfo key = sendRequest ["CF.INFO", key]++-- |Adds one or more items to a Cuckoo filter, creating it when needed (<https://redis.io/commands/cf.insert>).+--+-- This is equivalent to inserting with default options and automatic creation enabled.+--+-- /O(n * (k + i))/, where /n/ is the number of items, /k/ is the number of sub-filters, and /i/ is maxIterations.+--+-- Since RedisBloom 1.0.0+cfinsert+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Cuckoo filter.+ -> NonEmpty ByteString -- ^ Items to add.+ -> m (f [CFInsertResult])+cfinsert key items = cfinsertOpts key items defaultCFInsertOpts++-- |Adds one or more items to a Cuckoo filter, creating it when needed (<https://redis.io/commands/cf.insert>).+--+-- /O(n * (k + i))/, where /n/ is the number of items, /k/ is the number of sub-filters, and /i/ is maxIterations.+--+-- Since RedisBloom 1.0.0+cfinsertOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Cuckoo filter.+ -> NonEmpty ByteString -- ^ Items to add.+ -> CFInsertOpts -- ^ Optional creation parameters.+ -> m (f [CFInsertResult])+cfinsertOpts key items opts =+ sendRequest $ ["CF.INSERT", key] ++ cfInsertOptsToArgs opts ++ ["ITEMS"] ++ NE.toList items++-- |Adds one or more items to a Cuckoo filter only if they did not already exist (<https://redis.io/commands/cf.insertnx>).+--+-- This is equivalent to inserting with default options and automatic creation enabled.+--+-- /O(n * (k + i))/, where /n/ is the number of items, /k/ is the number of sub-filters, and /i/ is maxIterations.+--+-- Since RedisBloom 1.0.0+cfinsertnx+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Cuckoo filter.+ -> NonEmpty ByteString -- ^ Items to add.+ -> m (f [CFInsertResult])+cfinsertnx key items = cfinsertnxOpts key items defaultCFInsertOpts++-- |Adds one or more items to a Cuckoo filter only if they did not already exist (<https://redis.io/commands/cf.insertnx>).+--+-- /O(n * (k + i))/, where /n/ is the number of items, /k/ is the number of sub-filters, and /i/ is maxIterations.+--+-- Since RedisBloom 1.0.0+cfinsertnxOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Cuckoo filter.+ -> NonEmpty ByteString -- ^ Items to add.+ -> CFInsertOpts -- ^ Optional creation parameters.+ -> m (f [CFInsertResult])+cfinsertnxOpts key items opts =+ sendRequest $ ["CF.INSERTNX", key] ++ cfInsertOptsToArgs opts ++ ["ITEMS"] ++ NE.toList items++-- |Checks whether one or more items may exist in a Cuckoo filter (<https://redis.io/commands/cf.mexists>).+--+-- A 'False' result means the item is definitely absent, or the key does not exist.+--+-- /O(k * n)/, where /k/ is the number of sub-filters and /n/ is the number of items.+--+-- Since RedisBloom 1.0.0+cfmexists+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Cuckoo filter.+ -> NonEmpty ByteString -- ^ Items to check.+ -> m (f [Bool])+cfmexists key items = sendRequest $ ["CF.MEXISTS", key] ++ NE.toList items++-- |Creates an empty Cuckoo filter (<https://redis.io/commands/cf.reserve>).+--+-- The filter will fail if the key already exists.+--+-- /O(1)/+--+-- Since RedisBloom 1.0.0+cfreserve+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Cuckoo filter to create.+ -> Integer -- ^ Initial capacity.+ -> m (f Status)+cfreserve key capacity = cfreserveOpts key capacity defaultCFReserveOpts++-- |Creates an empty Cuckoo filter (<https://redis.io/commands/cf.reserve>).+--+-- /O(1)/+--+-- Since RedisBloom 1.0.0+cfreserveOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Cuckoo filter to create.+ -> Integer -- ^ Initial capacity.+ -> CFReserveOpts -- ^ Bucket and scaling options.+ -> m (f Status)+cfreserveOpts key capacity opts =+ sendRequest $ ["CF.RESERVE", key, encode capacity] ++ cfReserveOptsToArgs opts
+ src/Database/Redis/ManualCommands/Cms.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Database.Redis.ManualCommands.Cms where++import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (listToMaybe)++import Database.Redis.Core+import Database.Redis.Protocol+import Database.Redis.Types++data CMSInfo = CMSInfo+ { cmsInfoWidth :: Integer+ -- ^ Number of counters in each array row.+ , cmsInfoDepth :: Integer+ -- ^ Number of counter array rows.+ , cmsInfoCount :: Integer+ -- ^ Total count added to the sketch.+ } deriving (Show, Eq)++instance RedisResult CMSInfo where+ decode r = do+ fields <- decode r :: Either Reply [(ByteString, Integer)]+ cmsInfoWidth <- decodeField ["width", "Width"] fields+ cmsInfoDepth <- decodeField ["depth", "Depth"] fields+ cmsInfoCount <- decodeField ["count", "Count"] fields+ pure CMSInfo{..}+ where+ decodeField keys fields =+ maybe (Left r) Right . listToMaybe $+ [value | key <- keys, value <- maybeToList (lookup key fields)]++ maybeToList = maybe [] pure++data CMSMergeOpts+ = CMSMergeUnweighted (NonEmpty ByteString)+ -- ^ Merge the given source sketches using the default weight of @1@.+ | CMSMergeWeighted (NonEmpty (ByteString, Integer))+ -- ^ Merge the given source sketches using an explicit weight for each source.+ deriving (Show, Eq)++cmsMergeOptsToArgs :: CMSMergeOpts -> [ByteString]+cmsMergeOptsToArgs (CMSMergeUnweighted sourceKeys) =+ encode (fromIntegral (NE.length sourceKeys) :: Integer) : NE.toList sourceKeys+cmsMergeOptsToArgs (CMSMergeWeighted weightedSourceKeys) =+ encode (fromIntegral (NE.length weightedSourceKeys) :: Integer)+ : map fst sourceKeyWeights+ ++ ["WEIGHTS"]+ ++ map (encode . snd) sourceKeyWeights+ where+ sourceKeyWeights = NE.toList weightedSourceKeys++-- |Increases the count of one or more items by increment (<https://redis.io/commands/cms.incrby>).+--+-- /O(n)/ where /n/ is the number of items+--+-- Since RedisBloom 2.0.0+cmsincrby+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Count-Min Sketch.+ -> NonEmpty (ByteString, Integer) -- ^ Item and increment pairs.+ -> m (f [Integer])+cmsincrby key itemIncrements =+ sendRequest $ ["CMS.INCRBY", key] ++ concatMap encodeItemIncrement (NE.toList itemIncrements)+ where+ encodeItemIncrement (item, increment) = [item, encode increment]++-- |Returns information about a sketch (<https://redis.io/commands/cms.info>).+--+-- /O(1)/+--+-- Since RedisBloom 2.0.0+cmsinfo+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Count-Min Sketch.+ -> m (f CMSInfo)+cmsinfo key = sendRequest ["CMS.INFO", key]++-- |Initializes a Count-Min Sketch to dimensions specified by user (<https://redis.io/commands/cms.initbydim>).+--+-- /O(1)/+--+-- Since RedisBloom 2.0.0+cmsinitbydim+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Count-Min Sketch to create.+ -> Integer -- ^ Number of counters in each row.+ -> Integer -- ^ Number of counter rows.+ -> m (f Status)+cmsinitbydim key width depth =+ sendRequest ["CMS.INITBYDIM", key, encode width, encode depth]++-- |Initializes a Count-Min Sketch to accommodate requested tolerances (<https://redis.io/commands/cms.initbyprob>).+--+-- /O(1)/+--+-- Since RedisBloom 2.0.0+cmsinitbyprob+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Count-Min Sketch to create.+ -> Double -- ^ Error factor.+ -> Double -- ^ Probability of the error factor.+ -> m (f Status)+cmsinitbyprob key err probability =+ sendRequest ["CMS.INITBYPROB", key, encode err, encode probability]++-- |Merges several sketches into one sketch (<https://redis.io/commands/cms.merge>).+--+-- Source sketches are merged with the default weight of @1@.+--+-- /O(n)/ where /n/ is the number of sketches+--+-- Since RedisBloom 2.0.0+cmsmerge+ :: (RedisCtx m f)+ => ByteString -- ^ Destination sketch key.+ -> NonEmpty ByteString -- ^ Source sketch keys.+ -> m (f Status)+cmsmerge destination sourceKeys =+ cmsmergeOpts destination (CMSMergeUnweighted sourceKeys)++-- |Merges several sketches into one sketch (<https://redis.io/commands/cms.merge>).+--+-- /O(n)/ where /n/ is the number of sketches+--+-- Since RedisBloom 2.0.0+cmsmergeOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Destination sketch key.+ -> CMSMergeOpts -- ^ Source sketches with optional weights.+ -> m (f Status)+cmsmergeOpts destination opts =+ sendRequest $ ["CMS.MERGE", destination] ++ cmsMergeOptsToArgs opts++-- |Merges several sketches into one sketch (<https://redis.io/commands/cms.merge>).+--+-- /O(n)/ where /n/ is the number of sketches+--+-- Since RedisBloom 2.0.0+cmsmergeWeighted+ :: (RedisCtx m f)+ => ByteString -- ^ Destination sketch key.+ -> NonEmpty (ByteString, Integer) -- ^ Source sketch keys paired with weights.+ -> m (f Status)+cmsmergeWeighted destination weightedSourceKeys =+ cmsmergeOpts destination (CMSMergeWeighted weightedSourceKeys)++-- |Returns the count for one or more items in a sketch (<https://redis.io/commands/cms.query>).+--+-- /O(n)/ where /n/ is the number of items+--+-- Since RedisBloom 2.0.0+cmsquery+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Count-Min Sketch.+ -> NonEmpty ByteString -- ^ Items to query.+ -> m (f [Integer])+cmsquery key items = sendRequest $ ["CMS.QUERY", key] ++ NE.toList items
+ src/Database/Redis/ManualCommands/FT.hs view
@@ -0,0 +1,1397 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Database.Redis.ManualCommands.FT where++import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE++import Database.Redis.Core+import Database.Redis.ManualCommands (GeoUnit(..), SortOrder(..))+import Database.Redis.Protocol+import Database.Redis.Types++data FTOn+ = FTOnHash+ | FTOnJson+ deriving (Show, Eq)++instance RedisArg FTOn where+ encode FTOnHash = "HASH"+ encode FTOnJson = "JSON"++data FTIndexAllMode+ = FTIndexAllEnable+ | FTIndexAllDisable+ deriving (Show, Eq)++instance RedisArg FTIndexAllMode where+ encode FTIndexAllEnable = "ENABLE"+ encode FTIndexAllDisable = "DISABLE"++data FTFieldIdentifier+ = FTFieldName ByteString+ | FTFieldNameAs ByteString ByteString+ deriving (Show, Eq)++data FTSortable+ = FTSortable+ | FTSortableUnf+ deriving (Show, Eq)++data FTCommonFieldOpts = FTCommonFieldOpts+ { ftCommonFieldWithSuffixTrie :: Bool+ , ftCommonFieldIndexEmpty :: Bool+ , ftCommonFieldIndexMissing :: Bool+ , ftCommonFieldSortable :: Maybe FTSortable+ , ftCommonFieldNoIndex :: Bool+ } deriving (Show, Eq)++defaultFTCommonFieldOpts :: FTCommonFieldOpts+defaultFTCommonFieldOpts = FTCommonFieldOpts+ { ftCommonFieldWithSuffixTrie = False+ , ftCommonFieldIndexEmpty = False+ , ftCommonFieldIndexMissing = False+ , ftCommonFieldSortable = Nothing+ , ftCommonFieldNoIndex = False+ }++data FTTextFieldOpts = FTTextFieldOpts+ { ftTextFieldWeight :: Maybe Double+ , ftTextFieldNoStem :: Bool+ , ftTextFieldPhonetic :: Maybe ByteString+ , ftTextFieldCommonOpts :: FTCommonFieldOpts+ } deriving (Show, Eq)++defaultFTTextFieldOpts :: FTTextFieldOpts+defaultFTTextFieldOpts = FTTextFieldOpts+ { ftTextFieldWeight = Nothing+ , ftTextFieldNoStem = False+ , ftTextFieldPhonetic = Nothing+ , ftTextFieldCommonOpts = defaultFTCommonFieldOpts+ }++data FTTagFieldOpts = FTTagFieldOpts+ { ftTagFieldSeparator :: Maybe ByteString+ , ftTagFieldCaseSensitive :: Bool+ , ftTagFieldCommonOpts :: FTCommonFieldOpts+ } deriving (Show, Eq)++defaultFTTagFieldOpts :: FTTagFieldOpts+defaultFTTagFieldOpts = FTTagFieldOpts+ { ftTagFieldSeparator = Nothing+ , ftTagFieldCaseSensitive = False+ , ftTagFieldCommonOpts = defaultFTCommonFieldOpts+ }++data FTGeoShapeFieldOpts = FTGeoShapeFieldOpts+ { ftGeoShapeFieldCoordSystem :: Maybe ByteString+ , ftGeoShapeFieldCommonOpts :: FTCommonFieldOpts+ } deriving (Show, Eq)++defaultFTGeoShapeFieldOpts :: FTGeoShapeFieldOpts+defaultFTGeoShapeFieldOpts = FTGeoShapeFieldOpts+ { ftGeoShapeFieldCoordSystem = Nothing+ , ftGeoShapeFieldCommonOpts = defaultFTCommonFieldOpts+ }++data FTVectorFieldOpts = FTVectorFieldOpts+ { ftVectorFieldAlgorithm :: ByteString+ , ftVectorFieldAttributes :: NonEmpty (ByteString, ByteString)+ , ftVectorFieldCommonOpts :: FTCommonFieldOpts+ } deriving (Show, Eq)++data FTCreateField+ = FTCreateTextField FTFieldIdentifier FTTextFieldOpts+ | FTCreateTagField FTFieldIdentifier FTTagFieldOpts+ | FTCreateNumericField FTFieldIdentifier FTCommonFieldOpts+ | FTCreateGeoField FTFieldIdentifier FTCommonFieldOpts+ | FTCreateGeoShapeField FTFieldIdentifier FTGeoShapeFieldOpts+ | FTCreateVectorField FTFieldIdentifier FTVectorFieldOpts+ deriving (Show, Eq)++data FTCreateOpts = FTCreateOpts+ { ftCreateOn :: Maybe FTOn+ , ftCreateIndexAll :: Maybe FTIndexAllMode+ , ftCreatePrefixes :: [ByteString]+ , ftCreateFilter :: Maybe ByteString+ , ftCreateLanguage :: Maybe ByteString+ , ftCreateLanguageField :: Maybe ByteString+ , ftCreateScore :: Maybe Double+ , ftCreateScoreField :: Maybe ByteString+ , ftCreatePayloadField :: Maybe ByteString+ , ftCreateMaxTextFields :: Bool+ , ftCreateTemporarySeconds :: Maybe Double+ , ftCreateNoOffsets :: Bool+ , ftCreateNoHl :: Bool+ , ftCreateNoFields :: Bool+ , ftCreateNoFreqs :: Bool+ , ftCreateStopwords :: Maybe [ByteString]+ , ftCreateSkipInitialScan :: Bool+ } deriving (Show, Eq)++defaultFTCreateOpts :: FTCreateOpts+defaultFTCreateOpts = FTCreateOpts+ { ftCreateOn = Nothing+ , ftCreateIndexAll = Nothing+ , ftCreatePrefixes = []+ , ftCreateFilter = Nothing+ , ftCreateLanguage = Nothing+ , ftCreateLanguageField = Nothing+ , ftCreateScore = Nothing+ , ftCreateScoreField = Nothing+ , ftCreatePayloadField = Nothing+ , ftCreateMaxTextFields = False+ , ftCreateTemporarySeconds = Nothing+ , ftCreateNoOffsets = False+ , ftCreateNoHl = False+ , ftCreateNoFields = False+ , ftCreateNoFreqs = False+ , ftCreateStopwords = Nothing+ , ftCreateSkipInitialScan = False+ }++data FTAlterOpts = FTAlterOpts+ { ftAlterSkipInitialScan :: Bool+ } deriving (Show, Eq)++defaultFTAlterOpts :: FTAlterOpts+defaultFTAlterOpts = FTAlterOpts+ { ftAlterSkipInitialScan = False+ }++data FTExplainOpts = FTExplainOpts+ { ftExplainDialect :: Maybe Integer+ } deriving (Show, Eq)++defaultFTExplainOpts :: FTExplainOpts+defaultFTExplainOpts = FTExplainOpts+ { ftExplainDialect = Nothing+ }++data FTSearchContentMode+ = FTSearchReturnDocuments+ | FTSearchReturnIdsOnly+ deriving (Show, Eq)++data FTSearchScoreMode+ = FTSearchNoScores+ | FTSearchWithScores+ | FTSearchWithExplainScore+ deriving (Show, Eq)++data FTSearchPayloadMode+ = FTSearchNoPayloads+ | FTSearchWithPayloads+ deriving (Show, Eq)++data FTSearchSortKeysMode+ = FTSearchNoSortKeys+ | FTSearchWithSortKeys+ deriving (Show, Eq)++data FTReturnField+ = FTReturnField ByteString+ | FTReturnFieldAs ByteString ByteString+ deriving (Show, Eq)++data FTSummarizeOpts = FTSummarizeOpts+ { ftSummarizeFields :: [ByteString]+ , ftSummarizeFrags :: Maybe Integer+ , ftSummarizeLen :: Maybe Integer+ , ftSummarizeSeparator :: Maybe ByteString+ } deriving (Show, Eq)++defaultFTSummarizeOpts :: FTSummarizeOpts+defaultFTSummarizeOpts = FTSummarizeOpts+ { ftSummarizeFields = []+ , ftSummarizeFrags = Nothing+ , ftSummarizeLen = Nothing+ , ftSummarizeSeparator = Nothing+ }++data FTHighlightOpts = FTHighlightOpts+ { ftHighlightFields :: [ByteString]+ , ftHighlightTags :: Maybe (ByteString, ByteString)+ } deriving (Show, Eq)++defaultFTHighlightOpts :: FTHighlightOpts+defaultFTHighlightOpts = FTHighlightOpts+ { ftHighlightFields = []+ , ftHighlightTags = Nothing+ }++data FTNumericFilter = FTNumericFilter+ { ftNumericFilterField :: ByteString+ , ftNumericFilterMin :: Double+ , ftNumericFilterMax :: Double+ } deriving (Show, Eq)++data FTGeoFilter = FTGeoFilter+ { ftGeoFilterField :: ByteString+ , ftGeoFilterLongitude :: Double+ , ftGeoFilterLatitude :: Double+ , ftGeoFilterRadius :: Double+ , ftGeoFilterUnit :: GeoUnit+ } deriving (Show, Eq)++data FTSortBy = FTSortBy+ { ftSortByField :: ByteString+ , ftSortByOrder :: Maybe SortOrder+ } deriving (Show, Eq)++data FTSearchOpts = FTSearchOpts+ { ftSearchContentMode :: FTSearchContentMode+ , ftSearchVerbatim :: Bool+ , ftSearchNoStopWords :: Bool+ , ftSearchScoreMode :: FTSearchScoreMode+ , ftSearchPayloadMode :: FTSearchPayloadMode+ , ftSearchSortKeysMode :: FTSearchSortKeysMode+ , ftSearchNumericFilters :: [FTNumericFilter]+ , ftSearchGeoFilters :: [FTGeoFilter]+ , ftSearchInKeys :: [ByteString]+ , ftSearchInFields :: [ByteString]+ , ftSearchReturnFields :: [FTReturnField]+ , ftSearchSummarize :: Maybe FTSummarizeOpts+ , ftSearchHighlight :: Maybe FTHighlightOpts+ , ftSearchSlop :: Maybe Integer+ , ftSearchTimeout :: Maybe Integer+ , ftSearchInOrder :: Bool+ , ftSearchLanguage :: Maybe ByteString+ , ftSearchExpander :: Maybe ByteString+ , ftSearchScorer :: Maybe ByteString+ , ftSearchPayload :: Maybe ByteString+ , ftSearchSortBy :: Maybe FTSortBy+ , ftSearchLimit :: Maybe (Integer, Integer)+ , ftSearchParams :: [(ByteString, ByteString)]+ , ftSearchDialect :: Maybe Integer+ } deriving (Show, Eq)++defaultFTSearchOpts :: FTSearchOpts+defaultFTSearchOpts = FTSearchOpts+ { ftSearchContentMode = FTSearchReturnDocuments+ , ftSearchVerbatim = False+ , ftSearchNoStopWords = False+ , ftSearchScoreMode = FTSearchNoScores+ , ftSearchPayloadMode = FTSearchNoPayloads+ , ftSearchSortKeysMode = FTSearchNoSortKeys+ , ftSearchNumericFilters = []+ , ftSearchGeoFilters = []+ , ftSearchInKeys = []+ , ftSearchInFields = []+ , ftSearchReturnFields = []+ , ftSearchSummarize = Nothing+ , ftSearchHighlight = Nothing+ , ftSearchSlop = Nothing+ , ftSearchTimeout = Nothing+ , ftSearchInOrder = False+ , ftSearchLanguage = Nothing+ , ftSearchExpander = Nothing+ , ftSearchScorer = Nothing+ , ftSearchPayload = Nothing+ , ftSearchSortBy = Nothing+ , ftSearchLimit = Nothing+ , ftSearchParams = []+ , ftSearchDialect = Nothing+ }++data FTAggregateLoad+ = FTAggregateLoadAll+ | FTAggregateLoadFields (NonEmpty ByteString)+ deriving (Show, Eq)++data FTSortProperty = FTSortProperty+ { ftSortPropertyName :: ByteString+ , ftSortPropertyOrder :: Maybe SortOrder+ } deriving (Show, Eq)++data FTReduce = FTReduce+ { ftReduceFunction :: ByteString+ , ftReduceArgs :: [ByteString]+ , ftReduceAlias :: Maybe ByteString+ } deriving (Show, Eq)++data FTGroupBy = FTGroupBy+ { ftGroupByProperties :: NonEmpty ByteString+ , ftGroupByReducers :: [FTReduce]+ } deriving (Show, Eq)++data FTApply = FTApply+ { ftApplyExpression :: ByteString+ , ftApplyAlias :: Maybe ByteString+ } deriving (Show, Eq)++data FTCursorOpts = FTCursorOpts+ { ftCursorCount :: Maybe Integer+ , ftCursorMaxIdle :: Maybe Integer+ } deriving (Show, Eq)++defaultFTCursorOpts :: FTCursorOpts+defaultFTCursorOpts = FTCursorOpts+ { ftCursorCount = Nothing+ , ftCursorMaxIdle = Nothing+ }++data FTAggregateOpts = FTAggregateOpts+ { ftAggregateVerbatim :: Bool+ , ftAggregateLoad :: Maybe FTAggregateLoad+ , ftAggregateTimeout :: Maybe Integer+ , ftAggregateGroupBy :: [FTGroupBy]+ , ftAggregateSortBy :: Maybe (NonEmpty FTSortProperty, Maybe Integer)+ , ftAggregateApply :: [FTApply]+ , ftAggregateLimit :: Maybe (Integer, Integer)+ , ftAggregateFilter :: Maybe ByteString+ , ftAggregateCursor :: Maybe FTCursorOpts+ , ftAggregateParams :: [(ByteString, ByteString)]+ , ftAggregateDialect :: Maybe Integer+ } deriving (Show, Eq)++defaultFTAggregateOpts :: FTAggregateOpts+defaultFTAggregateOpts = FTAggregateOpts+ { ftAggregateVerbatim = False+ , ftAggregateLoad = Nothing+ , ftAggregateTimeout = Nothing+ , ftAggregateGroupBy = []+ , ftAggregateSortBy = Nothing+ , ftAggregateApply = []+ , ftAggregateLimit = Nothing+ , ftAggregateFilter = Nothing+ , ftAggregateCursor = Nothing+ , ftAggregateParams = []+ , ftAggregateDialect = Nothing+ }++data FTHybridSearchClause = FTHybridSearchClause+ { ftHybridSearchQuery :: ByteString+ , ftHybridSearchScorer :: Maybe ByteString+ , ftHybridSearchYieldScoreAs :: Maybe ByteString+ } deriving (Show, Eq)++data FTHybridVectorQuery+ = FTHybridKnn+ { ftHybridKnnCount :: Integer+ , ftHybridKnnK :: Integer+ , ftHybridKnnEfRuntime :: Maybe Integer+ , ftHybridKnnYieldScoreAs :: Maybe ByteString+ }+ | FTHybridRange+ { ftHybridRangeCount :: Integer+ , ftHybridRangeRadius :: Double+ , ftHybridRangeEpsilon :: Maybe Double+ , ftHybridRangeYieldScoreAs :: Maybe ByteString+ }+ deriving (Show, Eq)++data FTHybridVSimClause = FTHybridVSimClause+ { ftHybridVSimField :: ByteString+ , ftHybridVSimVector :: ByteString+ , ftHybridVSimQuery :: Maybe FTHybridVectorQuery+ , ftHybridVSimFilter :: Maybe ByteString+ } deriving (Show, Eq)++data FTHybridCombine+ = FTHybridCombineRRF+ { ftHybridRrfCount :: Integer+ , ftHybridRrfConstant :: Maybe Double+ , ftHybridRrfWindow :: Maybe Integer+ , ftHybridRrfYieldScoreAs :: Maybe ByteString+ }+ | FTHybridCombineLinear+ { ftHybridLinearCount :: Integer+ , ftHybridLinearAlphaBeta :: Maybe (Double, Double)+ , ftHybridLinearWindow :: Maybe Integer+ , ftHybridLinearYieldScoreAs :: Maybe ByteString+ }+ deriving (Show, Eq)++data FTHybridSort+ = FTHybridSortBy ByteString (Maybe SortOrder)+ | FTHybridNoSort+ deriving (Show, Eq)++data FTHybridLoad+ = FTHybridLoadFields (NonEmpty ByteString)+ | FTHybridLoadAll+ deriving (Show, Eq)++data FTHybridOpts = FTHybridOpts+ { ftHybridCombine :: Maybe FTHybridCombine+ , ftHybridLimit :: Maybe (Integer, Integer)+ , ftHybridSorting :: Maybe FTHybridSort+ , ftHybridParams :: [(ByteString, ByteString)]+ , ftHybridTimeout :: Maybe Integer+ , ftHybridFormat :: Maybe ByteString+ , ftHybridLoad :: Maybe FTHybridLoad+ , ftHybridGroupBy :: [FTGroupBy]+ , ftHybridApply :: [FTApply]+ , ftHybridFilter :: Maybe ByteString+ , ftHybridDialect :: Maybe Integer+ } deriving (Show, Eq)++defaultFTHybridOpts :: FTHybridOpts+defaultFTHybridOpts = FTHybridOpts+ { ftHybridCombine = Nothing+ , ftHybridLimit = Nothing+ , ftHybridSorting = Nothing+ , ftHybridParams = []+ , ftHybridTimeout = Nothing+ , ftHybridFormat = Nothing+ , ftHybridLoad = Nothing+ , ftHybridGroupBy = []+ , ftHybridApply = []+ , ftHybridFilter = Nothing+ , ftHybridDialect = Nothing+ }++data FTProfileQueryType+ = FTProfileSearch+ | FTProfileHybrid+ | FTProfileAggregate+ deriving (Show, Eq)++instance RedisArg FTProfileQueryType where+ encode FTProfileSearch = "SEARCH"+ encode FTProfileHybrid = "HYBRID"+ encode FTProfileAggregate = "AGGREGATE"++data FTProfileOpts = FTProfileOpts+ { ftProfileLimited :: Bool+ } deriving (Show, Eq)++defaultFTProfileOpts :: FTProfileOpts+defaultFTProfileOpts = FTProfileOpts+ { ftProfileLimited = False+ }++data FTSpellcheckTermsMode+ = FTSpellcheckInclude ByteString [ByteString]+ | FTSpellcheckExclude ByteString [ByteString]+ deriving (Show, Eq)++data FTSpellcheckOpts = FTSpellcheckOpts+ { ftSpellcheckDistance :: Maybe Integer+ , ftSpellcheckTermsMode :: Maybe FTSpellcheckTermsMode+ , ftSpellcheckDialect :: Maybe Integer+ } deriving (Show, Eq)++defaultFTSpellcheckOpts :: FTSpellcheckOpts+defaultFTSpellcheckOpts = FTSpellcheckOpts+ { ftSpellcheckDistance = Nothing+ , ftSpellcheckTermsMode = Nothing+ , ftSpellcheckDialect = Nothing+ }++data FTSugAddOpts+ = FTSugAddDefault+ | FTSugAddWithPayload ByteString+ | FTSugAddIncrement+ | FTSugAddIncrementWithPayload ByteString+ deriving (Show, Eq)++data FTCursorReadOpts = FTCursorReadOpts+ { ftCursorReadCount :: Maybe Integer+ } deriving (Show, Eq)++defaultFTCursorReadOpts :: FTCursorReadOpts+defaultFTCursorReadOpts = FTCursorReadOpts+ { ftCursorReadCount = Nothing+ }++countArgs :: [a] -> ByteString+countArgs = encode . (fromIntegral :: Int -> Integer) . length++fieldIdentifierToArgs :: FTFieldIdentifier -> [ByteString]+fieldIdentifierToArgs (FTFieldName name) = [name]+fieldIdentifierToArgs (FTFieldNameAs name alias) = [name, "AS", alias]++sortableToArgs :: FTSortable -> [ByteString]+sortableToArgs FTSortable = ["SORTABLE"]+sortableToArgs FTSortableUnf = ["SORTABLE", "UNF"]++commonFieldOptsToArgs :: FTCommonFieldOpts -> [ByteString]+commonFieldOptsToArgs FTCommonFieldOpts{..} =+ withSuffixTrieArg ++ indexEmptyArg ++ indexMissingArg ++ sortableArg ++ noIndexArg+ where+ withSuffixTrieArg = ["WITHSUFFIXTRIE" | ftCommonFieldWithSuffixTrie]+ indexEmptyArg = ["INDEXEMPTY" | ftCommonFieldIndexEmpty]+ indexMissingArg = ["INDEXMISSING" | ftCommonFieldIndexMissing]+ sortableArg = maybe [] sortableToArgs ftCommonFieldSortable+ noIndexArg = ["NOINDEX" | ftCommonFieldNoIndex]++createFieldToArgs :: FTCreateField -> [ByteString]+createFieldToArgs field =+ case field of+ FTCreateTextField identifier FTTextFieldOpts{..} ->+ fieldIdentifierToArgs identifier+ ++ ["TEXT"]+ ++ maybe [] (\weight -> ["WEIGHT", encode weight]) ftTextFieldWeight+ ++ ["NOSTEM" | ftTextFieldNoStem]+ ++ maybe [] (\matcher -> ["PHONETIC", matcher]) ftTextFieldPhonetic+ ++ commonFieldOptsToArgs ftTextFieldCommonOpts+ FTCreateTagField identifier FTTagFieldOpts{..} ->+ fieldIdentifierToArgs identifier+ ++ ["TAG"]+ ++ maybe [] (\separator -> ["SEPARATOR", separator]) ftTagFieldSeparator+ ++ ["CASESENSITIVE" | ftTagFieldCaseSensitive]+ ++ commonFieldOptsToArgs ftTagFieldCommonOpts+ FTCreateNumericField identifier opts ->+ fieldIdentifierToArgs identifier ++ ["NUMERIC"] ++ commonFieldOptsToArgs opts+ FTCreateGeoField identifier opts ->+ fieldIdentifierToArgs identifier ++ ["GEO"] ++ commonFieldOptsToArgs opts+ FTCreateGeoShapeField identifier FTGeoShapeFieldOpts{..} ->+ fieldIdentifierToArgs identifier+ ++ ["GEOSHAPE"]+ ++ maybe [] (\coordSystem -> ["COORD_SYSTEM", coordSystem]) ftGeoShapeFieldCoordSystem+ ++ commonFieldOptsToArgs ftGeoShapeFieldCommonOpts+ FTCreateVectorField identifier FTVectorFieldOpts{..} ->+ fieldIdentifierToArgs identifier+ ++ [ "VECTOR"+ , ftVectorFieldAlgorithm+ , countArgs (NE.toList ftVectorFieldAttributes)+ ]+ ++ concatMap (\(name, value) -> [name, value]) (NE.toList ftVectorFieldAttributes)+ ++ commonFieldOptsToArgs ftVectorFieldCommonOpts++ftCreateOptsToArgs :: FTCreateOpts -> [ByteString]+ftCreateOptsToArgs FTCreateOpts{..} =+ onArg+ ++ indexAllArg+ ++ prefixesArg+ ++ filterArg+ ++ languageArg+ ++ languageFieldArg+ ++ scoreArg+ ++ scoreFieldArg+ ++ payloadFieldArg+ ++ maxTextFieldsArg+ ++ temporaryArg+ ++ noOffsetsArg+ ++ noHlArg+ ++ noFieldsArg+ ++ noFreqsArg+ ++ stopwordsArg+ ++ skipInitialScanArg+ where+ onArg = maybe [] (\dataType -> ["ON", encode dataType]) ftCreateOn+ indexAllArg = maybe [] (\mode -> ["INDEXALL", encode mode]) ftCreateIndexAll+ prefixesArg =+ if null ftCreatePrefixes+ then []+ else ["PREFIX", countArgs ftCreatePrefixes] ++ ftCreatePrefixes+ filterArg = maybe [] (\filterExpr -> ["FILTER", filterExpr]) ftCreateFilter+ languageArg = maybe [] (\lang -> ["LANGUAGE", lang]) ftCreateLanguage+ languageFieldArg = maybe [] (\field -> ["LANGUAGE_FIELD", field]) ftCreateLanguageField+ scoreArg = maybe [] (\score -> ["SCORE", encode score]) ftCreateScore+ scoreFieldArg = maybe [] (\field -> ["SCORE_FIELD", field]) ftCreateScoreField+ payloadFieldArg = maybe [] (\field -> ["PAYLOAD_FIELD", field]) ftCreatePayloadField+ maxTextFieldsArg = ["MAXTEXTFIELDS" | ftCreateMaxTextFields]+ temporaryArg = maybe [] (\seconds -> ["TEMPORARY", encode seconds]) ftCreateTemporarySeconds+ noOffsetsArg = ["NOOFFSETS" | ftCreateNoOffsets]+ noHlArg = ["NOHL" | ftCreateNoHl]+ noFieldsArg = ["NOFIELDS" | ftCreateNoFields]+ noFreqsArg = ["NOFREQS" | ftCreateNoFreqs]+ stopwordsArg = maybe [] (\words' -> ["STOPWORDS", countArgs words'] ++ words') ftCreateStopwords+ skipInitialScanArg = ["SKIPINITIALSCAN" | ftCreateSkipInitialScan]++ftAlterOptsToArgs :: FTAlterOpts -> [ByteString]+ftAlterOptsToArgs FTAlterOpts{..} =+ ["SKIPINITIALSCAN" | ftAlterSkipInitialScan]++ftExplainOptsToArgs :: FTExplainOpts -> [ByteString]+ftExplainOptsToArgs FTExplainOpts{..} =+ maybe [] (\dialect -> ["DIALECT", encode dialect]) ftExplainDialect++returnFieldToArgs :: FTReturnField -> [ByteString]+returnFieldToArgs (FTReturnField identifier) = [identifier]+returnFieldToArgs (FTReturnFieldAs identifier alias) = [identifier, "AS", alias]++summarizeOptsToArgs :: FTSummarizeOpts -> [ByteString]+summarizeOptsToArgs FTSummarizeOpts{..} =+ ["SUMMARIZE"]+ ++ fieldsArg+ ++ fragsArg+ ++ lenArg+ ++ separatorArg+ where+ fieldsArg =+ if null ftSummarizeFields+ then []+ else ["FIELDS", countArgs ftSummarizeFields] ++ ftSummarizeFields+ fragsArg = maybe [] (\frags -> ["FRAGS", encode frags]) ftSummarizeFrags+ lenArg = maybe [] (\len -> ["LEN", encode len]) ftSummarizeLen+ separatorArg = maybe [] (\separator -> ["SEPARATOR", separator]) ftSummarizeSeparator++highlightOptsToArgs :: FTHighlightOpts -> [ByteString]+highlightOptsToArgs FTHighlightOpts{..} =+ ["HIGHLIGHT"] ++ fieldsArg ++ tagsArg+ where+ fieldsArg =+ if null ftHighlightFields+ then []+ else ["FIELDS", countArgs ftHighlightFields] ++ ftHighlightFields+ tagsArg = maybe [] (\(openTag, closeTag) -> ["TAGS", openTag, closeTag]) ftHighlightTags++numericFilterToArgs :: FTNumericFilter -> [ByteString]+numericFilterToArgs FTNumericFilter{..} =+ [ "FILTER"+ , ftNumericFilterField+ , encode ftNumericFilterMin+ , encode ftNumericFilterMax+ ]++geoFilterToArgs :: FTGeoFilter -> [ByteString]+geoFilterToArgs FTGeoFilter{..} =+ [ "GEOFILTER"+ , ftGeoFilterField+ , encode ftGeoFilterLongitude+ , encode ftGeoFilterLatitude+ , encode ftGeoFilterRadius+ , encode ftGeoFilterUnit+ ]++sortByToArgs :: FTSortBy -> [ByteString]+sortByToArgs FTSortBy{..} =+ ["SORTBY", ftSortByField] ++ maybe [] (\order -> [encodeSortOrder order]) ftSortByOrder+ where+ encodeSortOrder Asc = "ASC"+ encodeSortOrder Desc = "DESC"++ftSearchOptsToArgs :: FTSearchOpts -> [ByteString]+ftSearchOptsToArgs FTSearchOpts{..} =+ contentArg+ ++ verbatimArg+ ++ noStopWordsArg+ ++ scoreArg+ ++ payloadsArg+ ++ sortKeysArg+ ++ concatMap numericFilterToArgs ftSearchNumericFilters+ ++ concatMap geoFilterToArgs ftSearchGeoFilters+ ++ inKeysArg+ ++ inFieldsArg+ ++ returnArg+ ++ maybe [] summarizeOptsToArgs ftSearchSummarize+ ++ maybe [] highlightOptsToArgs ftSearchHighlight+ ++ slopArg+ ++ timeoutArg+ ++ inOrderArg+ ++ languageArg+ ++ expanderArg+ ++ scorerArg+ ++ payloadArg+ ++ sortByArg+ ++ limitArg+ ++ paramsArg+ ++ dialectArg+ where+ contentArg = ["NOCONTENT" | ftSearchContentMode == FTSearchReturnIdsOnly]+ verbatimArg = ["VERBATIM" | ftSearchVerbatim]+ noStopWordsArg = ["NOSTOPWORDS" | ftSearchNoStopWords]+ scoreArg = case ftSearchScoreMode of+ FTSearchNoScores -> []+ FTSearchWithScores -> ["WITHSCORES"]+ FTSearchWithExplainScore -> ["WITHSCORES", "EXPLAINSCORE"]+ payloadsArg = ["WITHPAYLOADS" | ftSearchPayloadMode == FTSearchWithPayloads]+ sortKeysArg = ["WITHSORTKEYS" | ftSearchSortKeysMode == FTSearchWithSortKeys]+ inKeysArg =+ if null ftSearchInKeys+ then []+ else ["INKEYS", countArgs ftSearchInKeys] ++ ftSearchInKeys+ inFieldsArg =+ if null ftSearchInFields+ then []+ else ["INFIELDS", countArgs ftSearchInFields] ++ ftSearchInFields+ returnArg =+ if null ftSearchReturnFields+ then []+ else ["RETURN", countArgs ftSearchReturnFields] ++ concatMap returnFieldToArgs ftSearchReturnFields+ slopArg = maybe [] (\slop -> ["SLOP", encode slop]) ftSearchSlop+ timeoutArg = maybe [] (\timeout -> ["TIMEOUT", encode timeout]) ftSearchTimeout+ inOrderArg = ["INORDER" | ftSearchInOrder]+ languageArg = maybe [] (\language -> ["LANGUAGE", language]) ftSearchLanguage+ expanderArg = maybe [] (\expander -> ["EXPANDER", expander]) ftSearchExpander+ scorerArg = maybe [] (\scorer -> ["SCORER", scorer]) ftSearchScorer+ payloadArg = maybe [] (\payload -> ["PAYLOAD", payload]) ftSearchPayload+ sortByArg = maybe [] sortByToArgs ftSearchSortBy+ limitArg = maybe [] (\(offset, num) -> ["LIMIT", encode offset, encode num]) ftSearchLimit+ paramsArg =+ if null ftSearchParams+ then []+ else ["PARAMS", encode (fromIntegral (2 * length ftSearchParams) :: Integer)]+ ++ concatMap (\(name, value) -> [name, value]) ftSearchParams+ dialectArg = maybe [] (\dialect -> ["DIALECT", encode dialect]) ftSearchDialect++aggregateLoadToArgs :: FTAggregateLoad -> [ByteString]+aggregateLoadToArgs FTAggregateLoadAll = ["LOAD", "*"]+aggregateLoadToArgs (FTAggregateLoadFields fields) =+ ["LOAD", countArgs (NE.toList fields)] ++ NE.toList fields++sortPropertyToArgs :: FTSortProperty -> [ByteString]+sortPropertyToArgs FTSortProperty{..} =+ [ftSortPropertyName] ++ maybe [] (\order -> [encodeSortOrder order]) ftSortPropertyOrder+ where+ encodeSortOrder Asc = "ASC"+ encodeSortOrder Desc = "DESC"++reduceToArgs :: FTReduce -> [ByteString]+reduceToArgs FTReduce{..} =+ [ "REDUCE"+ , ftReduceFunction+ , encode (fromIntegral (length ftReduceArgs) :: Integer)+ ]+ ++ ftReduceArgs+ ++ maybe [] (\alias -> ["AS", alias]) ftReduceAlias++groupByToArgs :: FTGroupBy -> [ByteString]+groupByToArgs FTGroupBy{..} =+ [ "GROUPBY"+ , encode (fromIntegral (NE.length ftGroupByProperties) :: Integer)+ ]+ ++ NE.toList ftGroupByProperties+ ++ concatMap reduceToArgs ftGroupByReducers++applyToArgs :: FTApply -> [ByteString]+applyToArgs FTApply{..} =+ ["APPLY", ftApplyExpression] ++ maybe [] (\alias -> ["AS", alias]) ftApplyAlias++cursorOptsToArgs :: FTCursorOpts -> [ByteString]+cursorOptsToArgs FTCursorOpts{..} =+ ["WITHCURSOR"] ++ countArg ++ maxIdleArg+ where+ countArg = maybe [] (\count -> ["COUNT", encode count]) ftCursorCount+ maxIdleArg = maybe [] (\maxIdle -> ["MAXIDLE", encode maxIdle]) ftCursorMaxIdle++ftAggregateOptsToArgs :: FTAggregateOpts -> [ByteString]+ftAggregateOptsToArgs FTAggregateOpts{..} =+ verbatimArg+ ++ maybe [] aggregateLoadToArgs ftAggregateLoad+ ++ timeoutArg+ ++ concatMap groupByToArgs ftAggregateGroupBy+ ++ sortByArg+ ++ concatMap applyToArgs ftAggregateApply+ ++ limitArg+ ++ filterArg+ ++ maybe [] cursorOptsToArgs ftAggregateCursor+ ++ paramsArg+ ++ dialectArg+ where+ verbatimArg = ["VERBATIM" | ftAggregateVerbatim]+ timeoutArg = maybe [] (\timeout -> ["TIMEOUT", encode timeout]) ftAggregateTimeout+ sortByArg = maybe [] encodeSortBy ftAggregateSortBy+ encodeSortBy (properties, maxResults) =+ [ "SORTBY"+ , encode (fromIntegral (NE.length properties) :: Integer)+ ]+ ++ concatMap sortPropertyToArgs (NE.toList properties)+ ++ maybe [] (\max' -> ["MAX", encode max']) maxResults+ limitArg = maybe [] (\(offset, num) -> ["LIMIT", encode offset, encode num]) ftAggregateLimit+ filterArg = maybe [] (\expr -> ["FILTER", expr]) ftAggregateFilter+ paramsArg =+ if null ftAggregateParams+ then []+ else ["PARAMS", encode (fromIntegral (2 * length ftAggregateParams) :: Integer)]+ ++ concatMap (\(name, value) -> [name, value]) ftAggregateParams+ dialectArg = maybe [] (\dialect -> ["DIALECT", encode dialect]) ftAggregateDialect++hybridVectorQueryToArgs :: FTHybridVectorQuery -> [ByteString]+hybridVectorQueryToArgs FTHybridKnn{..} =+ [ "KNN"+ , encode ftHybridKnnCount+ , "K"+ , encode ftHybridKnnK+ ]+ ++ maybe [] (\efRuntime -> ["EF_RUNTIME", encode efRuntime]) ftHybridKnnEfRuntime+ ++ maybe [] (\name -> ["YIELD_SCORE_AS", name]) ftHybridKnnYieldScoreAs+hybridVectorQueryToArgs FTHybridRange{..} =+ [ "RANGE"+ , encode ftHybridRangeCount+ , "RADIUS"+ , encode ftHybridRangeRadius+ ]+ ++ maybe [] (\epsilon -> ["EPSILON", encode epsilon]) ftHybridRangeEpsilon+ ++ maybe [] (\name -> ["YIELD_SCORE_AS", name]) ftHybridRangeYieldScoreAs++hybridSearchClauseToArgs :: FTHybridSearchClause -> [ByteString]+hybridSearchClauseToArgs FTHybridSearchClause{..} =+ [ "SEARCH"+ , ftHybridSearchQuery+ ]+ ++ maybe [] (\scorer -> ["SCORER", scorer]) ftHybridSearchScorer+ ++ maybe [] (\name -> ["YIELD_SCORE_AS", name]) ftHybridSearchYieldScoreAs++hybridVSimClauseToArgs :: FTHybridVSimClause -> [ByteString]+hybridVSimClauseToArgs FTHybridVSimClause{..} =+ [ "VSIM"+ , ftHybridVSimField+ , ftHybridVSimVector+ ]+ ++ maybe [] hybridVectorQueryToArgs ftHybridVSimQuery+ ++ maybe [] (\expr -> ["FILTER", expr]) ftHybridVSimFilter++hybridCombineToArgs :: FTHybridCombine -> [ByteString]+hybridCombineToArgs FTHybridCombineRRF{..} =+ [ "COMBINE"+ , "RRF"+ , encode ftHybridRrfCount+ ]+ ++ maybe [] (\constant -> ["CONSTANT", encode constant]) ftHybridRrfConstant+ ++ maybe [] (\window -> ["WINDOW", encode window]) ftHybridRrfWindow+ ++ maybe [] (\name -> ["YIELD_SCORE_AS", name]) ftHybridRrfYieldScoreAs+hybridCombineToArgs FTHybridCombineLinear{..} =+ [ "COMBINE"+ , "LINEAR"+ , encode ftHybridLinearCount+ ]+ ++ maybe [] (\(alpha, beta) -> ["ALPHA", encode alpha, "BETA", encode beta]) ftHybridLinearAlphaBeta+ ++ maybe [] (\window -> ["WINDOW", encode window]) ftHybridLinearWindow+ ++ maybe [] (\name -> ["YIELD_SCORE_AS", name]) ftHybridLinearYieldScoreAs++hybridSortToArgs :: FTHybridSort -> [ByteString]+hybridSortToArgs FTHybridNoSort = ["NOSORT"]+hybridSortToArgs (FTHybridSortBy field order) =+ ["SORTBY", field] ++ maybe [] (\sortOrder -> [encodeSortOrder sortOrder]) order+ where+ encodeSortOrder Asc = "ASC"+ encodeSortOrder Desc = "DESC"++hybridLoadToArgs :: FTHybridLoad -> [ByteString]+hybridLoadToArgs FTHybridLoadAll = ["LOAD", "*"]+hybridLoadToArgs (FTHybridLoadFields fields) =+ ["LOAD", countArgs (NE.toList fields)] ++ NE.toList fields++ftHybridOptsToArgs :: FTHybridOpts -> [ByteString]+ftHybridOptsToArgs FTHybridOpts{..} =+ maybe [] hybridCombineToArgs ftHybridCombine+ ++ limitArg+ ++ maybe [] hybridSortToArgs ftHybridSorting+ ++ paramsArg+ ++ timeoutArg+ ++ formatArg+ ++ maybe [] hybridLoadToArgs ftHybridLoad+ ++ concatMap groupByToArgs ftHybridGroupBy+ ++ concatMap applyToArgs ftHybridApply+ ++ filterArg+ ++ dialectArg+ where+ limitArg = maybe [] (\(offset, num) -> ["LIMIT", encode offset, encode num]) ftHybridLimit+ paramsArg =+ if null ftHybridParams+ then []+ else ["PARAMS", encode (fromIntegral (2 * length ftHybridParams) :: Integer)]+ ++ concatMap (\(name, value) -> [name, value]) ftHybridParams+ timeoutArg = maybe [] (\timeout -> ["TIMEOUT", encode timeout]) ftHybridTimeout+ formatArg = maybe [] (\format -> ["FORMAT", format]) ftHybridFormat+ filterArg = maybe [] (\expr -> ["FILTER", expr]) ftHybridFilter+ dialectArg = maybe [] (\dialect -> ["DIALECT", encode dialect]) ftHybridDialect++ftProfileOptsToArgs :: FTProfileOpts -> [ByteString]+ftProfileOptsToArgs FTProfileOpts{..} =+ ["LIMITED" | ftProfileLimited]++spellcheckTermsModeToArgs :: FTSpellcheckTermsMode -> [ByteString]+spellcheckTermsModeToArgs termsMode =+ case termsMode of+ FTSpellcheckInclude dictionary terms ->+ ["TERMS", "INCLUDE", dictionary] ++ terms+ FTSpellcheckExclude dictionary terms ->+ ["TERMS", "EXCLUDE", dictionary] ++ terms++ftSpellcheckOptsToArgs :: FTSpellcheckOpts -> [ByteString]+ftSpellcheckOptsToArgs FTSpellcheckOpts{..} =+ distanceArg+ ++ maybe [] spellcheckTermsModeToArgs ftSpellcheckTermsMode+ ++ dialectArg+ where+ distanceArg = maybe [] (\distance -> ["DISTANCE", encode distance]) ftSpellcheckDistance+ dialectArg = maybe [] (\dialect -> ["DIALECT", encode dialect]) ftSpellcheckDialect++ftSugAddOptsToArgs :: FTSugAddOpts -> [ByteString]+ftSugAddOptsToArgs FTSugAddDefault = []+ftSugAddOptsToArgs (FTSugAddWithPayload payload) = ["PAYLOAD", payload]+ftSugAddOptsToArgs FTSugAddIncrement = ["INCR"]+ftSugAddOptsToArgs (FTSugAddIncrementWithPayload payload) = ["INCR", "PAYLOAD", payload]++ftCursorReadOptsToArgs :: FTCursorReadOpts -> [ByteString]+ftCursorReadOptsToArgs FTCursorReadOpts{..} =+ maybe [] (\count -> ["COUNT", encode count]) ftCursorReadCount++-- |Returns a list of all existing indexes (<https://redis.io/commands/ft._list>).+--+-- /O(1)/+--+-- Since RediSearch 2.0.0+ftList+ :: (RedisCtx m f)+ => m (f [ByteString])+ftList = sendRequest ["FT._LIST"]++-- |Run a search query on an index and perform aggregate transformations on the results (<https://redis.io/commands/ft.aggregate>).+--+-- The reply shape varies with options such as @WITHCURSOR@, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/+--+-- Since RediSearch 1.1.0+ftAggregate+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> ByteString -- ^ Query string.+ -> m (f Reply)+ftAggregate index query = ftAggregateOpts index query defaultFTAggregateOpts++-- |Run a search query on an index and perform aggregate transformations on the results (<https://redis.io/commands/ft.aggregate>).+--+-- The reply shape varies with options such as @WITHCURSOR@, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/+--+-- Since RediSearch 1.1.0+ftAggregateOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> ByteString -- ^ Query string.+ -> FTAggregateOpts -- ^ Aggregate options and transformation steps.+ -> m (f Reply)+ftAggregateOpts index query opts =+ sendRequest $ ["FT.AGGREGATE", index, query] ++ ftAggregateOptsToArgs opts++-- |Adds an alias to the index (<https://redis.io/commands/ft.aliasadd>).+--+-- /O(1)/+--+-- Since RediSearch 1.0.0+ftAliasAdd+ :: (RedisCtx m f)+ => ByteString -- ^ Alias name.+ -> ByteString -- ^ Index name.+ -> m (f Status)+ftAliasAdd alias index = sendRequest ["FT.ALIASADD", alias, index]++-- |Deletes an alias from the index (<https://redis.io/commands/ft.aliasdel>).+--+-- /O(1)/+--+-- Since RediSearch 1.0.0+ftAliasDel+ :: (RedisCtx m f)+ => ByteString -- ^ Alias name.+ -> m (f Status)+ftAliasDel alias = sendRequest ["FT.ALIASDEL", alias]++-- |Adds or updates an alias to the index (<https://redis.io/commands/ft.aliasupdate>).+--+-- /O(1)/+--+-- Since RediSearch 1.0.0+ftAliasUpdate+ :: (RedisCtx m f)+ => ByteString -- ^ Alias name.+ -> ByteString -- ^ Index name.+ -> m (f Status)+ftAliasUpdate alias index = sendRequest ["FT.ALIASUPDATE", alias, index]++-- |Adds a new field to the index (<https://redis.io/commands/ft.alter>).+--+-- /O(N)/ where /N/ is the number of keys in the keyspace+--+-- Since RediSearch 1.0.0+ftAlter+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> FTCreateField -- ^ Field definition to append to the schema.+ -> m (f Status)+ftAlter index field = ftAlterOpts index field defaultFTAlterOpts++-- |Adds a new field to the index (<https://redis.io/commands/ft.alter>).+--+-- /O(N)/ where /N/ is the number of keys in the keyspace+--+-- Since RediSearch 1.0.0+ftAlterOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> FTCreateField -- ^ Field definition to append to the schema.+ -> FTAlterOpts -- ^ Alter options.+ -> m (f Status)+ftAlterOpts index field opts =+ sendRequest $ ["FT.ALTER", index] ++ ftAlterOptsToArgs opts ++ ["SCHEMA", "ADD"] ++ createFieldToArgs field++-- |Sets runtime configuration options (<https://redis.io/commands/ft.config-set>).+--+-- /O(1)/+--+-- Since RediSearch 1.0.0+ftConfigSet+ :: (RedisCtx m f)+ => ByteString -- ^ Option name.+ -> ByteString -- ^ Option value.+ -> m (f Status)+ftConfigSet option value = sendRequest ["FT.CONFIG", "SET", option, value]++-- |Retrieves runtime configuration options (<https://redis.io/commands/ft.config-get>).+--+-- The server returns an option-dependent reply payload, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/+--+-- Since RediSearch 1.0.0+ftConfigGet+ :: (RedisCtx m f)+ => ByteString -- ^ Option name or pattern.+ -> m (f Reply)+ftConfigGet option = sendRequest ["FT.CONFIG", "GET", option]++-- |Creates an index with the given spec (<https://redis.io/commands/ft.create>).+--+-- /O(K)/ at creation where /K/ is the number of fields, /O(N)/ if scanning the keyspace is triggered, where /N/ is the number of keys in the keyspace+--+-- Since RediSearch 1.0.0+ftCreate+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> NonEmpty FTCreateField -- ^ Schema field definitions.+ -> m (f Status)+ftCreate index fields = ftCreateOpts index fields defaultFTCreateOpts++-- |Creates an index with the given spec (<https://redis.io/commands/ft.create>).+--+-- /O(K)/ at creation where /K/ is the number of fields, /O(N)/ if scanning the keyspace is triggered, where /N/ is the number of keys in the keyspace+--+-- Since RediSearch 1.0.0+ftCreateOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> NonEmpty FTCreateField -- ^ Schema field definitions.+ -> FTCreateOpts -- ^ Index creation options.+ -> m (f Status)+ftCreateOpts index fields opts =+ sendRequest $+ ["FT.CREATE", index]+ ++ ftCreateOptsToArgs opts+ ++ ["SCHEMA"]+ ++ concatMap createFieldToArgs (NE.toList fields)++-- |Deletes a cursor (<https://redis.io/commands/ft.cursor-del>).+--+-- /O(1)/+--+-- Since RediSearch 1.1.0+ftCursorDel+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> Integer -- ^ Cursor identifier.+ -> m (f Status)+ftCursorDel index cursorId = sendRequest ["FT.CURSOR", "DEL", index, encode cursorId]++-- |Reads from a cursor (<https://redis.io/commands/ft.cursor-read>).+--+-- The cursor batch payload is command-dependent, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/+--+-- Since RediSearch 1.1.0+ftCursorRead+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> Integer -- ^ Cursor identifier.+ -> m (f Reply)+ftCursorRead index cursorId = ftCursorReadOpts index cursorId defaultFTCursorReadOpts++-- |Reads from a cursor (<https://redis.io/commands/ft.cursor-read>).+--+-- The cursor batch payload is command-dependent, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/+--+-- Since RediSearch 1.1.0+ftCursorReadOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> Integer -- ^ Cursor identifier.+ -> FTCursorReadOpts -- ^ Cursor read options.+ -> m (f Reply)+ftCursorReadOpts index cursorId opts =+ sendRequest $ ["FT.CURSOR", "READ", index, encode cursorId] ++ ftCursorReadOptsToArgs opts++-- |Adds terms to a dictionary (<https://redis.io/commands/ft.dictadd>).+--+-- /O(1)/+--+-- Since RediSearch 1.4.0+ftDictAdd+ :: (RedisCtx m f)+ => ByteString -- ^ Dictionary name.+ -> NonEmpty ByteString -- ^ Terms to add.+ -> m (f Integer)+ftDictAdd dict terms = sendRequest $ ["FT.DICTADD", dict] ++ NE.toList terms++-- |Deletes terms from a dictionary (<https://redis.io/commands/ft.dictdel>).+--+-- /O(1)/+--+-- Since RediSearch 1.4.0+ftDictDel+ :: (RedisCtx m f)+ => ByteString -- ^ Dictionary name.+ -> NonEmpty ByteString -- ^ Terms to delete.+ -> m (f Integer)+ftDictDel dict terms = sendRequest $ ["FT.DICTDEL", dict] ++ NE.toList terms++-- |Deletes the index (<https://redis.io/commands/ft.dropindex>).+--+-- /O(1)/ or /O(N)/ if documents are deleted, where /N/ is the number of keys in the keyspace+--+-- Since RediSearch 2.0.0+ftDropIndex+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> m (f Status)+ftDropIndex index = sendRequest ["FT.DROPINDEX", index]++-- |Deletes the index (<https://redis.io/commands/ft.dropindex>).+--+-- This variant also deletes indexed documents.+--+-- /O(1)/ or /O(N)/ if documents are deleted, where /N/ is the number of keys in the keyspace+--+-- Since RediSearch 2.0.0+ftDropIndexDeleteDocs+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> m (f Status)+ftDropIndexDeleteDocs index = sendRequest ["FT.DROPINDEX", index, "DD"]++-- |Returns the execution plan for a complex query (<https://redis.io/commands/ft.explain>).+--+-- /O(1)/+--+-- Since RediSearch 1.0.0+ftExplain+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> ByteString -- ^ Query string.+ -> m (f ByteString)+ftExplain index query = ftExplainOpts index query defaultFTExplainOpts++-- |Returns the execution plan for a complex query (<https://redis.io/commands/ft.explain>).+--+-- /O(1)/+--+-- Since RediSearch 1.0.0+ftExplainOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> ByteString -- ^ Query string.+ -> FTExplainOpts -- ^ Explain options.+ -> m (f ByteString)+ftExplainOpts index query opts =+ sendRequest $ ["FT.EXPLAIN", index, query] ++ ftExplainOptsToArgs opts++-- |Performs hybrid search combining text search and vector similarity with configurable fusion methods (<https://redis.io/commands/ft.hybrid>).+--+-- The reply shape depends on requested projections and scoring options, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/+--+-- Since Redis Open Source 8.4.0+ftHybrid+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> FTHybridSearchClause -- ^ Textual search clause.+ -> FTHybridVSimClause -- ^ Vector similarity clause.+ -> m (f Reply)+ftHybrid index searchClause vsimClause =+ ftHybridOpts index searchClause vsimClause defaultFTHybridOpts++-- |Performs hybrid search combining text search and vector similarity with configurable fusion methods (<https://redis.io/commands/ft.hybrid>).+--+-- The reply shape depends on requested projections and scoring options, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/+--+-- Since Redis Open Source 8.4.0+ftHybridOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> FTHybridSearchClause -- ^ Textual search clause.+ -> FTHybridVSimClause -- ^ Vector similarity clause.+ -> FTHybridOpts -- ^ Hybrid query options.+ -> m (f Reply)+ftHybridOpts index searchClause vsimClause opts =+ sendRequest $+ ["FT.HYBRID", index]+ ++ hybridSearchClauseToArgs searchClause+ ++ hybridVSimClauseToArgs vsimClause+ ++ ftHybridOptsToArgs opts++-- |Returns information and statistics on the index (<https://redis.io/commands/ft.info>).+--+-- The response is a heterogeneous attribute map, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/+--+-- Since RediSearch 1.0.0+ftInfo+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> m (f Reply)+ftInfo index = sendRequest ["FT.INFO", index]++-- |Performs a `FT.SEARCH` or `FT.AGGREGATE` command and collects performance information (<https://redis.io/commands/ft.profile>).+--+-- The profiled reply depends on the wrapped query type, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/+--+-- Since RediSearch 2.2.0+ftProfile+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> FTProfileQueryType -- ^ Wrapped query type.+ -> ByteString -- ^ Query payload for the wrapped command.+ -> m (f Reply)+ftProfile index queryType query =+ ftProfileOpts index queryType query defaultFTProfileOpts++-- |Performs a `FT.SEARCH` or `FT.AGGREGATE` command and collects performance information (<https://redis.io/commands/ft.profile>).+--+-- The profiled reply depends on the wrapped query type, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/+--+-- Since RediSearch 2.2.0+ftProfileOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> FTProfileQueryType -- ^ Wrapped query type.+ -> ByteString -- ^ Query payload for the wrapped command.+ -> FTProfileOpts -- ^ Profiling options.+ -> m (f Reply)+ftProfileOpts index queryType query opts =+ sendRequest $+ ["FT.PROFILE", index, encode queryType]+ ++ ftProfileOptsToArgs opts+ ++ ["QUERY", query]++-- |Searches the index with a textual query, returning either documents or just ids (<https://redis.io/commands/ft.search>).+--+-- The reply shape depends on output flags such as @NOCONTENT@ and @WITHSCORES@, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/+--+-- Since RediSearch 1.0.0+ftSearch+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> ByteString -- ^ Query string.+ -> m (f Reply)+ftSearch index query = ftSearchOpts index query defaultFTSearchOpts++-- |Searches the index with a textual query, returning either documents or just ids (<https://redis.io/commands/ft.search>).+--+-- The reply shape depends on output flags such as @NOCONTENT@ and @WITHSCORES@, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/+--+-- Since RediSearch 1.0.0+ftSearchOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> ByteString -- ^ Query string.+ -> FTSearchOpts -- ^ Search options.+ -> m (f Reply)+ftSearchOpts index query opts =+ sendRequest $ ["FT.SEARCH", index, query] ++ ftSearchOptsToArgs opts++-- |Performs spelling correction on a query, returning suggestions for misspelled terms (<https://redis.io/commands/ft.spellcheck>).+--+-- The response contains nested suggestions, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/+--+-- Since RediSearch 1.4.0+ftSpellcheck+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> ByteString -- ^ Query string.+ -> m (f Reply)+ftSpellcheck index query = ftSpellcheckOpts index query defaultFTSpellcheckOpts++-- |Performs spelling correction on a query, returning suggestions for misspelled terms (<https://redis.io/commands/ft.spellcheck>).+--+-- The response contains nested suggestions, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/+--+-- Since RediSearch 1.4.0+ftSpellcheckOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> ByteString -- ^ Query string.+ -> FTSpellcheckOpts -- ^ Spellcheck options.+ -> m (f Reply)+ftSpellcheckOpts index query opts =+ sendRequest $ ["FT.SPELLCHECK", index, query] ++ ftSpellcheckOptsToArgs opts++-- |Adds a suggestion string to an auto-complete suggestion dictionary (<https://redis.io/commands/ft.sugadd>).+--+-- /O(1)/+--+-- Since RediSearch 1.0.0+ftSugAdd+ :: (RedisCtx m f)+ => ByteString -- ^ Suggestion dictionary key.+ -> ByteString -- ^ Suggestion string.+ -> Double -- ^ Suggestion score.+ -> m (f Integer)+ftSugAdd key string score = ftSugAddOpts key string score FTSugAddDefault++-- |Adds a suggestion string to an auto-complete suggestion dictionary (<https://redis.io/commands/ft.sugadd>).+--+-- /O(1)/+--+-- Since RediSearch 1.0.0+ftSugAddOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Suggestion dictionary key.+ -> ByteString -- ^ Suggestion string.+ -> Double -- ^ Suggestion score.+ -> FTSugAddOpts -- ^ Suggestion insertion options.+ -> m (f Integer)+ftSugAddOpts key string score opts =+ sendRequest $ ["FT.SUGADD", key, string, encode score] ++ ftSugAddOptsToArgs opts++-- |Deletes a string from a suggestion index (<https://redis.io/commands/ft.sugdel>).+--+-- /O(1)/+--+-- Since RediSearch 1.0.0+ftSugDel+ :: (RedisCtx m f)+ => ByteString -- ^ Suggestion dictionary key.+ -> ByteString -- ^ Suggestion string.+ -> m (f Integer)+ftSugDel key string = sendRequest ["FT.SUGDEL", key, string]++-- |Gets the size of an auto-complete suggestion dictionary (<https://redis.io/commands/ft.suglen>).+--+-- /O(1)/+--+-- Since RediSearch 1.0.0+ftSugLen+ :: (RedisCtx m f)+ => ByteString -- ^ Suggestion dictionary key.+ -> m (f Integer)+ftSugLen key = sendRequest ["FT.SUGLEN", key]++-- |Returns the distinct tags indexed in a Tag field (<https://redis.io/commands/ft.tagvals>).+--+-- /O(n)/ where /n/ is the number of distinct tags in the field+--+-- Since RediSearch 1.0.0+ftTagVals+ :: (RedisCtx m f)+ => ByteString -- ^ Index name.+ -> ByteString -- ^ Tag field name.+ -> m (f [ByteString])+ftTagVals index field = sendRequest ["FT.TAGVALS", index, field]
+ src/Database/Redis/ManualCommands/Function.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE OverloadedStrings #-}++module Database.Redis.ManualCommands.Function+ ( functionDelete+ , functionDump+ , functionFlush+ , functionFlushOpts+ , functionKill+ , functionLoad+ , functionLoadReplace+ , FunctionRestorePolicy(..)+ , FunctionRestoreOpts(..)+ , defaultFunctionRestoreOpts+ , functionRestore+ , functionRestoreOpts+ , functionStats+ ) where++import Data.ByteString (ByteString)++import Database.Redis.Core+import Database.Redis.Protocol+import Database.Redis.Types+import Database.Redis.ManualCommands (FlushOpts, FunctionRestorePolicy(..))+import qualified Database.Redis.ManualCommands as Manual++data FunctionRestoreOpts+ = FunctionRestoreDefault+ | FunctionRestoreWithPolicy FunctionRestorePolicy+ deriving (Show, Eq)++defaultFunctionRestoreOpts :: FunctionRestoreOpts+defaultFunctionRestoreOpts = FunctionRestoreDefault++-- |Deletes a library and its functions (<https://redis.io/commands/function-delete>).+--+-- Deletes the library named by the argument together with all functions it contains.+--+-- /O(1)/+--+-- Since Redis 7.0.0+functionDelete+ :: (RedisCtx m f)+ => ByteString -- ^ Library name.+ -> m (f Status)+functionDelete = Manual.functionDelete++-- |Dumps all libraries into a serialized binary payload (<https://redis.io/commands/function-dump>).+--+-- Serializes all loaded libraries into a binary payload that can later be used with 'functionRestore'.+--+-- /O(N)/ where /N/ is the number of functions.+--+-- Since Redis 7.0.0+functionDump+ :: (RedisCtx m f)+ => m (f ByteString)+functionDump = Manual.functionDump++-- |Deletes all libraries and functions (<https://redis.io/commands/function-flush>).+--+-- Removes every library currently loaded into Redis.+--+-- /O(N)/ where /N/ is the number of functions deleted.+--+-- Since Redis 7.0.0+functionFlush+ :: (RedisCtx m f)+ => m (f Status)+functionFlush = Manual.functionFlush++-- |Deletes all libraries and functions (<https://redis.io/commands/function-flush>).+--+-- Removes every library currently loaded into Redis using the requested flushing mode.+--+-- /O(N)/ where /N/ is the number of functions deleted.+--+-- Since Redis 7.0.0+functionFlushOpts+ :: (RedisCtx m f)+ => FlushOpts -- ^ Flush mode.+ -> m (f Status)+functionFlushOpts = Manual.functionFlushOpts++-- |Terminates a function during execution (<https://redis.io/commands/function-kill>).+--+-- Terminates the currently running function, if it is marked as killable by Redis.+--+-- /O(1)/+--+-- Since Redis 7.0.0+functionKill+ :: (RedisCtx m f)+ => m (f Status)+functionKill = Manual.functionKill++-- |Creates a library (<https://redis.io/commands/function-load>).+--+-- Loads a new function library and returns its library name.+--+-- /O(N)/ where /N/ is the number of bytes in the function's source code.+--+-- Since Redis 7.0.0+functionLoad+ :: (RedisCtx m f)+ => ByteString -- ^ Library source code.+ -> m (f ByteString)+functionLoad = Manual.functionLoad++-- |Creates a library, replacing an existing one with the same name (<https://redis.io/commands/function-load>).+--+-- Loads a function library and replaces an existing library with the same name.+--+-- /O(N)/ where /N/ is the number of bytes in the function's source code.+--+-- Since Redis 7.0.0+functionLoadReplace+ :: (RedisCtx m f)+ => ByteString -- ^ Library source code.+ -> m (f ByteString)+functionLoadReplace = Manual.functionLoadReplace++-- |Restores all libraries from a payload (<https://redis.io/commands/function-restore>).+--+-- Restores all libraries from a payload previously returned by 'functionDump'.+--+-- /O(N)/ where /N/ is the number of functions restored.+--+-- Since Redis 7.0.0+functionRestore+ :: (RedisCtx m f)+ => ByteString -- ^ Serialized libraries payload.+ -> m (f Status)+functionRestore payload = functionRestoreOpts payload defaultFunctionRestoreOpts++-- |Restores all libraries from a payload (<https://redis.io/commands/function-restore>).+--+-- Restores all libraries from a payload previously returned by 'functionDump', optionally selecting the restore policy.+--+-- /O(N)/ where /N/ is the number of functions restored.+--+-- Since Redis 7.0.0+functionRestoreOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Serialized libraries payload.+ -> FunctionRestoreOpts -- ^ Restore options.+ -> m (f Status)+functionRestoreOpts payload opts =+ Manual.functionRestore payload restorePolicy+ where+ restorePolicy = case opts of+ FunctionRestoreDefault -> Nothing+ FunctionRestoreWithPolicy policy -> Just policy++-- |Returns information about a function during execution (<https://redis.io/commands/function-stats>).+--+-- Returns execution statistics and runtime information for the function engine.+--+-- /O(1)/+--+-- Since Redis 7.0.0+functionStats+ :: (RedisCtx m f)+ => m (f Reply)+functionStats = Manual.functionStats
+ src/Database/Redis/ManualCommands/JSON.hs view
@@ -0,0 +1,621 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Database.Redis.ManualCommands.JSON where++import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE++import Database.Redis.Core+import Database.Redis.Protocol+import Database.Redis.Types++data JSONGetOpts = JSONGetOpts+ { jsonGetIndent :: Maybe ByteString+ , jsonGetNewline :: Maybe ByteString+ , jsonGetSpace :: Maybe ByteString+ , jsonGetPaths :: [ByteString]+ } deriving (Show, Eq)++defaultJSONGetOpts :: JSONGetOpts+defaultJSONGetOpts = JSONGetOpts+ { jsonGetIndent = Nothing+ , jsonGetNewline = Nothing+ , jsonGetSpace = Nothing+ , jsonGetPaths = []+ }++data JSONSetCondition+ = JSONSetIfNotExists+ | JSONSetIfExists+ deriving (Show, Eq)++instance RedisArg JSONSetCondition where+ encode JSONSetIfNotExists = "NX"+ encode JSONSetIfExists = "XX"++data JSONSetFPHA+ = JSONSetFP16+ | JSONSetBF16+ | JSONSetFP32+ | JSONSetFP64+ deriving (Show, Eq)++instance RedisArg JSONSetFPHA where+ encode JSONSetFP16 = "FP16"+ encode JSONSetBF16 = "BF16"+ encode JSONSetFP32 = "FP32"+ encode JSONSetFP64 = "FP64"++data JSONSetOpts = JSONSetOpts+ { jsonSetCondition :: Maybe JSONSetCondition+ , jsonSetFPHA :: Maybe JSONSetFPHA+ } deriving (Show, Eq)++defaultJSONSetOpts :: JSONSetOpts+defaultJSONSetOpts = JSONSetOpts+ { jsonSetCondition = Nothing+ , jsonSetFPHA = Nothing+ }++data JSONArrIndexOpts+ = JSONArrIndexAll+ | JSONArrIndexFrom Integer+ | JSONArrIndexFromTo Integer Integer+ deriving (Show, Eq)++defaultJSONArrIndexOpts :: JSONArrIndexOpts+defaultJSONArrIndexOpts = JSONArrIndexAll++jsonGetOptsToArgs :: JSONGetOpts -> [ByteString]+jsonGetOptsToArgs JSONGetOpts{..} =+ indentArg ++ newlineArg ++ spaceArg ++ jsonGetPaths+ where+ indentArg = maybe [] (\indent -> ["INDENT", indent]) jsonGetIndent+ newlineArg = maybe [] (\newline -> ["NEWLINE", newline]) jsonGetNewline+ spaceArg = maybe [] (\space -> ["SPACE", space]) jsonGetSpace++jsonSetOptsToArgs :: JSONSetOpts -> [ByteString]+jsonSetOptsToArgs JSONSetOpts{..} =+ conditionArg ++ fphaArg+ where+ conditionArg = maybe [] (\condition -> [encode condition]) jsonSetCondition+ fphaArg = maybe [] (\fpha -> ["FPHA", encode fpha]) jsonSetFPHA++jsonArrIndexOptsToArgs :: JSONArrIndexOpts -> [ByteString]+jsonArrIndexOptsToArgs JSONArrIndexAll = []+jsonArrIndexOptsToArgs (JSONArrIndexFrom start) = [encode start]+jsonArrIndexOptsToArgs (JSONArrIndexFromTo start stop) = [encode start, encode stop]++-- |Appends one or more JSON values into the array at path after the last element in it (<https://redis.io/commands/json.arrappend>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/ when path is evaluated to a single value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonArrappend+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to the array.+ -> NonEmpty ByteString -- ^ Serialized JSON values to append.+ -> m (f Reply)+jsonArrappend key path values =+ sendRequest $ ["JSON.ARRAPPEND", key, path] ++ NE.toList values++-- |Returns the index of the first occurrence of a JSON scalar value in the array at path (<https://redis.io/commands/json.arrindex>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/ when path is evaluated to a single value where /N/ is the size of the array, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonArrindex+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to the array.+ -> ByteString -- ^ Serialized JSON scalar to search for.+ -> m (f Reply)+jsonArrindex key path value = jsonArrindexOpts key path value defaultJSONArrIndexOpts++-- |Returns the index of the first occurrence of a JSON scalar value in the array at path (<https://redis.io/commands/json.arrindex>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/ when path is evaluated to a single value where /N/ is the size of the array, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonArrindexOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to the array.+ -> ByteString -- ^ Serialized JSON scalar to search for.+ -> JSONArrIndexOpts -- ^ Optional search range.+ -> m (f Reply)+jsonArrindexOpts key path value opts =+ sendRequest $ ["JSON.ARRINDEX", key, path, value] ++ jsonArrIndexOptsToArgs opts++-- |Returns the length of the array at the root path (<https://redis.io/commands/json.arrlen>).+--+-- /O(1)/ where path is evaluated to a single value, /O(N)/ where path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonArrlen+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> m (f Reply)+jsonArrlen key = sendRequest ["JSON.ARRLEN", key]++-- |Returns the length of the array at path (<https://redis.io/commands/json.arrlen>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/ where path is evaluated to a single value, /O(N)/ where path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonArrlenAt+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to the array.+ -> m (f Reply)+jsonArrlenAt key path = sendRequest ["JSON.ARRLEN", key, path]++-- |Inserts the JSON scalar(s) value at the specified index in the array at path (<https://redis.io/commands/json.arrinsert>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/ when path is evaluated to a single value where /N/ is the size of the array, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonArrinsert+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to the array.+ -> Integer -- ^ Insertion index.+ -> NonEmpty ByteString -- ^ Serialized JSON values to insert.+ -> m (f Reply)+jsonArrinsert key path index values =+ sendRequest $ ["JSON.ARRINSERT", key, path, encode index] ++ NE.toList values++-- |Removes and returns the element at the end of the array at the root path (<https://redis.io/commands/json.arrpop>).+--+-- /O(1)/ when the popped item is the last element, otherwise /O(N)/ where /N/ is the size of the array+--+-- Since RedisJSON 1.0.0+jsonArrpop+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> m (f Reply)+jsonArrpop key = sendRequest ["JSON.ARRPOP", key]++-- |Removes and returns the element at the end of the array at path (<https://redis.io/commands/json.arrpop>).+--+-- The reply shape depends on the path syntax and popped value type, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/ when the popped item is the last element, otherwise /O(N)/ where /N/ is the size of the array+--+-- Since RedisJSON 1.0.0+jsonArrpopAt+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to the array.+ -> m (f Reply)+jsonArrpopAt key path = sendRequest ["JSON.ARRPOP", key, path]++-- |Removes and returns the element at the specified index in the array at path (<https://redis.io/commands/json.arrpop>).+--+-- The reply shape depends on the path syntax and popped value type, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/ when the specified index is not the last element, otherwise /O(1)/+--+-- Since RedisJSON 1.0.0+jsonArrpopAtIndex+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to the array.+ -> Integer -- ^ Index to pop.+ -> m (f Reply)+jsonArrpopAtIndex key path index =+ sendRequest ["JSON.ARRPOP", key, path, encode index]++-- |Trims the array at path to contain only the specified inclusive range of indices from start to stop (<https://redis.io/commands/json.arrtrim>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/ when path is evaluated to a single value where /N/ is the size of the array, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonArrtrim+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to the array.+ -> Integer -- ^ Start index.+ -> Integer -- ^ Stop index.+ -> m (f Reply)+jsonArrtrim key path start stop =+ sendRequest ["JSON.ARRTRIM", key, path, encode start, encode stop]++-- |Clears all values from an array or an object and sets numeric values at the root path to @0@ (<https://redis.io/commands/json.clear>).+--+-- /O(N)/ when path is evaluated to a single value where /N/ is the size of the values, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 2.0.0+jsonClear+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> m (f Integer)+jsonClear key = sendRequest ["JSON.CLEAR", key]++-- |Clears all values from an array or an object and sets numeric values at path to @0@ (<https://redis.io/commands/json.clear>).+--+-- /O(N)/ when path is evaluated to a single value where /N/ is the size of the values, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 2.0.0+jsonClearAt+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to clear.+ -> m (f Integer)+jsonClearAt key path = sendRequest ["JSON.CLEAR", key, path]++-- |Executes the JSON debug container command (<https://redis.io/commands/json.debug>).+--+-- This is a container command for debugging related tasks.+--+-- N\/A+--+-- Since RedisJSON 1.0.0+jsonDebug+ :: (RedisCtx m f)+ => m (f Reply)+jsonDebug = sendRequest ["JSON.DEBUG"]++-- |Reports the size in bytes of a key at the root path (<https://redis.io/commands/json.debug-memory>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/ when path is evaluated to a single value, where /N/ is the size of the value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonDebugMemory+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> m (f Reply)+jsonDebugMemory key = sendRequest ["JSON.DEBUG", "MEMORY", key]++-- |Reports the size in bytes of a key at path (<https://redis.io/commands/json.debug-memory>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/ when path is evaluated to a single value, where /N/ is the size of the value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonDebugMemoryAt+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to inspect.+ -> m (f Reply)+jsonDebugMemoryAt key path = sendRequest ["JSON.DEBUG", "MEMORY", key, path]++-- |Deletes a value at the root path (<https://redis.io/commands/json.del>).+--+-- /O(N)/ when path is evaluated to a single value where /N/ is the size of the deleted value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonDel+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> m (f Integer)+jsonDel key = sendRequest ["JSON.DEL", key]++-- |Deletes a value at path (<https://redis.io/commands/json.del>).+--+-- /O(N)/ when path is evaluated to a single value where /N/ is the size of the deleted value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonDelAt+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to delete.+ -> m (f Integer)+jsonDelAt key path = sendRequest ["JSON.DEL", key, path]++-- |Deletes a value at the root path (<https://redis.io/commands/json.forget>).+--+-- /O(N)/ when path is evaluated to a single value where /N/ is the size of the deleted value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonForget+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> m (f Integer)+jsonForget key = sendRequest ["JSON.FORGET", key]++-- |Deletes a value at path (<https://redis.io/commands/json.forget>).+--+-- /O(N)/ when path is evaluated to a single value where /N/ is the size of the deleted value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonForgetAt+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to delete.+ -> m (f Integer)+jsonForgetAt key path = sendRequest ["JSON.FORGET", key, path]++-- |Gets the value at the root path in JSON serialized form (<https://redis.io/commands/json.get>).+--+-- /O(N)/ when path is evaluated to a single value where /N/ is the size of the value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonGet+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> m (f (Maybe ByteString))+jsonGet key = jsonGetOpts key defaultJSONGetOpts++-- |Gets the value at one or more paths in JSON serialized form (<https://redis.io/commands/json.get>).+--+-- /O(N)/ when path is evaluated to a single value where /N/ is the size of the value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonGetOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> JSONGetOpts -- ^ Formatting and path selection options.+ -> m (f (Maybe ByteString))+jsonGetOpts key opts =+ sendRequest $ ["JSON.GET", key] ++ jsonGetOptsToArgs opts++-- |Merges a given JSON value into matching paths (<https://redis.io/commands/json.merge>).+--+-- Consequently, JSON values at matching paths are updated, deleted, or expanded with new children.+--+-- /O(M+N)/ when path is evaluated to a single value where /M/ is the size of the original value and /N/ is the size of the new value, /O(M+N)/ when path is evaluated to multiple values where /M/ is the size of the key and /N/ is the size of the new value times the number of matches+--+-- Since RedisJSON 2.6.0+jsonMerge+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to merge into.+ -> ByteString -- ^ Serialized JSON value.+ -> m (f Status)+jsonMerge key path value = sendRequest ["JSON.MERGE", key, path, value]++-- |Returns the values at a path from one or more keys (<https://redis.io/commands/json.mget>).+--+-- /O(M*N)/ when path is evaluated to a single value where /M/ is the number of keys and /N/ is the size of the value, /O(N1+N2+\dots+Nm)/ when path is evaluated to multiple values+--+-- Since RedisJSON 1.0.0+jsonMget+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ Keys holding JSON values.+ -> ByteString -- ^ Path to fetch from each key.+ -> m (f [Maybe ByteString])+jsonMget keys path = sendRequest $ "JSON.MGET" : NE.toList keys ++ [path]++-- |Sets or updates the JSON value of one or more keys (<https://redis.io/commands/json.mset>).+--+-- /O(K*(M+N))/ where /K/ is the number of keys in the command+--+-- Since RedisJSON 2.6.0+jsonMset+ :: (RedisCtx m f)+ => NonEmpty (ByteString, ByteString, ByteString) -- ^ Key, path, serialized JSON value triplets.+ -> m (f Status)+jsonMset triplets =+ sendRequest $ "JSON.MSET" : concatMap encodeTriplet (NE.toList triplets)+ where+ encodeTriplet (key, path, value) = [key, path, value]++-- |Increments the numeric value at path by a value (<https://redis.io/commands/json.numincrby>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/ when path is evaluated to a single value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonNumincrby+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to the numeric value.+ -> Double -- ^ Increment value.+ -> m (f Reply)+jsonNumincrby key path value =+ sendRequest ["JSON.NUMINCRBY", key, path, encode value]++-- |Multiplies the numeric value at path by a value (<https://redis.io/commands/json.nummultby>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/ when path is evaluated to a single value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonNummultby+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to the numeric value.+ -> Double -- ^ Multiplier value.+ -> m (f Reply)+jsonNummultby key path value =+ sendRequest ["JSON.NUMMULTBY", key, path, encode value]++-- |Returns the key names of JSON objects at the root path (<https://redis.io/commands/json.objkeys>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/ when path is evaluated to a single value, where /N/ is the number of keys in the object, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonObjkeys+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> m (f Reply)+jsonObjkeys key = sendRequest ["JSON.OBJKEYS", key]++-- |Returns the key names of JSON objects at path (<https://redis.io/commands/json.objkeys>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/ when path is evaluated to a single value, where /N/ is the number of keys in the object, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonObjkeysAt+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to the object.+ -> m (f Reply)+jsonObjkeysAt key path = sendRequest ["JSON.OBJKEYS", key, path]++-- |Returns the number of keys in JSON objects at the root path (<https://redis.io/commands/json.objlen>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/ when path is evaluated to a single value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonObjlen+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> m (f Reply)+jsonObjlen key = sendRequest ["JSON.OBJLEN", key]++-- |Returns the number of keys in JSON objects at path (<https://redis.io/commands/json.objlen>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/ when path is evaluated to a single value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonObjlenAt+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to the object.+ -> m (f Reply)+jsonObjlenAt key path = sendRequest ["JSON.OBJLEN", key, path]++-- |Returns the JSON value at the root path in Redis Serialization Protocol (RESP) (<https://redis.io/commands/json.resp>).+--+-- The reply may be any RESP shape depending on the JSON value, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/ when path is evaluated to a single value, where /N/ is the size of the value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonResp+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> m (f Reply)+jsonResp key = sendRequest ["JSON.RESP", key]++-- |Returns the JSON value at path in Redis Serialization Protocol (RESP) (<https://redis.io/commands/json.resp>).+--+-- The reply may be any RESP shape depending on the JSON value, so this wrapper returns the raw 'Reply'.+--+-- /O(N)/ when path is evaluated to a single value, where /N/ is the size of the value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonRespAt+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to inspect.+ -> m (f Reply)+jsonRespAt key path = sendRequest ["JSON.RESP", key, path]++-- |Sets or updates the JSON value at a path (<https://redis.io/commands/json.set>).+--+-- $O(M+N)$ when path is evaluated to a single value where $M$ is the size of the original value and $N$ is the size of the new value, $O(M+N)$ when path is evaluated to multiple values where $M$ is the size of the key and $N$ is the size of the new value times the number of matches+--+-- Since RedisJSON 1.0.0+jsonSet+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to set.+ -> ByteString -- ^ Serialized JSON value.+ -> m (f (Maybe Status))+jsonSet key path value = jsonSetOpts key path value defaultJSONSetOpts++-- |Sets or updates the JSON value at a path (<https://redis.io/commands/json.set>).+--+-- /O(M+N)/ when path is evaluated to a single value where /M/ is the size of the original value and /N/ is the size of the new value, /O(M+N)/ when path is evaluated to multiple values where /M/ is the size of the key and /N/ is the size of the new value times the number of matches+--+-- Since RedisJSON 1.0.0+jsonSetOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to set.+ -> ByteString -- ^ Serialized JSON value.+ -> JSONSetOpts -- ^ Conditional and FPHA options.+ -> m (f (Maybe Status))+jsonSetOpts key path value opts =+ sendRequest $ ["JSON.SET", key, path, value] ++ jsonSetOptsToArgs opts++-- |Appends a string to JSON strings at the root path (<https://redis.io/commands/json.strappend>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/ when path is evaluated to a single value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonStrappend+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ String value to append.+ -> m (f Reply)+jsonStrappend key value = sendRequest ["JSON.STRAPPEND", key, value]++-- |Appends a string to JSON strings at path (<https://redis.io/commands/json.strappend>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/ when path is evaluated to a single value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonStrappendAt+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to the JSON string.+ -> ByteString -- ^ String value to append.+ -> m (f Reply)+jsonStrappendAt key path value = sendRequest ["JSON.STRAPPEND", key, path, value]++-- |Toggles a boolean value (<https://redis.io/commands/json.toggle>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/ when path is evaluated to a single value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 2.0.0+jsonToggle+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to the boolean value.+ -> m (f Reply)+jsonToggle key path = sendRequest ["JSON.TOGGLE", key, path]++-- |Returns the type of the JSON value at the root path (<https://redis.io/commands/json.type>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/ when path is evaluated to a single value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonType+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> m (f Reply)+jsonType key = sendRequest ["JSON.TYPE", key]++-- |Returns the type of the JSON value at path (<https://redis.io/commands/json.type>).+--+-- The reply shape depends on the path syntax, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/ when path is evaluated to a single value, /O(N)/ when path is evaluated to multiple values, where /N/ is the size of the key+--+-- Since RedisJSON 1.0.0+jsonTypeAt+ :: (RedisCtx m f)+ => ByteString -- ^ Key holding a JSON value.+ -> ByteString -- ^ Path to inspect.+ -> m (f Reply)+jsonTypeAt key path = sendRequest ["JSON.TYPE", key, path]
+ src/Database/Redis/ManualCommands/Tdigest.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Database.Redis.ManualCommands.Tdigest where++import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (listToMaybe)++import Database.Redis.Core+import Database.Redis.Protocol+import Database.Redis.Types++data TDigestCreateOpts = TDigestCreateOpts+ { tdigestCreateCompression :: Maybe Integer+ -- ^ Compression parameter controlling accuracy and size.+ } deriving (Show, Eq)++defaultTDigestCreateOpts :: TDigestCreateOpts+defaultTDigestCreateOpts = TDigestCreateOpts+ { tdigestCreateCompression = Nothing+ }++data TDigestMergeOpts = TDigestMergeOpts+ { tdigestMergeCompression :: Maybe Integer+ -- ^ Compression parameter for the destination digest.+ , tdigestMergeOverride :: Bool+ -- ^ Overwrite the destination key if it already exists.+ } deriving (Show, Eq)++defaultTDigestMergeOpts :: TDigestMergeOpts+defaultTDigestMergeOpts = TDigestMergeOpts+ { tdigestMergeCompression = Nothing+ , tdigestMergeOverride = False+ }++data TDigestInfo = TDigestInfo+ { tdigestInfoCompression :: Integer+ -- ^ Compression parameter of the digest.+ , tdigestInfoCapacity :: Integer+ -- ^ Allocated centroid capacity.+ , tdigestInfoMergedNodes :: Integer+ -- ^ Number of merged centroids.+ , tdigestInfoUnmergedNodes :: Integer+ -- ^ Number of pending unmerged centroids.+ , tdigestInfoMergedWeight :: Integer+ -- ^ Weight held by merged centroids.+ , tdigestInfoUnmergedWeight :: Integer+ -- ^ Weight held by pending unmerged centroids.+ , tdigestInfoObservations :: Integer+ -- ^ Total number of added observations.+ , tdigestInfoTotalCompressions :: Integer+ -- ^ Number of performed compression passes.+ , tdigestInfoMemoryUsage :: Integer+ -- ^ Memory usage in bytes.+ } deriving (Show, Eq)++instance RedisResult TDigestInfo where+ decode r = do+ fields <- decode r :: Either Reply [(ByteString, Integer)]+ tdigestInfoCompression <- decodeField ["Compression", "compression"] fields+ tdigestInfoCapacity <- decodeField ["Capacity", "capacity"] fields+ tdigestInfoMergedNodes <- decodeField ["Merged nodes", "merged nodes"] fields+ tdigestInfoUnmergedNodes <- decodeField ["Unmerged nodes", "unmerged nodes"] fields+ tdigestInfoMergedWeight <- decodeField ["Merged weight", "merged weight"] fields+ tdigestInfoUnmergedWeight <- decodeField ["Unmerged weight", "unmerged weight"] fields+ tdigestInfoObservations <- decodeField ["Observations", "observations"] fields+ tdigestInfoTotalCompressions <- decodeField ["Total compressions", "total compressions"] fields+ tdigestInfoMemoryUsage <- decodeField ["Memory usage", "memory usage"] fields+ pure TDigestInfo{..}+ where+ decodeField keys fields =+ maybe (Left r) Right . listToMaybe $+ [value | key <- keys, value <- maybeToList (lookup key fields)]++ maybeToList = maybe [] pure++tdigestCreateOptsToArgs :: TDigestCreateOpts -> [ByteString]+tdigestCreateOptsToArgs TDigestCreateOpts{..} =+ maybe [] (\compression -> ["COMPRESSION", encode compression]) tdigestCreateCompression++tdigestMergeOptsToArgs :: TDigestMergeOpts -> [ByteString]+tdigestMergeOptsToArgs TDigestMergeOpts{..} =+ compressionArg ++ overrideArg+ where+ compressionArg = maybe [] (\compression -> ["COMPRESSION", encode compression]) tdigestMergeCompression+ overrideArg = ["OVERRIDE" | tdigestMergeOverride]++-- |Adds one or more observations to a t-digest sketch (<https://redis.io/commands/tdigest.add>).+--+-- /O(n \log k)/, where /n/ is the number of observations and /k/ is the compression parameter.+--+-- Since RedisBloom 2.4.0+tdigestAdd+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the t-digest sketch.+ -> NonEmpty Double -- ^ Observations to add.+ -> m (f Status)+tdigestAdd key values = sendRequest $ ["TDIGEST.ADD", key] ++ map encode (NE.toList values)++-- |Returns observations by their ascending ranks from a t-digest sketch (<https://redis.io/commands/tdigest.byrank>).+--+-- /O(n \log k)/, where /n/ is the number of requested ranks and /k/ is the compression parameter.+--+-- Since RedisBloom 2.4.0+tdigestByrank+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the t-digest sketch.+ -> NonEmpty Integer -- ^ Requested ranks.+ -> m (f [Double])+tdigestByrank key ranks = sendRequest $ ["TDIGEST.BYRANK", key] ++ map encode (NE.toList ranks)++-- |Returns observations by their descending ranks from a t-digest sketch (<https://redis.io/commands/tdigest.byrevrank>).+--+-- /O(n \log k)/, where /n/ is the number of requested reverse ranks and /k/ is the compression parameter.+--+-- Since RedisBloom 2.4.0+tdigestByrevrank+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the t-digest sketch.+ -> NonEmpty Integer -- ^ Requested reverse ranks.+ -> m (f [Double])+tdigestByrevrank key ranks = sendRequest $ ["TDIGEST.BYREVRANK", key] ++ map encode (NE.toList ranks)++-- |Returns cumulative distribution estimates for one or more observations (<https://redis.io/commands/tdigest.cdf>).+--+-- /O(n \log k)/, where /n/ is the number of queried values and /k/ is the compression parameter.+--+-- Since RedisBloom 2.4.0+tdigestCdf+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the t-digest sketch.+ -> NonEmpty Double -- ^ Observations to query.+ -> m (f [Double])+tdigestCdf key values = sendRequest $ ["TDIGEST.CDF", key] ++ map encode (NE.toList values)++-- |Creates an empty t-digest sketch (<https://redis.io/commands/tdigest.create>).+--+-- /O(1)/+--+-- Since RedisBloom 2.4.0+tdigestCreate+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the t-digest sketch to create.+ -> m (f Status)+tdigestCreate key = tdigestCreateOpts key defaultTDigestCreateOpts++-- |Creates an empty t-digest sketch (<https://redis.io/commands/tdigest.create>).+--+-- /O(1)/+--+-- Since RedisBloom 2.4.0+tdigestCreateOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the t-digest sketch to create.+ -> TDigestCreateOpts -- ^ Creation options.+ -> m (f Status)+tdigestCreateOpts key opts =+ sendRequest $ ["TDIGEST.CREATE", key] ++ tdigestCreateOptsToArgs opts++-- |Returns information about a t-digest sketch (<https://redis.io/commands/tdigest.info>).+--+-- /O(1)/+--+-- Since RedisBloom 2.4.0+tdigestInfo+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the t-digest sketch.+ -> m (f TDigestInfo)+tdigestInfo key = sendRequest ["TDIGEST.INFO", key]++-- |Returns the maximum observation in a t-digest sketch (<https://redis.io/commands/tdigest.max>).+--+-- /O(1)/+--+-- Since RedisBloom 2.4.0+tdigestMax+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the t-digest sketch.+ -> m (f Double)+tdigestMax key = sendRequest ["TDIGEST.MAX", key]++-- |Merges multiple t-digest sketches into a destination sketch (<https://redis.io/commands/tdigest.merge>).+--+-- /O(n \cdot k)/, where /n/ is the number of source sketches and /k/ is the compression parameter.+--+-- Since RedisBloom 2.4.0+tdigestMerge+ :: (RedisCtx m f)+ => ByteString -- ^ Destination key.+ -> NonEmpty ByteString -- ^ Source sketch keys.+ -> m (f Status)+tdigestMerge destination sources =+ tdigestMergeOpts destination sources defaultTDigestMergeOpts++-- |Merges multiple t-digest sketches into a destination sketch (<https://redis.io/commands/tdigest.merge>).+--+-- /O(n \cdot k)/, where /n/ is the number of source sketches and /k/ is the compression parameter.+--+-- Since RedisBloom 2.4.0+tdigestMergeOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Destination key.+ -> NonEmpty ByteString -- ^ Source sketch keys.+ -> TDigestMergeOpts -- ^ Merge options.+ -> m (f Status)+tdigestMergeOpts destination sources opts =+ sendRequest $+ ["TDIGEST.MERGE", destination, encode (fromIntegral (NE.length sources) :: Integer)]+ ++ NE.toList sources+ ++ tdigestMergeOptsToArgs opts++-- |Returns the minimum observation in a t-digest sketch (<https://redis.io/commands/tdigest.min>).+--+-- /O(1)/+--+-- Since RedisBloom 2.4.0+tdigestMin+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the t-digest sketch.+ -> m (f Double)+tdigestMin key = sendRequest ["TDIGEST.MIN", key]++-- |Returns quantile estimates for one or more quantiles (<https://redis.io/commands/tdigest.quantile>).+--+-- /O(n \log k)/, where /n/ is the number of quantiles and /k/ is the compression parameter.+--+-- Since RedisBloom 2.4.0+tdigestQuantile+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the t-digest sketch.+ -> NonEmpty Double -- ^ Quantiles to estimate.+ -> m (f [Double])+tdigestQuantile key quantiles =+ sendRequest $ ["TDIGEST.QUANTILE", key] ++ map encode (NE.toList quantiles)++-- |Returns ascending rank estimates for one or more observations (<https://redis.io/commands/tdigest.rank>).+--+-- /O(n \log k)/, where /n/ is the number of observations and /k/ is the compression parameter.+--+-- Since RedisBloom 2.4.0+tdigestRank+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the t-digest sketch.+ -> NonEmpty Double -- ^ Observations to rank.+ -> m (f [Integer])+tdigestRank key values = sendRequest $ ["TDIGEST.RANK", key] ++ map encode (NE.toList values)++-- |Resets a t-digest sketch to its empty state (<https://redis.io/commands/tdigest.reset>).+--+-- /O(1)/+--+-- Since RedisBloom 2.4.0+tdigestReset+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the t-digest sketch.+ -> m (f Status)+tdigestReset key = sendRequest ["TDIGEST.RESET", key]++-- |Returns descending rank estimates for one or more observations (<https://redis.io/commands/tdigest.revrank>).+--+-- /O(n \log k)/, where /n/ is the number of observations and /k/ is the compression parameter.+--+-- Since RedisBloom 2.4.0+tdigestRevrank+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the t-digest sketch.+ -> NonEmpty Double -- ^ Observations to rank.+ -> m (f [Integer])+tdigestRevrank key values = sendRequest $ ["TDIGEST.REVRANK", key] ++ map encode (NE.toList values)++-- |Returns the trimmed mean for observations within the provided quantile range (<https://redis.io/commands/tdigest.trimmed_mean>).+--+-- /O(\log k)/, where /k/ is the compression parameter.+--+-- Since RedisBloom 2.4.0+tdigestTrimmedMean+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the t-digest sketch.+ -> Double -- ^ Lower quantile bound.+ -> Double -- ^ Upper quantile bound.+ -> m (f Double)+tdigestTrimmedMean key lowCut highCut =+ sendRequest ["TDIGEST.TRIMMED_MEAN", key, encode lowCut, encode highCut]
+ src/Database/Redis/ManualCommands/Topk.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Database.Redis.ManualCommands.Topk where++import Data.ByteString (ByteString)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE++import Database.Redis.Core+import Database.Redis.Protocol+import Database.Redis.Types++data TopkInfo = TopkInfo+ { topkInfoK :: Integer+ -- ^ Number of items kept in the Top-K list.+ , topkInfoWidth :: Integer+ -- ^ Number of counters in each array.+ , topkInfoDepth :: Integer+ -- ^ Number of counter arrays.+ , topkInfoDecay :: Double+ -- ^ Decay factor of the sketch.+ } deriving (Show, Eq)++instance RedisResult TopkInfo where+ decode r = do+ fields <- decode r :: Either Reply [(ByteString, Reply)]+ topkInfoK <- decodeField "k" fields+ topkInfoWidth <- decodeField "width" fields+ topkInfoDepth <- decodeField "depth" fields+ topkInfoDecay <- decodeField "decay" fields+ pure TopkInfo{..}+ where+ decodeField key fields = maybe (Left r) decode (lookup key fields)++-- |Adds one or more items to a Top-K sketch (<https://redis.io/commands/topk.add>).+--+-- Returns the items dropped from the sketch after each insertion, or 'Nothing' when no item was expelled.+--+-- /O(n \cdot d)/, where /n/ is the number of items and /d/ is the depth of the sketch.+--+-- Since RedisBloom 2.0.0+topkAdd+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Top-K sketch.+ -> NonEmpty ByteString -- ^ Items to add.+ -> m (f [Maybe ByteString])+topkAdd key items = sendRequest $ ["TOPK.ADD", key] ++ NE.toList items++-- |Returns the count for one or more items in a Top-K sketch (<https://redis.io/commands/topk.count>).+--+-- Returns @0@ for items that are not tracked by the sketch.+--+-- /O(n \cdot d)/, where /n/ is the number of items and /d/ is the depth of the sketch.+--+-- Since RedisBloom 2.0.0+topkCount+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Top-K sketch.+ -> NonEmpty ByteString -- ^ Items to count.+ -> m (f [Integer])+topkCount key items = sendRequest $ ["TOPK.COUNT", key] ++ NE.toList items++-- |Increments the count of one or more items by a configured amount (<https://redis.io/commands/topk.incrby>).+--+-- Returns the items dropped from the sketch after each increment, or 'Nothing' when no item was expelled.+--+-- /O(n \cdot d)/, where /n/ is the number of item-increment pairs and /d/ is the depth of the sketch.+--+-- Since RedisBloom 2.0.0+topkIncrby+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Top-K sketch.+ -> NonEmpty (ByteString, Integer) -- ^ Item and increment pairs.+ -> m (f [Maybe ByteString])+topkIncrby key itemIncrements =+ sendRequest $ ["TOPK.INCRBY", key] ++ concatMap encodePair (NE.toList itemIncrements)+ where+ encodePair (item, increment) = [item, encode increment]++-- |Returns information about a Top-K sketch (<https://redis.io/commands/topk.info>).+--+-- $O(1)$+--+-- Since RedisBloom 2.0.0+topkInfo+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Top-K sketch.+ -> m (f TopkInfo)+topkInfo key = sendRequest ["TOPK.INFO", key]++-- |Returns the items in a Top-K sketch (<https://redis.io/commands/topk.list>).+--+-- /O(k)/, where /k/ is the configured top-k size.+--+-- Since RedisBloom 2.0.0+topkList+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Top-K sketch.+ -> m (f [ByteString])+topkList key = sendRequest ["TOPK.LIST", key]++-- |Returns the items in a Top-K sketch along with their approximated counts (<https://redis.io/commands/topk.list>).+--+-- /O(k)/, where /k/ is the configured top-k size.+--+-- Since RedisBloom 2.0.0+topkListWithCount+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Top-K sketch.+ -> m (f [(ByteString, Integer)])+topkListWithCount key = sendRequest ["TOPK.LIST", key, "WITHCOUNT"]++-- |Creates an empty Top-K sketch (<https://redis.io/commands/topk.reserve>).+--+-- The sketch will fail to be created if the key already exists.+--+-- /O(1)/+--+-- Since RedisBloom 2.0.0+topkReserve+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Top-K sketch to create.+ -> Integer -- ^ Number of items to keep in the sketch.+ -> Integer -- ^ Number of counters in each array.+ -> Integer -- ^ Number of counter arrays.+ -> Double -- ^ Decay factor.+ -> m (f Status)+topkReserve key topk width depth decay =+ sendRequest ["TOPK.RESERVE", key, encode topk, encode width, encode depth, encode decay]++-- |Checks whether one or more items are present in a Top-K sketch (<https://redis.io/commands/topk.query>).+--+-- A 'False' value means the item is not currently one of the tracked heavy hitters.+--+-- /O(n \cdot d)/, where /n/ is the number of items and /d/ is the depth of the sketch.+--+-- Since RedisBloom 2.0.0+topkQuery+ :: (RedisCtx m f)+ => ByteString -- ^ Key of the Top-K sketch.+ -> NonEmpty ByteString -- ^ Items to check.+ -> m (f [Bool])+topkQuery key items = sendRequest $ ["TOPK.QUERY", key] ++ NE.toList items
+ src/Database/Redis/ManualCommands/Ts.hs view
@@ -0,0 +1,756 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Database.Redis.ManualCommands.Ts where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as Char8+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE++import Database.Redis.Core+import Database.Redis.Protocol+import Database.Redis.Types++data TsSample = TsSample+ { tsSampleTimestamp :: Integer+ , tsSampleValue :: Double+ } deriving (Show, Eq)++instance RedisResult TsSample where+ decode (MultiBulk (Just [timestampReply, valueReply])) =+ TsSample <$> decode timestampReply <*> decode valueReply+ decode response = Left response++data TsEncoding+ = TsUncompressed+ | TsCompressed+ deriving (Show, Eq)++instance RedisArg TsEncoding where+ encode TsUncompressed = "UNCOMPRESSED"+ encode TsCompressed = "COMPRESSED"++data TsDuplicatePolicy+ = TsDuplicateBlock+ | TsDuplicateFirst+ | TsDuplicateLast+ | TsDuplicateMin+ | TsDuplicateMax+ | TsDuplicateSum+ deriving (Show, Eq)++instance RedisArg TsDuplicatePolicy where+ encode TsDuplicateBlock = "BLOCK"+ encode TsDuplicateFirst = "FIRST"+ encode TsDuplicateLast = "LAST"+ encode TsDuplicateMin = "MIN"+ encode TsDuplicateMax = "MAX"+ encode TsDuplicateSum = "SUM"++data TsIgnore = TsIgnore+ { tsIgnoreMaxTimeDiff :: Integer+ , tsIgnoreMaxValDiff :: Double+ } deriving (Show, Eq)++data TsCreateOpts = TsCreateOpts+ { tsCreateRetention :: Maybe Integer+ , tsCreateEncoding :: Maybe TsEncoding+ , tsCreateChunkSize :: Maybe Integer+ , tsCreateDuplicatePolicy :: Maybe TsDuplicatePolicy+ , tsCreateIgnore :: Maybe TsIgnore+ , tsCreateLabels :: [(ByteString, ByteString)]+ } deriving (Show, Eq)++defaultTsCreateOpts :: TsCreateOpts+defaultTsCreateOpts = TsCreateOpts+ { tsCreateRetention = Nothing+ , tsCreateEncoding = Nothing+ , tsCreateChunkSize = Nothing+ , tsCreateDuplicatePolicy = Nothing+ , tsCreateIgnore = Nothing+ , tsCreateLabels = []+ }++data TsAlterOpts = TsAlterOpts+ { tsAlterRetention :: Maybe Integer+ , tsAlterChunkSize :: Maybe Integer+ , tsAlterDuplicatePolicy :: Maybe TsDuplicatePolicy+ , tsAlterLabels :: [(ByteString, ByteString)]+ } deriving (Show, Eq)++defaultTsAlterOpts :: TsAlterOpts+defaultTsAlterOpts = TsAlterOpts+ { tsAlterRetention = Nothing+ , tsAlterChunkSize = Nothing+ , tsAlterDuplicatePolicy = Nothing+ , tsAlterLabels = []+ }++data TsAddOpts = TsAddOpts+ { tsAddRetention :: Maybe Integer+ , tsAddEncoding :: Maybe TsEncoding+ , tsAddChunkSize :: Maybe Integer+ , tsAddOnDuplicate :: Maybe TsDuplicatePolicy+ , tsAddIgnore :: Maybe TsIgnore+ , tsAddLabels :: [(ByteString, ByteString)]+ } deriving (Show, Eq)++defaultTsAddOpts :: TsAddOpts+defaultTsAddOpts = TsAddOpts+ { tsAddRetention = Nothing+ , tsAddEncoding = Nothing+ , tsAddChunkSize = Nothing+ , tsAddOnDuplicate = Nothing+ , tsAddIgnore = Nothing+ , tsAddLabels = []+ }++data TsIncrByOpts = TsIncrByOpts+ { tsIncrByTimestamp :: Maybe ByteString+ , tsIncrByRetention :: Maybe Integer+ , tsIncrByUncompressed :: Bool+ , tsIncrByChunkSize :: Maybe Integer+ , tsIncrByDuplicatePolicy :: Maybe TsDuplicatePolicy+ , tsIncrByIgnore :: Maybe TsIgnore+ , tsIncrByLabels :: [(ByteString, ByteString)]+ } deriving (Show, Eq)++defaultTsIncrByOpts :: TsIncrByOpts+defaultTsIncrByOpts = TsIncrByOpts+ { tsIncrByTimestamp = Nothing+ , tsIncrByRetention = Nothing+ , tsIncrByUncompressed = False+ , tsIncrByChunkSize = Nothing+ , tsIncrByDuplicatePolicy = Nothing+ , tsIncrByIgnore = Nothing+ , tsIncrByLabels = []+ }++data TsGetOpts = TsGetOpts+ { tsGetLatest :: Bool+ } deriving (Show, Eq)++defaultTsGetOpts :: TsGetOpts+defaultTsGetOpts = TsGetOpts+ { tsGetLatest = False+ }++data TsAggregator+ = TsAggAvg+ | TsAggFirst+ | TsAggLast+ | TsAggMin+ | TsAggMax+ | TsAggSum+ | TsAggRange+ | TsAggCount+ | TsAggStdP+ | TsAggStdS+ | TsAggVarP+ | TsAggVarS+ | TsAggTwa+ | TsAggCountNaN+ | TsAggCountAll+ deriving (Show, Eq)++instance RedisArg TsAggregator where+ encode TsAggAvg = "avg"+ encode TsAggFirst = "first"+ encode TsAggLast = "last"+ encode TsAggMin = "min"+ encode TsAggMax = "max"+ encode TsAggSum = "sum"+ encode TsAggRange = "range"+ encode TsAggCount = "count"+ encode TsAggStdP = "std.p"+ encode TsAggStdS = "std.s"+ encode TsAggVarP = "var.p"+ encode TsAggVarS = "var.s"+ encode TsAggTwa = "twa"+ encode TsAggCountNaN = "countnan"+ encode TsAggCountAll = "countall"++newtype TsAggregators = TsAggregators+ { unTsAggregators :: NonEmpty TsAggregator+ } deriving (Show, Eq)++instance RedisArg TsAggregators where+ encode = Char8.intercalate "," . map encode . NE.toList . unTsAggregators++data TsBucketTimestamp+ = TsBucketStart+ | TsBucketEnd+ | TsBucketMid+ deriving (Show, Eq)++instance RedisArg TsBucketTimestamp where+ encode TsBucketStart = "-"+ encode TsBucketEnd = "+"+ encode TsBucketMid = "~"++data TsAggregationOpts = TsAggregationOpts+ { tsAggregationAlign :: Maybe ByteString+ , tsAggregationType :: TsAggregators+ , tsAggregationBucketDuration :: Integer+ , tsAggregationBucketTimestamp :: Maybe TsBucketTimestamp+ , tsAggregationEmpty :: Bool+ } deriving (Show, Eq)++data TsRangeOpts = TsRangeOpts+ { tsRangeLatest :: Bool+ , tsRangeFilterByTs :: [Integer]+ , tsRangeFilterByValue :: Maybe (Double, Double)+ , tsRangeCount :: Maybe Integer+ , tsRangeAggregation :: Maybe TsAggregationOpts+ } deriving (Show, Eq)++defaultTsRangeOpts :: TsRangeOpts+defaultTsRangeOpts = TsRangeOpts+ { tsRangeLatest = False+ , tsRangeFilterByTs = []+ , tsRangeFilterByValue = Nothing+ , tsRangeCount = Nothing+ , tsRangeAggregation = Nothing+ }++data TsLabelSelection+ = TsWithLabels+ | TsSelectedLabels (NonEmpty ByteString)+ deriving (Show, Eq)++data TsGroupByReduce = TsGroupByReduce+ { tsGroupByLabel :: ByteString+ , tsGroupByReducer :: TsAggregator+ } deriving (Show, Eq)++data TsMGetOpts = TsMGetOpts+ { tsMGetLatest :: Bool+ , tsMGetLabels :: Maybe TsLabelSelection+ } deriving (Show, Eq)++defaultTsMGetOpts :: TsMGetOpts+defaultTsMGetOpts = TsMGetOpts+ { tsMGetLatest = False+ , tsMGetLabels = Nothing+ }++data TsMRangeOpts = TsMRangeOpts+ { tsMRangeLatest :: Bool+ , tsMRangeFilterByTs :: [Integer]+ , tsMRangeFilterByValue :: Maybe (Double, Double)+ , tsMRangeLabels :: Maybe TsLabelSelection+ , tsMRangeCount :: Maybe Integer+ , tsMRangeAggregation :: Maybe TsAggregationOpts+ , tsMRangeGroupByReduce :: Maybe TsGroupByReduce+ } deriving (Show, Eq)++defaultTsMRangeOpts :: TsMRangeOpts+defaultTsMRangeOpts = TsMRangeOpts+ { tsMRangeLatest = False+ , tsMRangeFilterByTs = []+ , tsMRangeFilterByValue = Nothing+ , tsMRangeLabels = Nothing+ , tsMRangeCount = Nothing+ , tsMRangeAggregation = Nothing+ , tsMRangeGroupByReduce = Nothing+ }++data TsInfoOpts+ = TsInfoDefault+ | TsInfoDebug+ deriving (Show, Eq)++tsLabelsToArgs :: [(ByteString, ByteString)] -> [ByteString]+tsLabelsToArgs [] = []+tsLabelsToArgs labels = "LABELS" : concatMap (\(k, v) -> [k, v]) labels++tsIgnoreToArgs :: TsIgnore -> [ByteString]+tsIgnoreToArgs TsIgnore{..} =+ ["IGNORE", encode tsIgnoreMaxTimeDiff, encode tsIgnoreMaxValDiff]++tsCreateOptsToArgs :: TsCreateOpts -> [ByteString]+tsCreateOptsToArgs TsCreateOpts{..} =+ retentionArg ++ encodingArg ++ chunkSizeArg ++ duplicatePolicyArg ++ ignoreArg ++ tsLabelsToArgs tsCreateLabels+ where+ retentionArg = maybe [] (\retention -> ["RETENTION", encode retention]) tsCreateRetention+ encodingArg = maybe [] (\encoding -> ["ENCODING", encode encoding]) tsCreateEncoding+ chunkSizeArg = maybe [] (\size -> ["CHUNK_SIZE", encode size]) tsCreateChunkSize+ duplicatePolicyArg = maybe [] (\policy -> ["DUPLICATE_POLICY", encode policy]) tsCreateDuplicatePolicy+ ignoreArg = maybe [] tsIgnoreToArgs tsCreateIgnore++tsAlterOptsToArgs :: TsAlterOpts -> [ByteString]+tsAlterOptsToArgs TsAlterOpts{..} =+ retentionArg ++ chunkSizeArg ++ duplicatePolicyArg ++ tsLabelsToArgs tsAlterLabels+ where+ retentionArg = maybe [] (\retention -> ["RETENTION", encode retention]) tsAlterRetention+ chunkSizeArg = maybe [] (\size -> ["CHUNK_SIZE", encode size]) tsAlterChunkSize+ duplicatePolicyArg = maybe [] (\policy -> ["DUPLICATE_POLICY", encode policy]) tsAlterDuplicatePolicy++tsAddOptsToArgs :: TsAddOpts -> [ByteString]+tsAddOptsToArgs TsAddOpts{..} =+ retentionArg ++ encodingArg ++ chunkSizeArg ++ onDuplicateArg ++ ignoreArg ++ tsLabelsToArgs tsAddLabels+ where+ retentionArg = maybe [] (\retention -> ["RETENTION", encode retention]) tsAddRetention+ encodingArg = maybe [] (\encoding -> ["ENCODING", encode encoding]) tsAddEncoding+ chunkSizeArg = maybe [] (\size -> ["CHUNK_SIZE", encode size]) tsAddChunkSize+ onDuplicateArg = maybe [] (\policy -> ["ON_DUPLICATE", encode policy]) tsAddOnDuplicate+ ignoreArg = maybe [] tsIgnoreToArgs tsAddIgnore++tsIncrByOptsToArgs :: TsIncrByOpts -> [ByteString]+tsIncrByOptsToArgs TsIncrByOpts{..} =+ timestampArg ++ retentionArg ++ uncompressedArg ++ chunkSizeArg ++ duplicatePolicyArg ++ ignoreArg ++ tsLabelsToArgs tsIncrByLabels+ where+ timestampArg = maybe [] (\timestamp -> ["TIMESTAMP", timestamp]) tsIncrByTimestamp+ retentionArg = maybe [] (\retention -> ["RETENTION", encode retention]) tsIncrByRetention+ uncompressedArg = ["UNCOMPRESSED" | tsIncrByUncompressed]+ chunkSizeArg = maybe [] (\size -> ["CHUNK_SIZE", encode size]) tsIncrByChunkSize+ duplicatePolicyArg = maybe [] (\policy -> ["DUPLICATE_POLICY", encode policy]) tsIncrByDuplicatePolicy+ ignoreArg = maybe [] tsIgnoreToArgs tsIncrByIgnore++tsAggregationToArgs :: TsAggregationOpts -> [ByteString]+tsAggregationToArgs TsAggregationOpts{..} =+ alignArg ++ ["AGGREGATION", encode tsAggregationType, encode tsAggregationBucketDuration] ++ bucketTimestampArg ++ emptyArg+ where+ alignArg = maybe [] (\align -> ["ALIGN", align]) tsAggregationAlign+ bucketTimestampArg = maybe [] (\bt -> ["BUCKETTIMESTAMP", encode bt]) tsAggregationBucketTimestamp+ emptyArg = ["EMPTY" | tsAggregationEmpty]++tsRangeOptsToArgs :: TsRangeOpts -> [ByteString]+tsRangeOptsToArgs TsRangeOpts{..} =+ latestArg ++ filterByTsArg ++ filterByValueArg ++ countArg ++ aggregationArg+ where+ latestArg = ["LATEST" | tsRangeLatest]+ filterByTsArg = ["FILTER_BY_TS" | not (null tsRangeFilterByTs)] ++ map encode tsRangeFilterByTs+ filterByValueArg = maybe [] (\(minValue, maxValue) -> ["FILTER_BY_VALUE", encode minValue, encode maxValue]) tsRangeFilterByValue+ countArg = maybe [] (\count -> ["COUNT", encode count]) tsRangeCount+ aggregationArg = maybe [] tsAggregationToArgs tsRangeAggregation++tsLabelSelectionToArgs :: TsLabelSelection -> [ByteString]+tsLabelSelectionToArgs TsWithLabels = ["WITHLABELS"]+tsLabelSelectionToArgs (TsSelectedLabels labels) = ["SELECTED_LABELS"] ++ NE.toList labels++tsMGetOptsToArgs :: TsMGetOpts -> [ByteString]+tsMGetOptsToArgs TsMGetOpts{..} =+ latestArg ++ labelsArg+ where+ latestArg = ["LATEST" | tsMGetLatest]+ labelsArg = maybe [] tsLabelSelectionToArgs tsMGetLabels++tsGroupByReduceToArgs :: TsGroupByReduce -> [ByteString]+tsGroupByReduceToArgs TsGroupByReduce{..} =+ ["GROUPBY", tsGroupByLabel, "REDUCE", encode tsGroupByReducer]++tsMRangeOptsToArgs :: TsMRangeOpts -> [ByteString]+tsMRangeOptsToArgs TsMRangeOpts{..} =+ latestArg ++ filterByTsArg ++ filterByValueArg ++ labelsArg ++ countArg ++ aggregationArg ++ groupByReduceArg+ where+ latestArg = ["LATEST" | tsMRangeLatest]+ filterByTsArg = ["FILTER_BY_TS" | not (null tsMRangeFilterByTs)] ++ map encode tsMRangeFilterByTs+ filterByValueArg = maybe [] (\(minValue, maxValue) -> ["FILTER_BY_VALUE", encode minValue, encode maxValue]) tsMRangeFilterByValue+ labelsArg = maybe [] tsLabelSelectionToArgs tsMRangeLabels+ countArg = maybe [] (\count -> ["COUNT", encode count]) tsMRangeCount+ aggregationArg = maybe [] tsAggregationToArgs tsMRangeAggregation+ groupByReduceArg = maybe [] tsGroupByReduceToArgs tsMRangeGroupByReduce++-- |Appends a sample to a time series (<https://redis.io/commands/ts.add>).+--+-- /O(M)/ when /M/ is the number of compaction rules, or /O(1)/ with no compaction+--+-- Since RedisTimeSeries 1.0.0+tsAdd+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> ByteString -- ^ Timestamp, or @*@ for the current server time.+ -> Double -- ^ Sample value.+ -> m (f Integer)+tsAdd key timestamp value = tsAddOpts key timestamp value defaultTsAddOpts++-- |Appends a sample to a time series (<https://redis.io/commands/ts.add>).+--+-- /O(M)/ when /M/ is the number of compaction rules, or /O(1)/ with no compaction+--+-- Since RedisTimeSeries 1.0.0+tsAddOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> ByteString -- ^ Timestamp, or @*@ for the current server time.+ -> Double -- ^ Sample value.+ -> TsAddOpts -- ^ Insertion options.+ -> m (f Integer)+tsAddOpts key timestamp value opts =+ sendRequest $ ["TS.ADD", key, timestamp, encode value] ++ tsAddOptsToArgs opts++-- |Update the retention, chunk size, duplicate policy, and labels of an existing time series (<https://redis.io/commands/ts.alter>).+--+-- /O(N)/ where /N/ is the number of labels requested to update+--+-- Since RedisTimeSeries 1.0.0+tsAlter+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> TsAlterOpts -- ^ Alteration options.+ -> m (f Status)+tsAlter key opts = sendRequest $ ["TS.ALTER", key] ++ tsAlterOptsToArgs opts++-- |Create a new time series (<https://redis.io/commands/ts.create>).+--+-- /O(1)/+--+-- Since RedisTimeSeries 1.0.0+tsCreate+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> m (f Status)+tsCreate key = tsCreateOpts key defaultTsCreateOpts++-- |Create a new time series (<https://redis.io/commands/ts.create>).+--+-- /O(1)/+--+-- Since RedisTimeSeries 1.0.0+tsCreateOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> TsCreateOpts -- ^ Creation options.+ -> m (f Status)+tsCreateOpts key opts = sendRequest $ ["TS.CREATE", key] ++ tsCreateOptsToArgs opts++-- |Create a compaction rule (<https://redis.io/commands/ts.createrule>).+--+-- /O(1)/+--+-- Since RedisTimeSeries 1.0.0+tsCreaterule+ :: (RedisCtx m f)+ => ByteString -- ^ Source time series key.+ -> ByteString -- ^ Destination time series key.+ -> TsAggregator -- ^ Aggregation function.+ -> Integer -- ^ Bucket duration in milliseconds.+ -> m (f Status)+tsCreaterule source destination aggregator bucketDuration =+ sendRequest ["TS.CREATERULE", source, destination, "AGGREGATION", encode aggregator, encode bucketDuration]++-- |Create a compaction rule with an aligned bucket timestamp (<https://redis.io/commands/ts.createrule>).+--+-- /O(1)/+--+-- Since RedisTimeSeries 1.8.0+tsCreateruleAlign+ :: (RedisCtx m f)+ => ByteString -- ^ Source time series key.+ -> ByteString -- ^ Destination time series key.+ -> TsAggregator -- ^ Aggregation function.+ -> Integer -- ^ Bucket duration in milliseconds.+ -> Integer -- ^ Alignment timestamp in milliseconds.+ -> m (f Status)+tsCreateruleAlign source destination aggregator bucketDuration alignTimestamp =+ sendRequest ["TS.CREATERULE", source, destination, "AGGREGATION", encode aggregator, encode bucketDuration, encode alignTimestamp]++-- |Decrease the value of the sample with the maximum timestamp, or create a new sample with a decremented value (<https://redis.io/commands/ts.decrby>).+--+-- /O(M)/ when /M/ is the number of compaction rules, or /O(1)/ with no compaction+--+-- Since RedisTimeSeries 1.0.0+tsDecrby+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> Double -- ^ Decrement amount.+ -> m (f Integer)+tsDecrby key value = tsDecrbyOpts key value defaultTsIncrByOpts++-- |Decrease the value of the sample with the maximum timestamp, or create a new sample with a decremented value (<https://redis.io/commands/ts.decrby>).+--+-- /O(M)/ when /M/ is the number of compaction rules, or /O(1)/ with no compaction+--+-- Since RedisTimeSeries 1.0.0+tsDecrbyOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> Double -- ^ Decrement amount.+ -> TsIncrByOpts -- ^ Update options.+ -> m (f Integer)+tsDecrbyOpts key value opts =+ sendRequest $ ["TS.DECRBY", key, encode value] ++ tsIncrByOptsToArgs opts++-- |Delete all samples between two timestamps for a given time series (<https://redis.io/commands/ts.del>).+--+-- /O(N)/ where /N/ is the number of data points that will be removed+--+-- Since RedisTimeSeries 1.6.0+tsDel+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> Integer -- ^ Lower timestamp bound.+ -> Integer -- ^ Upper timestamp bound.+ -> m (f Integer)+tsDel key fromTimestamp toTimestamp =+ sendRequest ["TS.DEL", key, encode fromTimestamp, encode toTimestamp]++-- |Delete a compaction rule (<https://redis.io/commands/ts.delrule>).+--+-- /O(1)/+--+-- Since RedisTimeSeries 1.0.0+tsDelrule+ :: (RedisCtx m f)+ => ByteString -- ^ Source time series key.+ -> ByteString -- ^ Destination time series key.+ -> m (f Status)+tsDelrule source destination = sendRequest ["TS.DELRULE", source, destination]++-- |Get the sample with the highest timestamp from a given time series (<https://redis.io/commands/ts.get>).+--+-- /O(1)/+--+-- Since RedisTimeSeries 1.0.0+tsGet+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> m (f (Maybe TsSample))+tsGet key = tsGetOpts key defaultTsGetOpts++-- |Get the sample with the highest timestamp from a given time series (<https://redis.io/commands/ts.get>).+--+-- /O(1)/+--+-- Since RedisTimeSeries 1.0.0+tsGetOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> TsGetOpts -- ^ Read options.+ -> m (f (Maybe TsSample))+tsGetOpts key TsGetOpts{..} =+ sendRequest $ ["TS.GET", key] ++ ["LATEST" | tsGetLatest]++-- |Increase the value of the sample with the maximum timestamp, or create a new sample with an incremented value (<https://redis.io/commands/ts.incrby>).+--+-- /O(M)/ when /M/ is the number of compaction rules, or /O(1)/ with no compaction+--+-- Since RedisTimeSeries 1.0.0+tsIncrby+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> Double -- ^ Increment amount.+ -> m (f Integer)+tsIncrby key value = tsIncrbyOpts key value defaultTsIncrByOpts++-- |Increase the value of the sample with the maximum timestamp, or create a new sample with an incremented value (<https://redis.io/commands/ts.incrby>).+--+-- /O(M)/ when /M/ is the number of compaction rules, or /O(1)/ with no compaction+--+-- Since RedisTimeSeries 1.0.0+tsIncrbyOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> Double -- ^ Increment amount.+ -> TsIncrByOpts -- ^ Update options.+ -> m (f Integer)+tsIncrbyOpts key value opts =+ sendRequest $ ["TS.INCRBY", key, encode value] ++ tsIncrByOptsToArgs opts++-- |Returns information and statistics for a time series (<https://redis.io/commands/ts.info>).+--+-- The reply is a heterogeneous attribute map, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/+--+-- Since RedisTimeSeries 1.0.0+tsInfo+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> m (f Reply)+tsInfo key = tsInfoOpts key TsInfoDefault++-- |Returns information and statistics for a time series (<https://redis.io/commands/ts.info>).+--+-- The reply is a heterogeneous attribute map, so this wrapper returns the raw 'Reply'.+--+-- /O(1)/+--+-- Since RedisTimeSeries 1.0.0+tsInfoOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> TsInfoOpts -- ^ Information query options.+ -> m (f Reply)+tsInfoOpts key infoOpts =+ sendRequest $ ["TS.INFO", key] ++ case infoOpts of+ TsInfoDefault -> []+ TsInfoDebug -> ["DEBUG"]++-- |Append new samples to one or more time series (<https://redis.io/commands/ts.madd>).+--+-- /O(N \cdot M)/ when /N/ is the number of series updated and /M/ is the number of compaction rules, or /O(N)/ with no compaction+--+-- Since RedisTimeSeries 1.0.0+tsMadd+ :: (RedisCtx m f)+ => NonEmpty (ByteString, ByteString, Double) -- ^ Time series key, timestamp, and sample value triplets.+ -> m (f [Integer])+tsMadd triples = sendRequest $ "TS.MADD" : concatMap encodeTriple (NE.toList triples)+ where+ encodeTriple (key, timestamp, value) = [key, timestamp, encode value]++-- |Get the sample with the highest timestamp from each time series matching a specific filter (<https://redis.io/commands/ts.mget>).+--+-- The reply is heterogeneous and depends on label options, so this wrapper returns the raw 'Reply'.+--+-- /O(n)/ where /n/ is the number of time-series that match the filters+--+-- Since RedisTimeSeries 1.0.0+tsMget+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ Filter expressions.+ -> m (f Reply)+tsMget filters = tsMgetOpts filters defaultTsMGetOpts++-- |Get the sample with the highest timestamp from each time series matching a specific filter (<https://redis.io/commands/ts.mget>).+--+-- The reply is heterogeneous and depends on label options, so this wrapper returns the raw 'Reply'.+--+-- /O(n)/ where /n/ is the number of time-series that match the filters+--+-- Since RedisTimeSeries 1.0.0+tsMgetOpts+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ Filter expressions.+ -> TsMGetOpts -- ^ Read options.+ -> m (f Reply)+tsMgetOpts filters opts =+ sendRequest $ ["TS.MGET"] ++ tsMGetOptsToArgs opts ++ ["FILTER"] ++ NE.toList filters++-- |Query a range across multiple time series by filters in forward direction (<https://redis.io/commands/ts.mrange>).+--+-- The reply is heterogeneous and may include labels or grouped output, so this wrapper returns the raw 'Reply'.+--+-- /O(n\/m+k)/ where /n/ is the number of data points, /m/ is the chunk size, and /k/ is the number of returned samples+--+-- Since RedisTimeSeries 1.0.0+tsMrange+ :: (RedisCtx m f)+ => ByteString -- ^ Lower timestamp bound, or @-@.+ -> ByteString -- ^ Upper timestamp bound, or @+@.+ -> NonEmpty ByteString -- ^ Filter expressions.+ -> m (f Reply)+tsMrange fromTimestamp toTimestamp filters =+ tsMrangeOpts fromTimestamp toTimestamp filters defaultTsMRangeOpts++-- |Query a range across multiple time series by filters in forward direction (<https://redis.io/commands/ts.mrange>).+--+-- The reply is heterogeneous and may include labels or grouped output, so this wrapper returns the raw 'Reply'.+--+-- /O(n\/m+k)/ where /n/ is the number of data points, /m/ is the chunk size, and /k/ is the number of returned samples+--+-- Since RedisTimeSeries 1.0.0+tsMrangeOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Lower timestamp bound, or @-@.+ -> ByteString -- ^ Upper timestamp bound, or @+@.+ -> NonEmpty ByteString -- ^ Filter expressions.+ -> TsMRangeOpts -- ^ Query options.+ -> m (f Reply)+tsMrangeOpts fromTimestamp toTimestamp filters opts =+ sendRequest $ ["TS.MRANGE", fromTimestamp, toTimestamp] ++ tsMRangeOptsToArgs opts ++ ["FILTER"] ++ NE.toList filters++-- |Query a range across multiple time series by filters in reverse direction (<https://redis.io/commands/ts.mrevrange>).+--+-- The reply is heterogeneous and may include labels or grouped output, so this wrapper returns the raw 'Reply'.+--+-- /O(n\/m+k)/ where /n/ is the number of data points, /m/ is the chunk size, and /k/ is the number of returned samples+--+-- Since RedisTimeSeries 1.4.0+tsMrevrange+ :: (RedisCtx m f)+ => ByteString -- ^ Lower timestamp bound, or @-@.+ -> ByteString -- ^ Upper timestamp bound, or @+@.+ -> NonEmpty ByteString -- ^ Filter expressions.+ -> m (f Reply)+tsMrevrange fromTimestamp toTimestamp filters =+ tsMrevrangeOpts fromTimestamp toTimestamp filters defaultTsMRangeOpts++-- |Query a range across multiple time series by filters in reverse direction (<https://redis.io/commands/ts.mrevrange>).+--+-- The reply is heterogeneous and may include labels or grouped output, so this wrapper returns the raw 'Reply'.+--+-- /O(n\/m+k)/ where /n/ is the number of data points, /m/ is the chunk size, and /k/ is the number of returned samples+--+-- Since RedisTimeSeries 1.4.0+tsMrevrangeOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Lower timestamp bound, or @-@.+ -> ByteString -- ^ Upper timestamp bound, or @+@.+ -> NonEmpty ByteString -- ^ Filter expressions.+ -> TsMRangeOpts -- ^ Query options.+ -> m (f Reply)+tsMrevrangeOpts fromTimestamp toTimestamp filters opts =+ sendRequest $ ["TS.MREVRANGE", fromTimestamp, toTimestamp] ++ tsMRangeOptsToArgs opts ++ ["FILTER"] ++ NE.toList filters++-- |Get all time series keys matching a filter list (<https://redis.io/commands/ts.queryindex>).+--+-- /O(n)/ where /n/ is the number of time-series that match the filters+--+-- Since RedisTimeSeries 1.0.0+tsQueryindex+ :: (RedisCtx m f)+ => NonEmpty ByteString -- ^ Filter expressions.+ -> m (f [ByteString])+tsQueryindex filters = sendRequest $ "TS.QUERYINDEX" : NE.toList filters++-- |Query a range in forward direction (<https://redis.io/commands/ts.range>).+--+-- /O(n\/m+k)/ where /n/ is the number of data points, /m/ is the chunk size, and /k/ is the number of returned samples+--+-- Since RedisTimeSeries 1.0.0+tsRange+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> ByteString -- ^ Lower timestamp bound, or @-@.+ -> ByteString -- ^ Upper timestamp bound, or @+@.+ -> m (f [TsSample])+tsRange key fromTimestamp toTimestamp =+ tsRangeOpts key fromTimestamp toTimestamp defaultTsRangeOpts++-- |Query a range in forward direction (<https://redis.io/commands/ts.range>).+--+-- /O(n\/m+k)/ where /n/ is the number of data points, /m/ is the chunk size, and /k/ is the number of returned samples+--+-- Since RedisTimeSeries 1.0.0+tsRangeOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> ByteString -- ^ Lower timestamp bound, or @-@.+ -> ByteString -- ^ Upper timestamp bound, or @+@.+ -> TsRangeOpts -- ^ Query options.+ -> m (f [TsSample])+tsRangeOpts key fromTimestamp toTimestamp opts =+ sendRequest $ ["TS.RANGE", key, fromTimestamp, toTimestamp] ++ tsRangeOptsToArgs opts++-- |Query a range in reverse direction (<https://redis.io/commands/ts.revrange>).+--+-- /O(n\/m+k)/ where /n/ is the number of data points, /m/ is the chunk size, and /k/ is the number of returned samples+--+-- Since RedisTimeSeries 1.4.0+tsRevrange+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> ByteString -- ^ Lower timestamp bound, or @-@.+ -> ByteString -- ^ Upper timestamp bound, or @+@.+ -> m (f [TsSample])+tsRevrange key fromTimestamp toTimestamp =+ tsRevrangeOpts key fromTimestamp toTimestamp defaultTsRangeOpts++-- |Query a range in reverse direction (<https://redis.io/commands/ts.revrange>).+--+-- /O(n\/m+k)/ where /n/ is the number of data points, /m/ is the chunk size, and /k/ is the number of returned samples+--+-- Since RedisTimeSeries 1.4.0+tsRevrangeOpts+ :: (RedisCtx m f)+ => ByteString -- ^ Time series key.+ -> ByteString -- ^ Lower timestamp bound, or @-@.+ -> ByteString -- ^ Upper timestamp bound, or @+@.+ -> TsRangeOpts -- ^ Query options.+ -> m (f [TsSample])+tsRevrangeOpts key fromTimestamp toTimestamp opts =+ sendRequest $ ["TS.REVRANGE", key, fromTimestamp, toTimestamp] ++ tsRangeOptsToArgs opts
+ src/Database/Redis/ManualCommands/Wait.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Database.Redis.ManualCommands.Wait+ ( WaitAofResult(..)+ , wait+ , waitaof+ ) where++import Database.Redis.Core+import Database.Redis.Types++data WaitAofResult = WaitAofResult+ { waitAofLocal :: Integer+ -- ^ Number of local Redis instances (0 or 1) that fsynced all preceding writes to AOF.+ , waitAofReplicas :: Integer+ -- ^ Number of replicas that fsynced all preceding writes to AOF.+ } deriving (Show, Eq)++instance RedisResult WaitAofResult where+ decode response = do+ (waitAofLocal, waitAofReplicas) <- decode response+ pure WaitAofResult{..}++-- |+-- /O(1)/ Wait for preceding writes to be acknowledged by a given number of replicas (<https://redis.io/commands/wait>).+--+-- Blocks until the asynchronous replication of all preceding write commands sent by the connection is completed.+--+-- Since Redis 3.0.0+wait+ :: (RedisCtx m f)+ => Integer -- ^ Number of replicas to wait for.+ -> Integer -- ^ Maximum time to wait in milliseconds. @0@ means wait forever.+ -> m (f Integer)+wait numReplicas timeout =+ sendRequest ["WAIT", encode numReplicas, encode timeout]++-- |+-- /O(1)/ Wait for preceding writes to be fsynced to the append-only file locally and\/or on replicas (<https://redis.io/commands/waitaof>).+--+-- Blocks until all of the preceding write commands sent by the connection are written to the append-only file of the master and\/or replicas.+--+-- Since Redis 7.2.0+waitaof+ :: (RedisCtx m f)+ => Integer -- ^ Number of local Redis instances to wait for AOF fsync on (@0@ or @1@).+ -> Integer -- ^ Number of replicas to wait for AOF fsync on.+ -> Integer -- ^ Maximum time to wait in milliseconds. @0@ means wait forever.+ -> m (f WaitAofResult)+waitaof numLocal numReplicas timeout =+ sendRequest ["WAITAOF", encode numLocal, encode numReplicas, encode timeout]
src/Database/Redis/ProtocolPipelining.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} -- |A module for automatic, optimal protocol pipelining.@@ -16,7 +17,7 @@ -- module Database.Redis.ProtocolPipelining ( Connection,- connect, enableTLS, beginReceiving, disconnect, request, send, recv, flush, fromCtx+ connect, connectWithHooks, beginReceiving, disconnect, request, send, recv, flush, fromCtx, fromCtxWithHooks, hooks ) where import Prelude@@ -24,12 +25,12 @@ import qualified Scanner import qualified Data.ByteString as S import Data.IORef-import qualified Network.Socket as NS import qualified Network.TLS as TLS import System.IO.Unsafe import Database.Redis.Protocol import qualified Database.Redis.ConnectionContext as CC+import Database.Redis.Hooks data Connection = Conn { connCtx :: CC.ConnectionContext -- ^ Connection socket-handle.@@ -41,25 +42,27 @@ -- ^ Number of pending replies and thus the difference length between -- 'connReplies' and 'connPending'. -- length connPending - pendingCount = length connReplies+ , hooks :: Hooks } fromCtx :: CC.ConnectionContext -> IO Connection-fromCtx ctx = Conn ctx <$> newIORef [] <*> newIORef [] <*> newIORef 0+fromCtx ctx = Conn ctx <$> newIORef [] <*> newIORef [] <*> newIORef 0 <*> pure defaultHooks -connect :: NS.HostName -> CC.PortID -> Maybe Int -> IO Connection-connect hostName portId timeoutOpt = do- connCtx <- CC.connect hostName portId timeoutOpt+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{..} -enableTLS :: TLS.ClientParams -> Connection -> IO Connection-enableTLS tlsParams conn@Conn{..} = do- newCtx <- CC.enableTLS tlsParams connCtx- return conn{connCtx = newCtx}- beginReceiving :: Connection -> IO () beginReceiving conn = do rs <- connGetReplies conn@@ -73,7 +76,7 @@ -- The 'Handle' is 'hFlush'ed when reading replies from the 'connCtx'. send :: Connection -> S.ByteString -> IO () send Conn{..} s = do- CC.send connCtx s+ sendHook hooks (CC.send connCtx) s -- Signal that we expect one more reply from Redis. n <- atomicModifyIORef' connPendingCnt $ \n -> let n' = n+1 in (n', n')@@ -87,10 +90,11 @@ -- |Take a reply-thunk from the list of future replies. recv :: Connection -> IO Reply-recv Conn{..} = do- (r:rs) <- readIORef connReplies- writeIORef connReplies rs- return r+recv Conn{..} =+ receiveHook hooks $ do+ (r:rs) <- readIORef connReplies+ writeIORef connReplies rs+ return r -- | Flush the socket. Normally, the socket is flushed in 'recv' (actually 'conGetReplies'), but -- for the multithreaded pub/sub code, the sending thread needs to explicitly flush the subscription@@ -129,7 +133,9 @@ Scanner.Done rest' r -> do -- r is the same as 'head' of 'connPending'. Since we just -- received r, we remove it from the pending list.- atomicModifyIORef' connPending $ \(_:rs) -> (rs, ())+ atomicModifyIORef' connPending $ \case+ (_:rs) -> (rs, ())+ [] -> error "Hedis: impossible happened parseWith missing value that it just received" -- We now expect one less reply from Redis. We don't count to -- negative, which would otherwise occur during pubsub. atomicModifyIORef' connPendingCnt $ \n -> (max 0 (n-1), ())
src/Database/Redis/PubSub.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, EmptyDataDecls, FlexibleInstances, FlexibleContexts, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables, TupleSections, ConstraintKinds #-}+{-# LANGUAGE BlockArguments #-} module Database.Redis.PubSub ( publish,@@ -17,31 +19,44 @@ RedisChannel, RedisPChannel, MessageCallback, PMessageCallback, PubSubController, newPubSubController, currentChannels, currentPChannels, addChannels, addChannelsAndWait, removeChannels, removeChannelsAndWait,- UnregisterCallbacksAction+ UnregisterCallbacksAction,+ pendingChannels, pendingPatternChannels,+ -- ** Short lived connections+ -- $shortlivedexpl+ withPubSub ) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative import Data.Monoid hiding (<>) #endif-import Control.Concurrent.Async (withAsync, waitEitherCatch, waitEitherCatchSTM)+import Control.Arrow (second)+import Control.Concurrent.Async (withAsync, waitEitherCatch, waitEitherCatchSTM, concurrently) import Control.Concurrent.STM-import Control.Exception (throwIO)+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.List (foldl')+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 qualified Database.Redis.Connection as Connection-import qualified Database.Redis.ProtocolPipelining as PP import Database.Redis.Protocol (Reply(..), renderRequest) import Database.Redis.Types+import Control.Monad.IO.Unlift (MonadUnliftIO(withRunInIO))+import Data.Functor (($>)) -- |While in PubSub mode, we keep track of the number of current subscriptions -- (as reported by Redis replies) and the number of messages we expect to@@ -111,20 +126,17 @@ sendCmd :: (Command (Cmd a b)) => Cmd a b -> StateT PubSubState Core.Redis () sendCmd DoNothing = return () sendCmd cmd = do- lift $ Core.send (redisCmd cmd : changes cmd)- modifyPending (updatePending cmd)--cmdCount :: Cmd a b -> Int-cmdCount DoNothing = 0-cmdCount (Cmd c) = length c--totalPendingChanges :: PubSub -> Int-totalPendingChanges (PubSub{..}) =- cmdCount subs + cmdCount unsubs + cmdCount psubs + cmdCount punsubs+ conn <- lift $ Core.reRedis $ asks Core.envConn+ let hook = Core.sendPubSubHook $ PP.hooks conn+ lift $ withRunInIO $ \runInIO -> hook (runInIO . Core.send) (redisCmd cmd : changes cmd)+ modifyPending (updatePending cmd) rawSendCmd :: (Command (Cmd a b)) => PP.Connection -> Cmd a b -> IO () rawSendCmd _ DoNothing = return ()-rawSendCmd conn cmd = PP.send conn $ renderRequest $ redisCmd cmd : changes cmd+rawSendCmd conn cmd =+ let hook = Core.sendPubSubHook $ PP.hooks conn+ msg = redisCmd cmd : changes cmd+ in hook (PP.send conn . renderRequest) msg plusChangeCnt :: Cmd a b -> Int -> Int plusChangeCnt DoNothing = id@@ -151,7 +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 ------------------------------------------------------------------------------@@ -172,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@@ -182,12 +199,21 @@ -> PubSub unsubscribe cs = mempty{ unsubs = Cmd cs } +-- |Stop listening for messages posted to the given channels.+-- It works like 'unsubscribe', except it does not unsubscribe from+-- all channels when no channel is passed+unsubscribe1+ :: [ByteString] -- ^ channel+ -> PubSub+unsubscribe1 [] = mempty+unsubscribe1 cs = mempty{ unsubs = Cmd cs }+ -- |Listen for messages published to channels matching the given patterns -- (<http://redis.io/commands/psubscribe>). psubscribe :: [ByteString] -- ^ pattern -> PubSub-psubscribe [] = mempty+psubscribe [] = mempty psubscribe ps = mempty{ psubs = Cmd ps } -- |Stop listening for messages posted to channels matching the given patterns@@ -197,6 +223,15 @@ -> PubSub punsubscribe ps = mempty{ punsubs = Cmd ps } +-- |Stop listening for messages posted to channels matching the given patterns.+-- It works like 'punsubscribe', except it does not unsubscribe from all channels+-- in case when the list is empty.+punsubscribe1+ :: [ByteString] -- ^ pattern+ -> PubSub+punsubscribe1 [] = mempty+punsubscribe1 ps = mempty{ punsubs = Cmd ps }+ -- |Listens to published messages on subscribed channels and channels matching -- the subscribed patterns. For documentation on the semantics of Redis -- Pub\/Sub see <http://redis.io/topics/pubsub>.@@ -246,15 +281,21 @@ recv :: StateT PubSubState Core.Redis () recv = do+ hook <- lift $ Core.reRedis $ asks $ Core.callbackHook . PP.hooks . Core.envConn reply <- lift Core.recv case decodeMsg reply of- Msg msg -> liftIO (callback msg) >>= send- Subscribed -> modifyPending (subtract 1) >> recv- Unsubscribed n -> do- putSubCnt n- PubSubState{..} <- get- unless (subCnt == 0 && pending == 0) recv+ Msg msg -> liftIO (hook callback msg) >>= send+ Subscribed _ -> modifyPending (subtract 1) >> recv+ PSubscribed _ -> modifyPending (subtract 1) >> recv+ PUnsubscribed _ n -> onUnsubscribe n+ Unsubscribed _ n -> onUnsubscribe n + onUnsubscribe :: Int -> StateT PubSubState Core.Redis ()+ onUnsubscribe n = do+ putSubCnt n+ PubSubState{..} <- get+ unless (subCnt == 0 && pending == 0) recv+ -- | A Redis channel name type RedisChannel = ByteString @@ -298,6 +339,15 @@ newtype UnregisterHandle = UnregisterHandle Integer deriving (Eq, Show, Num) +-- | Stores channels subscribed, pending subscription, and pending removal+-- by type, where type can be a normal channel, or a pattern channel.+data ChannelData channel callback+ = ChannelData+ { cdSubscribedChannels :: !(TVar (HM.HashMap channel [(UnregisterHandle, callback)]))+ , cdChannelsPendingSubscription :: !(TVar (HS.HashSet channel))+ , cdChannelsPendingRemoval :: !(TVar (HS.HashSet channel))+ }+ -- | A controller that stores a set of channels, pattern channels, and callbacks. -- It allows you to manage Pub/Sub subscriptions and pattern subscriptions and alter them at -- any time throughout the life of your program.@@ -305,48 +355,74 @@ -- through the life of your program, using 'addChannels' and 'removeChannels' to update the -- current subscriptions. data PubSubController = PubSubController- { callbacks :: TVar (HM.HashMap RedisChannel [(UnregisterHandle, MessageCallback)])- , pcallbacks :: TVar (HM.HashMap RedisPChannel [(UnregisterHandle, PMessageCallback)])- , sendChanges :: TBQueue PubSub- , pendingCnt :: TVar Int+ { sendChanges :: TBQueue PubSub+ , pscChannelData :: ChannelData RedisChannel MessageCallback+ , pscPChannelData :: ChannelData RedisPChannel PMessageCallback , lastUsedCallbackId :: TVar UnregisterHandle } +newChannelData :: Hashable channel => [(channel, callback)] -> STM (ChannelData channel callback)+newChannelData initialSubs+ = ChannelData+ <$> newTVar (HM.fromListWith (++) $ map (second $ pure . (0,)) initialSubs)+ <*> newTVar mempty+ <*> newTVar mempty+ -- | Create a new 'PubSubController'. Note that this does not subscribe to any channels, it just -- creates the controller. The subscriptions will happen once 'pubSubForever' is called. newPubSubController :: MonadIO m => [(RedisChannel, MessageCallback)] -- ^ the initial subscriptions -> [(RedisPChannel, PMessageCallback)] -- ^ the initial pattern subscriptions -> m PubSubController-newPubSubController x y = liftIO $ do- cbs <- newTVarIO (HM.map (\z -> [(0,z)]) $ HM.fromList x)- pcbs <- newTVarIO (HM.map (\z -> [(0,z)]) $ HM.fromList y)- c <- newTBQueueIO 10- pending <- newTVarIO 0- lastId <- newTVarIO 0- return $ PubSubController cbs pcbs c pending lastId+newPubSubController initialSubs initialPSubs = liftIO $ atomically $ do+ c <- newTBQueue 10+ lastId <- newTVar 0+ channelData' <- newChannelData initialSubs+ pchannelData' <- newChannelData initialPSubs+ return $ PubSubController c channelData' pchannelData' lastId +#if __GLASGOW_HASKELL__ < 710+type FunctorMonadIO m = (MonadIO m, Functor m)+#else+type FunctorMonadIO m = MonadIO m+#endif+ -- | Get the list of current channels in the 'PubSubController'. WARNING! This might not -- exactly reflect the subscribed channels in the Redis server, because there is a delay -- between adding or removing a channel in the 'PubSubController' and when Redis receives -- and processes the subscription change request.-#if __GLASGOW_HASKELL__ < 710-currentChannels :: (MonadIO m, Functor m) => PubSubController -> m [RedisChannel]-#else-currentChannels :: MonadIO m => PubSubController -> m [RedisChannel]-#endif-currentChannels ctrl = HM.keys <$> (liftIO $ atomically $ readTVar $ callbacks ctrl)+currentChannels :: FunctorMonadIO m => PubSubController -> m [RedisChannel]+currentChannels ctrl = HM.keys <$> (liftIO $ atomically $ readTVar $ cdSubscribedChannels $ pscChannelData ctrl) -- | Get the list of current pattern channels in the 'PubSubController'. WARNING! This might not -- exactly reflect the subscribed channels in the Redis server, because there is a delay -- between adding or removing a channel in the 'PubSubController' and when Redis receives -- and processes the subscription change request.-#if __GLASGOW_HASKELL__ < 710-currentPChannels :: (MonadIO m, Functor m) => PubSubController -> m [RedisPChannel]-#else-currentPChannels :: MonadIO m => PubSubController -> m [RedisPChannel]-#endif-currentPChannels ctrl = HM.keys <$> (liftIO $ atomically $ readTVar $ pcallbacks ctrl)+currentPChannels :: FunctorMonadIO m => PubSubController -> m [RedisPChannel]+currentPChannels ctrl = HM.keys <$> (liftIO $ atomically $ readTVar $ cdSubscribedChannels $ pscPChannelData ctrl) +pendingChannels :: MonadIO m => PubSubController -> m (HS.HashSet RedisChannel)+pendingChannels ctrl = liftIO $ readTVarIO $ cdChannelsPendingSubscription $ pscChannelData ctrl++pendingPatternChannels :: MonadIO m => PubSubController -> m (HS.HashSet RedisPChannel)+pendingPatternChannels ctrl = liftIO $ readTVarIO $ cdChannelsPendingSubscription $ pscPChannelData ctrl++-- type CallbackMap a = HM.HashMap ByteString [(UnregisterHandle, a)]++-- | Helper for `addChannels`. Can take either normal or pattern channels.+addChannelsOfType+ :: Hashable channel+ => UnregisterHandle+ -> [(channel, callback)]+ -> ChannelData channel callback+ -> STM [channel]+addChannelsOfType ident newChans channelData = do+ callbacks <- readTVar $ cdSubscribedChannels channelData+ pendingCallbacks <- readTVar $ cdChannelsPendingSubscription channelData+ let newChans' = filter (not . memberMapOrSet callbacks pendingCallbacks) $ fst <$> newChans+ writeTVar (cdSubscribedChannels channelData) (HM.unionWith (++) callbacks $ (\z -> [(ident,z)]) <$> HM.fromList newChans)+ writeTVar (cdChannelsPendingSubscription channelData) $ HS.union pendingCallbacks $ HS.fromList newChans'+ pure newChans'+ -- | Add channels into the 'PubSubController', and if there is an active 'pubSubForever', send the subscribe -- and psubscribe commands to Redis. The 'addChannels' function is thread-safe. This function -- does not wait for Redis to acknowledge that the channels have actually been subscribed; use@@ -366,24 +442,19 @@ ident <- atomically $ do modifyTVar (lastUsedCallbackId ctrl) (+1) ident <- readTVar $ lastUsedCallbackId ctrl- cm <- readTVar $ callbacks ctrl- pm <- readTVar $ pcallbacks ctrl- let newChans' = [ n | (n,_) <- newChans, not $ HM.member n cm]- newPChans' = [ n | (n, _) <- newPChans, not $ HM.member n pm]- ps = subscribe newChans' `mappend` psubscribe newPChans'+ newChannels <- addChannelsOfType ident newChans $ pscChannelData ctrl+ newPChannels <- addChannelsOfType ident newPChans $ pscPChannelData ctrl+ let ps = subscribe newChannels `mappend` psubscribe newPChannels writeTBQueue (sendChanges ctrl) ps- writeTVar (callbacks ctrl) (HM.unionWith (++) cm (fmap (\z -> [(ident,z)]) $ HM.fromList newChans))- writeTVar (pcallbacks ctrl) (HM.unionWith (++) pm (fmap (\z -> [(ident,z)]) $ HM.fromList newPChans))- modifyTVar (pendingCnt ctrl) (+ totalPendingChanges ps) return ident return $ unsubChannels ctrl (map fst newChans) (map fst newPChans) ident + -- | Call 'addChannels' and then wait for Redis to acknowledge that the channels are actually subscribed. ----- Note that this function waits for all pending subscription change requests, so if you for example call--- 'addChannelsAndWait' from multiple threads simultaneously, they all will wait for all pending--- subscription changes to be acknowledged by Redis (this is due to the fact that we just track the total--- number of pending change requests sent to Redis and just wait until that count reaches zero).+-- Note that this function waits for requested subscription change requests, so if you for example call+-- 'addChannelsAndWait' from multiple threads simultaneously, they will all wait their pending+-- subscription changes to be acknowledged by Redis. -- -- This also correctly waits if the network connection dies during the subscription change. Say that the -- network connection dies right after we send a subscription change to Redis. 'pubSubForever' will throw@@ -399,11 +470,21 @@ addChannelsAndWait _ [] [] = return $ return () addChannelsAndWait ctrl newChans newPChans = do unreg <- addChannels ctrl newChans newPChans- liftIO $ atomically $ do- r <- readTVar (pendingCnt ctrl)- when (r > 0) retry+ liftIO $+ waitUntilAbsent+ [ (cdChannelsPendingSubscription $ pscChannelData ctrl, fst <$> newChans)+ , (cdChannelsPendingSubscription $ pscPChannelData ctrl, fst <$> newPChans)+ ] return unreg +-- | Wait until all interesting channels are instantiated.+waitUntilAbsent :: Hashable channel => [(TVar (HS.HashSet channel), [channel])] -> IO ()+waitUntilAbsent pending = atomically $ do+ forM_ pending $ \(tPendingChannels, channels) -> do+ unless (null channels) $ do+ pendingChannels' <- readTVar tPendingChannels+ when (any (\ch -> HS.member ch pendingChannels') channels) retry+ -- | Remove channels from the 'PubSubController', and if there is an active 'pubSubForever', send the -- unsubscribe commands to Redis. Note that as soon as this function returns, no more callbacks will be -- executed even if more messages arrive during the period when we request to unsubscribe from the channel@@ -419,55 +500,78 @@ -> m () removeChannels _ [] [] = return () removeChannels ctrl remChans remPChans = liftIO $ atomically $ do- cm <- readTVar $ callbacks ctrl- pm <- readTVar $ pcallbacks ctrl- let remChans' = filter (\n -> HM.member n cm) remChans- remPChans' = filter (\n -> HM.member n pm) remPChans- ps = (if null remChans' then mempty else unsubscribe remChans')- `mappend` (if null remPChans' then mempty else punsubscribe remPChans')- writeTBQueue (sendChanges ctrl) ps- writeTVar (callbacks ctrl) (foldl' (flip HM.delete) cm remChans')- writeTVar (pcallbacks ctrl) (foldl' (flip HM.delete) pm remPChans')- modifyTVar (pendingCnt ctrl) (+ totalPendingChanges ps)+ remChans' <- removeChannels' (pscChannelData ctrl) remChans+ remPChans' <- removeChannels' (pscPChannelData ctrl) remPChans+ writeTBQueue (sendChanges ctrl) $ unsubscribe1 remChans' `mappend` punsubscribe1 remPChans' --- | Internal function to unsubscribe only from those channels matching the given handle.-unsubChannels :: PubSubController -> [RedisChannel] -> [RedisPChannel] -> UnregisterHandle -> IO ()-unsubChannels ctrl chans pchans h = liftIO $ atomically $ do- cm <- readTVar $ callbacks ctrl- pm <- readTVar $ pcallbacks ctrl+#if !(MIN_VERSION_stm(2,3,0))+-- | Strict version of 'modifyTVar'.+--+-- @since 2.3+modifyTVar' :: TVar a -> (a -> a) -> STM ()+modifyTVar' var f = do+ x <- readTVar var+ writeTVar var $! f x+{-# INLINE modifyTVar' #-}+#endif - -- only worry about channels that exist- let remChans = filter (\n -> HM.member n cm) chans- remPChans = filter (\n -> HM.member n pm) pchans+-- Helper for `removeChannels` that works on normal or pattern channels+removeChannels' :: (Hashable channel) => ChannelData channel callback -> [channel] -> STM [channel]+removeChannels' channelData remChannels = do+ subbedChannels <- readTVar $ cdSubscribedChannels channelData+ pendingChannelSubs <- readTVar $ cdChannelsPendingSubscription channelData+ let remChannels' = filter (memberMapOrSet subbedChannels pendingChannelSubs) remChannels+ writeTVar (cdSubscribedChannels channelData) (L.foldl' (flip HM.delete) subbedChannels remChannels')+ writeTVar (cdChannelsPendingSubscription channelData) (L.foldl' (flip HS.delete) pendingChannelSubs remChannels')+ modifyTVar' (cdChannelsPendingRemoval channelData) $ flip (L.foldl' $ flip HS.insert) remChannels'+ pure remChannels' +memberMapOrSet :: Hashable k => HM.HashMap k v1 -> HS.HashSet k -> k -> Bool+memberMapOrSet m s k = HM.member k m || HS.member k s++unregisterHandles+ :: forall channel callback. Hashable channel => ChannelData channel callback+ -> [channel]+ -> UnregisterHandle+ -> STM [channel]+unregisterHandles channelData remChansParam h = do+ callbacks <- readTVar $ cdSubscribedChannels channelData+ let remChans = filter (`HM.member` callbacks) remChansParam+ -- helper functions to filter out handlers that match- let filterHandle :: Maybe [(UnregisterHandle,a)] -> Maybe [(UnregisterHandle,a)]+ -- returns number of removals, and remaining subscriptions+ -- maps after taking out channels matching the handle+ let callbacks' = L.foldl' removeHandles callbacks remChans+ remChans' = filter (\chan -> HM.member chan callbacks && not (HM.member chan callbacks')) remChans++ writeTVar (cdSubscribedChannels channelData) callbacks'+ unless (null remChans') $ modifyTVar (cdChannelsPendingSubscription channelData) (`HS.difference` HS.fromList remChans')+ pure remChans'++ where+ filterHandle :: Maybe [(UnregisterHandle,a)] -> Maybe [(UnregisterHandle,a)] filterHandle Nothing = Nothing filterHandle (Just lst) = case filter (\x -> fst x /= h) lst of [] -> Nothing xs -> Just xs- let removeHandles :: HM.HashMap ByteString [(UnregisterHandle,a)]- -> ByteString- -> HM.HashMap ByteString [(UnregisterHandle,a)]++ removeHandles :: HM.HashMap channel [(UnregisterHandle,a)]+ -> channel+ -> HM.HashMap channel [(UnregisterHandle,a)] removeHandles m k = case filterHandle (HM.lookup k m) of -- recent versions of unordered-containers have alter Nothing -> HM.delete k m- Just v -> HM.insert k v m+ Just v -> HM.insert k v m - -- maps after taking out channels matching the handle- let cm' = foldl' removeHandles cm remChans- pm' = foldl' removeHandles pm remPChans+-- | Internal function to unsubscribe only from those channels matching the given handle.+unsubChannels :: PubSubController -> [RedisChannel] -> [RedisPChannel] -> UnregisterHandle -> IO ()+unsubChannels ctrl chans pchans h = liftIO $ atomically $ do+ channelsToDrop <- unregisterHandles (pscChannelData ctrl) chans h+ pChannelsToDrop <- unregisterHandles (pscPChannelData ctrl) pchans h - -- the channels to unsubscribe are those that no longer exist in cm' and pm'- let remChans' = filter (\n -> not $ HM.member n cm') remChans- remPChans' = filter (\n -> not $ HM.member n pm') remPChans- ps = (if null remChans' then mempty else unsubscribe remChans')- `mappend` (if null remPChans' then mempty else punsubscribe remPChans')+ let commands = unsubscribe1 channelsToDrop `mappend` punsubscribe1 pChannelsToDrop -- do the unsubscribe- writeTBQueue (sendChanges ctrl) ps- writeTVar (callbacks ctrl) cm'- writeTVar (pcallbacks ctrl) pm'- modifyTVar (pendingCnt ctrl) (+ totalPendingChanges ps)+ writeTBQueue (sendChanges ctrl) commands return () -- | Call 'removeChannels' and then wait for all pending subscription change requests to be acknowledged@@ -478,12 +582,16 @@ -> [RedisChannel] -> [RedisPChannel] -> m ()-removeChannelsAndWait _ [] [] = return ()-removeChannelsAndWait ctrl remChans remPChans = do- removeChannels ctrl remChans remPChans- liftIO $ atomically $ do- r <- readTVar (pendingCnt ctrl)- when (r > 0) retry+removeChannelsAndWait ctrl remChannels remPChannels = liftIO $ do+ (remChans', remPChans') <- atomically $ do+ remChans' <- removeChannels' (pscChannelData ctrl) remChannels+ remPChans' <- removeChannels' (pscPChannelData ctrl) remPChannels+ writeTBQueue (sendChanges ctrl) $ unsubscribe1 remChans' `mappend` punsubscribe1 remPChans'+ pure (remChans', remPChans')+ waitUntilAbsent+ [ (cdChannelsPendingRemoval $ pscChannelData ctrl, remChans')+ , (cdChannelsPendingRemoval $ pscPChannelData ctrl, remPChans')+ ] -- | Internal thread which listens for messages and executes callbacks. -- This is the only thread which ever receives data from the underlying@@ -492,20 +600,18 @@ listenThread ctrl rawConn = forever $ do msg <- PP.recv rawConn case decodeMsg msg of- Msg (Message channel msgCt) -> do- cm <- atomically $ readTVar (callbacks ctrl)- case HM.lookup channel cm of- Nothing -> return ()- Just c -> mapM_ (\(_,x) -> x msgCt) c- Msg (PMessage pattern channel msgCt) -> do- pm <- atomically $ readTVar (pcallbacks ctrl)- case HM.lookup pattern pm of- Nothing -> return ()- Just c -> mapM_ (\(_,x) -> x channel msgCt) c- Subscribed -> atomically $- modifyTVar (pendingCnt ctrl) (\x -> x - 1)- Unsubscribed _ -> atomically $- modifyTVar (pendingCnt ctrl) (\x -> x - 1)+ Msg message@(Message channel _) -> do+ cm <- atomically $ readTVar $ cdSubscribedChannels $ pscChannelData ctrl+ forM_ (HM.lookup channel cm) $ \c -> do+ void $ Core.callbackHook (PP.hooks rawConn) (\m -> mapM_ (\(_,x) -> x $ msgMessage m) c $> mempty) message+ Msg message@(PMessage pattern _ _) -> do+ pm <- atomically $ readTVar $ cdSubscribedChannels $ pscPChannelData ctrl+ forM_ (HM.lookup pattern pm) $ \c -> do+ void $ Core.callbackHook (PP.hooks rawConn) (\m -> mapM_ (\(_,x) -> x (msgChannel m) (msgMessage m)) c $> mempty) message+ Subscribed chan -> atomically $ modifyTVar (cdChannelsPendingSubscription $ pscChannelData ctrl) $ HS.delete chan+ PSubscribed chan -> atomically $ modifyTVar (cdChannelsPendingSubscription $ pscPChannelData ctrl) $ HS.delete chan+ Unsubscribed chan _ -> atomically $ modifyTVar (cdChannelsPendingRemoval $ pscChannelData ctrl) $ HS.delete chan+ PUnsubscribed chan _ -> atomically $ modifyTVar (cdChannelsPendingRemoval $ pscPChannelData ctrl) $ HS.delete chan -- | Internal thread which sends subscription change requests. -- This is the only thread which ever sends data on the underlying@@ -569,17 +675,30 @@ -- the controller are now subscribed. You can use this after an exception (such as -- 'ConnectionLost') to signal that all subscriptions are now reactivated. -> IO ()-pubSubForever (Connection.NonClusteredConnection pool) ctrl onInitialLoad = withResource pool $ \rawConn -> do+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- cm <- readTVar $ callbacks ctrl- pm <- readTVar $ pcallbacks ctrl- let ps = subscribe (HM.keys cm) `mappend` psubscribe (HM.keys pm)+ channels <- fmap HM.keys $ readTVar $ cdSubscribedChannels $ pscChannelData ctrl+ patternChannels <- fmap HM.keys $ readTVar $ cdSubscribedChannels $ pscPChannelData ctrl+ let ps = subscribe channels `mappend` psubscribe patternChannels writeTBQueue (sendChanges ctrl) ps- writeTVar (pendingCnt ctrl) (totalPendingChanges ps)+ writeTVar (cdChannelsPendingSubscription $ pscChannelData ctrl) $ HS.fromList channels+ writeTVar (cdChannelsPendingSubscription $ pscPChannelData ctrl) $ HS.fromList patternChannels withAsync (listenThread ctrl rawConn) $ \listenT -> withAsync (sendThread ctrl rawConn) $ \sendT -> do@@ -588,8 +707,11 @@ mret <- atomically $ (Left <$> (waitEitherCatchSTM listenT sendT)) `orElse`- (Right <$> (readTVar (pendingCnt ctrl) >>=- \x -> if x > 0 then retry else return ()))+ (Right <$> do+ a <- readTVar $ cdChannelsPendingSubscription $ pscChannelData ctrl+ unless (HS.null a) retry+ b <- readTVar $ cdChannelsPendingSubscription $ pscPChannelData ctrl+ unless (HS.null b) retry) case mret of Right () -> onInitialLoad _ -> return () -- if there is an error, waitEitherCatch below will also see it@@ -600,7 +722,6 @@ (Right (Left err)) -> throwIO err (Left (Left err)) -> throwIO err _ -> return () -- should never happen, since threads exit only with an error-pubSubForever (Connection.ClusteredConnection _ _) _ _ = undefined ------------------------------------------------------------------------------@@ -612,15 +733,16 @@ case kind :: ByteString of "message" -> Msg <$> decodeMessage "pmessage" -> Msg <$> decodePMessage- "subscribe" -> return Subscribed- "psubscribe" -> return Subscribed- "unsubscribe" -> Unsubscribed <$> decodeCnt- "punsubscribe" -> Unsubscribed <$> decodeCnt+ "subscribe" -> Subscribed <$> decodeChan+ "psubscribe" -> PSubscribed <$> decodeChan+ "unsubscribe" -> Unsubscribed <$> decodeChan <*> decodeCnt+ "punsubscribe" -> PUnsubscribed <$> decodeChan <*> decodeCnt _ -> errMsg r where decodeMessage = Message <$> decode r1 <*> decode r2 decodePMessage = PMessage <$> decode r1 <*> decode r2 <*> decode (head rs) decodeCnt = fromInteger <$> decode r2+ decodeChan = decode r1 decodeMsg r = errMsg r @@ -637,3 +759,67 @@ -- 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
@@ -14,7 +14,7 @@ -- Example: -- -- @--- conn <- 'connect' 'SentinelConnectionInfo' (("localhost", PortNumber 26379) :| []) "mymaster" 'defaultConnectInfo'+-- conn <- 'connect' 'SentinelConnectionInfo' (("localhost", 26379) :| []) "mymaster" 'defaultConnectInfo' -- -- 'runRedis' conn $ do -- 'set' "hello" "world"@@ -44,17 +44,17 @@ import Control.Concurrent import Control.Exception (Exception, IOException, evaluate, throwIO) import Control.Monad-import Control.Monad.Catch (Handler (..), MonadCatch, catches, throwM)+import Control.Monad.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.Typeable (Typeable) import Data.Unique-import Network.Socket (HostName)+import qualified Network.Socket as NS import Database.Redis hiding (Connection, connect, runRedis) import qualified Database.Redis as Redis@@ -79,6 +79,7 @@ then return (oldMasterConnectInfo, oldBaseConnection) else do newConn <- Redis.connect newMasterConnectInfo+ Redis.disconnect oldBaseConnection return (newMasterConnectInfo, newConn) return@@ -105,7 +106,7 @@ where sameHost :: Redis.ConnectInfo -> Redis.ConnectInfo -> Bool- sameHost l r = connectHost l == connectHost r && connectPort l == connectPort r+ sameHost l r = connectAddr l == connectAddr r setCheckSentinel preToken = modifyMVar_ connMVar $ \conn@SentinelConnection'{rcToken} -> if preToken == rcToken@@ -147,28 +148,31 @@ ) Right () -> throwIO $ NoSentinels connectSentinels where- trySentinel :: HostName -> PortID -> ExceptT (Redis.ConnectInfo, (HostName, PortID)) IO ()+ trySentinel :: NS.HostName -> NS.PortNumber -> ExceptT (Redis.ConnectInfo, (NS.HostName, NS.PortNumber)) IO () trySentinel sentinelHost sentinelPort = do -- bang to ensure exceptions from runRedis get thrown immediately. !replyE <- liftIO $ do- !sentinelConn <- Redis.connect $ Redis.defaultConnectInfo- { connectHost = sentinelHost- , connectPort = sentinelPort+ bracket+ (Redis.connect $ Redis.defaultConnectInfo+ { connectAddr = ConnectAddrHostPort sentinelHost sentinelPort , connectMaxConnections = 1- }- Redis.runRedis sentinelConn $ sendRequest- ["SENTINEL", "get-master-addr-by-name", connectMasterName]+ })+ Redis.disconnect+ $ \sentinelConn -> Redis.runRedis sentinelConn $ sendRequest+ ["SENTINEL", "get-master-addr-by-name", connectMasterName] case replyE of Right [host, port] -> throwError ( connectBaseInfo- { connectHost = BS8.unpack host- , connectPort =- maybe- (PortNumber 26379)- (PortNumber . fromIntegral . fst)+ { connectAddr =+ ConnectAddrHostPort+ (BS8.unpack host)+ (maybe+ 26379+ (fromIntegral . fst) $ BS8.readInt port+ ) } , (sentinelHost, sentinelPort) )@@ -202,20 +206,20 @@ -- | Configuration of Sentinel hosts. data SentinelConnectInfo = SentinelConnectInfo- { connectSentinels :: NonEmpty (HostName, PortID)+ { connectSentinels :: NonEmpty (NS.HostName, NS.PortNumber) -- ^ List of sentinels. , connectMasterName :: ByteString -- ^ Name of master to connect to. , connectBaseInfo :: Redis.ConnectInfo -- ^ This is used to configure auth and other parameters for Redis connection,- -- but 'Redis.connectHost' and 'Redis.connectPort' are ignored.+ -- but 'Redis.connectAddr' is ignored. } deriving (Show) -- | Exception thrown by "Database.Redis.Sentinel". data RedisSentinelException- = NoSentinels (NonEmpty (HostName, PortID))+ = NoSentinels (NonEmpty (NS.HostName, NS.PortNumber)) -- ^ Thrown if no sentinel can be reached.- deriving (Show, Typeable)+ deriving (Show) deriving instance Exception RedisSentinelException
src/Database/Redis/Types.hs view
@@ -11,6 +11,7 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif+import Data.Int import Control.DeepSeq import Data.ByteString.Char8 (ByteString, pack) import qualified Data.ByteString.Lex.Fractional as F (readSigned, readExponential)@@ -38,6 +39,9 @@ instance RedisArg Integer where encode = pack . show +instance RedisArg Int64 where+ encode = pack . show+ instance RedisArg Double where encode a | isInfinite a && a > 0 = "+inf"@@ -52,7 +56,7 @@ instance NFData Status -data RedisType = None | String | Hash | List | Set | ZSet+data RedisType = None | String | Hash | List | Set | ZSet | Stream | VectorSet deriving (Show, Eq) instance RedisResult Reply where@@ -68,6 +72,11 @@ 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.readExponential =<< decode r @@ -86,6 +95,8 @@ "list" -> List "set" -> Set "zset" -> ZSet+ "stream" -> Stream+ "vector" -> VectorSet _ -> error $ "Hedis: unhandled redis type: " ++ show s decode r = Left r @@ -107,10 +118,14 @@ (RedisResult a) => RedisResult [a] where decode (MultiBulk (Just rs)) = mapM decode rs decode r = Left r- + instance (RedisResult a, RedisResult b) => RedisResult (a,b) where decode (MultiBulk (Just [x, y])) = (,) <$> decode x <*> decode y decode r = Left r++instance (RedisResult a, RedisResult b, RedisResult c) => RedisResult (a,b,c) where+ decode (MultiBulk (Just [x, y, z])) = (,,) <$> decode x <*> decode y <*> decode z+ decode r = Left r instance (RedisResult k, RedisResult v) => RedisResult [(k,v)] where decode r = case r of
src/Database/Redis/URL.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-} module Database.Redis.URL ( parseConnectInfo ) where@@ -6,60 +9,134 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif+import qualified Data.ByteString.Char8 as C8 import Control.Error.Util (note)-import Control.Monad (guard) #if __GLASGOW_HASKELL__ < 808 import Data.Monoid ((<>)) #endif+import Data.String (fromString) import Database.Redis.Connection (ConnectInfo(..), defaultConnectInfo) import qualified Database.Redis.ConnectionContext as CC import Network.HTTP.Base-import Network.URI (parseURI, uriPath, uriScheme)+import Network.URI (parseURI, uriPath, uriScheme, uriQuery, URI)+import Network.TLS (defaultParamsClient)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Network.HTTP.Types (parseSimpleQuery) import Text.Read (readMaybe) -import qualified Data.ByteString.Char8 as C8 --- | Parse a @'ConnectInfo'@ from a URL+-- | Parse a @'ConnectInfo'@ from a URL according to the Rules in Redis client ----- Username is ignored, path is used to specify the database:+-- __Standalone Redis__: --+-- @+-- redis :\/\/ [[username :] password@] host [:port][/database]+-- @+-- -- >>> parseConnectInfo "redis://username:password@host:42/2"--- Right (ConnInfo {connectHost = "host", connectPort = PortNumber 42, connectAuth = Just "password", connectDatabase = 2, connectMaxConnections = 50, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing})+-- Right (ConnInfo {connectAddr = ConnectAddrHostPort "host" 42, connectAuth = Just "password", connectUsername = Just "username", connectDatabase = 2, connectMaxConnections = 50, connectNumStripes = Just 1, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing, connectHooks = Hooks {...}, connectPoolLabel = ""}) --+-- >>> parseConnectInfo "redis://password@host:42/2"+-- Right (ConnInfo {connectAddr = ConnectAddrHostPort "host" 42, connectAuth = Just "password", connectUsername = Nothing, connectDatabase = 2, connectMaxConnections = 50, connectNumStripes = Just 1, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing, connectHooks = Hooks {...}, connectPoolLabel = ""})+--+-- __TLS-enabled Redis__:+--+-- @+-- rediss :\/\/ [[username :] password@] host [: port][/database]+-- @+--+-- __Unix socket Redis__:+--+-- @+-- redis-socket :// [[username :] password@]path [? [&database=database]+-- @+--+-- >>> parseConnectInfo "redis-socket://password@/tmp/redis.sock?database=2"+-- Right (ConnInfo {connectAddr = ConnectAddrUnixSocket "/tmp/redis.sock", connectAuth = Just "password", connectUsername = Nothing, connectDatabase = 2, connectMaxConnections = 50, connectNumStripes = Just 1, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing, connectHooks = Hooks {...}, connectPoolLabel = ""})+-- -- >>> parseConnectInfo "redis://username:password@host:42/db" -- Left "Invalid port: db" -- -- The scheme is validated, to prevent mixing up configurations: -- -- >>> parseConnectInfo "postgres://"--- Left "Wrong scheme"+-- Left "Wrong scheme postgres:" -- -- Beyond that, all values are optional. Omitted values are taken from -- @'defaultConnectInfo'@: ----- >>> parseConnectInfo "redis://"--- Right (ConnInfo {connectHost = "localhost", connectPort = PortNumber 6379, connectAuth = Nothing, connectDatabase = 0, connectMaxConnections = 50, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Nothing})+-- >>> parseConnectInfo "rediss://"+-- Right (ConnInfo {connectAddr = ConnectAddrHostPort "localhost" 6379, connectAuth = Nothing, connectUsername = Nothing, connectDatabase = 0, connectMaxConnections = 50, connectNumStripes = Just 1, connectMaxIdleTime = 30s, connectTimeout = Nothing, connectTLSParams = Just (ClientParams ...), connectHooks = Hooks {...}, connectPoolLabel = ""}) -- parseConnectInfo :: String -> Either String ConnectInfo parseConnectInfo url = do uri <- note "Invalid URI" $ parseURI url- note "Wrong scheme" $ guard $ uriScheme uri == "redis:"- uriAuth <- note "Missing or invalid Authority"- $ parseURIAuthority- $ uriToAuthorityString uri+ let userScheme = uriScheme uri+ case userScheme of+ "redis:" -> parseSocket False uri+ "rediss:" -> parseSocket True uri+ "redis-socket:" -> parseUnix uri+ x -> Left ("Wrong scheme " ++ x)+ where+ parseSocket :: Bool -> URI -> Either String ConnectInfo+ parseSocket isSecure uri = do+ uriAuth <- note "Missing or invalid Authority"+ $ parseURIAuthority+ $ uriToAuthorityString uri - let h = host uriAuth- dbNumPart = dropWhile (== '/') (uriPath uri)+ let h = host uriAuth+ dbNumPart = dropWhile (== '/') (uriPath uri) - db <- if null dbNumPart- then return $ connectDatabase defaultConnectInfo- else note ("Invalid port: " <> dbNumPart) $ readMaybe dbNumPart+ db <- if null dbNumPart+ then return $ connectDatabase defaultConnectInfo+ else note ("Invalid port: " <> dbNumPart) $ readMaybe dbNumPart - return defaultConnectInfo- { connectHost = if null h- then connectHost defaultConnectInfo- else h- , connectPort = maybe (connectPort defaultConnectInfo) (CC.PortNumber . fromIntegral) (port uriAuth)- , connectAuth = C8.pack <$> password uriAuth- , connectDatabase = db- }+ let finalHost = if null h+ then case connectAddr defaultConnectInfo of+ CC.ConnectAddrHostPort defaultHost _ -> defaultHost+ CC.ConnectAddrUnixSocket _ -> "localhost"+ else h++ let (finalUser, finalAuth) = case (T.pack <$> user uriAuth, T.pack <$> password uriAuth) of+ (p, Nothing) -> (Nothing, p)+ (p, fmap T.strip -> Just "") -> (Nothing, p)+ (u, p) -> (u, p)++ return defaultConnectInfo+ { connectAddr =+ CC.ConnectAddrHostPort+ finalHost+ (maybe defaultPort fromIntegral (port uriAuth))+ , connectAuth = T.encodeUtf8 <$> finalAuth+ , connectUsername = T.encodeUtf8 <$> finalUser+ , connectDatabase = db+ , connectTLSParams = case isSecure of+ False -> Nothing+ True -> Just $ defaultParamsClient finalHost ""+ }+ where+ defaultPort = case connectAddr defaultConnectInfo of+ CC.ConnectAddrHostPort _ portNum -> portNum+ CC.ConnectAddrUnixSocket _ -> 6379++ parseUnix :: URI -> Either String ConnectInfo+ parseUnix uri = do+ auth <- note "Missing or invalid Authority"+ $ parseURIAuthority+ $ uriToAuthorityString uri+ db <- case lookup "database" query of+ Nothing -> return $ connectDatabase defaultConnectInfo+ Just dbNumPart ->+ note "Invalid database" $ readMaybe @Integer . T.unpack $ T.decodeUtf8 dbNumPart+ return defaultConnectInfo+ { connectAddr = CC.ConnectAddrUnixSocket (mkPath auth)+ , connectAuth = C8.pack <$> (user auth)+ , connectDatabase = (db :: Integer)+ }+ where+ mkPath auth =+ case host auth <> uriPath uri of+ ('/':_) -> host auth <> uriPath uri+ _ -> '/' : host auth <> uriPath uri+ query = parseSimpleQuery (T.encodeUtf8 $ fromString $ uriQuery uri)
test/ClusterMain.hs view
@@ -1,46 +1,64 @@ {-# 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 { connectPort = PortNumber 7000 }- Test.defaultMain (tests conn)+ conn <- connectCluster defaultConnectInfo { connectAddr = ConnectAddrHostPort redisHost redisPort }+ Test.defaultMain (tests redisHost redisPort conn) -tests :: Connection -> [Test.Test]-tests conn = map ($conn) $ concat+tests :: String -> PortNumber -> Connection -> [Test.Test]+tests host port conn = map ($ conn) $ concat @[] [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog] , testsZSets, [testTransaction], [testScripting]- , testsConnection, testsServer, [testSScan, testHScan, testZScan], [testZrangelex]- , [testXAddRead, testXReadGroup, testXRange, testXpending, testXClaim, testXInfo, testXDel, testXTrim]+ , testsConnection host port, testsClient, testsServer, [testSScan, testHScan, testZScan], [testZrangelex]+ , [testXAddRead, testXReadGroup, testXRange, testXpending7, testXClaim, testXInfo, testXDel, testXTrim, testClusterSlotStats8, testClusterMigration84] -- 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 :: [Test]-testsConnection = [ testConnectAuthUnexpected, testEcho, testPing- ]+testsConnection :: String -> PortNumber -> [Test]+testsConnection host port = [ testConnectAuthUnexpected host port, testEcho, testPing ] testsKeys :: [Test] testsKeys = [ testKeys, testExpireAt, testSortCluster, testGetType, testObject ] testSortCluster :: Test testSortCluster = testCase "sort" $ do- lpush "{same}ids" ["1","2","3"] >>=? 3+ lpush "{same}ids" ["1"::ByteString,"2","3"] >>=? 3 sort "{same}ids" defaultSortOpts >>=? ["1","2","3"] sortStore "{same}ids" "{same}anotherKey" defaultSortOpts >>=? 3 let opts = defaultSortOpts { sortOrder = Desc, sortAlpha = True
test/Main.hs view
@@ -1,34 +1,60 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE LambdaCase #-} module Main (main) where import qualified Test.Framework as Test import Database.Redis import Tests import PubSubTest+import System.Environment+import Text.Read (readMaybe)+import Network.Socket (PortNumber) main :: IO () main = do- conn <- connect defaultConnectInfo- Test.defaultMain (tests conn)+ redisPort <- ((readMaybe @PortNumber =<<) <$> lookupEnv "REDIS_PORT") >>= \case+ Just port -> return port+ _ -> return 6379+ host <- lookupEnv "REDIS_HOST" >>= \case+ Just host -> return host+ Nothing -> return "localhost"+ conn <- connect defaultConnectInfo { connectAddr = ConnectAddrHostPort host redisPort }+ Test.defaultMain (tests host redisPort conn) -tests :: Connection -> [Test.Test]-tests conn = map ($conn) $ concat+tests :: String -> PortNumber -> Connection -> [Test.Test]+tests host port conn = map ($ conn) $ concat [ testsMisc, testsKeys, testsStrings, [testHashes], testsLists, testsSets, [testHyperLogLog]- , testsZSets, [testPubSub], [testTransaction], [testScripting]- , testsConnection, testsServer, [testScans, testSScan, testHScan, testZScan], [testZrangelex]+ , testsZSets, [testPubSub], [testTransaction], [testScripting, testFunction7]+ , testsConnection host port+ , testsClient, testsServer+ , [testScans, testSScan, testHScan, testZScan], [testZrangelex] , [testXAddRead, testXReadGroup, testXRange, testXpending, testXClaim, testXInfo, testXDel, testXTrim]+ , [testBloomFilter, testCountMinSketch, testTopk, testTdigest, testCuckooFilter, testJSON, testTs] , testPubSubThreaded -- should always be run last as connection gets closed after it , [testQuit] ] ++testsClient :: [Test]+testsClient = [testClientId, testClientName, testClientUnpause]+ testsServer :: [Test] testsServer = [testServer, testBgrewriteaof, testFlushall, testInfo, testConfig ,testSlowlog, testDebugObject] -testsConnection :: [Test]-testsConnection = [ testConnectAuth, testConnectAuthUnexpected, testConnectDb- , testConnectDbUnexisting, testEcho, testPing, testSelect ]+testsConnection :: String -> PortNumber -> [Test]+testsConnection host port =+ [ testConnectAuth host port+ , testConnectAuthUnexpected host port+ , testConnectAuthAcl host port+ , testConnectDb host port+ , testConnectDbUnexisting host port+ , testEcho+ , testPing+ , testSelect+ ] testsKeys :: [Test]-testsKeys = [ testKeys, testKeysNoncluster, testExpireAt, testSort, testGetType, testObject ]+testsKeys = [ testKeys, testCopy, 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,32 @@+{-# 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)+ [ testSet7+ , testZAdd7+ , testExpireTime7+ , testHashExpire7+ , testSintercard7+ , testLMPop7+ , testZMPop7+ , testFunction7+ , testCommandList7+ , testXCreateGroup7+ , testXpending7+ , testXAutoClaim7+ , testQuit+ ]
+ test/MainRedis8.hs view
@@ -0,0 +1,28 @@+{-# 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)+ [ testStringCommands84+ , testHashes8+ , testRedis86Commands+ , testRedis88Commands+ , testVectorSet8+ , testVRange84+ , testXAckDel8+ , testXDelEx8+ , testQuit+ ]
test/PubSubTest.hs view
@@ -1,15 +1,18 @@-{-# LANGUAGE CPP, OverloadedStrings, DeriveDataTypeable #-}+{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE BlockArguments #-} module PubSubTest (testPubSubThreaded) where import Control.Concurrent import Control.Monad import Control.Concurrent.Async import Control.Exception-import Data.Typeable+import Data.Function (fix) import qualified Data.List-import Data.Text+import Data.Text (Text)+import Data.Typeable import Data.ByteString import Control.Concurrent.STM+import System.Timeout (timeout) import qualified Test.Framework as Test import qualified Test.Framework.Providers.HUnit as Test (testCase) import qualified Test.HUnit as HUnit@@ -17,7 +20,16 @@ import Database.Redis testPubSubThreaded :: [Connection -> Test.Test]-testPubSubThreaded = [removeAllTest, callbackErrorTest, removeFromUnregister]+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.@@ -100,7 +112,7 @@ waitForPMessage msgVar "InitialBar2" "bar2:aaa" "0987" data TestError = TestError ByteString- deriving (Eq, Show, Typeable)+ deriving (Eq, Show) instance Exception TestError -- | Test an error thrown from a message handler@@ -171,3 +183,123 @@ 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" -> next (True, seenFoo200)+ PMessage "foo2*" "foo200" "bar" -> next (seenFoo100, True)+ x -> HUnit.assertFailure $ "Received unexpected message: " ++ show x+ 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 (300000) $ atomically messageSTM+ case result of+ Nothing -> pure ()+ Just x -> HUnit.assertFailure $ "Expected to timeout without receiving a message, but received: " ++ show x
test/Tests.hs view
@@ -1,788 +1,2231 @@-{-# LANGUAGE CPP, OverloadedStrings, RecordWildCards, LambdaCase #-}-module Tests where--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-import Data.Monoid (mappend)-#endif-import qualified Control.Concurrent.Async as Async-import Control.Exception (try)-import Control.Concurrent-import Control.Monad-import Control.Monad.Trans-import qualified Data.List as L-import Data.Time-import Data.Time.Clock.POSIX-import qualified Test.Framework as Test (Test)-import qualified Test.Framework.Providers.HUnit as Test (testCase)-import qualified Test.HUnit as HUnit--import Database.Redis----------------------------------------------------------------------------------- helpers----type Test = Connection -> Test.Test--testCase :: String -> Redis () -> Test-testCase name r conn = Test.testCase name $ do- withTimeLimit 0.5 $ runRedis conn $ flushdb >>=? Ok >> r- where- withTimeLimit limit act = do- start <- getCurrentTime- _ <- act- deltaT <-fmap (`diffUTCTime` start) getCurrentTime- when (deltaT > limit) $- putStrLn $ name ++ ": " ++ show deltaT--(>>=?) :: (Eq a, Show a) => Redis (Either Reply a) -> a -> Redis ()-redis >>=? expected = do- a <- redis- liftIO $ case a of- Left reply -> HUnit.assertFailure $ "Redis error: " ++ show reply- Right actual -> expected HUnit.@=? actual--assert :: Bool -> Redis ()-assert = liftIO . HUnit.assert----------------------------------------------------------------------------------- Miscellaneous----testsMisc :: [Test]-testsMisc =- [ testConstantSpacePipelining, testForceErrorReply, testPipelining- , testEvalReplies- ]--testConstantSpacePipelining :: Test-testConstantSpacePipelining = testCase "constant-space pipelining" $ do- -- This testcase should not exceed the maximum heap size, as set in- -- the run-test.sh script.- replicateM_ 100000 ping- -- If the program didn't crash, pipelining takes constant memory.- assert True--testForceErrorReply :: Test-testForceErrorReply = testCase "force error reply" $ do- set "key" "value" >>= \case- Left _ -> error "impossible"- _ -> return ()- -- key is not a hash -> wrong kind of value- reply <- hkeys "key"- assert $ case reply of- Left (Error _) -> True- _ -> False--testPipelining :: Test-testPipelining = testCase "pipelining" $ do- let n = 100- tPipe <- deltaT $ do- pongs <- replicateM n ping- assert $ pongs == replicate n (Right Pong)-- tNoPipe <- deltaT $ replicateM_ n (ping >>=? Pong)- -- pipelining should at least be twice as fast.- assert $ tNoPipe / tPipe > 2- where- deltaT redis = do- start <- liftIO $ getCurrentTime- _ <- redis- liftIO $ fmap (`diffUTCTime` start) getCurrentTime--testEvalReplies :: Test-testEvalReplies conn = testCase "eval unused replies" go conn- where- go = do- _ <- liftIO $ runRedis conn $ set "key" "value"- result <- liftIO $ do- threadDelay $ 10 ^ (5 :: Int)- mvar <- newEmptyMVar- _ <-- (Async.wait =<< Async.async (runRedis conn (get "key"))) >>= putMVar mvar- takeMVar mvar- pure result >>=? Just "value"----------------------------------------------------------------------------------- Keys----testKeys :: Test-testKeys = testCase "keys" $ do- set "{same}key" "value" >>=? Ok- get "{same}key" >>=? Just "value"- exists "{same}key" >>=? True- expire "{same}key" 1 >>=? True- pexpire "{same}key" 1000 >>=? True- ttl "{same}key" >>= \case- Left _ -> error "error"- Right t -> do- assert $ t `elem` [0..1]- pttl "{same}key" >>= \case- Left _ -> error "error"- Right pt -> do- assert $ pt `elem` [990..1000]- persist "{same}key" >>=? True- dump "{same}key" >>= \case- Left _ -> error "impossible"- Right s -> do- restore "{same}key'" 0 s >>=? Ok- rename "{same}key" "{same}key'" >>=? Ok- renamenx "{same}key'" "{same}key" >>=? True- del ["{same}key"] >>=? 1--testKeysNoncluster :: Test-testKeysNoncluster = testCase "keysNoncluster" $ do- set "key" "value" >>=? Ok- keys "*" >>=? ["key"]- randomkey >>=? Just "key"- move "key" 13 >>=? True- select 13 >>=? Ok- get "key" >>=? Just "value"- select 0 >>=? Ok--testExpireAt :: Test-testExpireAt = testCase "expireat" $ do- set "key" "value" >>=? Ok- t <- ceiling . utcTimeToPOSIXSeconds <$> liftIO getCurrentTime- let expiry = t+1- expireat "key" expiry >>=? True- pexpireat "key" (expiry*1000) >>=? True--testSort :: Test-testSort = testCase "sort" $ do- lpush "ids" ["1","2","3"] >>=? 3- sort "ids" defaultSortOpts >>=? ["1","2","3"]- sortStore "ids" "anotherKey" defaultSortOpts >>=? 3- mset- [("weight_1","1")- ,("weight_2","2")- ,("weight_3","3")- ,("object_1","foo")- ,("object_2","bar")- ,("object_3","baz")- ] >>= \case- Left _ -> error "error"- _ -> return ()- let opts = defaultSortOpts { sortOrder = Desc, sortAlpha = True- , sortLimit = (1,2)- , sortBy = Just "weight_*"- , sortGet = ["#", "object_*"] }- sort "ids" opts >>=? ["2", "bar", "1", "foo"]---testGetType :: Test-testGetType = testCase "getType" $ do- getType "key" >>=? None- forM_ ts $ \(setKey, typ) -> do- setKey- getType "key" >>=? typ- del ["key"] >>=? 1- where- ts = [ (set "key" "value" >>=? Ok, String)- , (hset "key" "field" "value" >>=? 1, Hash)- , (lpush "key" ["value"] >>=? 1, List)- , (sadd "key" ["member"] >>=? 1, Set)- , (zadd "key" [(42,"member"),(12.3,"value")] >>=? 2, ZSet)- ]--testObject :: Test-testObject = testCase "object" $ do- set "key" "value" >>=? Ok- objectRefcount "key" >>=? 1- objectEncoding "key" >>= \case- Left _ -> error "error"- _ -> return ()- objectIdletime "key" >>=? 0----------------------------------------------------------------------------------- Strings----testsStrings :: [Test]-testsStrings = [testStrings, testBitops]--testStrings :: Test-testStrings = testCase "strings" $ do- setnx "key" "value" >>=? True- getset "key" "hello" >>=? Just "value"- append "key" "world" >>=? 10- strlen "key" >>=? 10- setrange "key" 0 "hello" >>=? 10- getrange "key" 0 4 >>=? "hello"- mset [("{same}k1","v1"), ("{same}k2","v2")] >>=? Ok- msetnx [("{same}k1","v1"), ("{same}k2","v2")] >>=? False- mget ["key"] >>=? [Just "helloworld"]- setex "key" 1 "42" >>=? Ok- psetex "key" 1000 "42" >>=? Ok- decr "key" >>=? 41- decrby "key" 1 >>=? 40- incr "key" >>=? 41- incrby "key" 1 >>=? 42- incrbyfloat "key" 1 >>=? 43- del ["key"] >>=? 1- setbit "key" 42 "1" >>=? 0- getbit "key" 42 >>=? 1- bitcount "key" >>=? 1- bitcountRange "key" 0 (-1) >>=? 1--testBitops :: Test-testBitops = testCase "bitops" $ do- set "{same}k1" "a" >>=? Ok- set "{same}k2" "b" >>=? Ok- bitopAnd "{same}k3" ["{same}k1", "{same}k2"] >>=? 1- bitopOr "{same}k3" ["{same}k1", "{same}k2"] >>=? 1- bitopXor "{same}k3" ["{same}k1", "{same}k2"] >>=? 1- bitopNot "{same}k3" "{same}k1" >>=? 1----------------------------------------------------------------------------------- Hashes----testHashes :: Test-testHashes = testCase "hashes" $ do- hset "key" "field" "another" >>=? 1- hset "key" "field" "another" >>=? 0- hset "key" "field" "value" >>=? 0- hsetnx "key" "field" "value" >>=? False- hexists "key" "field" >>=? True- hlen "key" >>=? 1- hget "key" "field" >>=? Just "value"- hmget "key" ["field", "-"] >>=? [Just "value", Nothing]- hgetall "key" >>=? [("field","value")]- hkeys "key" >>=? ["field"]- hvals "key" >>=? ["value"]- hdel "key" ["field"] >>=? 1- hmset "key" [("field","40")] >>=? Ok- hincrby "key" "field" 2 >>=? 42- hincrbyfloat "key" "field" 2 >>=? 44----------------------------------------------------------------------------------- Lists----testsLists :: [Test]-testsLists =- [testLists, testBpop]--testLists :: Test-testLists = testCase "lists" $ do- lpushx "notAKey" "-" >>=? 0- rpushx "notAKey" "-" >>=? 0- lpush "key" ["value"] >>=? 1- lpop "key" >>=? Just "value"- rpush "key" ["value"] >>=? 1- rpop "key" >>=? Just "value"- rpush "key" ["v2"] >>=? 1- linsertBefore "key" "v2" "v1" >>=? 2- linsertAfter "key" "v2" "v3" >>=? 3- lindex "key" 0 >>=? Just "v1"- lrange "key" 0 (-1) >>=? ["v1", "v2", "v3"]- lset "key" 1 "v2" >>=? Ok- lrem "key" 0 "v2" >>=? 1- llen "key" >>=? 2- ltrim "key" 0 1 >>=? Ok--testBpop :: Test-testBpop = testCase "blocking push/pop" $ do- lpush "{same}key" ["v3","v2","v1"] >>=? 3- blpop ["{same}key"] 1 >>=? Just ("{same}key","v1")- brpop ["{same}key"] 1 >>=? Just ("{same}key","v3")- rpush "{same}k1" ["v1","v2"] >>=? 2- brpoplpush "{same}k1" "{same}k2" 1 >>=? Just "v2"- rpoplpush "{same}k1" "{same}k2" >>=? Just "v1"----------------------------------------------------------------------------------- Sets----testsSets :: [Test]-testsSets = [testSets, testSetAlgebra]--testSets :: Test-testSets = testCase "sets" $ do- sadd "set" ["member"] >>=? 1- sismember "set" "member" >>=? True- scard "set" >>=? 1- smembers "set" >>=? ["member"]- srandmember "set" >>=? Just "member"- spop "set" >>=? Just "member"- srem "set" ["member"] >>=? 0- smove "{same}set" "{same}set'" "member" >>=? False- _ <- sadd "set" ["member1", "member2"]- (fmap L.sort <$> spopN "set" 2) >>=? ["member1", "member2"]- _ <- sadd "set" ["member1", "member2"]- (fmap L.sort <$> srandmemberN "set" 2) >>=? ["member1", "member2"]--testSetAlgebra :: Test-testSetAlgebra = testCase "set algebra" $ do- sadd "{same}s1" ["member"] >>=? 1- sdiff ["{same}s1", "{same}s2"] >>=? ["member"]- sunion ["{same}s1", "{same}s2"] >>=? ["member"]- sinter ["{same}s1", "{same}s2"] >>=? []- sdiffstore "{same}s3" ["{same}s1", "{same}s2"] >>=? 1- sunionstore "{same}s3" ["{same}s1", "{same}s2"] >>=? 1- sinterstore "{same}s3" ["{same}s1", "{same}s2"] >>=? 0----------------------------------------------------------------------------------- Sorted Sets----testsZSets :: [Test]-testsZSets = [testZSets, testZStore]--testZSets :: Test-testZSets = testCase "sorted sets" $ do- zadd "key" [(1,"v1"),(2,"v2"),(40,"v3")] >>=? 3- zcard "key" >>=? 3- zscore "key" "v3" >>=? Just 40- zincrby "key" 2 "v3" >>=? 42-- zrank "key" "v1" >>=? Just 0- zrevrank "key" "v1" >>=? Just 2- zcount "key" 10 100 >>=? 1-- zrange "key" 0 1 >>=? ["v1","v2"]- zrevrange "key" 0 1 >>=? ["v3","v2"]- zrangeWithscores "key" 0 1 >>=? [("v1",1),("v2",2)]- zrevrangeWithscores "key" 0 1 >>=? [("v3",42),("v2",2)]- zrangebyscore "key" 0.5 1.5 >>=? ["v1"]- zrangebyscoreWithscores "key" 0.5 1.5 >>=? [("v1",1)]- zrangebyscoreWithscores "key" (-inf) inf >>=? [("v1",1.0),("v2",2.0),("v3",42.0)]- zrangebyscoreLimit "key" 0.5 2.5 0 1 >>=? ["v1"]- zrangebyscoreWithscoresLimit "key" 0.5 2.5 0 1 >>=? [("v1",1)]- zrevrangebyscore "key" 1.5 0.5 >>=? ["v1"]- zrevrangebyscoreWithscores "key" 1.5 0.5 >>=? [("v1",1)]- zrevrangebyscoreLimit "key" 2.5 0.5 0 1 >>=? ["v2"]- zrevrangebyscoreWithscoresLimit "key" 2.5 0.5 0 1 >>=? [("v2",2)]-- zrem "key" ["v2"] >>=? 1- zremrangebyscore "key" 10 100 >>=? 1- zremrangebyrank "key" 0 0 >>=? 1--testZStore :: Test-testZStore = testCase "zunionstore/zinterstore" $ do- zadd "{same}k1" [(1, "v1"), (2, "v2")] >>= \case- Left _ -> error "error"- _ -> return ()- zadd "{same}k2" [(2, "v2"), (3, "v3")] >>= \case- Left _ -> error "error"- _ -> return ()- zinterstore "{same}newkey" ["{same}k1","{same}k2"] Sum >>=? 1- zinterstoreWeights "{same}newkey" [("{same}k1",1),("{same}k2",2)] Max >>=? 1- zunionstore "{same}newkey" ["{same}k1","{same}k2"] Sum >>=? 3- zunionstoreWeights "{same}newkey" [("{same}k1",1),("{same}k2",2)] Min >>=? 3----------------------------------------------------------------------------------- HyperLogLog-----testHyperLogLog :: Test-testHyperLogLog = testCase "hyperloglog" $ do- -- test creation- pfadd "hll1" ["a"] >>= \case- Left _ -> error "error"- _ -> return ()- pfcount ["hll1"] >>=? 1- -- test cardinality- pfadd "hll1" ["a"] >>= \case- Left _ -> error "error"- _ -> return ()- pfcount ["hll1"] >>=? 1- pfadd "hll1" ["b", "c", "foo", "bar"] >>= \case- Left _ -> error "error"- _ -> return ()- pfcount ["hll1"] >>=? 5- -- test merge- pfadd "{same}hll2" ["1", "2", "3"] >>= \case- Left _ -> error "error"- _ -> return ()- pfadd "{same}hll3" ["4", "5", "6"] >>= \case- Left _ -> error "error"- _ -> return ()- pfmerge "{same}hll4" ["{same}hll2", "{same}hll3"] >>= \case- Left _ -> error "error"- _ -> return ()- pfcount ["{same}hll4"] >>=? 6- -- test union cardinality- pfcount ["{same}hll2", "{same}hll3"] >>=? 6----------------------------------------------------------------------------------- Pub/Sub----testPubSub :: Test-testPubSub conn = testCase "pubSub" go conn- where- go = do- -- producer- asyncProducer <- liftIO $ Async.async $ do- runRedis conn $ do- let t = 10^(5 :: Int)- liftIO $ threadDelay t- publish "chan1" "hello" >>=? 1- liftIO $ threadDelay t- publish "chan2" "world" >>=? 1- return ()-- -- consumer- pubSub (subscribe ["chan1"]) $ \msg -> do- -- ready for a message- case msg of- Message{..} -> return- (unsubscribe [msgChannel] `mappend` psubscribe ["chan*"])- PMessage{..} -> return (punsubscribe [msgPattern])-- pubSub (subscribe [] `mappend` psubscribe []) $ \_ -> do- liftIO $ HUnit.assertFailure "no subs: should return immediately"- undefined- liftIO $ Async.wait asyncProducer------------------------------------------------------------------------------------ Transaction----testTransaction :: Test-testTransaction = testCase "transaction" $ do- watch ["{same}k1", "{same}k2"] >>=? Ok- unwatch >>=? Ok- set "{same}foo" "foo" >>= \case- Left _ -> error "error"- _ -> return ()- set "{same}bar" "bar" >>= \case- Left _ -> error "error"- _ -> return ()- foobar <- multiExec $ do- foo <- get "{same}foo"- bar <- get "{same}bar"- return $ (,) <$> foo <*> bar- assert $ foobar == TxSuccess (Just "foo", Just "bar")------------------------------------------------------------------------------------ Scripting----testScripting :: Test-testScripting conn = testCase "scripting" go conn- where- go = do- let script = "return {false, 42}"- scriptRes = (False, 42 :: Integer)- scriptLoad script >>= \case- Left _ -> error "error"- Right scriptHash -> do- eval script [] [] >>=? scriptRes- evalsha scriptHash [] [] >>=? scriptRes- scriptExists [scriptHash, "notAScript"] >>=? [True, False]- scriptFlush >>=? Ok- -- start long running script from another client- configSet "lua-time-limit" "100" >>=? Ok- evalFinished <- liftIO newEmptyMVar- asyncScripting <- liftIO $ Async.async $ runRedis conn $ do- -- we must pattern match to block the thread- (eval "while true do end" [] []- :: Redis (Either Reply Integer)) >>= \case- Left _ -> return ()- _ -> error "impossible"- liftIO (putMVar evalFinished ())- return ()- liftIO (threadDelay 500000) -- 0.5s- scriptKill >>=? Ok- () <- liftIO (takeMVar evalFinished)- liftIO $ Async.wait asyncScripting- return ()----------------------------------------------------------------------------------- Connection----testConnectAuth :: Test-testConnectAuth = testCase "connect/auth" $ do- configSet "requirepass" "pass" >>=? Ok- liftIO $ do- c <- checkedConnect defaultConnectInfo { connectAuth = Just "pass" }- runRedis c (ping >>=? Pong)- auth "pass" >>=? Ok- configSet "requirepass" "" >>=? Ok--testConnectAuthUnexpected :: Test-testConnectAuthUnexpected = testCase "connect/auth/unexpected" $ do- liftIO $ do- res <- try $ void $ checkedConnect connInfo- HUnit.assertEqual "" err res-- where connInfo = defaultConnectInfo { connectAuth = Just "pass" }- err = Left $ ConnectAuthError $- Error "ERR AUTH <password> called without any password configured for the default user. Are you sure your configuration is correct?"--testConnectDb :: Test-testConnectDb = testCase "connect/db" $ do- set "connect" "value" >>=? Ok- liftIO $ void $ do- c <- checkedConnect defaultConnectInfo { connectDatabase = 1 }- runRedis c (get "connect" >>=? Nothing)--testConnectDbUnexisting :: Test-testConnectDbUnexisting = testCase "connect/db/unexisting" $ do- liftIO $ do- res <- try $ void $ checkedConnect connInfo- case res of- Left (ConnectSelectError _) -> return ()- _ -> HUnit.assertFailure $- "Expected ConnectSelectError, got " ++ show res-- where connInfo = defaultConnectInfo { connectDatabase = 100 }--testEcho :: Test-testEcho = testCase "echo" $- echo ("value" ) >>=? "value"--testPing :: Test-testPing = testCase "ping" $ ping >>=? Pong--testQuit :: Test-testQuit = testCase "quit" $ quit >>=? Ok--testSelect :: Test-testSelect = testCase "select" $ do- select 13 >>=? Ok- select 0 >>=? Ok------------------------------------------------------------------------------------ Server----testServer :: Test-testServer = testCase "server" $ do- time >>= \case- Right (_,_) -> return ()- Left _ -> error "error"- slaveof "no" "one" >>=? Ok- return ()--testBgrewriteaof :: Test-testBgrewriteaof = testCase "bgrewriteaof/bgsave/save" $ do- save >>=? Ok- bgsave >>= \case- Right (Status _) -> return ()- _ -> error "error"- -- Redis needs time to finish the bgsave- liftIO $ threadDelay (10^(5 :: Int))- bgrewriteaof >>= \case- Right (Status _) -> return ()- _ -> error "error"- return ()--testConfig :: Test-testConfig = testCase "config/auth" $ do- configGet "requirepass" >>=? [("requirepass", "")]- configSet "requirepass" "pass" >>=? Ok- auth "pass" >>=? Ok- configSet "requirepass" "" >>=? Ok--testFlushall :: Test-testFlushall = testCase "flushall/flushdb" $ do- flushall >>=? Ok- flushdb >>=? Ok--testInfo :: Test-testInfo = testCase "info/lastsave/dbsize" $ do- info >>= \case- Left _ -> error "error"- _ -> return ()- lastsave >>= \case- Left _ -> error "error"- _ -> return ()- dbsize >>=? 0- configResetstat >>=? Ok--testSlowlog :: Test-testSlowlog = testCase "slowlog" $ do- slowlogReset >>=? Ok- slowlogGet 5 >>=? []- slowlogLen >>=? 0--testDebugObject :: Test-testDebugObject = testCase "debugObject/debugSegfault" $ do- set "key" "value" >>=? Ok- debugObject "key" >>= \case- Left _ -> error "error"- _ -> return ()- return ()--testScans :: Test-testScans = testCase "scans" $ do- set "key" "value" >>=? Ok- scan cursor0 >>=? (cursor0, ["key"])- scanOpts cursor0 sOpts1 >>=? (cursor0, ["key"])- scanOpts cursor0 sOpts2 >>=? (cursor0, [])- where sOpts1 = defaultScanOpts { scanMatch = Just "k*" }- sOpts2 = defaultScanOpts { scanMatch = Just "not*"}--testSScan :: Test-testSScan = testCase "sscan" $ do- sadd "set" ["1"] >>=? 1- sscan "set" cursor0 >>=? (cursor0, ["1"])--testHScan :: Test-testHScan = testCase "hscan" $ do- hset "hash" "k" "v" >>=? 1- hscan "hash" cursor0 >>=? (cursor0, [("k", "v")])--testZScan :: Test-testZScan = testCase "zscan" $ do- zadd "zset" [(42, "2")] >>=? 1- zscan "zset" cursor0 >>=? (cursor0, [("2", 42)])--testZrangelex ::Test-testZrangelex = testCase "zrangebylex" $ do- let testSet = [(10, "aaa"), (10, "abb"), (10, "ccc"), (10, "ddd")]- zadd "zrangebylex" testSet >>=? 4- zrangebylex "zrangebylex" (Incl "aaa") (Incl "bbb") >>=? ["aaa","abb"]- zrangebylex "zrangebylex" (Excl "aaa") (Excl "ddd") >>=? ["abb","ccc"]- zrangebylex "zrangebylex" Minr Maxr >>=? ["aaa","abb","ccc","ddd"]- zrangebylexLimit "zrangebylex" Minr Maxr 2 1 >>=? ["ccc"]--testXAddRead ::Test-testXAddRead = testCase "xadd/xread" $ do- xadd "{same}somestream" "123" [("key", "value"), ("key2", "value2")]- xadd "{same}otherstream" "456" [("key1", "value1")]- xaddOpts "{same}thirdstream" "*" [("k", "v")] (Maxlen 1)- xaddOpts "{same}thirdstream" "*" [("k", "v")] (ApproxMaxlen 1)- xread [("{same}somestream", "0"), ("{same}otherstream", "0")] >>=? Just [- XReadResponse {- stream = "{same}somestream",- records = [StreamsRecord{recordId = "123-0", keyValues = [("key", "value"), ("key2", "value2")]}]- },- XReadResponse {- stream = "{same}otherstream",- records = [StreamsRecord{recordId = "456-0", keyValues = [("key1", "value1")]}]- }]- xlen "{same}somestream" >>=? 1--testXReadGroup ::Test-testXReadGroup = testCase "XGROUP */xreadgroup/xack" $ do- xadd "somestream" "123" [("key", "value")]- xgroupCreate "somestream" "somegroup" "0"- xreadGroup "somegroup" "consumer1" [("somestream", ">")] >>=? Just [- XReadResponse {- stream = "somestream",- records = [StreamsRecord{recordId = "123-0", keyValues = [("key", "value")]}]- }]- xack "somestream" "somegroup" ["123-0"] >>=? 1- xreadGroup "somegroup" "consumer1" [("somestream", ">")] >>=? Nothing- xgroupSetId "somestream" "somegroup" "0" >>=? Ok- xgroupDelConsumer "somestream" "somegroup" "consumer1" >>=? 0- xgroupDestroy "somestream" "somegroup" >>=? True--testXRange ::Test-testXRange = testCase "xrange/xrevrange" $ do- xadd "somestream" "121" [("key1", "value1")]- xadd "somestream" "122" [("key2", "value2")]- xadd "somestream" "123" [("key3", "value3")]- xadd "somestream" "124" [("key4", "value4")]- xrange "somestream" "122" "123" Nothing >>=? [- StreamsRecord{recordId = "122-0", keyValues = [("key2", "value2")]},- StreamsRecord{recordId = "123-0", keyValues = [("key3", "value3")]}- ]- xrevRange "somestream" "123" "122" Nothing >>=? [- StreamsRecord{recordId = "123-0", keyValues = [("key3", "value3")]},- StreamsRecord{recordId = "122-0", keyValues = [("key2", "value2")]}- ]--testXpending ::Test-testXpending = testCase "xpending" $ do- xadd "somestream" "121" [("key1", "value1")]- xadd "somestream" "122" [("key2", "value2")]- xadd "somestream" "123" [("key3", "value3")]- xadd "somestream" "124" [("key4", "value4")]- xgroupCreate "somestream" "somegroup" "0"- xreadGroup "somegroup" "consumer1" [("somestream", ">")]- xpendingSummary "somestream" "somegroup" Nothing >>=? XPendingSummaryResponse {- numPendingMessages = 4,- smallestPendingMessageId = "121-0",- largestPendingMessageId = "124-0",- numPendingMessagesByconsumer = [("consumer1", 4)]- }- detail <- xpendingDetail "somestream" "somegroup" "121" "121" 10 Nothing- liftIO $ case detail of- Left reply -> HUnit.assertFailure $ "Redis error: " ++ show reply- Right [XPendingDetailRecord{..}] -> do- messageId HUnit.@=? "121-0"- Right bad -> HUnit.assertFailure $ "Unexpectedly got " ++ show bad--testXClaim ::Test-testXClaim =- testCase "xclaim" $ do- xadd "somestream" "121" [("key1", "value1")] >>=? "121-0"- xadd "somestream" "122" [("key2", "value2")] >>=? "122-0"- xgroupCreate "somestream" "somegroup" "0" >>=? Ok- xreadGroupOpts- "somegroup"- "consumer1"- [("somestream", ">")]- (defaultXreadOpts {recordCount = Just 2}) >>=?- Just- [ XReadResponse- { stream = "somestream"- , records =- [ StreamsRecord- {recordId = "121-0", keyValues = [("key1", "value1")]}- , StreamsRecord- {recordId = "122-0", keyValues = [("key2", "value2")]}- ]- }- ]- xclaim "somestream" "somegroup" "consumer2" 0 defaultXClaimOpts ["121-0"] >>=?- [StreamsRecord {recordId = "121-0", keyValues = [("key1", "value1")]}]- xclaimJustIds- "somestream"- "somegroup"- "consumer2"- 0- defaultXClaimOpts- ["122-0"] >>=?- ["122-0"]--testXInfo ::Test-testXInfo = testCase "xinfo" $ do- xadd "somestream" "121" [("key1", "value1")]- xadd "somestream" "122" [("key2", "value2")]- xgroupCreate "somestream" "somegroup" "0"- xreadGroupOpts "somegroup" "consumer1" [("somestream", ">")] (defaultXreadOpts { recordCount = Just 2})- consumerInfos <- xinfoConsumers "somestream" "somegroup"- liftIO $ case consumerInfos of- Left reply -> HUnit.assertFailure $ "Redis error: " ++ show reply- Right [XInfoConsumersResponse{..}] -> do- xinfoConsumerName HUnit.@=? "consumer1"- xinfoConsumerNumPendingMessages HUnit.@=? 2- Right bad -> HUnit.assertFailure $ "Unexpectedly got " ++ show bad- xinfoGroups "somestream" >>=? [- XInfoGroupsResponse{- xinfoGroupsGroupName = "somegroup",- xinfoGroupsNumConsumers = 1,- xinfoGroupsNumPendingMessages = 2,- xinfoGroupsLastDeliveredMessageId = "122-0"- }]- xinfoStream "somestream" >>=? XInfoStreamResponse- { xinfoStreamLength = 2- , xinfoStreamRadixTreeKeys = 1- , xinfoStreamRadixTreeNodes = 2- , xinfoStreamNumGroups = 1- , xinfoStreamLastEntryId = "122-0"- , xinfoStreamFirstEntry = StreamsRecord- { recordId = "121-0"- , keyValues = [("key1", "value1")]- }- , xinfoStreamLastEntry = StreamsRecord- { recordId = "122-0"- , keyValues = [("key2", "value2")]- }- }--testXDel ::Test-testXDel = testCase "xdel" $ do- xadd "somestream" "121" [("key1", "value1")]- xadd "somestream" "122" [("key2", "value2")]- xdel "somestream" ["122"] >>=? 1- xlen "somestream" >>=? 1--testXTrim ::Test-testXTrim = testCase "xtrim" $ do- xadd "somestream" "121" [("key1", "value1")]- xadd "somestream" "122" [("key2", "value2")]- xadd "somestream" "123" [("key3", "value3")]- xadd "somestream" "124" [("key4", "value4")]- xadd "somestream" "125" [("key5", "value5")]- xtrim "somestream" (Maxlen 2) >>=? 3+{-# 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 qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as Char8+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++isUnknownCommandReply :: Reply -> Bool+isUnknownCommandReply (Error message) = "unknown command" `BS.isInfixOf` message+isUnknownCommandReply _ = False++isHotkeysInactiveReply :: Reply -> Bool+isHotkeysInactiveReply (Error message) =+ "not currently active" `BS.isInfixOf` message || "tracking is not active" `BS.isInfixOf` message+isHotkeysInactiveReply (Bulk Nothing) = True+isHotkeysInactiveReply _ = False++------------------------------------------------------------------------------+-- Miscellaneous+--+testsMisc :: [Test]+testsMisc =+ [ testConstantSpacePipelining, testForceErrorReply, testPipelining+ , testEvalReplies, testGeo, testWaitCommands+ ]++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)++testWaitCommands :: Test+testWaitCommands = testCase "wait commands" $ do+ set "wait:key" "value" >>=? Ok+ wait 0 0 >>=? 0++ waitaofResult <- waitaof 0 0 0+ liftIO $ case waitaofResult of+ Right result -> WaitAofResult 0 0 HUnit.@=? result+ Left reply | isUnknownCommandReply reply -> pure ()+ Left reply -> HUnit.assertFailure $ "Unexpected WAITAOF reply: " ++ show reply++------------------------------------------------------------------------------+-- 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++testCopy :: Test+testCopy = testCase "copy" $ do+ set "dolly" "sheep" >>=? Ok+ copy "dolly" "clone" >>=? True+ get "clone" >>=? Just "sheep"+ copy "dolly" "clone" >>=? False+ copyOpts "dolly" "clone" defaultCopyOpts { copyReplace = True } >>=? True++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, testStringCommands6, 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"+ substr "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++testStringCommands6 :: Test+testStringCommands6 = testCase "strings redis 6" $ do+ set "mykey" "Hello" >>=? Ok+ getdel "mykey" >>=? Just "Hello"+ get "mykey" >>=? Nothing+ set "mykey" "Hello" >>=? Ok+ getexOpts "mykey" defaultGetExOpts { getExSeconds = Just 10 } >>=? Just "Hello"+ ttl "mykey" >>@? \value ->+ HUnit.assertBool "GETEX should set ttl" (value >= 0 && value <= 10)++testStringCommands84 :: Test+testStringCommands84 = testCase "strings redis 8.4" $ do+ set "digest-key" "Hello world" >>=? Ok+ digest "digest-key" >>=? Just "b6acb9d84a38ff74"+ delexWhen "digest-key" (DelexIfEq "Goodbye") >>=? False+ get "digest-key" >>=? Just "Hello world"+ digest "digest-key" >>= \case+ Left reply -> liftIO $ HUnit.assertFailure $ "Redis error: " ++ show reply+ Right (Just digestValue) -> do+ delexWhen "digest-key" (DelexIfDigestEq digestValue) >>=? True+ get "digest-key" >>=? Nothing+ Right Nothing -> liftIO $ HUnit.assertFailure "DIGEST should return a digest for an existing string key"++ msetexOpts (("k1", "v1") NE.:| [("k2", "v2")]) defaultSetOpts { setSeconds = Just 60 } >>=? True+ mget ["k1", "k2"] >>=? [Just "v1", Just "v2"]+ ttl "k1" >>@? \value ->+ HUnit.assertBool "MSETEX should set ttl" (value >= 0 && value <= 60)++ msetexOpts (("k1", "new-v1") NE.:| [("k3", "v3")]) defaultSetOpts { setCondition = Just Nx } >>=? False+ get "k1" >>=? Just "v1"+ get "k3" >>=? Nothing++ msetexOpts (("k1", "new-v1") NE.:| [("k2", "new-v2")]) defaultSetOpts { setCondition = Just Xx } >>=? True+ mget ["k1", "k2"] >>=? [Just "new-v1", Just "new-v2"]++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+ hset "coin" [("heads","obverse"),("tails","reverse"),("edge","null")] >>=? 3+ hrandfield "coin" >>@? \field ->+ HUnit.assertBool "HRANDFIELD should return an existing field" (field `elem` ([Just "heads", Just "tails", Just "edge"] :: [Maybe ByteString]))+ hrandfieldCount "coin" 2 >>@? \fields -> do+ HUnit.assertEqual "HRANDFIELD count" 2 (length fields)+ HUnit.assertBool "HRANDFIELD count should return distinct fields" (fields == L.nub fields)+ HUnit.assertBool "HRANDFIELD count should return existing fields" (all (`elem` (["heads", "tails", "edge"] :: [ByteString])) fields)+ hrandfieldCountWithValues "coin" 2 >>@? \fields -> do+ HUnit.assertEqual "HRANDFIELD WITHVALUES count" 2 (length fields)+ HUnit.assertBool "HRANDFIELD WITHVALUES should return existing field/value pairs" $+ all (`elem` ([("heads", "obverse"), ("tails", "reverse"), ("edge", "null")] :: [(ByteString, ByteString)])) fields++testHashes8 :: Test+testHashes8 = testCase "hashes redis 8" $ do+ hsetexOpts "myhash" (("field1", "Hello") NE.:| [("field2", "World")])+ defaultHSetExOpts { hSetExSeconds = Just 60 }+ >>=? True+ httl "myhash" ["field1"] >>@? \case+ (HashFieldExpirationInfo value:_) ->+ HUnit.assertBool ("HSETEX should set ttl: " <> show value) (value >= 0 && value <= 60)+ x -> HUnit.assertFailure $ "HTTL should return field expiration info for field1" <> show x++ hgetexOpts "myhash" ("field1" NE.:| ["field2", "missing"])+ defaultHGetExOpts { hGetExPersist = True }+ >>=? [Just "Hello", Just "World", Nothing]+ ttl "myhash" >>=? (-1)++ hgetdel "myhash" ("field1" NE.:| ["field2", "missing"])+ >>=? [Just "Hello", Just "World", Nothing]+ hgetall "myhash" >>=? []++ hsetexOpts "myhash" (("field1", "Hello") NE.:| [])+ defaultHSetExOpts { hSetExCondition = Just HSetExFnx }+ >>=? True+ hsetexOpts "myhash" (("field1", "World") NE.:| [])+ defaultHSetExOpts { hSetExCondition = Just HSetExFnx }+ >>=? False+ hsetexOpts "myhash" (("field1", "World") NE.:| [])+ defaultHSetExOpts { hSetExCondition = Just HSetExFxx }+ >>=? True+ hget "myhash" "field1" >>=? Just "World"++------------------------------------------------------------------------------+-- Lists+--+testsLists :: [Test]+testsLists =+ [testLists, testListCommands6, 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 ()++testListCommands6 :: Test+testListCommands6 = testCase "lists redis 6" $ do+ rpush "mylist" ["a", "b", "c", "d", "1", "2", "3", "4", "3", "3", "3"] >>=? 11+ lpos "mylist" "3" >>=? Just 6+ lposCount "mylist" "3" 0 >>=? [6, 8, 9, 10]+ lposOpts "mylist" "3" defaultLPosOpts { lposRank = Just 2 } >>=? Just 8++ rpush "{same}src" ["one", "two", "three"] >>=? 3+ lmove "{same}src" "{same}dst" ListLeft ListRight >>=? Just "one"+ lrange "{same}src" 0 (-1) >>=? ["two", "three"]+ lrange "{same}dst" 0 (-1) >>=? ["one"]++ rpush "{same}src2" ["one", "two", "three"] >>=? 3+ blmove "{same}src2" "{same}dst2" ListRight ListLeft 1 >>=? Just "three"+ lrange "{same}src2" 0 (-1) >>=? ["one", "two"]+ lrange "{same}dst2" 0 (-1) >>=? ["three"]++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, testSMIsMember, 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"]++testSMIsMember :: Test+testSMIsMember = testCase "smismember" $ do+ sadd "myset" (NE.fromList ["one"]) >>=? 1+ smismember "myset" ("one" NE.:| ["notamember"]) >>=? [True, False]++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, testSortedSetCommands6, 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++testSortedSetCommands6 :: Test+testSortedSetCommands6 = testCase "sorted sets redis 6" $ do+ zadd "{same}zset1" [(1, "one"), (2, "two"), (3, "three")] >>=? 3+ zadd "{same}zset2" [(1, "one"), (2, "two")] >>=? 2++ zdiff ("{same}zset1" NE.:| ["{same}zset2"]) >>=? ["three"]+ zdiffWithscores ("{same}zset1" NE.:| ["{same}zset2"]) >>=? [("three", 3)]+ zdiffstore "{same}out" ("{same}zset1" NE.:| ["{same}zset2"]) >>=? 1+ zrangeWithscores "{same}out" 0 (-1) >>=? [("three", 3)]++ zinter ("{same}zset1" NE.:| ["{same}zset2"]) >>=? ["one", "two"]+ zinterWithscores ("{same}zset1" NE.:| ["{same}zset2"]) >>=? [("one", 2), ("two", 4)]+ zinterWithscoresOpts ("{same}zset1" NE.:| ["{same}zset2"])+ defaultZAggregateOpts { zAggregateWeights = [2, 3], zAggregateAggregate = Max }+ >>=? [("one", 3), ("two", 6)]++ zunion ("{same}zset1" NE.:| ["{same}zset2"]) >>=? ["one", "three", "two"]+ zunionWithscores ("{same}zset1" NE.:| ["{same}zset2"]) >>=? [("one", 2), ("three", 3), ("two", 4)]+ zmscore "{same}zset1" ("one" NE.:| ["notamember"]) >>=? [Just 1, Nothing]++ zrandmember "{same}zset1" >>@? \member ->+ HUnit.assertBool "ZRANDMEMBER should return an existing member" (member `elem` ([Just "one", Just "two", Just "three"] :: [Maybe ByteString]))+ zrandmemberN "{same}zset1" 2 >>@? \members -> do+ HUnit.assertEqual "ZRANDMEMBER count" 2 (length members)+ HUnit.assertBool "ZRANDMEMBER count should return existing members" (all (`elem` (["one", "two", "three"] :: [ByteString])) members)+ zrandmemberWithscores "{same}zset1" 2 >>@? \members -> do+ HUnit.assertEqual "ZRANDMEMBER WITHSCORES count" 2 (length members)+ HUnit.assertBool "ZRANDMEMBER WITHSCORES should return valid pairs" $+ all (`elem` ([("one", 1), ("two", 2), ("three", 3)] :: [(ByteString, Double)])) members++ zrangestore "{same}newzset" "{same}zset1" 2 (-1) >>=? 1+ zrange "{same}newzset" 0 (-1) >>=? ["three"]++-- 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++------------------------------------------------------------------------------+-- Bloom Filters+--+testBloomFilter :: Test+testBloomFilter = testCase "bloom filter" $ do+ liftIO $ putStrLn "Testing bloom filter with default parameters..."+ bfadd "bf1" "observation1" >>=? True+ liftIO $ putStrLn "Testing bloom filter info commands..."+ bfinfoSize "bf1" >>=? [240]+ liftIO $ putStrLn "Testing bloom filter info commands with error handling..."+ Right [infoSize] <- bfinfoSize "bf1"+ liftIO $ putStrLn $ "Bloom filter info: " ++ show infoSize+ bfinfo "bf1" >>=? BFInfo+ { bfInfoCapacity = 100+ , bfInfoSize = infoSize+ , bfInfoFilters = 1+ , bfInfoItems = 1+ , bfInfoExpansion = 2+ }+ bfinfoCapacity "bf1" >>=? [100]+ bfinfoFilters "bf1" >>=? [1]+ bfinfoItems "bf1" >>=? [1]+ bfinfoExpansion "bf1" >>=? [Just 2]+ bfcard "bf1" >>=? 1+ bfcard "bf_new" >>=? 0+++ liftIO $ putStrLn "Testing bloom filter with custom parameters..."++ bfreserve "bf" 0.01 1000 >>=? Ok+ bfadd "bf" "item1" >>=? True+ bfexists "bf" "item1" >>=? True+ bfexists "bf" "item2" >>=? False++ liftIO $ putStrLn "Testing bloom filter multi-item commands..."++ bfmadd "bfm" ("item1" NE.:| ["item2", "item2"]) >>=? [True, True, False]+ bfmexists "bfm" ("item1" NE.:| ["item2", "item3"]) >>=? [True, True, False]++ liftIO $ putStrLn "Testing bloom filter insert commands with custom parameters..."++ bfinsert "bfi" ("item1" NE.:| ["item2"]) >>=? [True, True]+ bfinsertOpts "bf_insert" ("item1" NE.:| ["item2"]) defaultBFInsertOpts+ { bfInsertCapacity = Just 1000+ , bfInsertError = Just 0.01+ , bfInsertExpansion = Just 3+ , bfInsertNonScaling = True+ } >>=? [True, True]+++ bfinfoCapacity "bf_insert" >>=? [1000]+ bfinfoExpansion "bf_insert" >>=? [Nothing]++ bfinsertOpts "bf_insert1" ("item1" NE.:| ["item2"]) defaultBFInsertOpts+ { bfInsertCapacity = Just 1000+ , bfInsertError = Just 0.01+ , bfInsertExpansion = Just 4+ , bfInsertNonScaling = False+ } >>=? [True, True]+ bfinfoExpansion "bf_insert1" >>=? [Just 4]+++ bfreserveOpts "bf_exp" 0.01 1000 defaultBFReserveOpts+ { bfReserveExpansion = Just 2+ } >>=? Ok+ bfinfoExpansion "bf_exp" >>=? [Just 2]+++ bfreserve "bfdump" 0.1 10 >>=? Ok+ bfadd "bfdump" "item1" >>=? True++-- Count-Min Sketches+--+testCountMinSketch :: Test+testCountMinSketch = testCase "count-min sketch" $ do+ cmsinitbydim "cms1" 20 5 >>=? Ok+ cmsinfo "cms1" >>=? CMSInfo+ { cmsInfoWidth = 20+ , cmsInfoDepth = 5+ , cmsInfoCount = 0+ }++ cmsincrby "cms1" (("foo", 2) NE.:| [("bar", 3), ("foo", 4)]) >>=? [2, 3, 6]+ cmsquery "cms1" ("foo" NE.:| ["bar", "baz"]) >>=? [6, 3, 0]+ cmsinfo "cms1" >>=? CMSInfo+ { cmsInfoWidth = 20+ , cmsInfoDepth = 5+ , cmsInfoCount = 9+ }++ cmsinitbyprob "cms2" 0.001 0.99 >>=? Ok+ cmsquery "cms2" ("foo" NE.:| ["bar"]) >>=? [0, 0]+ cmsincrby "cms2" (("foo", 7) NE.:| [("bar", 1)]) >>=? [7, 1]+ cmsinfo "cms2" >>@? \CMSInfo{..} -> do+ HUnit.assertBool "cms2 width should be positive" (cmsInfoWidth > 0)+ HUnit.assertBool "cms2 depth should be positive" (cmsInfoDepth > 0)+ 8 HUnit.@=? cmsInfoCount++ cmsinitbydim "cms3" 20 5 >>=? Ok+ cmsincrby "cms3" (("foo", 7) NE.:| [("bar", 1)]) >>=? [7, 1]++ cmsinitbydim "cms_merged" 20 5 >>=? Ok+ cmsmerge "cms_merged" ("cms1" NE.:| ["cms3"]) >>=? Ok+ cmsquery "cms_merged" ("foo" NE.:| ["bar", "baz"]) >>=? [13, 4, 0]++ cmsinitbydim "cms_weighted" 20 5 >>=? Ok+ cmsmergeWeighted "cms_weighted" (("cms1", 1) NE.:| [("cms3", 2)]) >>=? Ok+ cmsquery "cms_weighted" ("foo" NE.:| ["bar", "baz"]) >>=? [20, 5, 0]++-- Top-K+--+testTopk :: Test+testTopk = testCase "topk" $ do+ topkReserve "topk1" 3 50 5 0.9 >>=? Ok+ topkInfo "topk1" >>=? TopkInfo+ { topkInfoK = 3+ , topkInfoWidth = 50+ , topkInfoDepth = 5+ , topkInfoDecay = 0.9+ }++ topkAdd "topk1" ("foo" NE.:| ["bar", "baz"]) >>=? [Nothing, Nothing, Nothing]+ topkQuery "topk1" ("foo" NE.:| ["bar", "missing"]) >>=? [True, True, False]+ topkCount "topk1" ("foo" NE.:| ["bar", "missing"]) >>@? \counts ->+ case counts of+ [fooCount, barCount, 0] -> do+ HUnit.assertBool "TOPK.COUNT foo should be positive" (fooCount > 0)+ HUnit.assertBool "TOPK.COUNT bar should be positive" (barCount > 0)+ _ -> HUnit.assertFailure $ "Unexpected TOPK.COUNT response: " ++ show counts++ topkIncrby "topk1" (("foo", 10) NE.:| [("baz", 3), ("qux", 1)]) >>@? \results ->+ HUnit.assertEqual "TOPK.INCRBY result length" 3 (length results)++ topkList "topk1" >>@? \items -> do+ HUnit.assertEqual "TOPK.LIST length" 3 (length items)+ HUnit.assertBool "TOPK.LIST should include foo" ("foo" `elem` items)++ topkListWithCount "topk1" >>@? \itemsWithCount -> do+ HUnit.assertEqual "TOPK.LIST WITHCOUNT length" 3 (length itemsWithCount)+ let itemKeys = map fst itemsWithCount+ HUnit.assertBool "TOPK.LIST WITHCOUNT should include foo" ("foo" `elem` itemKeys)+ HUnit.assertBool "TOPK.LIST WITHCOUNT counts should be positive" (all ((> 0) . snd) itemsWithCount)++-- T-Digest+--+testTdigest :: Test+testTdigest = testCase "tdigest" $ do+ tdigestCreate "td1" >>=? Ok+ tdigestAdd "td1" (1 NE.:| [2, 3, 4, 5]) >>=? Ok++ tdigestMin "td1" >>=? 1+ tdigestMax "td1" >>=? 5+ tdigestByrank "td1" (0 NE.:| [2, 4]) >>@? \values ->+ case values of+ [v0, v2, v4] -> do+ HUnit.assertEqual "TDIGEST.BYRANK 0" 1 v0+ HUnit.assertBool "TDIGEST.BYRANK 2 should be within range" (v2 >= 2 && v2 <= 4)+ HUnit.assertEqual "TDIGEST.BYRANK 4" 5 v4+ _ -> HUnit.assertFailure $ "Unexpected TDIGEST.BYRANK response: " ++ show values+ tdigestByrevrank "td1" (0 NE.:| [2, 4]) >>@? \values ->+ case values of+ [v0, v2, v4] -> do+ HUnit.assertEqual "TDIGEST.BYREVRANK 0" 5 v0+ HUnit.assertBool "TDIGEST.BYREVRANK 2 should be within range" (v2 >= 2 && v2 <= 4)+ HUnit.assertEqual "TDIGEST.BYREVRANK 4" 1 v4+ _ -> HUnit.assertFailure $ "Unexpected TDIGEST.BYREVRANK response: " ++ show values+ tdigestQuantile "td1" (0.0 NE.:| [0.5, 1.0]) >>@? \values ->+ case values of+ [q0, q50, q100] -> do+ HUnit.assertEqual "TDIGEST.QUANTILE 0" 1 q0+ HUnit.assertBool "TDIGEST.QUANTILE 0.5 should be within range" (q50 >= 2 && q50 <= 4)+ HUnit.assertEqual "TDIGEST.QUANTILE 1" 5 q100+ _ -> HUnit.assertFailure $ "Unexpected TDIGEST.QUANTILE response: " ++ show values++ tdigestCdf "td1" (1 NE.:| [3, 5]) >>@? \values ->+ case values of+ [cdf1, cdf3, cdf5] -> do+ HUnit.assertBool "TDIGEST.CDF should be monotonic" (cdf1 <= cdf3 && cdf3 <= cdf5)+ HUnit.assertBool "TDIGEST.CDF last value should be close to 1" (cdf5 >= 0.8)+ _ -> HUnit.assertFailure $ "Unexpected TDIGEST.CDF response: " ++ show values++ tdigestRank "td1" (1 NE.:| [3, 5]) >>@? \values ->+ case values of+ [r1, r3, r5] -> HUnit.assertBool "TDIGEST.RANK should be monotonic" (r1 <= r3 && r3 <= r5)+ _ -> HUnit.assertFailure $ "Unexpected TDIGEST.RANK response: " ++ show values++ tdigestRevrank "td1" (1 NE.:| [3, 5]) >>@? \values ->+ case values of+ [r1, r3, r5] -> HUnit.assertBool "TDIGEST.REVRANK should be monotonic descending" (r1 >= r3 && r3 >= r5)+ _ -> HUnit.assertFailure $ "Unexpected TDIGEST.REVRANK response: " ++ show values++ tdigestTrimmedMean "td1" 0.2 0.8 >>@? \value ->+ HUnit.assertBool "TDIGEST.TRIMMED_MEAN should be within observed range" (value >= 1 && value <= 5)++ tdigestInfo "td1" >>@? \TDigestInfo{..} -> do+ HUnit.assertBool "TDIGEST.INFO compression should be positive" (tdigestInfoCompression > 0)+ HUnit.assertBool "TDIGEST.INFO observations should reflect inserts" (tdigestInfoObservations >= 5)+ HUnit.assertBool "TDIGEST.INFO memory usage should be positive" (tdigestInfoMemoryUsage > 0)++ tdigestCreateOpts "td2" defaultTDigestCreateOpts+ { tdigestCreateCompression = Just 200+ } >>=? Ok+ tdigestAdd "td2" (10 NE.:| [20, 30]) >>=? Ok++ tdigestMerge "td_merged" ("td1" NE.:| ["td2"]) >>@? \status ->+ HUnit.assertEqual "TDIGEST.MERGE status" Ok status+ tdigestInfo "td_merged" >>@? \digestInfo ->+ HUnit.assertBool "TDIGEST.MERGE should populate destination" (tdigestInfoObservations digestInfo >= 8)++ tdigestCreate "td_override" >>=? Ok+ tdigestMergeOpts "td_override" ("td1" NE.:| ["td2"]) defaultTDigestMergeOpts+ { tdigestMergeCompression = Just 150+ , tdigestMergeOverride = True+ } >>=? Ok+ tdigestInfo "td_override" >>@? \digestInfo -> do+ 150 HUnit.@=? tdigestInfoCompression digestInfo+ HUnit.assertBool "TDIGEST.MERGE override should populate destination" (tdigestInfoObservations digestInfo >= 8)++ tdigestReset "td1" >>=? Ok+ tdigestInfo "td1" >>@? \digestInfo ->+ HUnit.assertEqual "TDIGEST.RESET observations" 0 (tdigestInfoObservations digestInfo)++-- TimeSeries+--+testTs :: Test+testTs = testCase "timeseries" $ do+ tsCreateOpts "ts:series" defaultTsCreateOpts+ { tsCreateRetention = Just 100000+ , tsCreateEncoding = Just TsCompressed+ , tsCreateChunkSize = Just 128+ , tsCreateDuplicatePolicy = Just TsDuplicateLast+ , tsCreateLabels = [("metric", "temperature"), ("sensor", "alpha")]+ } >>=? Ok++ tsAdd "ts:series" "1000" 1.5 >>=? 1000+ tsAddOpts "ts:series" "2000" 2.5 defaultTsAddOpts+ { tsAddOnDuplicate = Just TsDuplicateLast+ } >>=? 2000+ tsGet "ts:series" >>=? Just (TsSample 2000 2.5)+ tsGetOpts "ts:series" defaultTsGetOpts+ { tsGetLatest = True+ } >>=? Just (TsSample 2000 2.5)++ tsRange "ts:series" "-" "+" >>=? [TsSample 1000 1.5, TsSample 2000 2.5]+ tsRangeOpts "ts:series" "-" "+" defaultTsRangeOpts+ { tsRangeCount = Just 1+ } >>=? [TsSample 1000 1.5]+ tsRevrange "ts:series" "-" "+" >>=? [TsSample 2000 2.5, TsSample 1000 1.5]++ tsAlter "ts:series" defaultTsAlterOpts+ { tsAlterRetention = Just 200000+ , tsAlterChunkSize = Just 256+ , tsAlterDuplicatePolicy = Just TsDuplicateMax+ , tsAlterLabels = [("metric", "temperature"), ("sensor", "beta")]+ } >>=? Ok++ tsIncrbyOpts "ts:counter" 5 defaultTsIncrByOpts+ { tsIncrByTimestamp = Just "1000"+ , tsIncrByLabels = [("metric", "counter"), ("sensor", "alpha")]+ } >>=? 1000+ tsDecrbyOpts "ts:counter" 2 defaultTsIncrByOpts+ { tsIncrByTimestamp = Just "2000"+ } >>=? 2000+ tsGet "ts:counter" >>=? Just (TsSample 2000 3.0)++ tsMadd+ ( ("ts:series", "3000", 3.5) NE.:|+ [ ("ts:counter", "3000", 4.0)+ ]+ ) >>=? [3000, 3000]++ tsQueryindex ("metric=temperature" NE.:| []) >>@? \seriesKeys ->+ HUnit.assertBool "TS.QUERYINDEX should return the labeled series" ("ts:series" `elem` seriesKeys)++ tsMget ("sensor=alpha" NE.:| []) >>@? \reply ->+ HUnit.assertBool "TS.MGET should return payload" (replyHasPayload reply)+ tsMgetOpts ("sensor=alpha" NE.:| []) defaultTsMGetOpts+ { tsMGetLatest = True+ , tsMGetLabels = Just TsWithLabels+ } >>@? \reply ->+ HUnit.assertBool "TS.MGET WITHLABELS should return payload" (replyHasPayload reply)++ tsMrange "-" "+" ("sensor=alpha" NE.:| []) >>@? \reply ->+ HUnit.assertBool "TS.MRANGE should return payload" (replyHasPayload reply)+ tsMrangeOpts "-" "+" ("sensor=alpha" NE.:| []) defaultTsMRangeOpts+ { tsMRangeLabels = Just (TsSelectedLabels ("metric" NE.:| ["sensor"]))+ , tsMRangeAggregation = Just TsAggregationOpts+ { tsAggregationAlign = Nothing+ , tsAggregationType = TsAggregators (TsAggAvg NE.:| [])+ , tsAggregationBucketDuration = 1000+ , tsAggregationBucketTimestamp = Just TsBucketStart+ , tsAggregationEmpty = False+ }+ } >>@? \reply ->+ HUnit.assertBool "TS.MRANGE aggregation should return payload" (replyHasPayload reply)+ tsMrevrange "-" "+" ("sensor=alpha" NE.:| []) >>@? \reply ->+ HUnit.assertBool "TS.MREVRANGE should return payload" (replyHasPayload reply)++ tsCreate "ts:source" >>=? Ok+ tsCreate "ts:dest" >>=? Ok+ tsCreaterule "ts:source" "ts:dest" TsAggAvg 1000 >>=? Ok+ tsAdd "ts:source" "1000" 1 >>=? 1000+ tsAdd "ts:source" "2000" 3 >>=? 2000+ tsAdd "ts:source" "3000" 5 >>=? 3000+ delRuleResult <- tsDelrule "ts:source" "ts:dest"+ liftIO $ case delRuleResult of+ Right Ok -> pure ()+ Left reply | isUnknownCommandReply reply -> pure ()+ Left reply -> HUnit.assertFailure $ "Unexpected TS.DELRULE reply: " ++ show reply+ Right status -> HUnit.assertFailure $ "Unexpected TS.DELRULE status: " ++ show status++ tsInfo "ts:series" >>@? \reply ->+ HUnit.assertBool "TS.INFO should return payload" (replyHasPayload reply)+ tsInfoOpts "ts:series" TsInfoDebug >>@? \reply ->+ HUnit.assertBool "TS.INFO DEBUG should return payload" (replyHasPayload reply)++ tsDel "ts:series" 3000 3000 >>=? 1+ tsRange "ts:series" "-" "+" >>=? [TsSample 1000 1.5, TsSample 2000 2.5]+ where+ replyHasPayload = \case+ Bulk (Just value) -> not (BS.null value)+ MultiBulk (Just replies) -> not (null replies)+ Integer _ -> True+ SingleLine value -> not (BS.null value)+ Error _ -> False+ Bulk Nothing -> False+ MultiBulk Nothing -> False++-- RedisJSON+--+testJSON :: Test+testJSON = testCase "json" $ do+ jsonSet "json:doc" "$"+ "{\"name\":\"base\",\"numbers\":[1,2],\"enabled\":true,\"nested\":{\"inner\":5},\"remove\":\"gone\"}" >>=? Just Ok++ jsonGet "json:doc" >>@? \actual ->+ case actual of+ Just payload -> HUnit.assertBool "JSON.GET should return the object" ("\"name\":\"base\"" `BS.isInfixOf` payload)+ Nothing -> HUnit.assertFailure "JSON.GET returned Nothing"++ jsonGetOpts "json:doc" defaultJSONGetOpts+ { jsonGetIndent = Just " "+ , jsonGetNewline = Just "\n"+ , jsonGetSpace = Just " "+ , jsonGetPaths = ["$"]+ } >>@? \actual ->+ case actual of+ Just payload -> HUnit.assertBool "JSON.GET opts should format output" ("\n" `BS.isInfixOf` payload)+ Nothing -> HUnit.assertFailure "JSON.GET opts returned Nothing"++ jsonSetOpts "json:nx" "$" "{\"value\":1}" defaultJSONSetOpts+ { jsonSetCondition = Just JSONSetIfNotExists+ } >>=? Just Ok+ jsonSetOpts "json:nx" "$" "{\"value\":2}" defaultJSONSetOpts+ { jsonSetCondition = Just JSONSetIfNotExists+ } >>=? Nothing+ jsonSetOpts "json:nx" "$" "{\"value\":3}" defaultJSONSetOpts+ { jsonSetCondition = Just JSONSetIfExists+ } >>=? Just Ok++ jsonMset+ ( ("json:m1", "$", "{\"name\":\"one\"}") NE.:|+ [ ("json:m2", "$", "{\"name\":\"two\"}")+ ]+ ) >>=? Ok+ jsonMget ("json:m1" NE.:| ["json:m2"]) "$" >>@? \results ->+ HUnit.assertBool "JSON.MGET should return both values" (length results == 2 && all isJust results)++ jsonArrappend "json:doc" "$.numbers" ("3" NE.:| ["4"]) >>@? \reply ->+ HUnit.assertEqual "JSON.ARRAPPEND result" [4] (replyIntegers reply)+ jsonArrlenAt "json:doc" "$.numbers" >>@? \reply ->+ HUnit.assertEqual "JSON.ARRLEN result" [4] (replyIntegers reply)+ jsonArrindexOpts "json:doc" "$.numbers" "2" (JSONArrIndexFromTo 0 3) >>@? \reply ->+ HUnit.assertEqual "JSON.ARRINDEX result" [1] (replyIntegers reply)+ jsonArrinsert "json:doc" "$.numbers" 1 ("9" NE.:| []) >>@? \reply ->+ HUnit.assertEqual "JSON.ARRINSERT result" [5] (replyIntegers reply)+ jsonArrpopAtIndex "json:doc" "$.numbers" 1 >>@? \reply ->+ HUnit.assertBool "JSON.ARRPOP should return popped value" (replyContains "9" reply)+ jsonArrtrim "json:doc" "$.numbers" 1 2 >>@? \reply ->+ HUnit.assertEqual "JSON.ARRTRIM result" [2] (replyIntegers reply)++ jsonNumincrby "json:doc" "$.nested.inner" 5 >>@? \reply ->+ HUnit.assertBool "JSON.NUMINCRBY should update value" (replyContains "10" reply)+ jsonNummultby "json:doc" "$.nested.inner" 2 >>@? \reply ->+ HUnit.assertBool "JSON.NUMMULTBY should update value" (replyContains "20" reply)+ jsonClearAt "json:doc" "$.nested.inner" >>=? 1+ jsonGetOpts "json:doc" defaultJSONGetOpts { jsonGetPaths = ["$.nested.inner"] } >>@? \actual ->+ case actual of+ Just payload -> HUnit.assertBool "JSON.CLEAR should zero numeric value" ("0" `BS.isInfixOf` payload)+ Nothing -> HUnit.assertFailure "JSON.GET nested inner returned Nothing"++ jsonStrappendAt "json:doc" "$.name" "\"!\"" >>@? \reply ->+ HUnit.assertEqual "JSON.STRAPPEND result" [5] (replyIntegers reply)+ jsonToggle "json:doc" "$.enabled" >>@? \reply ->+ HUnit.assertEqual "JSON.TOGGLE result" [False] (replyBools reply)++ jsonObjkeysAt "json:doc" "$" >>@? \reply ->+ HUnit.assertBool "JSON.OBJKEYS should include name" (replyContains "name" reply)+ jsonObjlenAt "json:doc" "$" >>@? \reply ->+ HUnit.assertEqual "JSON.OBJLEN result" [5] (replyIntegers reply)+ jsonTypeAt "json:doc" "$.numbers" >>@? \reply ->+ HUnit.assertBool "JSON.TYPE should report array" (replyContains "array" reply)+ jsonRespAt "json:doc" "$.name" >>@? \reply ->+ HUnit.assertBool "JSON.RESP should return payload" (replyHasPayload reply)+ jsonDebugMemoryAt "json:doc" "$.numbers" >>@? \reply ->+ HUnit.assertBool "JSON.DEBUG MEMORY should return payload" (replyHasPayload reply)++ jsonMerge "json:doc" "$" "{\"merged\":true,\"name\":\"base!\"}" >>=? Ok+ jsonGet "json:doc" >>@? \actual ->+ case actual of+ Just payload -> do+ HUnit.assertBool "JSON.MERGE should add merged field" ("\"merged\":true" `BS.isInfixOf` payload)+ HUnit.assertBool "JSON.MERGE should update name" ("\"name\":\"base!\"" `BS.isInfixOf` payload)+ Nothing -> HUnit.assertFailure "JSON.GET after merge returned Nothing"++ jsonDelAt "json:doc" "$.remove" >>=? 1+ jsonForgetAt "json:doc" "$.merged" >>=? 1+ jsonGet "json:doc" >>@? \actual ->+ case actual of+ Just payload -> do+ HUnit.assertBool "JSON.DEL should remove field" (not ("\"remove\"" `BS.isInfixOf` payload))+ HUnit.assertBool "JSON.FORGET should remove field" (not ("\"merged\"" `BS.isInfixOf` payload))+ Nothing -> HUnit.assertFailure "JSON.GET after delete/forget returned Nothing"++ jsonSet "json:rootArray" "$" "[1,2,3]" >>=? Just Ok+ jsonArrlen "json:rootArray" >>@? \reply ->+ HUnit.assertBool "JSON.ARRLEN root should return payload" (replyHasPayload reply)+ jsonArrpop "json:rootArray" >>@? \reply ->+ HUnit.assertBool "JSON.ARRPOP root should return payload" (replyContains "3" reply)++ jsonSet "json:rootString" "$" "\"abc\"" >>=? Just Ok+ jsonStrappend "json:rootString" "\"d\"" >>@? \reply ->+ HUnit.assertBool "JSON.STRAPPEND root should return payload" (replyHasPayload reply)++ jsonSet "json:clearRoot" "$" "{\"a\":1}" >>=? Just Ok+ jsonClear "json:clearRoot" >>=? 1++ jsonSet "json:deleteRoot" "$" "{\"a\":1}" >>=? Just Ok+ jsonForget "json:deleteRoot" >>=? 1++ jsonSet "json:typeRoot" "$" "{\"a\":1}" >>=? Just Ok+ jsonType "json:typeRoot" >>@? \reply ->+ HUnit.assertBool "JSON.TYPE root should return payload" (replyHasPayload reply)+ jsonObjkeys "json:typeRoot" >>@? \reply ->+ HUnit.assertBool "JSON.OBJKEYS root should return payload" (replyContains "a" reply)+ jsonObjlen "json:typeRoot" >>@? \reply ->+ HUnit.assertBool "JSON.OBJLEN root should return payload" (replyHasPayload reply)+ jsonResp "json:typeRoot" >>@? \reply ->+ HUnit.assertBool "JSON.RESP root should return payload" (replyHasPayload reply)+ jsonDebugMemory "json:typeRoot" >>@? \reply ->+ HUnit.assertBool "JSON.DEBUG MEMORY root should return payload" (replyHasPayload reply)+ jsonDel "json:typeRoot" >>=? 1+ where+ isJust (Just _) = True+ isJust Nothing = False++ replyContains needle = \case+ SingleLine value -> needle `BS.isInfixOf` value+ Error value -> needle `BS.isInfixOf` value+ Integer value -> needle `BS.isInfixOf` Char8.pack (show value)+ Bulk (Just value) -> needle `BS.isInfixOf` value+ Bulk Nothing -> False+ MultiBulk (Just replies) -> any (replyContains needle) replies+ MultiBulk Nothing -> False++ replyHasPayload = \case+ Bulk (Just value) -> not (BS.null value)+ MultiBulk (Just replies) -> not (null replies)+ Integer _ -> True+ SingleLine value -> not (BS.null value)+ Error _ -> False+ Bulk Nothing -> False+ MultiBulk Nothing -> False++ replyIntegers = \case+ Integer value -> [value]+ MultiBulk (Just replies) -> [value | reply <- replies, Right value <- [decode reply :: Either Reply Integer]]+ reply -> case decode reply :: Either Reply Integer of+ Right value -> [value]+ Left _ -> []++ replyBools = \case+ Integer 1 -> [True]+ Integer 0 -> [False]+ MultiBulk (Just replies) -> [value | reply <- replies, Right value <- [decode reply :: Either Reply Bool]]+ reply -> case decode reply :: Either Reply Bool of+ Right value -> [value]+ Left _ -> []++------------------------------------------------------------------------------+-- Cuckoo Filters+--+testCuckooFilter :: Test+testCuckooFilter = testCase "cuckoo filter" $ do+ cfreserveOpts "cf" 1000 defaultCFReserveOpts+ { cfReserveBucketSize = Just 4+ , cfReserveMaxIterations = Just 50+ , cfReserveExpansion = Just 2+ } >>=? Ok++ cfinfo "cf" >>@? \CFInfo{..} -> do+ HUnit.assertBool "cfInfoSize should be positive" (cfInfoSize > 0)+ HUnit.assertBool "cfInfoBuckets should be positive" (cfInfoBuckets > 0)+ 1 HUnit.@=? cfInfoFilters+ 0 HUnit.@=? cfInfoItemsInserted+ 0 HUnit.@=? cfInfoItemsDeleted+ 4 HUnit.@=? cfInfoBucketSize+ 2 HUnit.@=? cfInfoExpansion+ 50 HUnit.@=? cfInfoMaxIterations++ cfadd "cf" "item1" >>=? True+ cfadd "cf" "item1" >>=? True+ cfcount "cf" "item1" >>=? 2+ cfexists "cf" "item1" >>=? True+ cfaddnx "cf" "item1" >>=? False+ cfcount "cf" "item1" >>=? 2++ cfinsert "cf" ("item2" NE.:| ["item3"]) >>=? [CFInsertAdded, CFInsertAdded]+ cfinsertnx "cf" ("item1" NE.:| ["item4"]) >>=? [CFInsertAlreadyExists, CFInsertAdded]+ cfmexists "cf" ("item1" NE.:| ["item2", "item3", "item4", "missing"]) >>=? [True, True, True, True, False]++ cfdel "cf" "item2" >>=? True+ cfcount "cf" "item2" >>=? 0+ cfdel "cf" "item2" >>=? False++------------------------------------------------------------------------------+-- 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 ()++testExpireTime7 :: Test+testExpireTime7 = testCase "expiretime" $ do+ set "mykey" "Hello" >>=? Ok+ expireat "mykey" 33177117420 >>=? True+ expiretime "mykey" >>=? 33177117420+ pexpireat "mykey" 33177117420000 >>=? True+ pexpiretime "mykey" >>=? 33177117420000++testHashExpire7 :: Test+testHashExpire7 = testCase "hash expire" $ do+ hset "mykey" [("field1", "hello"), ("field2", "world")] >>=? 2++ hexpire "mykey" 60 ("field1" NE.:| ["field2", "missing"]) >>=?+ [ HashFieldExpirationSet+ , HashFieldExpirationSet+ , HashFieldExpirationNoSuchField+ ]++ httl "mykey" ("field1" NE.:| ["field2", "missing"]) >>@? \values ->+ case values of+ [HashFieldExpirationInfo ttl1, HashFieldExpirationInfo ttl2, HashFieldExpirationInfoNoSuchField] -> do+ HUnit.assertBool "HTTL field1 should be positive" (ttl1 > 0 && ttl1 <= 60)+ HUnit.assertBool "HTTL field2 should be positive" (ttl2 > 0 && ttl2 <= 60)+ _ -> HUnit.assertFailure $ "Unexpected HTTL reply: " ++ show values++ hpexpire "mykey" 2000 ("field1" NE.:| ["field2"]) >>=?+ [ HashFieldExpirationSet+ , HashFieldExpirationSet+ ]++ hpttl "mykey" ("field1" NE.:| ["field2"]) >>@? \values ->+ case values of+ [HashFieldExpirationInfo ttl1, HashFieldExpirationInfo ttl2] -> do+ HUnit.assertBool "HPTTL field1 should be positive" (ttl1 > 0 && ttl1 <= 2000)+ HUnit.assertBool "HPTTL field2 should be positive" (ttl2 > 0 && ttl2 <= 2000)+ _ -> HUnit.assertFailure $ "Unexpected HPTTL reply: " ++ show values++ now <- round <$> liftIO getPOSIXTime+ hexpireat "mykey" (now + 60) ("field1" NE.:| ["field2"]) >>=?+ [ HashFieldExpirationSet+ , HashFieldExpirationSet+ ]++ hexpiretime "mykey" ("field1" NE.:| ["field2"]) >>@? \values ->+ case values of+ [HashFieldExpirationInfo ts1, HashFieldExpirationInfo ts2] -> do+ HUnit.assertBool "HEXPIRETIME field1 should be near target" (ts1 >= now && ts1 <= now + 60)+ HUnit.assertBool "HEXPIRETIME field2 should be near target" (ts2 >= now && ts2 <= now + 60)+ _ -> HUnit.assertFailure $ "Unexpected HEXPIRETIME reply: " ++ show values++ nowMs <- round . (* 1000) <$> liftIO getPOSIXTime+ hpexpireat "mykey" (nowMs + 2000) ("field1" NE.:| ["field2"]) >>=?+ [ HashFieldExpirationSet+ , HashFieldExpirationSet+ ]++ hpexpiretime "mykey" ("field1" NE.:| ["field2"]) >>@? \values ->+ case values of+ [HashFieldExpirationInfo ts1, HashFieldExpirationInfo ts2] -> do+ HUnit.assertBool "HPEXPIRETIME field1 should be near target" (ts1 >= nowMs && ts1 <= nowMs + 2000)+ HUnit.assertBool "HPEXPIRETIME field2 should be near target" (ts2 >= nowMs && ts2 <= nowMs + 2000)+ _ -> HUnit.assertFailure $ "Unexpected HPEXPIRETIME reply: " ++ show values++ hexpireOpts "mykey" 10 ("field1" NE.:| [])+ (ExpireOptsTime Nx)+ >>=? [HashFieldExpirationConditionNotMet]++testSintercard7 :: Test+testSintercard7 = testCase "sintercard" $ do+ sadd "{same}bikes:racing:france" ("bike:1" NE.:| ["bike:2", "bike:3"]) >>=? 3+ sadd "{same}bikes:racing:usa" ("bike:1" NE.:| ["bike:4"]) >>=? 2+ sadd "{same}bikes:racing:japan" ("bike:1" NE.:| ["bike:3"]) >>=? 2+ sintercard ("{same}bikes:racing:france" NE.:| ["{same}bikes:racing:usa", "{same}bikes:racing:japan"]) >>=? 1+ sintercardOpts ("{same}bikes:racing:france" NE.:| ["{same}bikes:racing:usa", "{same}bikes:racing:japan"])+ defaultSintercardOpts { sintercardLimit = Just 1 } >>=? 1++testLMPop7 :: Test+testLMPop7 = testCase "lmpop" $ do+ lmpop ("non1" NE.:| ["non2"]) ListLeft >>=? Nothing+ lpush "mylist" ["one", "two", "three", "four", "five"] >>=? 5+ lmpop ("mylist" NE.:| []) ListLeft >>=? Just ("mylist", ["five"])+ lrange "mylist" 0 (-1) >>=? ["four", "three", "two", "one"]++ lpush "mylist2" ["a", "b", "c", "d", "e"] >>=? 5+ lpush "mylist3" ["one", "two", "three", "four", "five"] >>=? 5+ lmpopCount ("mylist" NE.:| ["mylist2"]) ListRight 3 >>=? Just ("mylist", ["one", "two", "three"])+ blmpopCount 1 ("mylist3" NE.:| ["mylist2"]) ListRight 5 >>=? Just ("mylist3", ["one", "two", "three", "four", "five"])+ blmpopCount 1 ("mylist3" NE.:| ["mylist2"]) ListRight 10 >>=? Just ("mylist2", ["a", "b", "c", "d", "e"])++testZMPop7 :: Test+testZMPop7 = testCase "zmpop" $ do+ zadd "{same}zset1" [(1, "one"), (2, "two"), (3, "three")] >>=? 3+ zadd "{same}zset2" [(10, "ten")] >>=? 1+ zmpop ("{same}zset1" NE.:| ["{same}zset2"]) ZPopMax >>=? Just ZPopResponse+ { zPopResponseKey = Just "{same}zset1"+ , zPopResponseValues = [("three", 3)]+ }+ zmpopCount ("{same}zset1" NE.:| ["{same}zset2"]) ZPopMin 2 >>=? Just ZPopResponse+ { zPopResponseKey = Just "{same}zset1"+ , zPopResponseValues = [("one", 1), ("two", 2)]+ }+ bzmpopCount 1 ("{same}zset1" NE.:| ["{same}zset2"]) ZPopMax 2 >>=? Just ZPopResponse+ { zPopResponseKey = Just "{same}zset2"+ , zPopResponseValues = [("ten", 10)]+ }++testFunction7 :: Test+testFunction7 = testCase "function" $ do+ functionFlushOpts FlushOptsSync >>=? Ok++ let libraryCode = "#!lua name=mylib\nredis.register_function('myfunc', function(keys, args) return args[1] end)\nredis.register_function{function_name='myro', callback=function(keys, args) return redis.call('GET', keys[1]) end, flags={ 'no-writes' }}"++ functionLoad libraryCode >>=? "mylib"+ fcall "myfunc" [] ["hello"] >>=? ("hello" :: ByteString)+ set "mykey" "value" >>=? Ok+ fcallReadonly "myro" ["mykey"] [] >>=? ("value" :: ByteString)+ functionList >>@? \reply ->+ case reply of+ MultiBulk (Just _) -> pure ()+ _ -> HUnit.assertFailure $ "Unexpected FUNCTION LIST reply: " ++ show reply+ functionListOpts defaultFunctionListOpts { functionListLibraryName = Just "mylib", functionListWithCode = True } >>@? \reply ->+ case reply of+ MultiBulk (Just _) -> pure ()+ _ -> HUnit.assertFailure $ "Unexpected FUNCTION LIST WITHCODE reply: " ++ show reply+ functionStats >>@? \reply ->+ case reply of+ MultiBulk (Just _) -> pure ()+ _ -> HUnit.assertFailure $ "Unexpected FUNCTION STATS reply: " ++ show reply+ payload <- functionDump+ case payload of+ Left reply -> liftIO $ HUnit.assertFailure $ "Unexpected FUNCTION DUMP reply: " ++ show reply+ Right dumped -> do+ functionDelete "mylib" >>=? Ok+ functionRestore dumped >>=? Ok+ fcall "myfunc" [] ["restored"] >>=? ("restored" :: ByteString)+ functionDelete "mylib" >>=? Ok+ functionRestoreOpts dumped (FunctionRestoreWithPolicy FunctionRestoreAppend) >>=? Ok+ fcall "myfunc" [] ["restored-again"] >>=? ("restored-again" :: ByteString)+ killResult <- functionKill+ liftIO $ case killResult of+ Left (Error _) -> pure ()+ Left reply -> HUnit.assertFailure $ "Unexpected FUNCTION KILL reply: " ++ show reply+ Right status -> HUnit.assertFailure $ "Unexpected FUNCTION KILL status: " ++ show status+ functionFlushOpts FlushOptsSync >>=? Ok++testCommandList7 :: Test+testCommandList7 = testCase "command list" $ do+ commandList >>@? \commands ->+ HUnit.assertBool "COMMAND LIST should contain GET" ("get" `elem` commands)+ commandListOpts (Just $ CommandListFilterByPattern "x*") >>@? \commands -> do+ HUnit.assertBool "pattern-filtered command list should contain xadd" ("xadd" `elem` commands)+ HUnit.assertBool "pattern-filtered command list should exclude get" ("get" `notElem` commands)+ commandListOpts (Just $ CommandListFilterByAclCat "connection") >>@? \commands ->+ HUnit.assertBool "ACLCAT-filtered command list should contain ping" ("ping" `elem` commands)++------------------------------------------------------------------------------+-- 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 }++testClientUnpause :: Test+testClientUnpause = testCase "client/unpause" $+ clientUnpause >>=? Ok++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}somestream8" "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}somestream8", "0"), ("{same}otherstream", "0")] >>=? Just [+ XReadResponse {+ stream = "{same}somestream8",+ records = [StreamsRecord{recordId = "123-0", keyValues = [("key", "value"), ("key2", "value2")]}]+ },+ XReadResponse {+ stream = "{same}otherstream",+ records = [StreamsRecord{recordId = "456-0", keyValues = [("key1", "value1")]}]+ }]+ xlen "{same}somestream8" >>=? 1+ where xaddTrimOpt a = XAddOpts{+ xAddTrimOpts = a,+ xAddnoMkStream = False}++testXReadGroup ::Test+testXReadGroup = testCase "XGROUP */xreadgroup/xack" $ void $ runExceptT $ do+ ExceptT $ xadd "somestream8" "123" [("key", "value")]+ ExceptT $ xgroupCreate "somestream8" "somegroup" "0"+ readResult <- ExceptT $ xreadGroup "somegroup" "consumer1" [("somestream8", ">")]+ liftIO $ readResult HUnit.@=? Just [+ XReadResponse {+ stream = "somestream8",+ records = [StreamsRecord{recordId = "123-0", keyValues = [("key", "value")]}]+ }]+ noAcked <- ExceptT $ xack "somestream8" "somegroup" ["123-0"]+ liftIO $ noAcked HUnit.@=? 1+ groupMessages <- ExceptT $ xreadGroup "somegroup" "consumer1" [("somestream8", ">")]+ liftIO $ groupMessages HUnit.@=? Nothing+ setIdOk <- ExceptT $ xgroupSetId "somestream8" "somegroup" "0"+ liftIO $ setIdOk HUnit.@=? Ok+ itemsLeft <- ExceptT $ xgroupDelConsumer "somestream8" "somegroup" "consumer1"+ liftIO $ itemsLeft HUnit.@=? 0+ groupDestroyed <- ExceptT (xgroupDestroy "somestream8" "somegroup")+ liftIO $ groupDestroyed HUnit.@=? True++testXCreateGroup7 ::Test+testXCreateGroup7 = testCase "XGROUP CREATE" $ do+ xgroupCreateOpts "somestream8" "somegroup" "0" XGroupCreateOpts {xGroupCreateMkStream = True,+ xGroupCreateEntriesRead = Just "1234"} >>=? Ok+ return ()++testXRange ::Test+testXRange = testCase "xrange/xrevrange" $ do+ xadd "somestream8" "121" [("key1", "value1")]+ xadd "somestream8" "122" [("key2", "value2")]+ xadd "somestream8" "123" [("key3", "value3")]+ xadd "somestream8" "124" [("key4", "value4")]+ xrange "somestream8" "122" "123" Nothing >>=? [+ StreamsRecord{recordId = "122-0", keyValues = [("key2", "value2")]},+ StreamsRecord{recordId = "123-0", keyValues = [("key3", "value3")]}+ ]+ xrevRange "somestream8" "123" "122" Nothing >>=? [+ StreamsRecord{recordId = "123-0", keyValues = [("key3", "value3")]},+ StreamsRecord{recordId = "122-0", keyValues = [("key2", "value2")]}+ ]++testXpending ::Test+testXpending = testCase "xpending" $ do+ xadd "somestream8" "121" [("key1", "value1")]+ xadd "somestream8" "122" [("key2", "value2")]+ xadd "somestream8" "123" [("key3", "value3")]+ xadd "somestream8" "124" [("key4", "value4")]+ xgroupCreate "somestream8" "somegroup" "0"+ xreadGroup "somegroup" "consumer1" [("somestream8", ">")]+ xpendingSummary "somestream8" "somegroup" >>=? XPendingSummaryResponse {+ numPendingMessages = 4,+ smallestPendingMessageId = "121-0",+ largestPendingMessageId = "124-0",+ numPendingMessagesByconsumer = [("consumer1", 4)]+ }+ xpendingDetail "somestream8" "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 "somestream8" "121" [("key1", "value1")]+ ExceptT $ xadd "somestream8" "122" [("key2", "value2")]+ ExceptT $ xadd "somestream8" "123" [("key3", "value3")]+ ExceptT $ xadd "somestream8" "124" [("key4", "value4")]+ ExceptT $ xgroupCreate "somestream8" "somegroup" "0"+ ExceptT $ xgroupCreate "somestream8" "somegroup2" "0"+ ExceptT $ xreadGroup "somegroup" "consumer1" [("somestream8", ">")]+ ExceptT $ xreadGroup "somegroup2" "consumer2" [("somestream8", ">")]+ ackedCount <- ExceptT $ xack "somestream8" "somegroup" ["121", "122", "123"]+ liftIO $ ackedCount HUnit.@=? 3+ pendingDetails <- ExceptT $ xpendingDetail "somestream8" "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 "somestream8" "121" [("key1", "value1")]+ liftIO $ storedKey1 HUnit.@=? "121-0"+ storedKey2 <- ExceptT $ xadd "somestream8" "122" [("key2", "value2")]+ liftIO $ storedKey2 HUnit.@=? "122-0"+ groupCreated <- ExceptT $ xgroupCreate "somestream8" "somegroup" "0"+ liftIO $ groupCreated HUnit.@=? Ok+ readResult <- ExceptT $ xreadGroupOpts+ "somegroup"+ "consumer1"+ [("somestream8", ">")]+ (defaultXReadGroupOpts {xReadGroupCount = Just 2})+ liftIO $ readResult HUnit.@=? Just+ [ XReadResponse+ { stream = "somestream8"+ , records =+ [ StreamsRecord+ {recordId = "121-0", keyValues = [("key1", "value1")]}+ , StreamsRecord+ {recordId = "122-0", keyValues = [("key2", "value2")]}+ ]+ }+ ]+ claimed <- ExceptT $ xclaim "somestream8" "somegroup" "consumer2" 0 defaultXClaimOpts ["121-0"]+ liftIO $ claimed HUnit.@=? [StreamsRecord {recordId = "121-0", keyValues = [("key1", "value1")]}]+ claimedJustIds <- ExceptT $ xclaimJustIds+ "somestream8"+ "somegroup"+ "consumer2"+ 0+ defaultXClaimOpts+ ["122-0"]+ liftIO $ claimedJustIds HUnit.@=? ["122-0"]++testXAutoClaim7 ::Test+testXAutoClaim7 =+ testCase "xautoclaim" $ do+ xadd "somestream8" "121" [("key1", "value1")] >>=? "121-0"+ xadd "somestream8" "122" [("key2", "value2")] >>=? "122-0"+ xgroupCreate "somestream8" "somegroup" "0" >>=? Ok+ xreadGroupOpts "somegroup" "consumer1" [("somestream8", ">")] defaultXReadGroupOpts { xReadGroupCount = Just 2 }++ let opts = XAutoclaimOpts {+ xAutoclaimCount = Just 1+ }+ xautoclaimJustIdsOpts "somestream8" "somegroup" "consumer2" 0 "0-0" opts >>@? (\case+ XAutoclaimResult{..} -> do+ xAutoclaimClaimedMessages HUnit.@=? ["121-0"]+ xAutoclaimDeletedMessages HUnit.@=? []+ return ())++ xtrim "somestream8" (trimOpts (TrimMaxlen 1) TrimExact) >>=? 1+ xautoclaim "somestream8" "somegroup" "consumer2" 0 "0-0" >>@? (\case+ XAutoclaimResult{..} -> do+ xAutoclaimClaimedMessages HUnit.@=? [StreamsRecord {+ recordId = "122-0",+ keyValues = [("key2", "value2")]+ }]+ xAutoclaimDeletedMessages HUnit.@=? ["121-0"]+ return ()+ )+ return ()++testXAckDel8 :: Test+testXAckDel8 = testCase "xackdel" $ do+ xadd "somestream8-1" "121" [("key1", "value1")] >>=? "121-0"+ xgroupCreate "somestream8-1" "somegroup1" "0" >>=? Ok+ xgroupCreate "somestream8-1" "somegroup2" "0" >>=? Ok+ xreadGroup "somegroup1" "consumer1" [("somestream8-1", ">")] >>@? const (pure ())+ xreadGroup "somegroup2" "consumer2" [("somestream8-1", ">")] >>@? const (pure ())++ let ackedOpts = defaultXEntryDeletionOpts { xEntryDeletionRefPolicy = XRefPolicyAcked }++ xackdelOpts "somestream8-1" "somegroup1" ("121-0" NE.:| []) ackedOpts+ >>=? [XEntryDeletionResultNotDeleted]+ xrange "somestream8-1" "-" "+" Nothing >>@? \records ->+ HUnit.assertEqual "entry should remain until all groups acknowledge it" 1 (length records)++ xackdelOpts "somestream8-1" "somegroup2" ("121-0" NE.:| []) ackedOpts+ >>=? [XEntryDeletionResultDeleted]+ xrange "somestream8-1" "-" "+" Nothing >>=? []++testXDelEx8 :: Test+testXDelEx8 = testCase "xdelex" $ do+ xadd "somestream8" "121" [("key1", "value1")] >>=? "121-0"+ xgroupCreate "somestream8" "somegroup1" "0" >>=? Ok++ let ackedOpts = defaultXEntryDeletionOpts { xEntryDeletionRefPolicy = XRefPolicyAcked }++ xdelexOpts "somestream8" ("121-0" NE.:| []) ackedOpts+ >>=? [XEntryDeletionResultNotDeleted]+ xrange "somestream8" "-" "+" Nothing >>@? \records ->+ HUnit.assertEqual "ACKED should not delete without consumer groups" 1 (length records)++ xgroupCreate "somestream8" "somegroup" "0" >>=? Ok+ xreadGroup "somegroup" "consumer1" [("somestream8", ">")] >>@? const (pure ())+ xdelex "somestream8" ("121-0" NE.:| [])+ >>=? [XEntryDeletionResultDeleted]+ xpendingSummary "somestream8" "somegroup" >>@? \summary ->+ numPendingMessages summary HUnit.@=? 1++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 "somestream8" "121" [("key1", "value1")]+ _ <- ExceptT $ xadd "somestream8" "122" [("key2", "value2")]+ _ <- ExceptT $ xgroupCreate "somestream8" "somegroup" "0"+ _ <- ExceptT $ xreadGroupOpts "somegroup" "consumer1" [("somestream8", ">")] defaultXReadGroupOpts { xReadGroupCount = Just 2 }++ z <- ExceptT $ xinfoConsumers "somestream8" "somegroup"+ liftIO $ case z of+ [XInfoConsumersResponse{..}] -> do+ xinfoConsumerName HUnit.@=? "consumer1"+ xinfoConsumerNumPendingMessages HUnit.@=? 2++ bad -> HUnit.assertFailure $ "Unexpectedly got " ++ show bad++ x <- ExceptT $ xinfoGroups "somestream8"+ 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 "somestream8"+ 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 "somestream8" "121" [("key1", "value1")]+ xadd "somestream8" "122" [("key2", "value2")]+ xdel "somestream8" ["122"] >>=? 1+ xlen "somestream8" >>=? 1++testVRange84 :: Test+testVRange84 = testCase "vrange" $ do+ vadd "word_embeddings" (0.1 NE.:| [1.2, 0.5]) "Redis" >>=? True+ vadd "word_embeddings" (0.2 NE.:| [1.1, 0.4]) "a7" >>=? True+ vadd "word_embeddings" (0.3 NE.:| [1.0, 0.3]) "b1" >>=? True+ vadd "word_embeddings" (0.4 NE.:| [0.9, 0.2]) "z9" >>=? True++ vrangeCount "word_embeddings" "[Redis" "+" 10 >>=? ["Redis", "a7", "b1", "z9"]+ vrangeCount "word_embeddings" "-" "+" 10 >>=? ["Redis", "a7", "b1", "z9"]+ vrangeCount "word_embeddings" "(a7" "+" 10 >>=? ["b1", "z9"]+ vrangeCount "word_embeddings" "-" "+" (-1) >>=? ["Redis", "a7", "b1", "z9"]++testRedis86Commands :: Test+testRedis86Commands = testCase "redis 8.6 commands" $ do+ xadd "idmp-stream" "*" [("field", "value")] >>@? const (pure ())++ xcfgset "idmp-stream" defaultXCfgSetOpts { xCfgSetIdmpDuration = Just 300 } >>= \case+ Left reply | isUnknownCommandReply reply -> pure ()+ Left reply -> liftIO $ HUnit.assertFailure $ "Unexpected XCFGSET reply: " ++ show reply+ Right Ok -> do+ xcfgset "idmp-stream" defaultXCfgSetOpts+ { xCfgSetIdmpDuration = Just 600+ , xCfgSetIdmpMaxsize = Just 500+ }+ >>=? Ok+ Right status ->+ liftIO $ HUnit.assertFailure $ "Unexpected XCFGSET status: " ++ show status++ hotkeysStop >>= \case+ Left reply | isUnknownCommandReply reply || isHotkeysInactiveReply reply -> pure ()+ Left reply -> liftIO $ HUnit.assertFailure $ "Unexpected HOTKEYS STOP reply: " ++ show reply+ Right Ok -> pure ()+ Right status -> liftIO $ HUnit.assertFailure $ "Unexpected HOTKEYS STOP status: " ++ show status++ hotkeysReset >>= \case+ Left reply | isUnknownCommandReply reply -> pure ()+ Left reply -> liftIO $ HUnit.assertFailure $ "Unexpected HOTKEYS RESET reply: " ++ show reply+ Right Ok -> do+ hotkeysStartOpts+ (HotkeysMetricCPU NE.:| [HotkeysMetricNET])+ defaultHotkeysStartOpts { hotkeysStartTopKCount = Just 2 }+ >>= \case+ Left reply | isUnknownCommandReply reply -> pure ()+ Left reply -> liftIO $ HUnit.assertFailure $ "Unexpected HOTKEYS START reply: " ++ show reply+ Right Ok -> do+ set "hotkey:001" "payload" >>=? Ok+ replicateM_ 25 $ do+ incr "hotkey:counter" >>@? const (pure ())+ get "hotkey:001" >>=? Just "payload"++ hotkeysGet >>@? \HotkeysGetResponse{..} -> do+ HUnit.assertBool "tracking should be active before HOTKEYS STOP" hotkeysGetTrackingActive+ HUnit.assertBool "sample ratio should be positive" (hotkeysGetSampleRatio >= 1)+ HUnit.assertBool "selected slots should not be empty" (not $ null hotkeysGetSelectedSlots)+ HUnit.assertBool "collection duration should be non-negative" (hotkeysGetCollectionDurationMs >= 0)+ HUnit.assertBool "expected CPU hotkeys to include generated keys" $+ maybe False (any (\(key, _) -> "hotkey:" `Char8.isPrefixOf` key)) hotkeysGetByCpuTimeUs+ HUnit.assertBool "expected NET hotkeys to include generated keys" $+ maybe False (any (\(key, _) -> "hotkey:" `Char8.isPrefixOf` key)) hotkeysGetByNetBytes++ hotkeysStop >>=? Ok+ hotkeysGet >>@? \HotkeysGetResponse{..} ->+ HUnit.assertBool "tracking should be stopped after HOTKEYS STOP" (not hotkeysGetTrackingActive)+ hotkeysReset >>=? Ok+ Right status ->+ liftIO $ HUnit.assertFailure $ "Unexpected HOTKEYS START status: " ++ show status+ Right status ->+ liftIO $ HUnit.assertFailure $ "Unexpected HOTKEYS RESET status: " ++ show status++testRedis88Commands :: Test+testRedis88Commands = testCase "redis 8.8 commands" $ do+ increx "counter88" >>= \case+ Left reply | isUnknownCommandReply reply -> pure ()+ Left reply -> liftIO $ HUnit.assertFailure $ "Unexpected INCREX reply: " ++ show reply+ Right (value, applied) -> do+ liftIO $ (1, 1) HUnit.@=? (value, applied)+ increxBy "counter88" 5 defaultIncrexOpts+ { increxLowerBound = Just 0+ , increxUpperBound = Just 10+ , increxExpiration = Just (IncrexSeconds 60)+ }+ >>=? (6, 5)+ ttl "counter88" >>@? \secondsLeft ->+ HUnit.assertBool "INCREX EX should set a TTL" (secondsLeft >= 0 && secondsLeft <= 60)+ increxByFloat "counter88:float" 0.5 defaultIncrexOpts+ { increxLowerBound = Just 0.0+ , increxUpperBound = Just 1.0+ }+ >>@? \(floatValue, floatApplied) ->+ HUnit.assertBool "INCREX BYFLOAT should increment the floating-point value" $+ abs (floatValue - 0.5) < 0.0001 && abs (floatApplied - 0.5) < 0.0001++ streamId <- xadd "stream88" "*" [("field", "value")] >>= \case+ Left reply -> liftIO (HUnit.assertFailure $ "Unexpected XADD reply: " ++ show reply) >> pure ""+ Right sid -> pure sid+ xidmprecord "stream88" "producer-1" "iid-1" streamId >>= \case+ Left reply | isUnknownCommandReply reply -> pure ()+ Left reply -> liftIO $ HUnit.assertFailure $ "Unexpected XIDMPRECORD reply: " ++ show reply+ Right Ok -> pure ()+ Right status -> liftIO $ HUnit.assertFailure $ "Unexpected XIDMPRECORD status: " ++ show status++ xadd "stream88-nack" "1-0" [("field", "value")] >>=? "1-0"+ xgroupCreate "stream88-nack" "group88" "0" >>=? Ok+ xreadGroup "group88" "consumer88" [("stream88-nack", ">")] >>@? const (pure ())+ xnack "stream88-nack" "group88" XNackFail ("1-0" NE.:| []) >>=? 1++ arset "arr88" 0 ("alpha" NE.:| ["beta", "gamma"]) >>= \case+ Left reply | isUnknownCommandReply reply -> pure ()+ Left reply -> liftIO $ HUnit.assertFailure $ "Unexpected ARSET reply: " ++ show reply+ Right createdSlots -> do+ liftIO $ 3 HUnit.@=? createdSlots+ arcount "arr88" >>=? 3+ arlen "arr88" >>=? 3+ armget "arr88" (0 NE.:| [2, 3]) >>=? [Just "alpha", Just "gamma", Nothing]+ argetrange "arr88" 0 3 >>=? [Just "alpha", Just "beta", Just "gamma", Nothing]++ argrep "arr88" "-" "+" (ARGrepExact "beta" NE.:| []) >>=? [1]+ argrepWithValuesOpts "arr88" "-" "+" (ARGrepMatch "a" NE.:| []) defaultARGrepOpts+ { arGrepLimit = Just 2+ }+ >>=? ARIndexValuePairsResponse [(0, "alpha"), (1, "beta")]++ arinfo "arr88" >>@? \ARInfoResponse{..} -> do+ 3 HUnit.@=? arInfoCount+ 3 HUnit.@=? arInfoLength+ HUnit.assertBool "ARINFO should report a positive slice size" (arInfoSliceSize > 0)++ arseek "arr88" 5 >>=? True+ arinsert "arr88" ("delta" NE.:| ["epsilon"]) >>=? 6+ arnext "arr88" >>=? Just 7+ arlastitems "arr88" 2 >>=? [Just "delta", Just "epsilon"]+ arlastitemsOpts "arr88" 2 defaultARLastItemsOpts { arLastItemsReverse = True } >>=? [Just "epsilon", Just "delta"]+ arscanOpts "arr88" 0 10 defaultARScanOpts { arScanLimit = Just 3 } >>=? ARIndexValuePairsResponse [(0, "alpha"), (1, "beta"), (2, "gamma")]+ ardel "arr88" (1 NE.:| [5]) >>=? 2+ arcount "arr88" >>=? 3++ arset "nums88" 0 ("1" NE.:| ["2", "3"]) >>=? 3+ aropValue "nums88" 0 2 AROpSum >>=? Just "6"+ aropCount "nums88" 0 2 AROpUsed >>=? Just 3++ arring "ring88" 3 ("v0" NE.:| ["v1", "v2", "v3"]) >>=? 0+ arcount "ring88" >>=? 3+ arlastitems "ring88" 3 >>=? [Just "v1", Just "v2", Just "v3"]++testVectorSet8 :: Test+testVectorSet8 = testCase "vector sets" $ do+ let key = "word_embeddings"+ members = ["apple", "apples", "pear", "pears", "potato"]+ insert element attrs vector =+ vaddOpts key vector element defaultVAddOpts+ { vAddQuantization = Just VAddNoQuant+ , vAddAttributes = attrs+ }++ insert "apple" (Just "{\"len\":5,\"kind\":\"fruit\"}") (1.0 NE.:| [0.0, 0.0]) >>=? True+ insert "apples" (Just "{\"len\":6,\"kind\":\"fruit\"}") (0.9 NE.:| [0.1, 0.0]) >>=? True+ insert "pear" (Just "{\"len\":4,\"kind\":\"fruit\"}") (0.8 NE.:| [0.2, 0.0]) >>=? True+ insert "pears" Nothing (0.75 NE.:| [0.25, 0.05]) >>=? True+ insert "potato" (Just "{\"len\":6,\"kind\":\"vegetable\"}") (0.0 NE.:| [1.0, 0.0]) >>=? True++ vcard key >>=? 5+ vdim key >>=? 3+ vismember key "apple" >>=? True+ vismember key "orange" >>=? False++ vemb key "apple" >>@? \case+ [x, y, z] -> do+ HUnit.assertBool "VEMB should approximately reconstruct the inserted vector" $+ abs (x - 1.0) < 0.001 && abs y < 0.001 && abs z < 0.001+ vector ->+ HUnit.assertFailure $ "Unexpected VEMB response: " ++ show vector++ vembRaw key "apple" >>@? \case+ Just VEmbRawResponse{..} -> do+ VQuantizationFP32 HUnit.@=? vEmbRawQuantization+ HUnit.assertBool "raw vector blob should not be empty" (BS.length vEmbRawData > 0)+ HUnit.assertBool "vector norm should be positive" (vEmbRawNorm > 0)+ Nothing HUnit.@=? vEmbRawRange+ reply ->+ HUnit.assertFailure $ "Unexpected VEMB RAW response: " ++ show reply++ vgetattr key "apple" >>=? Just "{\"len\":5,\"kind\":\"fruit\"}"+ vsetattr key "pears" "{\"len\":5,\"kind\":\"fruit\"}" >>=? True+ vgetattr key "pears" >>=? Just "{\"len\":5,\"kind\":\"fruit\"}"+ vsetattr key "pears" "" >>=? True+ vgetattr key "pears" >>=? Nothing++ vinfo key >>@? \case+ Just VInfoResponse{..} -> do+ HUnit.assertBool "quantization should be reported as f32/fp32" $+ vInfoQuantization == Just "f32" || vInfoQuantization == Just "fp32"+ Just 3 HUnit.@=? vInfoVectorDim+ Just 5 HUnit.@=? vInfoSize+ HUnit.assertBool "max level should be reported" $+ maybe False (>= 0) vInfoMaxLevel+ reply ->+ HUnit.assertFailure $ "Unexpected VINFO response: " ++ show reply++ vlinks key "apple" >>@? \case+ Just (VLinksResponse layers) ->+ HUnit.assertBool "VLINKS should return at least one adjacent element" $+ any (not . null) layers+ reply ->+ HUnit.assertFailure $ "Unexpected VLINKS response: " ++ show reply++ vlinksWithScores key "apple" >>@? \case+ Just (VLinksWithScoresResponse layers) -> do+ HUnit.assertBool "VLINKS WITHSCORES should return at least one adjacent element" $+ any (not . null) layers+ HUnit.assertBool "VLINKS WITHSCORES should only return known members" $+ all (\(neighbor, _) -> neighbor `elem` members)+ [ pair | layer <- layers, pair <- layer ]+ reply ->+ HUnit.assertFailure $ "Unexpected VLINKS WITHSCORES response: " ++ show reply++ vrandmember key >>@? \member ->+ HUnit.assertBool "VRANDMEMBER should return one of the inserted elements" $+ maybe False (`elem` members) member++ vrandmemberCount key 3 >>@? \randomMembers -> do+ HUnit.assertEqual "VRANDMEMBER count" 3 (length randomMembers)+ HUnit.assertBool "VRANDMEMBER count should only return known members" $+ all (`elem` members) randomMembers++ vrange key "-" "+" >>=? members+ vrangeCount key "[apple" "[pear" 10 >>=? ["apple", "apples", "pear"]++ vsim key (VSimByElement "apple") >>@? \similar -> do+ HUnit.assertBool "VSIM should return at least one match" (not $ null similar)+ case similar of+ firstMatch:_ ->+ HUnit.assertEqual "VSIM first match" "apple" firstMatch+ [] ->+ HUnit.assertFailure "VSIM returned no matches"++ vsimOpts key (VSimByValues (1.0 NE.:| [0.0, 0.0])) defaultVSimOpts { vSimCount = Just 2 } >>@? \similar -> do+ HUnit.assertEqual "VSIM VALUES count" 2 (length similar)+ case similar of+ firstMatch:_ ->+ HUnit.assertEqual "VSIM VALUES first match" "apple" firstMatch+ [] ->+ HUnit.assertFailure "VSIM VALUES returned no matches"++ vsimWithScoresOpts key (VSimByElement "apple") defaultVSimOpts { vSimCount = Just 3 } >>@? \similar -> do+ HUnit.assertEqual "VSIM WITHSCORES count" 3 (length similar)+ case similar of+ (firstMatch, firstScore):_ -> do+ HUnit.assertEqual "VSIM WITHSCORES first match" "apple" firstMatch+ HUnit.assertBool "VSIM WITHSCORES self similarity should be close to 1" $+ firstScore > 0.99+ [] ->+ HUnit.assertFailure "VSIM WITHSCORES returned no matches"++ vsimWithScoresWithAttribsOpts key (VSimByElement "apple") defaultVSimOpts { vSimCount = Just 3 } >>@? \VSimWithAttribsResponse{..} -> do+ HUnit.assertEqual "VSIM WITHATTRIBS count" 3 (length vSimWithAttribsResults)+ case vSimWithAttribsResults of+ firstMatch:_ -> do+ HUnit.assertEqual "VSIM WITHATTRIBS first match" "apple" (vSimResultElement firstMatch)+ Just "{\"len\":5,\"kind\":\"fruit\"}" HUnit.@=? vSimResultAttributes firstMatch+ [] ->+ HUnit.assertFailure "VSIM WITHATTRIBS returned no matches"++ vrem key "potato" >>=? True+ vismember key "potato" >>=? False+ vcard key >>=? 4++testClusterSlotStats8 :: Test+testClusterSlotStats8 = testCase "cluster slot-stats" $ do+ clusterSlotStatsSlotsRange 0 16383 >>@? \ClusterSlotStatsResponse{..} -> do+ HUnit.assertBool "CLUSTER SLOT-STATS SLOTSRANGE should return at least one slot" $+ not (null clusterSlotStatsResponseEntries)+ forM_ clusterSlotStatsResponseEntries $ \ClusterSlotStatsResponseEntry{..} -> do+ HUnit.assertBool "slot number should be in the valid cluster range" $+ clusterSlotStatsResponseEntrySlot >= 0 && clusterSlotStatsResponseEntrySlot <= 16383+ HUnit.assertBool "key-count should be present" $+ maybe False (>= 0) clusterSlotStatsResponseEntryKeyCount++ clusterSlotStatsOrderByOpts ClusterSlotStatsKeyCount+ defaultClusterSlotStatsOrderByOpts { clusterSlotStatsOrderByLimit = Just 1 }+ >>@? \ClusterSlotStatsResponse{..} ->+ HUnit.assertBool "ORDERBY with LIMIT should return at most one entry" $+ length clusterSlotStatsResponseEntries <= 1++testClusterMigration84 :: Test+testClusterMigration84 = testCase "cluster migration" $ do+ clusterMigrationCancelAll >>@? \cancelled ->+ HUnit.assertBool "cancel count should be non-negative" (cancelled >= 0)++ clusterMigrationStatusAll >>@? \ClusterMigrationStatusResponse{..} ->+ forM_ clusterMigrationStatusTasks $ \ClusterMigrationTask{..} -> do+ HUnit.assertBool "migration task id should not be empty" (clusterMigrationTaskId /= "")+ HUnit.assertBool "migration task retries should be non-negative when present" $+ maybe True (>= 0) clusterMigrationTaskRetries++testXTrim ::Test+testXTrim = testCase "xtrim" $ do+ xadd "somestream8" "121" [("key1", "value1")]+ xadd "somestream8" "122" [("key2", "value2")]+ xadd "somestream8" "123" [("key3", "value3")]+ streamId <- fromRight "" <$> xadd "somestream8" "124" [("key4", "value4")]+ xadd "somestream8" "125" [("key5", "value5")]+ xtrim "somestream8" (trimOpts (TrimMaxlen 3) TrimExact) >>=? 2+ xtrim "somestream8" (trimOpts (TrimMinId streamId) TrimExact) >>=? 1