{-
Copyright (c) 2010 Alexander Bogdanov <andorn@gmail.com>

Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
in the Software without restriction, including without limitation the rights
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
copies of the Software, and to permit persons to whom the Software is
furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in
all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
THE SOFTWARE.
-}

{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies,
  FlexibleContexts, OverloadedStrings #-}

-- | Main Redis API and protocol implementation
module Database.Redis.Redis (
       -- * Types ans Constructors
       Redis(..),
       Reply(..),
       Interval(..),
       IsInterval(..),
       SortOptions(..),
       Aggregate(..),
       sortDefaults,
       fromRInline, fromRBulk, fromRMulti, fromRMultiBulk,
       fromRInt, fromROk, noError, takeAll,

       -- * Database connection
       localhost, defaultPort,
       connect, disconnect, isConnected,

       -- * Redis commands
       -- ** Generic
       ping, auth, quit, shutdown,
       multi, exec, discard, run_multi, exists,
       del, getType, keys, randomKey, rename,
       renameNx, dbsize, expire, expireAt,
       ttl, select, move, flushDb,
       flushAll, info,

       -- ** Strings
       set, setNx, mSet, mSetNx,
       get, getSet, mGet,
       incr, incrBy, decr,
       decrBy, append, substr,

       -- ** Lists
       rpush, lpush, llen, lrange, ltrim,
       lindex, lset, lrem, lpop, rpop,
       rpoplpush, blpop, brpop,

       -- ** Sets
       sadd, srem, spop, smove, scard, sismember,
       smembers, srandmember, sinter, sinterStore,
       sunion, sunionStore, sdiff, sdiffStore,

       -- ** Sorted sets
       zadd, zrem, zincrBy, zrange,
       zrevrange, zrangebyscore, zcount,
       zremrangebyscore, zcard, zscore,
       zrank, zrevrank, zremrangebyrank,
       zunion, zinter,

       -- ** Hashes
       hset, hget, hdel, hexists, hlen,
       hkeys, hvals, hgetall,

       -- ** Sorting
       sort, listRelated,

       -- ** Persistent control
       save, bgsave, lastsave, bgrewriteaof
)
where

import Prelude hiding (putStrLn)
import qualified Network.Socket as S
import qualified System.IO as IO
import System.IO.UTF8 (putStrLn)
import qualified Data.ByteString as B
import Data.ByteString (ByteString)
import Data.ByteString.Char8 ()
import qualified Data.ByteString.UTF8 as U
import Data.Maybe (fromJust)
import Data.List (intersperse)

import Database.Redis.ByteStringClass

tracebs bs = putStrLn (U.toString bs)

-- | Redis connection descriptor
data Redis = Redis { server   :: (String, String), -- ^ hostname and port pair
                     handle :: IO.Handle           -- ^ real network connection
                   }
                deriving (Show, Eq)

-- | Redis command variants
data Command = CInline ByteString
             | CMInline [ByteString]
             | CBulk [ByteString] ByteString
             | CMBulk [ByteString]

-- | Redis reply variants
data BS s => Reply s = RTimeout               -- ^ Timeout. Currently unused
                     | ROk                    -- ^ \"Ok\" reply
                     | RPong                  -- ^ Reply for the ping command
                     | RQueued                -- ^ Used inside multi-exec block
                     | RError String          -- ^ Some kind of server-side error
                     | RInline s              -- ^ Simple oneline reply
                     | RInt Int               -- ^ Integer reply
                     | RBulk (Maybe s)        -- ^ Multiline reply
                     | RMulti (Maybe [Reply s]) -- ^ Complex reply. It may consists of various type of replys
                       deriving Eq

showbs :: BS s => s -> String
showbs = U.toString . toBS

instance BS s => Show (Reply s) where
    show RTimeout = "RTimeout"
    show ROk = "ROk"
    show RPong = "RPong"
    show RQueued = "RQueued"
    show (RError msg) = "RError: " ++ msg
    show (RInline s) = "RInline (" ++ (showbs s) ++ ")"
    show (RInt a) = "RInt " ++ show a
    show (RBulk (Just s)) = "RBulk " ++ showbs s
    show (RBulk Nothing) = "RBulk Nothing"
    show (RMulti (Just rs)) = "RMulti [" ++ join rs ++ "]"
                              where join = concat . intersperse ", " . map show
    show (RMulti Nothing) = "[]"

-- | Unwraps RInline reply.
--
-- Throws an exception when called with something different from RInline
fromRInline :: (Monad m, BS s) => Reply s -> m s
fromRInline reply = case reply of
                      RError msg -> error msg
                      RInline s  -> return s
                      _          -> error $ "wrong reply, RInline expected: " ++ (show reply)

-- | Unwraps RBulk reply.
--
-- Throws an exception when called with something different from RBulk
fromRBulk :: (Monad m, BS s) => Reply s -> m (Maybe s)
fromRBulk reply = case reply of
                    RError msg -> error msg
                    RBulk s    -> return s
                    _          -> error $ "wrong reply, RBulk expected: " ++ (show reply)

-- | Unwraps RMulti reply
--
-- Throws an exception when called with something different from RMulti
fromRMulti :: (Monad m, BS s) => Reply s -> m (Maybe [Reply s])
fromRMulti reply = case reply of
                     RError msg -> error msg
                     RMulti ss  -> return ss
                     _          -> error $ "wrong reply, RMulti expected: " ++ (show reply)

-- | Unwraps RMulti reply filled with RBulk
--
-- Throws an exception when called with something different from RMulti
fromRMultiBulk :: (Monad m, BS s) => Reply s -> m (Maybe [Maybe s])
fromRMultiBulk reply = fromRMulti reply >>= return . (>>= sequence . map fromRBulk)

-- | Unwraps RInt reply
--
-- Throws an exception when called with something different from RInt
fromRInt :: (Monad m, BS s) => Reply s -> m Int
fromRInt reply = case reply of
                   RError msg -> error msg
                   RInt n     -> return n
                   _          -> error $ "wrong reply, RInt expected: " ++ (show reply)

-- | Unwraps ROk reply
--
-- Throws an exception when called with something different from ROk
fromROk :: (Monad m, BS s) => Reply s -> m ()
fromROk reply = case reply of
                   RError msg -> error msg
                   ROk        -> return ()
                   _          -> error $ "wrong reply, ROk expected: " ++ (show reply)

-- | Unwraps every non-error reply
--
-- Throws an exception when called with something different from RMulti
noError :: (Monad m, BS s) => Reply s -> m ()
noError reply = case reply of
                   RError msg -> error msg
                   _          -> return ()

urn       = U.fromString "\r\n"
uspace    = U.fromString " "
uminus    = U.fromString "-"
uplus     = U.fromString "+"
ucolon    = U.fromString ":"
ubucks    = U.fromString "$"
uasterisk = U.fromString "*"

hPutRn h = B.hPut h urn

-- | default Redis port
defaultPort :: String
defaultPort = "6379"
-- | just a localhost
localhost :: String
localhost = "localhost"

-- | a (0, -1) range - takes all element from a list in lrange, zrange
-- and so on
takeAll :: (Int, Int)
takeAll = (0, -1)

-- | Conects to Redis server and returns connection descriptor
connect :: String -> String -> IO Redis
connect hostname port =
    do serveraddr <- head `fmap` S.getAddrInfo Nothing (Just hostname) (Just port)

       s <- S.socket (S.addrFamily serveraddr) S.Stream S.defaultProtocol
       S.setSocketOption s S.KeepAlive 1
       S.connect s (S.addrAddress serveraddr)

       h <- S.socketToHandle s IO.ReadWriteMode
       IO.hSetBuffering h (IO.BlockBuffering Nothing)

       return $ Redis (hostname, port) h

-- | Close connection
disconnect :: Redis -> IO ()
disconnect = IO.hClose . handle

-- | Returns True when connection handler is opened
isConnected :: Redis -> IO Bool
isConnected = IO.hIsOpen . handle

{- ================ Private =============== -}
send :: IO.Handle -> [ByteString] -> IO ()
send h [] = return ()
send h (bs:ls) = B.hPut h bs >> B.hPut h uspace >> send h ls

sendCommand :: Redis -> Command -> IO ()
sendCommand r (CInline bs) = let h = handle r
                             in B.hPut h bs >> hPutRn h >> IO.hFlush h
sendCommand r (CMInline ls) = let h = handle r
                              in send h ls >> hPutRn h >> IO.hFlush h
sendCommand r (CBulk lcmd bs) = let h = handle r
                                    size = U.fromString $ show $ B.length bs
                                in do send h lcmd
                                      B.hPut h uspace
                                      B.hPut h size
                                      hPutRn h
                                      B.hPut h bs
                                      hPutRn h
                                      IO.hFlush h
sendCommand r (CMBulk strings) = let h = handle r
                                     sendls [] = return ()
                                     sendls (bs:ls) = let size = U.fromString . show . B.length
                                                      in do B.hPut h ubucks
                                                            B.hPut h $ size bs
                                                            hPutRn h
                                                            B.hPut h bs
                                                            hPutRn h
                                                            sendls ls
                                 in do B.hPut h uasterisk
                                       B.hPut h $ U.fromString $ show $ length strings
                                       hPutRn h
                                       sendls strings
                                       IO.hFlush h

recv :: BS s => Redis -> IO (Reply s)
recv r = do first <- trim `fmap` B.hGetLine h
            case U.uncons first of
              Just ('-', rest)  -> recv_err rest
              Just ('+', rest)  -> recv_inline rest
              Just (':', rest)  -> recv_int rest
              Just ('$', rest)  -> recv_bulk rest
              Just ('*', rest)  -> recv_multi rest
    where
      h = handle r
      trim = B.takeWhile (\c -> c /= 13 && c /= 10)

      -- recv_err :: ByteString -> IO Reply
      recv_err rest = return $ RError $ U.toString rest

      -- recv_inline :: ByteString -> IO Reply
      recv_inline rest = return $ case rest of
                                    "OK"       -> ROk
                                    "PONG"     -> RPong
                                    "QUEUED"   -> RQueued
                                    _          -> RInline $ fromBS rest

      -- recv_int :: ByteString -> IO Reply
      recv_int rest = let reply = read (U.toString rest) :: Int
                      in return $ RInt reply

      -- recv_bulk :: ByteString -> IO Reply
      recv_bulk rest = let size = read (U.toString rest) :: Int
                       in do body <- recv_bulk_body size
                             return $ RBulk (fromBS `fmap` body)

      -- recv_bulk_body :: Int -> IO (Maybe ByteString)
      recv_bulk_body (-1) = return Nothing
      recv_bulk_body size = do body <- B.hGet h (size + 2)
                               let reply = B.take size body
                               return $ Just reply

      -- recv_multi :: ByteString -> IO Reply
      recv_multi rest = let cnt = read (U.toString rest) :: Int
                        in do bulks <- recv_multi_n cnt
                              return $ RMulti bulks

      -- recv_multi_n :: Int -> IO (Maybe [Reply])
      recv_multi_n (-1) = return Nothing
      recv_multi_n 0    = return $ Just []
      recv_multi_n n = do this <- recv r
                          tail <- fromJust `fmap` recv_multi_n (n-1)
                          return $ Just (this : tail)

{- ============ Just commands ============= -}
-- | ping - pong
--
-- RPong returned if no errors happends
ping :: Redis -> IO (Reply ())
ping r = sendCommand r (CInline "PING") >> recv r

-- | Password authentication
--
-- ROk returned
auth :: BS s =>
        Redis
     -> s                       -- ^ password
     -> IO (Reply ())
auth r pwd = sendCommand r (CMInline ["AUTH", toBS pwd] ) >> recv r

-- | Quit and close connection
quit :: Redis -> IO ()
quit r = sendCommand r (CInline "QUIT") >> disconnect r

-- | Stop all the clients, save the DB, then quit the server
shutdown :: Redis -> IO ()
shutdown r = sendCommand r (CInline "SHUTDOWN") >> disconnect r

-- | Begin the multi-exec block
--
-- ROk returned
multi :: Redis -> IO (Reply ())
multi r = sendCommand r (CInline "MULTI") >> recv r

-- | Execute queued commands
--
-- RMulti returned - replys for all executed commands
exec :: BS s => Redis -> IO (Reply s)
exec r = sendCommand r (CInline "EXEC") >> recv r

-- | Discard queued commands without execution
--
-- ROk returned
discard :: Redis -> IO (Reply ())
discard r = sendCommand r (CInline "DISCARD") >> recv r

-- | Run commands within multi-exec block
--
-- RMulti returned - replys for all executed commands
run_multi :: (BS s) =>
             Redis
          -> [IO (Reply ())]    -- ^ IO actions to run
          -> IO (Reply s)
run_multi r cs = let cs' = map (>>= noError) cs
                 in do multi r
                       sequence_ cs'
                       exec r

-- | Test if the key exists
--
-- (RInt 1) returned if the key exists and (RInt 0) otherwise
exists :: BS s =>
          Redis
       -> s                     -- ^ target key
       -> IO (Reply Int)
exists r key = sendCommand r (CMBulk ["EXISTS", toBS key]) >> recv r

-- | Remove the key
--
-- (RInt 0) returned if no keys were removed or (RInt n) with removed keys count
del :: BS s =>
       Redis
    -> s                        -- ^ target key
    -> IO (Reply Int)
del r key = sendCommand r (CMBulk ["DEL", toBS key]) >> recv r

-- | Return the type of the value stored at key in form of a string
--
-- RInline with one of "none", "string", "list", "set", "zset", "hash" returned
getType :: (BS s1, BS s2) =>
           Redis
        -> s1                   -- ^ target key
        -> IO (Reply s2)
getType r key = sendCommand r (CMBulk ["TYPE", toBS key]) >> recv r

-- | Returns all the keys matching the glob-style pattern
--
-- RMulti filled with RBulk returned
keys :: (BS s1, BS s2) =>
        Redis
     -> s1                      -- ^ target keys pattern
     -> IO (Reply s2)
keys r pattern = sendCommand r (CMInline ["KEYS", toBS pattern]) >> recv r

-- | Return random key name
--
-- RInline returned
randomKey :: BS s => Redis -> IO (Reply s)
randomKey r = sendCommand r (CInline "RANDOMKEY") >> recv r

-- | Rename the key. If key with that name exists it'll be overwritten.
--
-- ROk returned
rename :: (BS s1, BS s2) =>
          Redis
       -> s1                    -- ^ source key
       -> s2                    -- ^ destination key
       -> IO (Reply ())
rename r from to = sendCommand r (CMBulk ["RENAME", toBS from, toBS to]) >> recv r

-- | Rename the key if no keys with destination name exists.
--
-- (RInt 1) returned if key was renamed and (RInt 0) otherwise
renameNx :: (BS s1, BS s2) =>
            Redis
         -> s1                  -- ^ source key
         -> s2                  -- ^ destination key
         -> IO (Reply Int)
renameNx r from to = sendCommand r (CMBulk ["RENAMENX", toBS from, toBS to]) >> recv r

-- | Get the number of keys in the currently selected database
--
-- RInt returned
dbsize :: Redis -> IO (Reply Int)
dbsize r = sendCommand r (CInline "DBSIZE") >> recv r

-- | Set an expiration timeout in seconds on the specified key.
--
-- For more information see <http://code.google.com/p/redis/wiki/ExpireCommand>
--
-- (RInt 1) returned if timeout was set and (RInt 0) otherwise
expire :: BS s =>
          Redis
       -> s                     -- ^ target key
       -> Int                   -- ^ timeout in seconds
       -> IO (Reply Int)
expire r key seconds = sendCommand r (CMBulk ["EXPIRE", toBS key, toBS seconds]) >> recv r

-- | Set an expiration time in form of UNIX timestamp on the specified key
--
-- For more information see <http://code.google.com/p/redis/wiki/ExpireCommand>
--
-- (RInt 1) returned if timeout was set and (RInt 0) otherwise
expireAt :: BS s =>
            Redis
         -> s                   -- ^ target key
         -> Int                 -- ^ timeout in seconds
         -> IO (Reply Int)
expireAt r key timestamp = sendCommand r (CMBulk ["EXPIRE", toBS key, toBS timestamp]) >> recv r

-- | Return the remining time to live of the key or -1 if key has no
-- associated timeout
--
-- RInt returned
ttl :: BS s =>
       Redis
    -> s                        -- ^ target key
    -> IO (Reply Int)
ttl r key = sendCommand r (CMBulk ["TTL", toBS key]) >> recv r

-- | Select the DB with the specified zero-based numeric index
--
-- ROk returned
select :: Redis
       -> Int                   -- ^ database number
       -> IO (Reply ())
select r db = sendCommand r (CMInline ["SELECT", toBS db]) >> recv r

-- | Move the specified key from the currently selected DB to the
-- specified destination DB. If such a key is already exists in the
-- target DB no data modification performed.
--
-- (RInt 1) returned if the key was moved and (RInt 0) otherwise
move :: BS s =>
        Redis
     -> s                       -- ^ target key
     -> Int                     -- ^ destination database number
     -> IO (Reply Int)
move r key db = sendCommand r (CMBulk ["MOVE", toBS key, toBS db]) >> recv r

-- | Delete all the keys of the currently selected DB
--
-- ROk returned
flushDb :: Redis -> IO (Reply ())
flushDb r = sendCommand r (CInline "FLUSHDB") >> recv r

-- | Delete all the keys of all the existing databases
--
-- ROk returned
flushAll :: Redis -> IO (Reply ())
flushAll r = sendCommand r (CInline "FLUSHALL") >> recv r

-- | Returns different information and statistics about the server
--
-- for more information see <http://code.google.com/p/redis/wiki/InfoCommand>
--
-- RBulk returned
info :: BS s => Redis -> IO (Reply s)
info r = sendCommand r (CInline "INFO") >> recv r

-- | Set the string value as value of the key
--
-- ROk returned
set :: (BS s1, BS s2) => Redis
    -> s1                   -- ^ target key
    -> s2                   -- ^ value
    -> IO (Reply ())
set r key val = sendCommand r (CMBulk ["SET", toBS key, toBS val]) >> recv r

-- | Set the key value if key does not exists
--
-- (RInt 1) returned if key was set and (RInt 0) otherwise
setNx :: (BS s1, BS s2) =>
         Redis
      -> s1                     -- ^ target key
      -> s2                     -- ^ value
      -> IO (Reply Int)
setNx r key val = sendCommand r (CMBulk ["SETNX", toBS key, toBS val]) >> recv r

-- | Atomically set multiple keys
--
-- ROk returned
mSet :: (BS s1, BS s2) =>
        Redis
     -> [(s1, s2)]              -- ^ (key, value) pairs
     -> IO (Reply ())
mSet r ks = let interlace' [] ls = ls
                interlace' ((a, b):rest) ls = interlace' rest (toBS a : toBS b : ls)
                interlace ls = interlace' ls []
            in sendCommand r (CMBulk ("MSET" : interlace ks)) >> recv r

-- | Atomically set multiple keys if none of them exists.
--
-- (RInt 1) returned if all keys was set and (RInt 0) otherwise
mSetNx :: (BS s1, BS s2) =>
          Redis
       -> [(s1, s2)]            -- ^ (key, value) pairs
       -> IO (Reply Int)
mSetNx r ks = let interlace' [] ls = ls
                  interlace' ((a, b):rest) ls = interlace' rest (toBS a : toBS b : ls)
                  interlace ls = interlace' ls []
              in sendCommand r (CMBulk ("MSETNX" : interlace ks)) >> recv r

-- | Get the value of the specified key.
--
-- RBulk returned
get :: (BS s1, BS s2) =>
       Redis
    -> s1                       -- ^ target key
    -> IO (Reply s2)
get r key = sendCommand r (CMBulk ["GET", toBS key]) >> recv r


-- | Atomically set this value and return the old value
--
-- RBulk returned
getSet :: (BS s1, BS s2, BS s3) =>
          Redis
       -> s1                -- ^ target key
       -> s2                -- ^ value
       -> IO (Reply s3)
getSet r key val = sendCommand r (CMBulk ["GETSET", toBS key, toBS val]) >> recv r

-- | Get the values of all specified keys
--
-- RMulti filled with RBulk replys returned
mGet :: (BS s1, BS s2) =>
        Redis
     -> [s1]                    -- ^ target keys
     -> IO (Reply s2)
mGet r keys = sendCommand r (CMBulk ("MGET" : map toBS keys)) >> recv r

-- | Increment the key value by one
--
-- RInt returned with new key value
incr :: BS s =>
        Redis
     -> s                       -- ^ target key
     -> IO (Reply Int)
incr r key = sendCommand r (CMBulk ["INCR", toBS key]) >> recv r

-- | Increment the key value by N
--
-- RInt returned with new key value
incrBy :: BS s =>
          Redis
       -> s                     -- ^ target key
       -> Int                   -- ^ increment
       -> IO (Reply Int)
incrBy r key n = sendCommand r (CMBulk ["INCRBY", toBS key, toBS n]) >> recv r

-- | Decrement the key value by one
--
-- RInt returned with new key value
decr :: BS s =>
        Redis
     -> s                  -- ^ target key
     -> IO (Reply Int)
decr r key = sendCommand r (CMBulk ["DECR", toBS key]) >> recv r

-- | Decrement the key value by N
--
-- RInt returned with new key value
decrBy :: BS s =>
          Redis
       -> s                -- ^ target key
       -> Int                   -- ^ decrement
       -> IO (Reply Int)
decrBy r key n = sendCommand r (CMBulk ["DECRBY", toBS key, toBS n]) >> recv r

-- | Append string to the string-typed key
--
-- RInt returned - the length of resulting string
append :: (BS s1, BS s2) =>
          Redis
       -> s1                    -- ^ target key
       -> s2                    -- ^ value
       -> IO (Reply Int)
append r key str = sendCommand r (CMBulk ["APPEND", toBS key, toBS str]) >> recv r

-- | Get a substring. Indexes are zero-based.
--
-- RBulk returned
substr :: (BS s1, BS s2) =>
          Redis
       -> s1
       -> (Int, Int)
       -> IO (Reply s2)
substr r key (from, to) = sendCommand r (CMBulk ["SUBSTR", toBS key, toBS from, toBS to]) >> recv r

-- | Add string value to the head of the list-type key. New list
-- length returned
--
-- RInt returned
rpush :: (BS s1, BS s2) =>
         Redis
      -> s1                     -- ^ target key
      -> s2                     -- ^ value
      -> IO (Reply Int)
rpush r key val = sendCommand r (CMBulk ["RPUSH", toBS key, toBS val]) >> recv r

-- | Add string value to the tail of the list-type key. New list
-- length returned
--
-- RInt returned
lpush :: (BS s1, BS s2) =>
         Redis
      -> s1                     -- ^ target key
      -> s2                     -- ^ value
      -> IO (Reply Int)
lpush r key val = sendCommand r (CMBulk ["LPUSH", toBS key, toBS val]) >> recv r

-- | Return lenght of the list. Note that for not-existing keys it
-- returns zero length.
--
-- RInt returned or RError if key is not a list
llen :: BS s =>
        Redis
     -> s                       -- ^ target key
     -> IO (Reply Int)
llen r key = sendCommand r (CMBulk ["LLEN", toBS key]) >> recv r

-- | Return the specified range of list elements. List indexed from 0
-- to (llen - 1). lrange returns slice including \"from\" and \"to\"
-- elements, eg. lrange 0 2 will return the first three elements of
-- the list.
--
-- Parameters \"from\" and \"to\" may also be negative. If so it will counts as
-- offset from end ot the list. eg. -1 - is the last element of the
-- list, -2 - is the second from the end and so on.
--
-- RMulti filled with RBulk returned
lrange :: (BS s1, BS s2) =>
          Redis
       -> s1                    -- ^ traget key
       -> (Int, Int)            -- ^ (from, to) pair
       -> IO (Reply s2)
lrange r key (from, to) = sendCommand r (CMBulk ["LRANGE", toBS key, toBS from, toBS to]) >> recv r


-- | Trim list so that it will contain only the specified range of elements.
--
-- ROk returned
ltrim :: BS s =>
         Redis
      -> s                      -- ^ target key
      -> (Int, Int)             -- ^ (from, to) pair
      -> IO (Reply ())
ltrim r key (from, to) = sendCommand r (CMBulk ["LTRIM", toBS key, toBS from, toBS to]) >> recv r

-- | Return the specified element of the list by its index
--
-- RBulk returned
lindex :: (BS s1, BS s2) =>
          Redis
       -> s1                    -- ^ target key
       -> Int                   -- ^ index
       -> IO (Reply s2)
lindex r key index = sendCommand r (CMBulk ["LINDEX", toBS key, toBS index]) >> recv r

-- | Set the list's value indexed by an /index/ to the new value
--
-- ROk returned if element was set and RError if index is out of
-- range or key is not a list
lset :: (BS s1, BS s2) =>
        Redis
     -> s1                      -- ^ target key
     -> Int                     -- ^ index
     -> s2                      -- ^ new value
     -> IO (Reply ())
lset r key index val = sendCommand r (CMBulk ["LSET", toBS key, toBS index, toBS val]) >> recv r

-- | Remove the first /count/ occurrences of the /value/ element from the list
--
-- RInt returned - the number of elements removed
lrem :: (BS s1, BS s2) =>
        Redis
     -> s1                      -- ^ target key
     -> Int                     -- ^ occurrences
     -> s2                      -- ^ value
     -> IO (Reply Int)
lrem r key count value = sendCommand r (CMBulk ["LREM", toBS key, toBS count, toBS value]) >> recv r

-- | Atomically return and remove the first element of the list
--
-- RBulk returned
lpop :: (BS s1, BS s2) =>
        Redis
     -> s1                      -- ^ target key
     -> IO (Reply s2)
lpop r key = sendCommand r (CMBulk ["LPOP", toBS key]) >> recv r

-- | Atomically return and remove the last element of the list
--
-- RBulk returned
rpop :: (BS s1, BS s2) =>
        Redis
     -> s1                      -- ^ target key
     -> IO (Reply s2)
rpop r key = sendCommand r (CMBulk ["RPOP", toBS key]) >> recv r

-- | Atomically return and remove the last (tail) element of the
-- source list, and push the element as the first (head) element of
-- the destination list
--
-- RBulk returned
rpoplpush :: (BS s1, BS s2, BS s3) =>
             Redis
          -> s1                 -- ^ source key
          -> s2                 -- ^ destination key
          -> IO (Reply s3)
rpoplpush r src dst = sendCommand r (CMBulk ["RPOPLPUSH", toBS src, toBS dst]) >> recv r

-- | Blocking lpop
--
-- For more information see <http://code.google.com/p/redis/wiki/BlpopCommand>
--
-- RMulti returned filled with key name and popped value
blpop :: (BS s1, BS s2) =>
         Redis
      -> [s1]                   -- ^ keys list
      -> Int                    -- ^ timeout
      -> IO (Reply s2)
blpop r keys timeout = sendCommand r (CMBulk (("BLPOP" : map toBS keys) ++ [toBS timeout])) >> recv r

-- | Blocking rpop
--
-- For more information see <http://code.google.com/p/redis/wiki/BlpopCommand>
--
-- RMulti returned filled with key name and popped value
brpop :: (BS s1, BS s2) =>
         Redis
      -> [s1]                   -- ^ keys list
      -> Int                    -- ^ timeout
      -> IO (Reply s2)
brpop r keys timeout = sendCommand r (CMBulk (("BRPOP" : map toBS keys) ++ [toBS timeout])) >> recv r

-- | Add the specified member to the set value stored at key
--
-- (RInt 1) returned if element was added and (RInt 0) if element was
-- already a member of the set
sadd :: (BS s1, BS s2) =>
        Redis
     -> s1                      -- ^ target key
     -> s2                      -- ^ value
     -> IO (Reply Int)
sadd r key val = sendCommand r (CMBulk ["SADD", toBS key, toBS val]) >> recv r

-- | Remove the specified member from the set value stored at key
--
-- (RInt 1) returned if element was removed and (RInt 0) if element
-- is not a member of the set
srem :: (BS s1, BS s2) =>
        Redis
     -> s1                      -- ^ target key
     -> s2                      -- ^ value
     -> IO (Reply Int)
srem r key val = sendCommand r (CMBulk ["SREM", toBS key, toBS val]) >> recv r

-- | Remove a random element from a Set returning it as return value
--
-- RBulk returned
spop :: (BS s1, BS s2) =>
        Redis
     -> s1                      -- ^ target key
     -> IO (Reply s2)
spop r key = sendCommand r (CMBulk ["SPOP", toBS key]) >> recv r

-- | Move the specifided member from one set to another
--
-- (RInt 1) returned if element was moved and (RInt 0) if element
-- is not a member of the source set
smove :: (BS s1, BS s2, BS s3) =>
         Redis
      -> s1                     -- ^ source key
      -> s2                     -- ^ destination key
      -> s3                     -- ^ value
      -> IO (Reply Int)
smove r src dst member = sendCommand r (CMBulk ["SMOVE", toBS src, toBS dst, toBS member]) >> recv r

-- | Return the number of elements of the set. If key doesn't exists 0
-- returned.
--
-- RInt returned
scard :: BS s =>
         Redis
      -> s                      -- ^ target key
      -> IO (Reply Int)
scard r key = sendCommand r (CMBulk ["SCARD", toBS key]) >> recv r

-- | Test if element is member of the set. If key doesn't exists 0
-- returned.
--
-- (RInt 1) returned if element is member of the set and (RInt 0) otherwise
sismember :: BS s =>
             Redis
          -> s                  -- ^ target key
          -> IO (Reply Int)
sismember r key = sendCommand r (CMBulk ["SISMEMBER", toBS key]) >> recv r

-- | Return all the members (elements) of the set
--
-- RMulti filled with RBulk returned
smembers :: (BS s1, BS s2) =>
            Redis
         -> s1                  -- ^ target key
         -> IO (Reply s2)
smembers r key = sendCommand r (CMBulk ["SMEMBERS", toBS key]) >> recv r

-- | Return a random element from a set
--
-- RBulk returned
srandmember :: (BS s1, BS s2) =>
               Redis
            -> s1               -- ^ target key
            -> IO (Reply s2)
srandmember r key = sendCommand r (CMBulk ["SRANDMEMBER", toBS key]) >> recv r

-- | Return the members of a set resulting from the intersection of
-- all the specifided sets
--
-- RMulti filled with RBulk returned
sinter :: (BS s1, BS s2) =>
          Redis
       -> [s1]                  -- ^ keys list
       -> IO (Reply s2)
sinter r keys = sendCommand r (CMBulk ("SINTER" : map toBS keys)) >> recv r

-- | The same as 'sinter' but instead of being returned the resulting set
-- is stored
--
-- ROk returned
sinterStore :: (BS s1, BS s2) =>
               Redis
            -> s1               -- ^ where to store resulting set
            -> [s2]             -- ^ sets list
            -> IO (Reply ())
sinterStore r dst keys = sendCommand r (CMBulk ("SINTERSTORE" : toBS dst : map toBS keys)) >> recv r

-- | Return the members of a set resulting from the union of all the
-- specifided sets
--
-- RMulti filled with RBulk returned
sunion :: (BS s1, BS s2) =>
          Redis
       -> [s1]                  -- ^ keys list
       -> IO (Reply s2)
sunion r keys = sendCommand r (CMBulk ("SUNION" : map toBS keys)) >> recv r

-- | The same as 'sunion' but instead of being returned the resulting set
-- is stored
--
-- ROk returned
sunionStore :: (BS s1, BS s2) =>
               Redis
            -> s1               -- ^ where to store resulting set
            -> [s2]             -- ^ sets list
            -> IO (Reply ())
sunionStore r dst keys = sendCommand r (CMBulk ("SUNIONSTORE" : toBS dst : map toBS keys)) >> recv r

-- | Return the members of a set resulting from the difference between
-- the first set provided and all the successive sets
--
-- RMulti filled with RBulk returned
sdiff :: (BS s1, BS s2) =>
         Redis
      -> [s1]                   -- ^ keys list
      -> IO (Reply s2)
sdiff r keys = sendCommand r (CMBulk ("SDIFF" : map toBS keys)) >> recv r

-- | The same as 'sdiff' but instead of being returned the resulting
-- set is stored
--
-- ROk returned
sdiffStore :: (BS s1, BS s2) =>
              Redis
           -> s1                -- ^ where to store resulting set
           -> [s2]              -- ^ sets list
           -> IO (Reply ())
sdiffStore r dst keys = sendCommand r (CMBulk ("SDIFFSTORE" : toBS dst : map toBS keys)) >> recv r

-- | Add the specified member having the specifeid score to the sorted
-- set
--
-- (RInt 1) returned if new element was added and (RInt 0) if that
-- element was already a member of the sortet set and the score was
-- updated
zadd :: (BS s1, BS s2) =>
        Redis
     -> s1                      -- ^ target key
     -> Double                  -- ^ score
     -> s2                      -- ^ value
     -> IO (Reply Int)
zadd r key score member = sendCommand r (CMBulk ["ZADD", toBS key, toBS score, toBS member]) >> recv r

-- | Remove the specified member from the sorted set
--
-- (RInt 1) returned if element was removed and (RInt 0) if element
-- was not a member of the sorted set
zrem :: (BS s1, BS s2) =>
        Redis
     -> s1                      -- ^ target key
     -> s2                      -- ^ value
     -> IO (Reply Int)
zrem r key member = sendCommand r (CMBulk ["ZREM", toBS key, toBS member]) >> recv r

-- | If /member/ already in the sorted set adds the /increment/ to its
-- score and updates the position of the element in the sorted set
-- accordingly. If member does not exist in the sorted set it is added
-- with increment as score (that is, like if the previous score was
-- virtually zero). The new score of the member is returned.
--
-- RBulk returned
zincrBy :: (BS s1, BS s2, BS s3) =>
           Redis
        -> s1                   -- ^ target key
        -> Double               -- ^ increment
        -> s2                   -- ^ value
        -> IO (Reply s3)
zincrBy r key increment member = sendCommand r (CMBulk ["ZINCRBY", toBS key, toBS increment, toBS member]) >> recv r

-- | Return the specified elements of the sorted set. Start and end
-- are zero-based indexes. WITHSCORES paramenter indicates if it's
-- needed to return elements with its scores or not. If WITHSCORES is
-- True then the resulting list will be composed of value1, score1,
-- value2, score2 and so on.
--
-- RMulti filled with RBulk returned
zrange :: (BS s1, BS s2) =>
          Redis
       -> s1                    -- ^ target key
       -> (Int, Int)            -- ^ (from, to) pair
       -> Bool                  -- ^ withscores option
       -> IO (Reply s2)
zrange r key limit withscores = let cmd' = ["ZRANGE", toBS key, toBS $ fst limit, toBS $ snd limit]
                                    cmd | withscores = cmd' ++ ["WITHSCORES"]
                                        | otherwise  = cmd'
                                in sendCommand r (CMBulk cmd) >> recv r

-- | Return the specified elements of the sorted set at the specified
-- key. The elements are considered sorted from the highest to the
-- lowerest score
--
-- RMulti filled with RBulk returned
zrevrange :: (BS s1, BS s2) =>
             Redis
          -> s1                 -- ^ target key
          -> (Int, Int)         -- ^ (from, to) pair
          -> Bool               -- ^ withscores option
          -> IO (Reply s2)
zrevrange r key limit withscores = let cmd' = ["ZREVRANGE", toBS key, toBS $ fst limit, toBS $ snd limit]
                                       cmd | withscores = cmd' ++ ["WITHSCORES"]
                                           | otherwise  = cmd'
                                   in sendCommand r (CMBulk cmd) >> recv r

-- | Interval representation
data Interval a = Closed a a    -- ^ closed interval [a, b]
                | Open a a      -- ^ open interval (a, b)
                | LeftOpen a a  -- ^ left-open interval (a, b]
                | RightOpen a a -- ^ right-open interval [a, b)
                deriving Show

-- | Class for conversion value to 'Interval'
--
-- Definied instances is:
--
-- * the Interval itself
--
-- * pair (a,b) for open interval
--
-- * two-member list [a, b] for closed interval (throws runtime error if the list length is different)
--
class IsInterval i a | i -> a where
    toInterval :: i -> Interval a

-- | Trivial IsInterval instance
instance IsInterval (Interval a) a where
    toInterval = id

-- | Pair (a, b) converted to open interval
instance IsInterval (a, a) a where
    toInterval (a, b) = Open a b

-- | Two-element list [a, b] converted to closed interval. No static
-- checking of list length performed.
instance IsInterval [a] a where
    toInterval (a : b : []) = Closed a b
    toInterval _ = error "Interval cast error"

from (Closed a _) = show a
from (Open a _) = '(' : (show a)
from (LeftOpen a _) = '(' : (show a)
from (RightOpen a _) = show a

to (Closed _ a) = show a
to (Open _ a) = '(' : (show a)
to (LeftOpen _ a) = show a
to (RightOpen _ a) = '(' : (show a)

-- | Return the all the elements in the sorted set with a score that
-- lays within a given interval
--
-- RMulti filled with RBulk returned
zrangebyscore :: (IsInterval i Double, BS s1, BS s2) =>
                 Redis
              -> s1             -- ^ target key
              -> i              -- ^ scores interval
              -> Bool           -- ^ withscores option
              -> IO (Reply s2)
zrangebyscore r key i withscores = let cmd' = i' `seq` ["ZRANGEBYSCORE", toBS key, toBS (from i'), toBS (to i')]
                                       cmd | withscores = cmd' ++ ["WITHSCORES"]
                                           | otherwise  = cmd'
                                       i' = toInterval i
                                   in cmd `seq` sendCommand r (CMBulk cmd) >> recv r

-- | Count a number of elements of the sorted set with a score that
-- lays within a given interval
--
-- RInt returned
zcount :: (IsInterval i Double, BS s) =>
          Redis
       -> s                     -- ^ target key
       -> i                     -- ^ scores interval
       -> IO (Reply Int)
zcount r key i = let cmd = i' `seq` ["ZCOUNT", toBS key, toBS (from i'), toBS (to i')]
                     i' = toInterval i
                 in cmd `seq` sendCommand r (CMBulk cmd) >> recv r

-- | Remove all the elements in the sorted set with a score that lays
-- within a given interval. For now this command doesn't supports open
-- and semi-open intervals
--
-- RInt returned - the number of elements removed
zremrangebyscore :: BS s =>
                    Redis
                 -> s                -- ^ target key
                 -> (Double, Double) -- ^ (from, to) pair. zremrangebyscore
                                     -- currently doesn't supports
                                     -- open intervals
                 -> IO (Reply Int)
zremrangebyscore r key (from, to) = sendCommand r (CMBulk ["ZREMRANGEBYSCORE", toBS key, toBS from, toBS to]) >> recv r

-- | Return the sorted set cardinality (number of elements)
--
-- RInt returned
zcard :: BS s =>
         Redis
      -> s                      -- ^ target key
      -> IO (Reply Int)
zcard r key = sendCommand r (CMBulk ["ZCARD", toBS key]) >> recv r

-- | Return the score of the specified element of the sorted set
--
-- RBulk returned
zscore :: (BS s1, BS s2, BS s3) =>
          Redis
       -> s1                    -- ^ target key
       -> s2                    -- ^ value
       -> IO (Reply s3)
zscore r key member = sendCommand r (CMBulk ["ZSCORE", toBS key, toBS member]) >> recv r

-- | Returns sorted set element sequence number counting from zero
--
-- RInt returned
zrank :: (BS s1, BS s2) =>
         Redis
      -> s1
      -> s2
      -> IO (Reply Int)
zrank r key member = sendCommand r (CMBulk ["ZRANK", toBS key, toBS member]) >> recv r

-- | Returns sorted set element sequence number for reversed sort order
--
-- RInt returned
zrevrank :: (BS s1, BS s2) =>
            Redis
         -> s1
         -> s2
         -> IO (Reply Int)
zrevrank r key member = sendCommand r (CMBulk ["ZREVRANK", toBS key, toBS member]) >> recv r

-- | Remove elements from the sorted set with rank lays within a given
-- interval.
--
-- RInt returned - the number of elements removed
zremrangebyrank :: (BS s) =>
                   Redis
                -> s
                -> (Int, Int)
                -> IO (Reply Int)
zremrangebyrank r key (from, to) =
    sendCommand r (CMBulk ["ZREMRANGEBYRANK", toBS key, toBS from, toBS to]) >> recv r

data Aggregate = SUM | MIN | MAX
                 deriving (Eq, Show)

-- | Create a union of provided sorted sets and store it at /destination/ key
--
-- If /weights/ is not null then scores of sorted sets used with
-- corresponding weights. If so lenght of /weights/ must be the same
-- as length of /sources/.
--
-- /Aggregate/ is an option how to aggregate resulting scores.
--
-- RInt returned - the number of elements in the resulting set.
zunion :: (BS s1, BS s2) =>
          Redis
       -> s1                    -- ^ destination key
       -> [s2]                  -- ^ sources keys
       -> [Double]              -- ^ weights
       -> Aggregate             -- ^ aggregate
       -> IO (Reply Int)
zunion r dst src weights aggregate =
    let src_s = toBS (length src) : map toBS src

        weight_s | null weights = []
                 | otherwise    = "WEIGHTS" : map toBS weights

        aggr_s | aggregate == SUM = []
               | otherwise        = ["AGGREGATE", toBS (show aggregate)]
    in sendCommand r (CMBulk (("ZUNION" : toBS dst : src_s) ++ weight_s ++ aggr_s)) >> recv r

-- | Create an intersectoin of provided sorted sets and store it at destination key
--
-- If /weights/ is not null then scores of sorted sets used with
-- corresponding weights. If so lenght of /weights/ must be the same
-- as length of /sources/.
--
-- Aggregate is an option how to aggregate resulting scores.
--
-- RInt returned - the number of elements in the resulting set.
zinter :: (BS s1, BS s2) =>
          Redis
       -> s1                    -- ^ destination key
       -> [s2]                  -- ^ sources keys
       -> [Double]              -- ^ weights
       -> Aggregate             -- ^ aggregate
       -> IO (Reply Int)
zinter r dst src weights aggregate =
    let src_s = toBS (length src) : map toBS src

        weight_s | null weights = []
                 | otherwise    = "WEIGHTS" : map toBS weights

        aggr_s | aggregate == SUM = []
               | otherwise        = ["AGGREGATE", toBS (show aggregate)]
    in sendCommand r (CMBulk (("ZINTER" : toBS dst : src_s) ++ weight_s ++ aggr_s)) >> recv r

-- | Set the specified hash field to the specified value
--
-- (RInt 0 returned if field value was updated and (RInt 1) if new field created
hset :: (BS s1, BS s2, BS s3) =>
        Redis                   
     -> s1                      -- ^ target key
     -> s2                      -- ^ field name
     -> s3                      -- ^ value
     -> IO (Reply Int)
hset r key field value = sendCommand r (CMBulk ["HSET", toBS key, toBS field, toBS value]) >> recv r

-- | Return value associated with specified field from hash
--
-- RBulk returned
hget :: (BS s1, BS s2, BS s3) =>
        Redis
     -> s1                      -- ^ key
     -> s2                      -- ^ field name
     -> IO (Reply s3)
hget r key field = sendCommand r (CMBulk ["HGET", toBS key, toBS field]) >> recv r

-- | Remove field from a hash
--
-- (RInt 1) returned if field was removed and (RInt 0) otherwise
hdel :: (BS s1, BS s2) =>
        Redis
     -> s1                      -- ^ key
     -> s2                      -- ^ field name
     -> IO (Reply Int)
hdel r key field = sendCommand r (CMBulk ["HDEL", toBS key, toBS field]) >> recv r

-- | Test if hash contains the specified field
--
-- (RInt 1) returned if fiels exists and (RInt 0) otherwise
hexists :: (BS s1, BS s2) =>
           Redis
        -> s1                   -- ^ key
        -> s2                   -- ^ field name
        -> IO (Reply Int)
hexists r key field = sendCommand r (CMBulk ["HEXISTS", toBS key, toBS field]) >> recv r

-- | Return the number of fields contained in the specified hash
--
-- RInt returned
hlen :: (BS s) =>
        Redis
     -> s
     -> IO (Reply Int)
hlen r key = sendCommand r (CMBulk ["HLEN", toBS key]) >> recv r

-- | Return all the field names the hash holding
--
-- RMulti field with RBulk returned
hkeys :: (BS s1, BS s2) =>
         Redis
      -> s1
      -> IO (Reply s2)
hkeys r key = sendCommand r (CMBulk ["HKEYS", toBS key]) >> recv r

-- | Return all the associated values the hash holding
--
-- RMulti field with RBulk returned
hvals :: (BS s1, BS s2) =>
         Redis
      -> s1
      -> IO (Reply s2)
hvals r key = sendCommand r (CMBulk ["HVALS", toBS key]) >> recv r

-- | Return all the field names and associated values the hash holding
-- in form of /[field1, value1, field2, value2...]/
--
-- RMulti field with RBulk returned
hgetall :: (BS s1, BS s2) =>
           Redis
        -> s1
        -> IO (Reply s2)
hgetall r key = sendCommand r (CMBulk ["HGETALL", toBS key]) >> recv r

-- | Options data type for the 'sort' command
data BS s => SortOptions s = SortOptions { desc       :: Bool,       -- ^ sort with descending order
                                           limit      :: (Int, Int), -- ^ return (from, to) elements
                                           alpha      :: Bool,       -- ^ sort alphabetically
                                           sort_by    :: s,          -- ^ sort by value from this key
                                           get_obj    :: [s],        -- ^ return this keys values
                                           store      :: s           -- ^ store result to this key
                                         }

-- | Default options for the 'sort' command
sortDefaults :: SortOptions ByteString
sortDefaults = SortOptions { desc = False,
                             limit = takeAll,
                             alpha = False,
                             sort_by = "",
                             get_obj = [],
                             store = "" }

-- | Sort the elements contained in the List, Set, or Sorted Set
--
-- for more information see <http://code.google.com/p/redis/wiki/SortCommand>
--
-- RMulti filled with RBulk returned
sort :: (BS s1, BS s2, BS s3) =>
        Redis
     -> s1                      -- ^ target key
     -> SortOptions s2          -- ^ options
     -> IO (Reply s3)
sort r key opt = let opt_s = buildOptions opt
                     buildOptions :: BS s => SortOptions s -> [ByteString]
                     buildOptions opt = let desc_s
                                                | desc opt  = ["DESC"]
                                                | otherwise = []
                                            limit_s
                                                | (limit opt) == (0, 0) = []
                                                | otherwise             = ["LIMIT", (toBS $ fst $ limit opt), (toBS $ snd $ limit opt)]
                                            alpha_s
                                                | alpha opt = ["ALPHA"]
                                                | otherwise = []
                                            sort_by_s
                                                | B.null $ toBS (sort_by opt) = []
                                                | otherwise                   = ["BY",(toBS $ sort_by opt)]
                                            get_obj_s
                                                | null $ get_obj opt = []
                                                | otherwise          = "GET" : map toBS (get_obj opt)
                                            store_s
                                                | B.null $ toBS (store opt) = []
                                                | otherwise                 = ["STORE", toBS $ store opt]
                                        in concat [sort_by_s, limit_s, get_obj_s, desc_s, alpha_s, store_s]
                 in sendCommand r (CMBulk ("SORT" : toBS key : opt_s)) >> recv r

-- | Shortcut for the 'sort' with some 'get_obj' and constant
-- 'sort_by' options
--
-- RMulti filled with RBulk returned
listRelated :: (BS s1, BS s2, BS s3) =>
               Redis
            -> s1               -- ^ related key
            -> s2               -- ^ index key
            -> (Int, Int)       -- ^ range
            -> IO (Reply s3)
listRelated r related key l = let opts = sortDefaults { sort_by = "x",
                                                        get_obj = [toBS related],
                                                        limit = l }
                              in sort r key opts

-- | Save the whole dataset on disk
--
-- ROk returned
save :: Redis -> IO (Reply ())
save r = sendCommand r (CInline "SAVE") >> recv r

-- | Save the DB in background
--
-- ROk returned
bgsave :: Redis -> IO (Reply ())
bgsave r = sendCommand r (CInline "BGSAVE") >> recv r

-- | Return the UNIX TIME of the last DB save executed with success
--
-- RInt returned
lastsave :: Redis -> IO (Reply Int)
lastsave r = sendCommand r (CInline "LASTSAVE") >> recv r

-- | Rewrites the Append Only File in background
--
-- ROk returned
bgrewriteaof :: Redis -> IO (Reply ())
bgrewriteaof r = sendCommand r (CInline "BGREWRITEAOF") >> recv r