diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/redis-resp.cabal b/redis-resp.cabal new file mode 100644 --- /dev/null +++ b/redis-resp.cabal @@ -0,0 +1,50 @@ +name: redis-resp +version: 0.2 +synopsis: REdis Serialization Protocol (RESP) implementation. +license: OtherLicense +license-file: LICENSE +author: Toralf Wittner +maintainer: Toralf Wittner +copyright: (c) 2014 Toralf Wittner +homepage: https://github.com/twittner/redis-resp/ +bug-reports: https://github.com/twittner/redis-resp/issues +stability: experimental +category: Data +build-type: Simple +cabal-version: >= 1.10 + +description: + REdis Serialization Protocol (RESP) implementation as specified + in . + . + Additionally most Redis commands are declared as an GADT which + enables different interpretations such as + . + +source-repository head + type: git + location: git://github.com/twittner/redis-resp.git + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall -O2 -fwarn-tabs -funbox-strict-fields + ghc-prof-options: -prof -auto-all + + exposed-modules: + Data.Redis + Data.Redis.Resp + Data.Redis.Command + + build-depends: + attoparsec >= 0.11 && < 0.13 + , base >= 4.5 && < 5.0 + , bytestring >= 0.10.4 && < 0.11 + , bytestring-conversion == 0.2.* + , containers >= 0.5 && < 0.6 + , double-conversion == 2.0.* + , dlist == 0.7.* + , operational == 0.2.* + , semigroups == 0.15.* + , split == 0.2.* + , transformers >= 0.3 && < 0.5 diff --git a/src/Data/Redis.hs b/src/Data/Redis.hs new file mode 100644 --- /dev/null +++ b/src/Data/Redis.hs @@ -0,0 +1,14 @@ +-- This Source Code Form is subject to the terms of the Mozilla Public +-- License, v. 2.0. If a copy of the MPL was not distributed with this +-- file, You can obtain one at http://mozilla.org/MPL/2.0/. + +module Data.Redis + ( module C + , Resp (..) + , resp + , decode + , encode + ) where + +import Data.Redis.Resp +import Data.Redis.Command as C diff --git a/src/Data/Redis/Command.hs b/src/Data/Redis/Command.hs new file mode 100644 --- /dev/null +++ b/src/Data/Redis/Command.hs @@ -0,0 +1,1261 @@ +-- This Source Code Form is subject to the terms of the Mozilla Public +-- License, v. 2.0. If a copy of the MPL was not distributed with this +-- file, You can obtain one at http://mozilla.org/MPL/2.0/. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +module Data.Redis.Command + ( -- * Types + Redis + , PubSub + , Command (..) + , PubSubCommand (..) + , PushMessage (..) + , Result + , RedisError (..) + , RedisType (..) + , TTL (..) + , Side (..) + , Choose (..) + , Aggregate (..) + , Min (..) + , Max (..) + , ScoreList (..) + , Seconds (..) + , Timestamp (..) + , Field + , Index + , Key (..) + + -- ** Cursor + , Cursor + , zero + + -- ** Non-empty lists + , one + + -- ** Options + , Opts + , none + + -- ** Bit + , BitStart + , BitEnd + , start + , end + + -- * Commands + -- ** Connection + , auth + , echo + , ping + , quit + , select + + -- ** Server + , bgrewriteaof + , bgsave + , dbsize + , flushall + , flushdb + , lastsave + , save + + -- ** Transactions + , discard + , exec + , execRaw + , multi + , unwatch + , watch + + -- ** Keys + , del + , dump + , exists + , expire + , expireat + , keys + , persist + , randomkey + , rename + , renamenx + , ttl + , typeof + + -- ** Strings + , append + , decr + , decrby + , get + , getrange + , getset + , incr + , incrby + , incrbyfloat + , mget + , mset + , msetnx + , set, ex, px, xx, nx + , setrange + , strlen + + -- ** Bits + , bitand + , bitcount, range + , bitnot + , bitor + , bitpos + , bitxor + , getbit + , setbit + + -- ** Hashes + , hdel + , hexists + , hget + , hgetall + , hincrby + , hincrbyfloat + , hkeys + , hlen + , hmget + , hmset + , hset + , hsetnx + , hvals + + -- ** Lists + , blpop + , brpop + , brpoplpush + , lindex + , linsert + , llen + , lpop + , lpush + , lpushx + , lrange + , lrem + , lset + , ltrim + , rpop + , rpoplpush + , rpush + , rpushx + + -- ** Sets + , sadd + , scard + , sdiff + , sdiffstore + , sinter + , sinterstore + , sismember + , smembers + , smove + , spop + , srandmember + , srem + , sunion + , sunionstore + + -- ** Sorted Sets + , zadd + , zcard + , zcount + , zincrby + , zinterstore + , zlexcount + , zrange + , zrangebylex + , zrangebyscore + , zrank + , zrem + , zremrangebylex + , zremrangebyrank + , zremrangebyscore + , zrevrangebyscore + , zrevrange + , zrevrank + , zscore + , zunionstore + + -- ** HyperLogLog + , pfadd + , pfcount + , pfmerge + + -- ** Scan + , scan, match, count + , hscan + , sscan + , zscan + + -- ** Sort + , sort, by, limit, getkey, asc, desc, alpha, store + + -- ** Pub/Sub + , publish + , subscribe + , psubscribe + , unsubscribe + , punsubscribe + + -- * Response Reading + , readInt + , readInt'Null + , readBool + , readTTL + , readBulk'Null + , readBulk + , readListOfMaybes + , readList + , readScoreList + , readFields + , readKeyValue + , readBulk'Array + , readScan + , matchStr + , readType + , fromSet + , anyStr + , readPushMessage + + -- * Re-exports + , NonEmpty (..) + , NE.nonEmpty + ) where + +import Control.Applicative +import Control.Exception (Exception) +import Control.Monad.Operational +import Data.ByteString.Builder (int64Dec) +import Data.ByteString.Builder.Extra +import Data.ByteString.Conversion +import Data.ByteString.Lazy (ByteString, fromStrict) +import Data.DList (DList, cons) +import Data.Double.Conversion.ByteString (toShortest) +import Data.Foldable (toList, foldr) +import Data.Int +import Data.List.NonEmpty (NonEmpty (..), (<|)) +import Data.List.Split (chunksOf) +import Data.Maybe (maybeToList) +import Data.Monoid hiding (Sum) +import Data.Redis.Resp +import Data.String +import Data.Typeable +import GHC.TypeLits +import Prelude hiding (foldr, readList) + +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.DList as DL +import qualified Data.List.NonEmpty as NE + +-- | Redis error type. +data RedisError + = RedisError !ByteString + -- ^ General error case. + | InvalidResponse !String + -- ^ The received response is invalid or unexpected (e.g. a bulk + -- string instead of an integer). + | InvalidConversion !String + -- ^ ByteString conversion using 'FromByteString' failed. + deriving (Eq, Ord, Show, Typeable) + +instance Exception RedisError + +type Redis = ProgramT Command +type PubSub = ProgramT PubSubCommand +type Result = Either RedisError + +-- | Redis commands. +data Command :: * -> * where + -- Connection + Ping :: Resp -> Command () + Echo :: FromByteString a => Resp -> Command a + Auth :: Resp -> Command () + Quit :: Resp -> Command () + Select :: Resp -> Command () + + -- Server + BgRewriteAOF :: Resp -> Command () + BgSave :: Resp -> Command () + Save :: Resp -> Command () + DbSize :: Resp -> Command Int64 + FlushAll :: Resp -> Command () + FlushDb :: Resp -> Command () + LastSave :: Resp -> Command Int64 + + -- Transactions + Multi :: Resp -> Command () + Watch :: Resp -> Command () + Unwatch :: Resp -> Command () + Discard :: Resp -> Command () + Exec :: FromByteString a => Resp -> Command [a] + ExecRaw :: Resp -> Command Resp + + -- Keys + Del :: Resp -> Command Int64 + Dump :: Resp -> Command (Maybe ByteString) + Exists :: Resp -> Command Bool + Expire :: Resp -> Command Bool + ExpireAt :: Resp -> Command Bool + Persist :: Resp -> Command Bool + Keys :: Resp -> Command [Key] + RandomKey :: Resp -> Command (Maybe Key) + Rename :: Resp -> Command () + RenameNx :: Resp -> Command Bool + Sort :: FromByteString a => Resp -> Command [a] + Ttl :: Resp -> Command (Maybe TTL) + Type :: Resp -> Command (Maybe RedisType) + Scan :: FromByteString a => Resp -> Command (Cursor, [a]) + + -- Strings + Append :: Resp -> Command Int64 + Get :: FromByteString a => Resp -> Command (Maybe a) + GetRange :: FromByteString a => Resp -> Command a + GetSet :: FromByteString a => Resp -> Command (Maybe a) + MGet :: FromByteString a => Resp -> Command [Maybe a] + MSet :: Resp -> Command () + MSetNx :: Resp -> Command Bool + Set :: Resp -> Command Bool + SetRange :: Resp -> Command Int64 + StrLen :: Resp -> Command Int64 + + -- Bits + BitAnd :: Resp -> Command Int64 + BitCount :: Resp -> Command Int64 + BitNot :: Resp -> Command Int64 + BitOr :: Resp -> Command Int64 + BitPos :: Resp -> Command Int64 + BitXOr :: Resp -> Command Int64 + GetBit :: Resp -> Command Int64 + SetBit :: Resp -> Command Int64 + + -- Numeric + Decr :: Resp -> Command Int64 + DecrBy :: Resp -> Command Int64 + Incr :: Resp -> Command Int64 + IncrBy :: Resp -> Command Int64 + IncrByFloat :: Resp -> Command Double + + -- Hashes + HDel :: Resp -> Command Int64 + HExists :: Resp -> Command Bool + HGet :: FromByteString a => Resp -> Command (Maybe a) + HGetAll :: FromByteString a => Resp -> Command [(Field, a)] + HIncrBy :: Resp -> Command Int64 + HIncrByFloat :: Resp -> Command Double + HKeys :: Resp -> Command [Field] + HLen :: Resp -> Command Int64 + HMGet :: FromByteString a => Resp -> Command [Maybe a] + HMSet :: Resp -> Command () + HSet :: Resp -> Command Bool + HSetNx :: Resp -> Command Bool + HVals :: FromByteString a => Resp -> Command [a] + HScan :: FromByteString a => Resp -> Command (Cursor, [a]) + + -- Lists + BLPop :: FromByteString a => Int64 -> Resp -> Command (Maybe (Key, a)) + BRPop :: FromByteString a => Int64 -> Resp -> Command (Maybe (Key, a)) + BRPopLPush :: FromByteString a => Int64 -> Resp -> Command (Maybe a) + LIndex :: FromByteString a => Resp -> Command (Maybe a) + LInsert :: Resp -> Command Int64 + LLen :: Resp -> Command Int64 + LPop :: FromByteString a => Resp -> Command (Maybe a) + LPush :: Resp -> Command Int64 + LPushX :: Resp -> Command Int64 + LRange :: FromByteString a => Resp -> Command [a] + LRem :: Resp -> Command Int64 + LSet :: Resp -> Command () + LTrim :: Resp -> Command () + RPop :: FromByteString a => Resp -> Command (Maybe a) + RPopLPush :: FromByteString a => Resp -> Command (Maybe a) + RPush :: Resp -> Command Int64 + RPushX :: Resp -> Command Int64 + + -- Sets + SAdd :: Resp -> Command Int64 + SCard :: Resp -> Command Int64 + SDiff :: FromByteString a => Resp -> Command [a] + SDiffStore :: Resp -> Command Int64 + SInter :: FromByteString a => Resp -> Command [a] + SInterStore :: Resp -> Command Int64 + SIsMember :: Resp -> Command Bool + SMembers :: FromByteString a => Resp -> Command [a] + SMove :: Resp -> Command Bool + SPop :: FromByteString a => Resp -> Command (Maybe a) + SRandMember :: FromByteString a => Choose -> Resp -> Command [a] + SRem :: Resp -> Command Int64 + SScan :: FromByteString a => Resp -> Command (Cursor, [a]) + SUnion :: FromByteString a => Resp -> Command [a] + SUnionStore :: Resp -> Command Int64 + + -- Sorted Sets + ZAdd :: Resp -> Command Int64 + ZCard :: Resp -> Command Int64 + ZCount :: Resp -> Command Int64 + ZIncrBy :: Resp -> Command Double + ZInterStore :: Resp -> Command Int64 + ZLexCount :: Resp -> Command Int64 + ZRange :: FromByteString a => Bool -> Resp -> Command (ScoreList a) + ZRangeByLex :: FromByteString a => Resp -> Command [a] + ZRangeByScore :: FromByteString a => Bool -> Resp -> Command (ScoreList a) + ZRank :: Resp -> Command (Maybe Int64) + ZRem :: Resp -> Command Int64 + ZRemRangeByLex :: Resp -> Command Int64 + ZRemRangeByRank :: Resp -> Command Int64 + ZRemRangeByScore :: Resp -> Command Int64 + ZRevRange :: FromByteString a => Bool -> Resp -> Command (ScoreList a) + ZRevRangeByScore :: FromByteString a => Bool -> Resp -> Command (ScoreList a) + ZRevRank :: Resp -> Command (Maybe Int64) + ZScan :: FromByteString a => Resp -> Command (Cursor, [a]) + ZScore :: Resp -> Command (Maybe Double) + ZUnionStore :: Resp -> Command Int64 + + -- HyperLogLog + PfAdd :: Resp -> Command Bool + PfCount :: Resp -> Command Int64 + PfMerge :: Resp -> Command () + + -- Pub/Sub + Publish :: Resp -> Command Int64 + +-- | Pub/Sub commands. +data PubSubCommand r where + Subscribe :: Resp -> PubSubCommand () + Unsubscribe :: Resp -> PubSubCommand () + PSubscribe :: Resp -> PubSubCommand () + PUnsubscribe :: Resp -> PubSubCommand () + +-- | Messages which are published to subscribers. +data PushMessage + = SubscribeMessage + { channel :: !ByteString + , subscriptions :: !Int64 + } + | UnsubscribeMessage + { channel :: !ByteString + , subscriptions :: !Int64 + } + | Message + { channel :: !ByteString + , message :: !ByteString + } + | PMessage + { pattern :: !ByteString + , channel :: !ByteString + , message :: !ByteString + } + deriving (Eq, Ord, Show) + +-- | The types redis reports via . +data RedisType + = RedisString + | RedisList + | RedisSet + | RedisZSet + | RedisHash + deriving (Eq, Ord, Show) + +-- | A type representing time-to-live values. +data TTL = NoTTL | TTL !Int64 + deriving (Eq, Ord, Show) + +-- | Used in 'linsert' to specify the insertion point. +data Side = Before | After + deriving (Eq, Ord, Show) + +data Choose + = One -- ^ Exactly one element + | Dist !Int64 -- ^ @n@ distint elements + | Arb !Int64 -- ^ @n@ arbitrary (i.e. potentially repeated) elements + deriving (Eq, Ord, Show) + +data Aggregate + = None -- ^ no aggregation + | Min -- ^ take the minimum score + | Max -- ^ take the maximum score + | Sum -- ^ addition of scores + deriving (Eq, Ord, Show) + +data Min + = MinIncl !ByteString -- ^ lower bound (inclusive) + | MinExcl !ByteString -- ^ lower bound (exclusive) + | MinInf -- ^ infinite lower bound + deriving (Eq, Ord, Show) + +data Max + = MaxIncl !ByteString -- ^ upper bound (inclusive) + | MaxExcl !ByteString -- ^ upper bound (exclusive) + | MaxInf -- ^ infinite upper bound + deriving (Eq, Ord, Show) + +data ScoreList a = ScoreList + { scores :: [Double] + , elements :: [a] + } deriving (Eq, Ord, Show) + +newtype Cursor = Cursor + { cursor :: ByteString + } deriving (Eq, Ord, Show, FromByteString) + +zero :: Cursor +zero = Cursor "0" + +type Field = ByteString +type Index = Int64 + +-- | Redis key type +newtype Key = Key + { key :: ByteString + } deriving (Eq, Ord, Show, FromByteString) + +instance IsString Key where + fromString = Key . fromString + +-- | Command options +data Opts (a :: Symbol) = Opts { len :: !Int, opts :: DList ByteString } + +instance Monoid (Opts a) where + mempty = Opts 0 DL.empty + Opts x a `mappend` Opts y b = Opts (x + y) (a `DL.append` b) + +none :: Monoid m => m +none = mempty + +newtype Seconds = Seconds Int64 +newtype Timestamp = Timestamp Int64 +newtype BitStart = BitStart ByteString +newtype BitEnd = BitEnd ByteString + +instance Monoid BitStart where + mempty = BitStart "" + _ `mappend` b = b + +instance Monoid BitEnd where + mempty = BitEnd "" + _ `mappend` b = b + +start :: Int64 -> BitStart +start = BitStart . int2bytes + +end :: Int64 -> BitEnd +end = BitEnd . int2bytes + +one :: a -> NonEmpty a +one a = a :| [] + +----------------------------------------------------------------------------- +-- Connection + +ping :: Monad m => Redis m () +ping = singleton $ Ping $ cmd 1 ["PING"] + +echo :: (Monad m, ToByteString a, FromByteString a) => a -> Redis m a +echo x = singleton $ Echo $ cmd 2 ["ECHO", toByteString x] + +auth :: Monad m => ByteString -> Redis m () +auth x = singleton $ Auth $ cmd 2 ["AUTH", x] + +quit :: Monad m => Redis m () +quit = singleton $ Quit $ cmd 1 ["QUIT"] + +select :: Monad m => Int64 -> Redis m () +select x = singleton $ Select $ cmd 2 ["SELECT", int2bytes x] + +----------------------------------------------------------------------------- +-- Server + +bgrewriteaof :: Monad m => Redis m () +bgrewriteaof = singleton $ BgRewriteAOF $ cmd 1 ["BGREWRITEAOF"] + +bgsave :: Monad m => Redis m () +bgsave = singleton $ BgSave $ cmd 1 ["BGSAVE"] + +save :: Monad m => Redis m () +save = singleton $ Save $ cmd 1 ["SAVE"] + +flushall :: Monad m => Redis m () +flushall = singleton $ FlushAll $ cmd 1 ["FLUSHALL"] + +flushdb :: Monad m => Redis m () +flushdb = singleton $ FlushDb $ cmd 1 ["FLUSHDB"] + +lastsave :: Monad m => Redis m Int64 +lastsave = singleton $ LastSave $ cmd 1 ["LASTSAVE"] + +dbsize :: Monad m => Redis m Int64 +dbsize = singleton $ DbSize $ cmd 1 ["DBSIZE"] + +----------------------------------------------------------------------------- +-- Transactions + +multi :: Monad m => Redis m () +multi = singleton $ Multi $ cmd 1 ["MULTI"] + +discard :: Monad m => Redis m () +discard = singleton $ Discard $ cmd 1 ["DISCARD"] + +unwatch :: Monad m => Redis m () +unwatch = singleton $ Unwatch $ cmd 1 ["UNWATCH"] + +watch :: Monad m => NonEmpty Key -> Redis m () +watch kk = singleton $ Watch $ cmd (1 + NE.length kk) $ "WATCH" : map key (toList kk) + +exec :: (Monad m, FromByteString a) => Redis m [a] +exec = singleton $ Exec $ cmd 1 ["EXEC"] + +execRaw :: Monad m => Redis m Resp +execRaw = singleton $ ExecRaw $ cmd 1 ["EXEC"] + +----------------------------------------------------------------------------- +-- Keys + +dump :: Monad m => Key -> Redis m (Maybe ByteString) +dump k = singleton $ Dump $ cmd 2 ["DUMP", key k] + +exists :: Monad m => Key -> Redis m Bool +exists k = singleton $ Exists $ cmd 2 ["EXISTS", key k] + +del :: Monad m => NonEmpty Key -> Redis m Int64 +del kk = singleton $ Del $ cmd (1 + NE.length kk) $ "DEL" : map key (toList kk) + +expire :: Monad m => Key -> Seconds -> Redis m Bool +expire k (Seconds n) = singleton $ Expire $ cmd 3 ["EXPIRE", key k, int2bytes n] + +expireat :: Monad m => Key -> Timestamp -> Redis m Bool +expireat k (Timestamp n) = singleton $ ExpireAt $ cmd 3 ["EXPIREAT", key k, int2bytes n] + +persist :: Monad m => Key -> Redis m Bool +persist k = singleton $ Persist $ cmd 2 ["PERSIST", key k] + +keys :: Monad m => ByteString -> Redis m [Key] +keys pat = singleton $ Keys $ cmd 2 ["KEYS", pat] + +randomkey :: Monad m => Redis m (Maybe Key) +randomkey = singleton $ RandomKey $ cmd 1 ["RANDOMKEY"] + +rename :: Monad m => Key -> Key -> Redis m () +rename a b = singleton $ Rename $ cmd 3 ["RENAME", key a, key b] + +renamenx :: Monad m => Key -> Key -> Redis m Bool +renamenx a b = singleton $ RenameNx $ cmd 3 ["RENAMENX", key a, key b] + +ttl :: Monad m => Key -> Redis m (Maybe TTL) +ttl k = singleton $ Ttl $ cmd 2 ["TTL", key k] + +typeof :: Monad m => Key -> Redis m (Maybe RedisType) +typeof k = singleton $ Type $ cmd 2 ["TYPE", key k] + +----------------------------------------------------------------------------- +-- Strings + +get :: (Monad m, FromByteString a) => Key -> Redis m (Maybe a) +get k = singleton $ Get $ cmd 2 ["GET", key k] + +set :: (Monad m, ToByteString a) => Key -> a -> Opts "SET" -> Redis m Bool +set k v o = singleton $ Set $ cmd (3 + len o) $ "SET" : key k : toByteString v : toList (opts o) + +ex :: Int64 -> Opts "SET" +ex i = Opts 2 $ "EX" `cons` DL.singleton (int2bytes i) + +px :: Int64 -> Opts "SET" +px i = Opts 2 $ "PX" `cons` DL.singleton (int2bytes i) + +xx :: Opts "SET" +xx = Opts 1 $ DL.singleton "XX" + +nx :: Opts "SET" +nx = Opts 1 $ DL.singleton "NX" + +getset :: (Monad m, ToByteString a, FromByteString b) => Key -> a -> Redis m (Maybe b) +getset k v = singleton $ GetSet $ cmd 3 ["GETSET", key k, toByteString v] + +mget :: (Monad m, FromByteString a) => NonEmpty Key -> Redis m [Maybe a] +mget kk = singleton $ MGet $ cmd (1 + NE.length kk) $ "MGET" : map key (toList kk) + +mset :: (Monad m, ToByteString a) => NonEmpty (Key, a) -> Redis m () +mset kv = singleton $ MSet $ cmd (1 + 2 * NE.length kv) $ "MSET" : foldr f [] kv + where + f (k, v) acc = key k : toByteString v : acc + +msetnx :: (Monad m, ToByteString a) => NonEmpty (Key, a) -> Redis m Bool +msetnx kv = singleton $ MSetNx $ cmd (1 + 2 * NE.length kv) $ "MSETNX" : foldr f [] kv + where + f (k, v) acc = key k : toByteString v : acc + +getrange :: (Monad m, FromByteString a) => Key -> Int64 -> Int64 -> Redis m a +getrange k a b = singleton $ GetRange $ cmd 4 ["GETRANGE", key k, int2bytes a, int2bytes b] + +setrange :: (Monad m, ToByteString a) => Key -> Int64 -> a -> Redis m Int64 +setrange k i a = singleton $ SetRange $ cmd 4 ["SETRANGE", key k, int2bytes i, toByteString a] + +append :: (Monad m, ToByteString a) => Key -> a -> Redis m Int64 +append k v = singleton $ Append $ cmd 3 ["APPEND", key k, toByteString v] + +strlen :: Monad m => Key -> Redis m Int64 +strlen k = singleton $ StrLen $ cmd 2 ["STRLEN", key k] + +decr :: Monad m => Key -> Redis m Int64 +decr k = singleton $ Decr $ cmd 2 ["DECR", key k] + +decrby :: Monad m => Key -> Int64 -> Redis m Int64 +decrby k v = singleton $ DecrBy $ cmd 3 ["DECRBY", key k, int2bytes v] + +incr :: Monad m => Key -> Redis m Int64 +incr k = singleton $ Incr $ cmd 2 ["INCR", key k] + +incrby :: Monad m => Key -> Int64 -> Redis m Int64 +incrby k v = singleton $ IncrBy $ cmd 3 ["INCRBY", key k, int2bytes v] + +incrbyfloat :: Monad m => Key -> Double -> Redis m Double +incrbyfloat k v = singleton $ IncrByFloat $ cmd 3 ["INCRBYFLOAT", key k, dbl2bytes v] + +----------------------------------------------------------------------------- +-- Bits + +bitcount :: Monad m => Key -> Opts "RANGE" -> Redis m Int64 +bitcount k o = singleton $ BitCount $ cmd (2 + len o) $ "BITCOUNT" : key k : toList (opts o) + +range :: Int64 -> Int64 -> Opts "RANGE" +range x y = Opts 2 $ int2bytes x `cons` DL.singleton (int2bytes y) + +bitand :: Monad m => Key -> NonEmpty Key -> Redis m Int64 +bitand k kk = singleton $ BitAnd $ bitop "AND" (k <| kk) + +bitor :: Monad m => Key -> NonEmpty Key -> Redis m Int64 +bitor k kk = singleton $ BitOr $ bitop "OR" (k <| kk) + +bitxor :: Monad m => Key -> NonEmpty Key -> Redis m Int64 +bitxor k kk = singleton $ BitXOr $ bitop "XOR" (k <| kk) + +bitnot :: Monad m => Key -> Key -> Redis m Int64 +bitnot k l = singleton $ BitNot $ bitop "NOT" (k :| [l]) + +bitop :: ByteString -> NonEmpty Key -> Resp +bitop o kk = cmd (2 + NE.length kk) $ "BITOP" : o : map key (toList kk) +{-# INLINE bitop #-} + +bitpos :: Monad m => Key -> Bool -> BitStart -> BitEnd -> Redis m Int64 +bitpos k b (BitStart s) (BitEnd e) = + let args = filter (not . Lazy.null) [s, e] in + singleton $ BitPos $ cmd (3 + length args) $ "BITPOS" : key k : toBit b : args + where + toBit True = "1" + toBit False = "0" + +getbit :: Monad m => Key -> Int64 -> Redis m Int64 +getbit k o = singleton $ GetBit $ cmd 3 ["GETBIT", key k, int2bytes o] + +setbit :: Monad m => Key -> Int64 -> Bool -> Redis m Int64 +setbit k o b = singleton $ SetBit $ cmd 4 ["SETBIT", key k, int2bytes o, toBit b] + where + toBit True = "1" + toBit False = "0" + +----------------------------------------------------------------------------- +-- Hashes + +hget :: (Monad m, FromByteString a) => Key -> Field -> Redis m (Maybe a) +hget h k = singleton $ HGet $ cmd 3 ["HGET", key h, k] + +hgetall :: (Monad m, FromByteString a) => Key -> Redis m [(Field, a)] +hgetall h = singleton $ HGetAll $ cmd 2 ["HGETALL", key h] + +hvals :: (Monad m, FromByteString a) => Key -> Redis m [a] +hvals h = singleton $ HVals $ cmd 2 ["HVALS", key h] + +hmget :: (Monad m, FromByteString a) => Key -> NonEmpty Field -> Redis m [Maybe a] +hmget h kk = singleton $ HMGet $ cmd (2 + NE.length kk) $ "HMGET" : key h : toList kk + +hmset :: (Monad m, ToByteString a) => Key -> NonEmpty (Field, a) -> Redis m () +hmset h kv = singleton $ HMSet $ cmd (2 + 2 * NE.length kv) $ "HMSET" : key h : foldr f [] kv + where + f (k, v) acc = k : toByteString v : acc + +hset :: (Monad m, ToByteString a) => Key -> Field -> a -> Redis m Bool +hset h k v = singleton $ HSet $ cmd 4 ["HSET", key h, k, toByteString v] + +hsetnx :: (Monad m, ToByteString a) => Key -> Field -> a -> Redis m Bool +hsetnx h k v = singleton $ HSetNx $ cmd 4 ["HSETNX", key h, k, toByteString v] + +hincrby :: Monad m => Key -> Field -> Int64 -> Redis m Int64 +hincrby h k v = singleton $ HIncrBy $ cmd 4 ["HINCRBY", key h, k, int2bytes v] + +hincrbyfloat :: Monad m => Key -> Field -> Double -> Redis m Double +hincrbyfloat h k v = singleton $ HIncrByFloat $ cmd 4 ["HINCRBYFLOAT", key h, k, dbl2bytes v] + +hdel :: Monad m => Key -> NonEmpty Field -> Redis m Int64 +hdel h kk = singleton $ HDel $ cmd (2 + NE.length kk) $ "HDEL" : key h : toList kk + +hexists :: Monad m => Key -> Field -> Redis m Bool +hexists h k = singleton $ HExists $ cmd 3 ["HEXISTS", key h, k] + +hkeys :: Monad m => Key -> Redis m [Field] +hkeys h = singleton $ HKeys $ cmd 2 ["HKEYS", key h] + +hlen :: Monad m => Key -> Redis m Int64 +hlen h = singleton $ HLen $ cmd 2 ["HLEN", key h] + +----------------------------------------------------------------------------- +-- Lists + +lindex :: (Monad m, FromByteString a) => Key -> Index -> Redis m (Maybe a) +lindex k i = singleton $ LIndex $ cmd 3 ["LINDEX", key k, int2bytes i] + +lpop :: (Monad m, FromByteString a) => Key -> Redis m (Maybe a) +lpop k = singleton $ LPop $ cmd 2 ["LPOP", key k] + +rpop :: (Monad m, FromByteString a) => Key -> Redis m (Maybe a) +rpop k = singleton $ RPop $ cmd 2 ["RPOP", key k] + +rpoplpush :: (Monad m, FromByteString a) => Key -> Key -> Redis m (Maybe a) +rpoplpush a b = singleton $ RPopLPush $ cmd 3 ["RPOPLPUSH", key a, key b] + +brpoplpush :: (Monad m, FromByteString a) => Key -> Key -> Seconds -> Redis m (Maybe a) +brpoplpush a b (Seconds t) = singleton $ BRPopLPush t $ cmd 4 ["BRPOPLPUSH", key a, key b, int2bytes t] + +blpop :: (Monad m, FromByteString a) => NonEmpty Key -> Seconds -> Redis m (Maybe (Key, a)) +blpop kk (Seconds t) = singleton $ BLPop t $ cmd (2 + NE.length kk) $ + "BLPOP" : map key (toList kk) ++ [int2bytes t] + +brpop :: (Monad m, FromByteString a) => NonEmpty Key -> Seconds -> Redis m (Maybe (Key, a)) +brpop kk (Seconds t) = singleton $ BRPop t $ cmd (2 + NE.length kk) $ + "BRPOP" : map key (toList kk) ++ [int2bytes t] + +lrange :: (Monad m, FromByteString a) => Key -> Int64 -> Int64 -> Redis m [a] +lrange k a b = singleton $ LRange $ cmd 4 ["LRANGE", key k, int2bytes a, int2bytes b] + +linsert :: (Monad m, ToByteString a) => Key -> Side -> a -> a -> Redis m Int64 +linsert k s p v = singleton $ LInsert $ cmd 5 ["LINSERT", key k, side2bytes s, toByteString p, toByteString v] + +lpush :: (Monad m, ToByteString a) => Key -> NonEmpty a -> Redis m Int64 +lpush k vv = singleton $ LPush $ cmd (2 + NE.length vv) $ "LPUSH" : key k : map toByteString (toList vv) + +rpush :: (Monad m, ToByteString a) => Key -> NonEmpty a -> Redis m Int64 +rpush k vv = singleton $ RPush $ cmd (2 + NE.length vv) $ "RPUSH" : key k : map toByteString (toList vv) + +lset :: (Monad m, ToByteString a) => Key -> Int64 -> a -> Redis m () +lset k i v = singleton $ LSet $ cmd 4 ["LSET", key k, int2bytes i, toByteString v] + +ltrim :: Monad m => Key -> Int64 -> Int64 -> Redis m () +ltrim k i j = singleton $ LTrim $ cmd 4 ["LTRIM", key k, int2bytes i, int2bytes j] + +lrem :: (Monad m, ToByteString a) => Key -> Int64 -> a -> Redis m Int64 +lrem k c v = singleton $ LRem $ cmd 4 ["LREM", key k, int2bytes c, toByteString v] + +lpushx :: (Monad m, ToByteString a) => Key -> a -> Redis m Int64 +lpushx k v = singleton $ LPushX $ cmd 3 ["LPUSHX", key k, toByteString v] + +rpushx :: (Monad m, ToByteString a) => Key -> a -> Redis m Int64 +rpushx k v = singleton $ RPushX $ cmd 3 ["RPUSHX", key k, toByteString v] + +llen :: Monad m => Key -> Redis m Int64 +llen k = singleton $ LLen $ cmd 2 ["LLEN", key k] + +----------------------------------------------------------------------------- +-- Sets + +spop :: (Monad m, FromByteString a) => Key -> Redis m (Maybe a) +spop k = singleton $ SPop $ cmd 2 ["SPOP", key k] + +sismember :: (Monad m, ToByteString a) => Key -> a -> Redis m Bool +sismember k v = singleton $ SIsMember $ cmd 3 ["SISMEMBER", key k, toByteString v] + +smove :: (Monad m, ToByteString a) => Key -> Key -> a -> Redis m Bool +smove a b v = singleton $ SMove $ cmd 4 ["SMOVE", key a, key b, toByteString v] + +sdiff :: (Monad m, FromByteString a) => NonEmpty Key -> Redis m [a] +sdiff kk = singleton $ SDiff $ cmd (1 + NE.length kk) $ "SDIFF" : map key (toList kk) + +sinter :: (Monad m, FromByteString a) => NonEmpty Key -> Redis m [a] +sinter kk = singleton $ SInter $ cmd (1 + NE.length kk) $ "SINTER" : map key (toList kk) + +smembers :: (Monad m, FromByteString a) => Key -> Redis m [a] +smembers k = singleton $ SMembers $ cmd 2 ["SMEMBERS", key k] + +srandmember :: (Monad m, FromByteString a) => Key -> Choose -> Redis m [a] +srandmember k One = singleton $ SRandMember One $ cmd 2 ["SRANDMEMBER", key k] +srandmember k chs = singleton $ SRandMember chs $ cmd 3 ["SRANDMEMBER", key k, choose chs] + where + choose (Dist n) = int2bytes n + choose (Arb n) = int2bytes n + choose One = "1" + +sdiffstore :: Monad m => Key -> NonEmpty Key -> Redis m Int64 +sdiffstore k kk = singleton $ SDiffStore $ cmd (2 + NE.length kk) $ + "SDIFFSTORE" : key k : map key (toList kk) + +sinterstore :: Monad m => Key -> NonEmpty Key -> Redis m Int64 +sinterstore k kk = singleton $ SInterStore $ cmd (2 + NE.length kk) $ + "SINTERSTORE" : key k : map key (toList kk) + +sunionstore :: Monad m => Key -> NonEmpty Key -> Redis m Int64 +sunionstore k kk = singleton $ SUnionStore $ cmd (2 + NE.length kk) $ + "SUNIONSTORE" : key k : map key (toList kk) + +sadd :: (Monad m, ToByteString a) => Key -> NonEmpty a -> Redis m Int64 +sadd k v = singleton $ SAdd $ cmd (2 + NE.length v) $ "SADD" : key k : map toByteString (toList v) + +srem :: (Monad m, ToByteString a) => Key -> NonEmpty a -> Redis m Int64 +srem k vv = singleton $ SRem $ cmd (2 + NE.length vv) $ "SREM" : key k : map toByteString (toList vv) + +sunion :: (Monad m, FromByteString a) => NonEmpty Key -> Redis m [a] +sunion kk = singleton $ SUnion $ cmd (1 + NE.length kk) $ "SUNION" : map key (toList kk) + +scard :: Monad m => Key -> Redis m Int64 +scard k = singleton $ SCard $ cmd 2 ["SCARD", key k] + +----------------------------------------------------------------------------- +-- Sorted Sets + +zrange :: (Monad m, FromByteString a) => Key -> Int64 -> Int64 -> Bool -> Redis m (ScoreList a) +zrange k a b s = + let args = ["ZRANGE", key k, int2bytes a, int2bytes b, "WITHSCORES"] + in if s then singleton $ ZRange s $ cmd 5 args + else singleton $ ZRange s $ cmd 4 (init args) + +zrevrange :: (Monad m, FromByteString a) => Key -> Int64 -> Int64 -> Bool -> Redis m (ScoreList a) +zrevrange k a b s = + let args = ["ZREVRANGE", key k, int2bytes a, int2bytes b, "WITHSCORES"] + in if s then singleton $ ZRevRange s $ cmd 5 args + else singleton $ ZRevRange s $ cmd 4 (init args) + +zrangebyscore :: (Monad m, FromByteString a) => Key -> Double -> Double -> Bool -> Opts "LIMIT" -> Redis m (ScoreList a) +zrangebyscore k a b s o = + let args = ["ZRANGEBYSCORE", key k, dbl2bytes a, dbl2bytes b, "WITHSCORES"] in + if s then singleton $ ZRangeByScore s $ cmd (5 + len o) $ args ++ toList (opts o) + else singleton $ ZRangeByScore s $ cmd (4 + len o) $ init args ++ toList (opts o) + +zrevrangebyscore :: (Monad m, FromByteString a) => Key -> Double -> Double -> Bool -> Opts "LIMIT" -> Redis m (ScoreList a) +zrevrangebyscore k a b s o = + let args = ["ZREVRANGEBYSCORE", key k, dbl2bytes a, dbl2bytes b, "WITHSCORES"] in + if s then singleton $ ZRevRangeByScore s $ cmd (5 + len o) $ args ++ toList (opts o) + else singleton $ ZRevRangeByScore s $ cmd (4 + len o) $ init args ++ toList (opts o) + +zadd :: (Monad m, ToByteString a) => Key -> NonEmpty (Double, a) -> Redis m Int64 +zadd k v = singleton $ ZAdd $ cmd (2 + 2 * NE.length v) $ "ZADD" : key k : foldr f [] v + where + f (i, x) acc = dbl2bytes i : toByteString x : acc + +zinterstore :: Monad m => Key -> NonEmpty Key -> [Int64] -> Aggregate -> Redis m Int64 +zinterstore = _interstore ZInterStore "ZINTERSTORE" + +zunionstore :: Monad m => Key -> NonEmpty Key -> [Int64] -> Aggregate -> Redis m Int64 +zunionstore = _interstore ZUnionStore "ZUNIONSTORE" + +_interstore :: (Resp -> Command Int64) + -> ByteString + -> Key + -> NonEmpty Key + -> [Int64] + -> Aggregate + -> Redis m Int64 +_interstore c n k kk ww a = + let ww' = map int2bytes ww ++ repeat "1" + aggr = aggr2bytes a + nkeys = NE.length kk + ntotal = 3 + 2 * nkeys + 1 + length aggr + keys' = map key (toList kk) + weights = "WEIGHTS" : take nkeys ww' + in singleton $ c $ cmd ntotal $ toList $ n + `cons` key k + `cons` int2bytes (fromIntegral nkeys) + `cons` DL.fromList keys' + <> DL.fromList weights + <> DL.fromList aggr + where + aggr2bytes :: Aggregate -> [ByteString] + aggr2bytes None = [] + aggr2bytes Min = ["AGGREGATE", "MIN"] + aggr2bytes Max = ["AGGREGATE", "MAX"] + aggr2bytes Sum = ["AGGREGATE", "SUM"] +{-# INLINE _interstore #-} + +zlexcount :: Monad m => Key -> Min -> Max -> Redis m Int64 +zlexcount k a b = singleton $ ZLexCount $ cmd 4 ["ZLEXCOUNT", key k, min2bytes a, max2bytes b] + +min2bytes :: Min -> ByteString +min2bytes MinInf = "-" +min2bytes (MinIncl x) = "[" <> x +min2bytes (MinExcl x) = "(" <> x + +max2bytes :: Max -> ByteString +max2bytes MaxInf = "+" +max2bytes (MaxIncl x) = "[" <> x +max2bytes (MaxExcl x) = "(" <> x + +zrangebylex :: (Monad m, FromByteString a) => Key -> Min -> Max -> Opts "LIMIT" -> Redis m [a] +zrangebylex k a b o = singleton $ ZRangeByLex $ cmd (4 + len o) $ + "ZRANGEBYLEX" : key k : min2bytes a : max2bytes b : toList (opts o) + +zremrangebylex :: Monad m => Key -> Min -> Max -> Redis m Int64 +zremrangebylex k a b = singleton $ ZRemRangeByLex $ cmd 4 + ["ZREMRANGEBYLEX", key k, min2bytes a, max2bytes b] + +zremrangebyrank :: Monad m => Key -> Int64 -> Int64 -> Redis m Int64 +zremrangebyrank k a b = singleton $ ZRemRangeByRank $ cmd 4 + ["ZREMRANGEBYRANK", key k, int2bytes a, int2bytes b] + +zremrangebyscore :: Monad m => Key -> Double -> Double -> Redis m Int64 +zremrangebyscore k a b = singleton $ ZRemRangeByScore $ cmd 4 + ["ZREMRANGEBYSCORE", key k, dbl2bytes a, dbl2bytes b] + +zrem :: (Monad m, ToByteString a) => Key -> NonEmpty a -> Redis m Int64 +zrem k vv = singleton $ ZRem $ cmd (2 + NE.length vv) $ "ZREM" : key k : map toByteString (toList vv) + +zincrby :: (Monad m, ToByteString a) => Key -> Double -> a -> Redis m Double +zincrby k i v = singleton $ ZIncrBy $ cmd 4 ["ZINCRBY", key k, dbl2bytes i, toByteString v] + +zscore :: (Monad m, ToByteString a) => Key -> a -> Redis m (Maybe Double) +zscore k v = singleton $ ZScore $ cmd 3 ["ZSCORE", key k, toByteString v] + +zcard :: Monad m => Key -> Redis m Int64 +zcard k = singleton $ ZCard $ cmd 2 ["ZCARD", key k] + +zcount :: Monad m => Key -> Double -> Double -> Redis m Int64 +zcount k a b = singleton $ ZCount $ cmd 4 ["ZCOUNT", key k, dbl2bytes a, dbl2bytes b] + +zrank :: (Monad m, ToByteString a) => Key -> a -> Redis m (Maybe Int64) +zrank k a = singleton $ ZRank $ cmd 3 ["ZRANK", key k, toByteString a] + +zrevrank :: (Monad m, ToByteString a) => Key -> a -> Redis m (Maybe Int64) +zrevrank k a = singleton $ ZRevRank $ cmd 3 ["ZREVRANK", key k, toByteString a] + +----------------------------------------------------------------------------- +-- HyperLogLog + +pfadd :: (Monad m, ToByteString a) => Key -> NonEmpty a -> Redis m Bool +pfadd k v = singleton $ PfAdd $ cmd (2 + NE.length v) $ "PFADD" : key k : map toByteString (toList v) + +pfcount :: Monad m => NonEmpty Key -> Redis m Int64 +pfcount kk = singleton $ PfCount $ cmd (1 + NE.length kk) $ "PFCOUNT" : map key (toList kk) + +pfmerge :: Monad m => Key -> NonEmpty Key -> Redis m () +pfmerge k kk = singleton $ PfMerge $ cmd (2 + NE.length kk) $ "PFMERGE" : key k : map key (toList kk) + +----------------------------------------------------------------------------- +-- Scan + +scan :: (Monad m, FromByteString a) => Cursor -> Opts "SCAN" -> Redis m (Cursor, [a]) +scan c o = singleton $ Scan $ cmd (2 + len o) $ "SCAN" : cursor c : toList (opts o) + +hscan :: (Monad m, FromByteString a) => Key -> Cursor -> Opts "SCAN" -> Redis m (Cursor, [a]) +hscan h c o = singleton $ HScan $ cmd (3 + len o) $ "HSCAN" : key h : cursor c : toList (opts o) + +sscan :: (Monad m, FromByteString a) => Key -> Cursor -> Opts "SCAN" -> Redis m (Cursor, [a]) +sscan h c o = singleton $ SScan $ cmd (3 + len o) $ "SSCAN" : key h : cursor c : toList (opts o) + +zscan :: (Monad m, FromByteString a) => Key -> Cursor -> Opts "SCAN" -> Redis m (Cursor, [a]) +zscan h c o = singleton $ ZScan $ cmd (3 + len o) $ "ZSCAN" : key h : cursor c : toList (opts o) + +match :: ByteString -> Opts "SCAN" +match pat = Opts 2 $ "MATCH" `cons` DL.singleton pat + +count :: Int64 -> Opts "SCAN" +count n = Opts 2 $ "COUNT" `cons` DL.singleton (int2bytes n) + +----------------------------------------------------------------------------- +-- Sort + +sort :: (Monad m, FromByteString a) => Key -> Opts "SORT" -> Redis m [a] +sort k o = singleton $ Sort $ cmd (2 + len o) $ "SORT" : key k : toList (opts o) + +by :: ByteString -> Opts "SORT" +by pat = Opts 2 $ "BY" `cons` DL.singleton pat + +limit :: Int64 -> Int64 -> Opts o +limit off cnt = Opts 3 $ DL.fromList ["LIMIT", int2bytes off, int2bytes cnt] + +getkey :: NonEmpty ByteString -> Opts "SORT" +getkey pats = foldr f none (toList pats) + where + f p acc = Opts 2 ("GET" `cons` DL.singleton p) <> acc + +asc :: Opts "SORT" +asc = Opts 1 $ DL.singleton "ASC" + +desc :: Opts "SORT" +desc = Opts 1 $ DL.singleton "DESC" + +alpha :: Opts "SORT" +alpha = Opts 1 $ DL.singleton "ALPHA" + +store :: Key -> Opts "SORT" +store k = Opts 2 $ "STORE" `cons` DL.singleton (key k) + +----------------------------------------------------------------------------- +-- Pub/Sub + +publish :: (Monad m, ToByteString a) => ByteString -> a -> Redis m Int64 +publish c m = singleton $ Publish $ cmd 3 $ ["PUBLISH", c, toByteString m] + +subscribe :: Monad m => NonEmpty ByteString -> PubSub m () +subscribe cs = singleton $ Subscribe $ cmd (1 + NE.length cs) $ "SUBSCRIBE" : toList cs + +psubscribe :: Monad m => NonEmpty ByteString -> PubSub m () +psubscribe cs = singleton $ PSubscribe $ cmd (1 + NE.length cs) $ "PSUBSCRIBE" : toList cs + +unsubscribe :: Monad m => [ByteString] -> PubSub m () +unsubscribe cs = singleton $ Unsubscribe $ cmd (1 + length cs) $ "UNSUBSCRIBE" : toList cs + +punsubscribe :: Monad m => [ByteString] -> PubSub m () +punsubscribe cs = singleton $ PUnsubscribe $ cmd (1 + length cs) $ "PUNSUBSCRIBE" : toList cs + +----------------------------------------------------------------------------- +-- Responses + +readInt'Null :: String -> Resp -> Result (Maybe Int64) +readInt'Null _ (Int i) = Right $ Just i +readInt'Null _ NullBulk = Right Nothing +readInt'Null s _ = Left $ InvalidResponse s + +readInt :: String -> Resp -> Result Int64 +readInt _ (Int i) = Right i +readInt s _ = Left $ InvalidResponse s + +readTTL :: String -> Resp -> Result (Maybe TTL) +readTTL s r = toTTL <$> readInt s r + where + toTTL (-2) = Nothing + toTTL (-1) = Just NoTTL + toTTL n = Just $ TTL n + +readBool :: String -> Resp -> Result Bool +readBool s r = readInt s r >>= toBool + where + toBool 0 = Right False + toBool 1 = Right True + toBool _ = Left $ InvalidResponse s + +readListOfMaybes :: FromByteString a => String -> Resp -> Result [Maybe a] +readListOfMaybes n (Array _ r) = foldr f (Right []) r + where + f _ x@(Left _) = x + f NullBulk (Right acc) = Right $ Nothing : acc + f (Bulk s) (Right acc) = (:acc) . Just <$> readStr s + f (Str s) (Right acc) = (:acc) . Just <$> readStr s + f _ _ = Left $ InvalidResponse n +readListOfMaybes n _ = Left $ InvalidResponse n + +readList :: FromByteString a => String -> Resp -> Result [a] +readList r (Array _ v) = foldr f (Right []) v + where + f _ x@(Left _) = x + f (Bulk s) (Right acc) = (:acc) <$> readStr s + f (Str s) (Right acc) = (:acc) <$> readStr s + f _ _ = Left $ InvalidResponse r +readList r _ = Left $ InvalidResponse r + +readScoreList :: FromByteString a => String -> Bool -> Resp -> Result (ScoreList a) +readScoreList r False a = ScoreList [] <$> readList r a +readScoreList r True (Array _ v) = toScoreList . unzip <$> foldr f (Right []) (chunksOf 2 v) + where + f _ x@(Left _) = x + f [Bulk x, Bulk d] (Right acc) = (\a b -> (a, b):acc) <$> readStr x <*> readStr d + f _ _ = Left $ InvalidResponse r + toScoreList (a, s) = ScoreList s a +readScoreList r _ _ = Left $ InvalidResponse r + +readFields :: FromByteString a => String -> Resp -> Result [(Field, a)] +readFields r (Array _ v) = foldr f (Right []) (chunksOf 2 v) + where + f _ x@(Left _) = x + f [Bulk k, Bulk x] (Right acc) = (:acc) . (k,) <$> readStr x + f _ _ = Left $ InvalidResponse r +readFields r _ = Left $ InvalidResponse r + +readKeyValue :: FromByteString a => String -> Resp -> Result (Maybe (Key, a)) +readKeyValue _ NullArray = return Nothing +readKeyValue _ (Array _ [Bulk k, Bulk v]) = Just . (Key k,) <$> readStr v +readKeyValue r _ = Left $ InvalidResponse r + +readBulk'Null :: FromByteString a => String -> Resp -> Result (Maybe a) +readBulk'Null _ NullBulk = Right Nothing +readBulk'Null _ (Bulk s) = Just <$> readStr s +readBulk'Null n _ = Left $ InvalidResponse n + +readBulk :: FromByteString a => String -> Resp -> Result a +readBulk _ (Bulk s) = readStr s +readBulk n _ = Left $ InvalidResponse n + +readBulk'Array :: FromByteString a => String -> Choose -> Resp -> Result [a] +readBulk'Array n One r = maybeToList <$> readBulk'Null n r +readBulk'Array n _ r = readList n r + +readScan :: FromByteString a => String -> Resp -> Result (Cursor, [a]) +readScan n (Array 2 (Bulk c:v:[])) = (Cursor c,) <$> readList n v +readScan n _ = Left $ InvalidResponse n + +matchStr :: String -> ByteString -> Resp -> Result () +matchStr n x (Str s) + | x == s = Right () + | otherwise = Left $ InvalidResponse n +matchStr n _ _ = Left $ InvalidResponse n + +anyStr :: String -> Resp -> Result () +anyStr _ (Str _) = Right () +anyStr n _ = Left $ InvalidResponse n + +readType :: String -> Resp -> Result (Maybe RedisType) +readType _ (Str s) = case s of + "string" -> return $ Just RedisString + "hash" -> return $ Just RedisHash + "list" -> return $ Just RedisList + "set" -> return $ Just RedisSet + "zset" -> return $ Just RedisZSet + "none" -> return Nothing + _ -> Left $ InvalidConversion ("unknown redis type: " ++ show s) +readType n _ = Left $ InvalidResponse n + +fromSet :: Resp -> Result Bool +fromSet (Str "OK") = Right True +fromSet NullBulk = Right False +fromSet _ = Left $ InvalidResponse "SET" + +readPushMessage :: Resp -> Result PushMessage +readPushMessage (Array 3 (Bulk "message":Bulk c:Bulk m:[])) = + Right $ Message c m +readPushMessage (Array 4 (Bulk "pmessage":Bulk p:Bulk c:Bulk m:[])) = + Right $ PMessage p c m +readPushMessage (Array 3 (Bulk "subscribe":Bulk c:Int n:[])) = + Right $ SubscribeMessage c n +readPushMessage (Array 3 (Bulk "unsubscribe":Bulk c:Int n:[])) = + Right $ UnsubscribeMessage c n +readPushMessage (Array 3 (Bulk "psubscribe":Bulk c:Int n:[])) = + Right $ SubscribeMessage c n +readPushMessage (Array 3 (Bulk "punsubscribe":Bulk c:Int n:[])) = + Right $ UnsubscribeMessage c n +readPushMessage _ = Left $ InvalidResponse "pub/sub" + +----------------------------------------------------------------------------- +-- Helpers + +cmd :: Int -> [ByteString] -> Resp +cmd n a = Array n (map Bulk a) +{-# INLINE cmd #-} + +int2bytes :: Int64 -> ByteString +int2bytes = toLazyByteStringWith (safeStrategy 20 8) mempty . int64Dec +{-# INLINE int2bytes #-} + +dbl2bytes :: Double -> ByteString +dbl2bytes = fromStrict . toShortest +{-# INLINE dbl2bytes #-} + +side2bytes :: Side -> ByteString +side2bytes Before = "BEFORE" +side2bytes After = "AFTER" +{-# INLINE side2bytes #-} + +readStr :: FromByteString a => ByteString -> Result a +readStr s = either (Left . InvalidConversion) Right $ runParser' parser s +{-# INLINE readStr #-} diff --git a/src/Data/Redis/Resp.hs b/src/Data/Redis/Resp.hs new file mode 100644 --- /dev/null +++ b/src/Data/Redis/Resp.hs @@ -0,0 +1,95 @@ +-- This Source Code Form is subject to the terms of the Mozilla Public +-- License, v. 2.0. If a copy of the MPL was not distributed with this +-- file, You can obtain one at http://mozilla.org/MPL/2.0/. + +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.Redis.Resp where + +import Control.Applicative +import Control.Monad (replicateM) +import Data.Attoparsec.ByteString.Char8 hiding (char8) +import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Builder +import Data.Int +import Data.Monoid +import Prelude hiding (take, takeWhile) + +import qualified Data.Attoparsec.ByteString.Lazy as P +import qualified Data.ByteString.Lazy as Lazy + +-- | 'Resp' defines the various RESP constructors. +data Resp + = Str !ByteString -- ^ RESP simple atrings + | Err !ByteString -- ^ RESP errors + | Int !Int64 -- ^ RESP integers + | Bulk !ByteString -- ^ RESP bulk strings + | Array !Int [Resp] -- ^ RESP arrays + | NullArray + | NullBulk + deriving (Eq, Ord, Show) + +decode :: ByteString -> Either String Resp +decode = P.eitherResult . P.parse resp + +encode :: Resp -> Lazy.ByteString +encode d = toLazyByteString (go d) + where + go (Str x) = char8 '+' <> lazyByteString x <> crlf' + go (Err x) = char8 '-' <> lazyByteString x <> crlf' + go (Int x) = char8 ':' <> int64Dec x <> crlf' + go (Bulk x) = char8 '$' + <> int64Dec (Lazy.length x) + <> crlf' + <> lazyByteString x + <> crlf' + go (Array n x) = char8 '*' + <> intDec n + <> crlf' + <> foldr (<>) mempty (map go x) + go NullArray = nullArray + go NullBulk = nullBulk + +----------------------------------------------------------------------------- +-- Parsing + +-- | An attoparsec parser to parse a single 'Resp' value. +resp :: Parser Resp +resp = do + t <- anyChar + case t of + '+' -> Str `fmap` bytes <* crlf + '-' -> Err `fmap` bytes <* crlf + ':' -> Int <$> signed decimal <* crlf + '$' -> bulk + '*' -> array + _ -> fail $ "invalid type tag: " ++ show t + +bulk :: Parser Resp +bulk = do + n <- signed decimal <* crlf + if | n >= 0 -> Bulk . Lazy.fromStrict <$> take n <* crlf + | n == -1 -> return NullBulk + | otherwise -> fail "negative bulk length" + +array :: Parser Resp +array = do + n <- signed decimal <* crlf :: Parser Int + if | n >= 0 -> Array n <$> replicateM n resp + | n == -1 -> return NullArray + | otherwise -> fail "negative array length" + +bytes :: Parser ByteString +bytes = Lazy.fromStrict <$> takeWhile (/= '\r') + +crlf :: Parser () +crlf = string "\r\n" >> return () + +----------------------------------------------------------------------------- +-- Serialising + +nullArray, nullBulk, crlf' :: Builder +nullArray = byteString "*-1\r\n" +nullBulk = byteString "$-1\r\n" +crlf' = byteString "\r\n"