diff --git a/Database/Redis/ByteStringClass.hs b/Database/Redis/ByteStringClass.hs new file mode 100644 --- /dev/null +++ b/Database/Redis/ByteStringClass.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +module Database.Redis.ByteStringClass where + +import Prelude hiding (concat) +import Data.ByteString +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.UTF8 as U +import Data.Binary + +-- | Utility class for conversion to and from Strict ByteString +class BS a where + toBS :: a -> ByteString + fromBS :: ByteString -> a + +instance BS ByteString where + toBS = id + fromBS = id + +instance BS L.ByteString where + toBS = concat . L.toChunks . encode + fromBS = decode . L.fromChunks . return + +instance BS String where + toBS = U.fromString + fromBS = U.toString + +instance BS Int where + toBS = U.fromString . show + fromBS = read . U.toString + +instance BS Double where + toBS = U.fromString . show + fromBS = read . U.toString + +instance BS () where + toBS = const empty + fromBS = const () diff --git a/Database/Redis/Monad.hs b/Database/Redis/Monad.hs --- a/Database/Redis/Monad.hs +++ b/Database/Redis/Monad.hs @@ -53,7 +53,7 @@ set, setNx, mSet, mSetNx, get, getSet, mGet, incr, incrBy, decr, - decrBy, append, + decrBy, append, substr, -- ** Lists rpush, lpush, llen, lrange, ltrim, @@ -69,6 +69,7 @@ zadd, zrem, zincrBy, zrange, zrevrange, zrangebyscore, zcount, zremrangebyscore, zcard, zscore, + zrank, -- ** Sorting sort, listRelated, @@ -85,6 +86,7 @@ import qualified Database.Redis.Redis as R import Database.Redis.Redis (IsInterval) +import Database.Redis.ByteStringClass class MonadIO m => WithRedis m where getRedis :: m (R.Redis) @@ -99,280 +101,288 @@ isConnected :: WithRedis m => m Bool isConnected = getRedis >>= liftIO . R.isConnected -ping :: WithRedis m => m R.Reply +ping :: WithRedis m => m (R.Reply ()) ping = getRedis >>= liftIO . R.ping -auth :: WithRedis m => String -> m R.Reply +auth :: WithRedis m => String -> m (R.Reply ()) auth pwd = getRedis >>= liftIO . flip R.auth pwd quit :: WithRedis m => m () quit = getRedis >>= liftIO . R.quit -shutdown :: WithRedis m => m R.Reply +shutdown :: WithRedis m => m () shutdown = getRedis >>= liftIO . R.shutdown -multi :: WithRedis m => m R.Reply +multi :: WithRedis m => m (R.Reply ()) multi = getRedis >>= liftIO . R.multi -exec :: WithRedis m => m R.Reply +exec :: (WithRedis m, BS s) => m (R.Reply s) exec = getRedis >>= liftIO . R.exec -discard :: WithRedis m => m R.Reply +discard :: WithRedis m => m (R.Reply ()) discard = getRedis >>= liftIO . R.discard -run_multi :: WithRedis m => [m R.Reply] -> m R.Reply +run_multi :: (WithRedis m, BS s) => [m (R.Reply ())] -> m (R.Reply s) run_multi cs = let cs' = map (>>= R.noError) cs in do multi sequence_ cs' exec -exists :: WithRedis m => String -> m R.Reply +exists :: (WithRedis m, BS s) => s -> m (R.Reply Int) exists key = getRedis >>= liftIO . flip R.exists key -del :: WithRedis m => String -> m R.Reply +del :: (WithRedis m, BS s) => s -> m (R.Reply Int) del key = getRedis >>= liftIO . flip R.del key -getType :: WithRedis m => String -> m R.Reply +getType :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2) getType key = getRedis >>= liftIO . flip R.getType key -keys :: WithRedis m => String -> m R.Reply +keys :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2) keys pattern = getRedis >>= liftIO . flip R.keys pattern -randomKey :: WithRedis m => m R.Reply +randomKey :: (WithRedis m, BS s) => m (R.Reply s) randomKey = getRedis >>= liftIO . R.randomKey -rename :: WithRedis m => String -> String -> m R.Reply +rename :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply ()) rename from to = do r <- getRedis liftIO $ R.rename r from to -renameNx :: WithRedis m => String -> String -> m R.Reply +renameNx :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int) renameNx from to = do r <- getRedis liftIO $ R.renameNx r from to -dbsize :: WithRedis m => m R.Reply +dbsize :: WithRedis m => m (R.Reply Int) dbsize = getRedis >>= liftIO . R.dbsize -expire :: WithRedis m => String -> Int -> m R.Reply +expire :: (WithRedis m, BS s) => s -> Int -> m (R.Reply Int) expire key seconds = do r <- getRedis liftIO $ R.expire r key seconds -expireAt :: WithRedis m => String -> Int -> m R.Reply +expireAt :: (WithRedis m, BS s) => s -> Int -> m (R.Reply Int) expireAt key timestamp = do r <- getRedis liftIO $ R.expireAt r key timestamp -ttl :: WithRedis m => String -> m R.Reply +ttl :: (WithRedis m, BS s) => s -> m (R.Reply Int) ttl key = getRedis >>= liftIO . flip R.ttl key -select :: WithRedis m => Int -> m R.Reply +select :: WithRedis m => Int -> m (R.Reply ()) select db = getRedis >>= liftIO . flip R.select db -move :: WithRedis m => String -> Int -> m R.Reply +move :: (WithRedis m, BS s) => s -> Int -> m (R.Reply Int) move key db = do r <- getRedis liftIO $ R.move r key db -flushDb :: WithRedis m => m R.Reply +flushDb :: WithRedis m => m (R.Reply ()) flushDb = getRedis >>= liftIO . R.flushDb -flushAll :: WithRedis m => m R.Reply +flushAll :: WithRedis m => m (R.Reply ()) flushAll = getRedis >>= liftIO . R.flushAll -info :: WithRedis m => m R.Reply +info :: (WithRedis m, BS s) => m (R.Reply s) info = getRedis >>= liftIO . R.info -set :: WithRedis m => String -> String -> m R.Reply +set :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply ()) set key val = do r <- getRedis liftIO $ R.set r key val -setNx :: WithRedis m => String -> String -> m R.Reply +setNx :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int) setNx key val = do r <- getRedis liftIO $ R.setNx r key val -mSet :: WithRedis m => [(String, String)] -> m R.Reply +mSet :: (WithRedis m, BS s1, BS s2) => [(s1, s2)] -> m (R.Reply ()) mSet ks = getRedis >>= liftIO . flip R.mSet ks -mSetNx :: WithRedis m => [(String, String)] -> m R.Reply +mSetNx :: (WithRedis m, BS s1, BS s2) => [(s1, s2)] -> m (R.Reply Int) mSetNx ks = getRedis >>= liftIO . flip R.mSetNx ks -get :: WithRedis m => String -> m R.Reply +get :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2) get key = getRedis >>= liftIO . flip R.get key -getSet :: WithRedis m => String -> String -> m R.Reply +getSet :: (WithRedis m, BS s1, BS s2, BS s3) => s1 -> s2 -> m (R.Reply s3) getSet key val = do r <- getRedis liftIO $ R.getSet r key val -mGet :: WithRedis m => [String] -> m R.Reply +mGet :: (WithRedis m, BS s1, BS s2) => [s1] -> m (R.Reply s2) mGet keys = getRedis >>= liftIO . flip R.mGet keys -incr :: WithRedis m => String -> m R.Reply +incr :: (WithRedis m, BS s) => s -> m (R.Reply Int) incr key = getRedis >>= liftIO . flip R.incr key -incrBy :: WithRedis m => String -> Int -> m R.Reply +incrBy :: (WithRedis m, BS s) => s -> Int -> m (R.Reply Int) incrBy key n = do r <- getRedis liftIO $ R.incrBy r key n -decr :: WithRedis m => String -> m R.Reply +decr :: (WithRedis m, BS s) => s -> m (R.Reply Int) decr key = getRedis >>= liftIO . flip R.decr key -decrBy :: WithRedis m => String -> Int -> m R.Reply +decrBy :: (WithRedis m, BS s) => s -> Int -> m (R.Reply Int) decrBy key n = do r <- getRedis liftIO $ R.decrBy r key n -append :: WithRedis m => String -> String -> m R.Reply +append :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int) append key str = do r <- getRedis liftIO $ R.append r key str -rpush :: WithRedis m => String -> String -> m R.Reply +substr :: (WithRedis m, BS s1, BS s2) => s1 -> (Int, Int) -> m (R.Reply s2) +substr key range = do r <- getRedis + liftIO $ R.substr r key range + +rpush :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int) rpush key val = do r <- getRedis liftIO $ R.rpush r key val -lpush :: WithRedis m => String -> String -> m R.Reply +lpush :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int) lpush key val = do r <- getRedis liftIO $ R.lpush r key val -llen :: WithRedis m => String -> m R.Reply +llen :: (WithRedis m, BS s) => s -> m (R.Reply Int) llen key = getRedis >>= liftIO . flip R.llen key -lrange :: WithRedis m => String -> (Int, Int) -> m R.Reply +lrange :: (WithRedis m, BS s1, BS s2) => s1 -> (Int, Int) -> m (R.Reply s2) lrange key limit = do r <- getRedis liftIO $ R.lrange r key limit -ltrim :: WithRedis m => String -> (Int, Int) -> m R.Reply +ltrim :: (WithRedis m, BS s) => s -> (Int, Int) -> m (R.Reply ()) ltrim key limit = do r <- getRedis liftIO $ R.ltrim r key limit -lindex :: WithRedis m => String -> Int -> m R.Reply +lindex :: (WithRedis m, BS s1, BS s2) => s1 -> Int -> m (R.Reply s2) lindex key index = do r <- getRedis liftIO $ R.lindex r key index -lset :: WithRedis m => String -> Int -> String -> m R.Reply +lset :: (WithRedis m, BS s1, BS s2) => s1 -> Int -> s2 -> m (R.Reply ()) lset key index val = do r <- getRedis liftIO $ R.lset r key index val -lrem :: WithRedis m => String -> Int -> String -> m R.Reply +lrem :: (WithRedis m, BS s1, BS s2) => s1 -> Int -> s2 -> m (R.Reply Int) lrem key count value = do r <- getRedis liftIO $ R.lrem r key count value -lpop :: WithRedis m => String -> m R.Reply +lpop :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2) lpop key = getRedis >>= liftIO . flip R.lpop key -rpop :: WithRedis m => String -> m R.Reply +rpop :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2) rpop key = getRedis >>= liftIO . flip R.rpop key -rpoplpush :: WithRedis m => String -> String -> m R.Reply +rpoplpush :: (WithRedis m, BS s1, BS s2, BS s3) => s1 -> s2 -> m (R.Reply s3) rpoplpush src dst = do r <- getRedis liftIO $ R.rpoplpush r src dst -blpop :: WithRedis m => [String] -> Int -> m R.Reply +blpop :: (WithRedis m, BS s1, BS s2) => [s1] -> Int -> m (R.Reply s2) blpop keys timeout = do r <- getRedis liftIO $ R.blpop r keys timeout -brpop :: WithRedis m => [String] -> Int -> m R.Reply +brpop :: (WithRedis m, BS s1, BS s2) => [s1] -> Int -> m (R.Reply s2) brpop keys timeout = do r <- getRedis liftIO $ R.brpop r keys timeout -sadd :: WithRedis m => String -> String -> m R.Reply +sadd :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int) sadd key val = do r <- getRedis liftIO $ R.sadd r key val -srem :: WithRedis m => String -> String -> m R.Reply +srem :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int) srem key val = do r <- getRedis liftIO $ R.srem r key val -spop :: WithRedis m => String -> m R.Reply +spop :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2) spop key = getRedis >>= liftIO . flip R.spop key -smove :: WithRedis m => String -> String -> String -> m R.Reply +smove :: (WithRedis m, BS s1, BS s2, BS s3) => s1 -> s2 -> s3 -> m (R.Reply Int) smove src dst member = do r <- getRedis liftIO $ R.smove r src dst member -scard :: WithRedis m => String -> m R.Reply +scard :: (WithRedis m, BS s) => s -> m (R.Reply Int) scard key = getRedis >>= liftIO . flip R.scard key -sismember :: WithRedis m => String -> m R.Reply +sismember :: (WithRedis m, BS s) => s -> m (R.Reply Int) sismember key = getRedis >>= liftIO . flip R.sismember key -smembers :: WithRedis m => String -> m R.Reply +smembers :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2) smembers key = getRedis >>= liftIO . flip R.smembers key -srandmember :: WithRedis m => String -> m R.Reply +srandmember :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2) srandmember key = getRedis >>= liftIO . flip R.srandmember key -sinter :: WithRedis m => [String] -> m R.Reply +sinter :: (WithRedis m, BS s1, BS s2) => [s1] -> m (R.Reply s2) sinter key = getRedis >>= liftIO . flip R.sinter key -sinterStore :: WithRedis m => String -> [String] -> m R.Reply +sinterStore :: (WithRedis m, BS s1, BS s2) => s1 -> [s2] -> m (R.Reply ()) sinterStore dst keys = do r <- getRedis liftIO $ R.sinterStore r dst keys -sunion :: WithRedis m => [String] -> m R.Reply +sunion :: (WithRedis m, BS s1, BS s2) => [s1] -> m (R.Reply s2) sunion keys = getRedis >>= liftIO . flip R.sunion keys -sunionStore :: WithRedis m => String -> [String] -> m R.Reply +sunionStore :: (WithRedis m, BS s1, BS s2) => s1 -> [s2] -> m (R.Reply ()) sunionStore dst keys = do r <- getRedis liftIO $ R.sunionStore r dst keys -sdiff :: WithRedis m => [String] -> m R.Reply +sdiff :: (WithRedis m, BS s1, BS s2) => [s1] -> m (R.Reply s2) sdiff keys = getRedis >>= liftIO . flip R.sdiff keys -sdiffStore :: WithRedis m => String -> [String] -> m R.Reply +sdiffStore :: (WithRedis m, BS s1, BS s2) => s1 -> [s2] -> m (R.Reply ()) sdiffStore dst keys = do r <- getRedis liftIO $ R.sdiffStore r dst keys -zadd :: WithRedis m => String -> Double -> String -> m R.Reply +zadd :: (WithRedis m, BS s1, BS s2) => s1 -> Double -> s2 -> m (R.Reply Int) zadd key score member = do r <- getRedis liftIO $ R.zadd r key score member -zrem :: WithRedis m => String -> String -> m R.Reply +zrem :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int) zrem key member = do r <- getRedis liftIO $ R.zrem r key member -zincrBy :: WithRedis m => String -> Double -> String -> m R.Reply +zincrBy :: (WithRedis m, BS s1, BS s2, BS s3) => s1 -> Double -> s2 -> m (R.Reply s3) zincrBy key score member = do r <- getRedis liftIO $ R.zincrBy r key score member -zrange :: WithRedis m => String -> (Int, Int) -> Bool -> m R.Reply +zrange :: (WithRedis m, BS s1, BS s2) => s1 -> (Int, Int) -> Bool -> m (R.Reply s2) zrange key limit withscores = do r <- getRedis liftIO $ R.zrange r key limit withscores -zrevrange :: WithRedis m => String -> (Int, Int) -> Bool -> m R.Reply +zrevrange :: (WithRedis m, BS s1, BS s2) => s1 -> (Int, Int) -> Bool -> m (R.Reply s2) zrevrange key limit withscores = do r <- getRedis liftIO $ R.zrevrange r key limit withscores -zrangebyscore :: (WithRedis m, IsInterval i Double) => String -> i -> Bool -> m R.Reply +zrangebyscore :: (WithRedis m, IsInterval i Double, BS s1, BS s2) => s1 -> i -> Bool -> m (R.Reply s2) zrangebyscore key limit withscores = do r <- getRedis liftIO $ R.zrangebyscore r key limit withscores -zcount :: (WithRedis m, IsInterval i Double) => String -> i -> m R.Reply +zcount :: (WithRedis m, IsInterval i Double, BS s) => s -> i -> m (R.Reply Int) zcount key limit = do r <- getRedis liftIO $ R.zcount r key limit -zremrangebyscore :: WithRedis m => String -> (Double, Double) -> m R.Reply +zremrangebyscore :: (WithRedis m, BS s) => s -> (Double, Double) -> m (R.Reply Int) zremrangebyscore key limit = do r <- getRedis liftIO $ R.zremrangebyscore r key limit -zcard :: WithRedis m => String -> m R.Reply +zcard :: (WithRedis m, BS s) => s -> m (R.Reply Int) zcard key = getRedis >>= liftIO . flip R.zcard key -zscore :: WithRedis m => String -> String -> m R.Reply +zscore :: (WithRedis m, BS s1, BS s2, BS s3) => s1 -> s2 -> m (R.Reply s3) zscore key member = do r <- getRedis liftIO $ R.zscore r key member -sort :: WithRedis m => String -> R.SortOptions -> m R.Reply +zrank :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int) +zrank key member = do r <- getRedis + liftIO $ R.zrank r key member + +sort :: (WithRedis m, BS s1, BS s2, BS s3) => s1 -> R.SortOptions s2 -> m (R.Reply s3) sort key opt = do r <- getRedis liftIO $ R.sort r key opt -listRelated :: WithRedis m => String -> String -> (Int, Int) -> m R.Reply +listRelated :: (WithRedis m, BS s1, BS s2, BS s3) => s1 -> s2 -> (Int, Int) -> m (R.Reply s3) listRelated related key l = do r <- getRedis liftIO $ R.listRelated r related key l -save :: WithRedis m => m R.Reply +save :: WithRedis m => m (R.Reply ()) save = getRedis >>= liftIO . R.save -bgsave :: WithRedis m => m R.Reply +bgsave :: WithRedis m => m (R.Reply ()) bgsave = getRedis >>= liftIO . R.bgsave -lastsave :: WithRedis m => m R.Reply +lastsave :: WithRedis m => m (R.Reply Int) lastsave = getRedis >>= liftIO . R.lastsave -bgrewriteaof :: WithRedis m => m R.Reply +bgrewriteaof :: WithRedis m => m (R.Reply ()) bgrewriteaof = getRedis >>= liftIO . R.bgrewriteaof diff --git a/Database/Redis/Redis.hs b/Database/Redis/Redis.hs --- a/Database/Redis/Redis.hs +++ b/Database/Redis/Redis.hs @@ -20,7 +20,8 @@ THE SOFTWARE. -} -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, + FlexibleContexts, OverloadedStrings #-} -- | Main Redis API and protocol implementation module Database.Redis.Redis ( @@ -51,7 +52,7 @@ set, setNx, mSet, mSetNx, get, getSet, mGet, incr, incrBy, decr, - decrBy, append, + decrBy, append, substr, -- ** Lists rpush, lpush, llen, lrange, ltrim, @@ -67,6 +68,7 @@ zadd, zrem, zincrBy, zrange, zrevrange, zrangebyscore, zcount, zremrangebyscore, zcard, zscore, + zrank, -- ** Sorting sort, listRelated, @@ -76,12 +78,21 @@ ) 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 @@ -89,27 +100,44 @@ deriving (Show, Eq) -- | Redis command variants -data Command = CInline String - | CMInline [String] - | CBulk [String] String - | CMBulk [String] +data Command = CInline ByteString + | CMInline [ByteString] + | CBulk [ByteString] ByteString + | CMBulk [ByteString] -- | Redis reply variants -data Reply = 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 String -- ^ Simple oneline reply - | RInt Int -- ^ Integer reply - | RBulk (Maybe String) -- ^ Multiline reply - | RMulti (Maybe [Reply]) -- ^ Complex reply. It may consists of various type of replys - deriving (Show, Eq) +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) => Reply -> m String +fromRInline :: (Monad m, BS s) => Reply s -> m s fromRInline reply = case reply of RError msg -> error msg RInline s -> return s @@ -118,7 +146,7 @@ -- | Unwraps RBulk reply. -- -- Throws an exception when called with something different from RBulk -fromRBulk :: (Monad m) => Reply -> m (Maybe String) +fromRBulk :: (Monad m, BS s) => Reply s -> m (Maybe s) fromRBulk reply = case reply of RError msg -> error msg RBulk s -> return s @@ -127,7 +155,7 @@ -- | Unwraps RMulti reply -- -- Throws an exception when called with something different from RMulti -fromRMulti :: (Monad m) => Reply -> m (Maybe [Reply]) +fromRMulti :: (Monad m, BS s) => Reply s -> m (Maybe [Reply s]) fromRMulti reply = case reply of RError msg -> error msg RMulti ss -> return ss @@ -136,13 +164,13 @@ -- | Unwraps RMulti reply filled with RBulk -- -- Throws an exception when called with something different from RMulti -fromRMultiBulk :: (Monad m) => Reply -> m (Maybe [Maybe String]) +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) => Reply -> m Int +fromRInt :: (Monad m, BS s) => Reply s -> m Int fromRInt reply = case reply of RError msg -> error msg RInt n -> return n @@ -151,7 +179,7 @@ -- | Unwraps ROk reply -- -- Throws an exception when called with something different from ROk -fromROk :: (Monad m) => Reply -> m () +fromROk :: (Monad m, BS s) => Reply s -> m () fromROk reply = case reply of RError msg -> error msg ROk -> return () @@ -160,7 +188,7 @@ -- | Unwraps every non-error reply -- -- Throws an exception when called with something different from RMulti -noError :: (Monad m) => Reply -> m () +noError :: (Monad m, BS s) => Reply s -> m () noError reply = case reply of RError msg -> error msg _ -> return () @@ -210,86 +238,82 @@ isConnected = IO.hIsOpen . handle {- ================ Private =============== -} -send :: IO.Handle -> [String] -> IO () +send :: IO.Handle -> [ByteString] -> IO () send h [] = return () -send h (s:ls) = let bs = U.fromString s - in B.hPut h bs >> B.hPut h uspace >> send h ls +send h (bs:ls) = B.hPut h bs >> B.hPut h uspace >> send h ls sendCommand :: Redis -> Command -> IO () -sendCommand r (CInline s) = let h = handle r - bs = U.fromString s - in B.hPut h bs >> hPutRn h >> IO.hFlush h +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 s) = let h = handle r - bs = U.fromString s - 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 (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 (l:ls) = let bs = U.fromString l - 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 + 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 :: Redis -> IO Reply -recv r = do first <- bsToStr `fmap` B.hGetLine h - case first of - ('-':rest) -> recv_err rest - ('+':rest) -> recv_inline rest - (':':rest) -> recv_int rest - ('$':rest) -> recv_bulk rest - ('*':rest) -> recv_multi rest +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 - bsToStr = (takeWhile (\c -> c /= '\r' && c /= '\n')) . U.toString + trim = B.takeWhile (\c -> c /= 13 && c /= 10) - recv_err :: String -> IO Reply - recv_err rest = return $ RError rest + -- recv_err :: ByteString -> IO Reply + recv_err rest = return $ RError $ U.toString rest - recv_inline :: String -> IO Reply + -- recv_inline :: ByteString -> IO Reply recv_inline rest = return $ case rest of "OK" -> ROk "PONG" -> RPong "QUEUED" -> RQueued - _ -> RInline rest + _ -> RInline $ fromBS rest - recv_int :: String -> IO Reply - recv_int rest = let reply = read rest :: Int + -- recv_int :: ByteString -> IO Reply + recv_int rest = let reply = read (U.toString rest) :: Int in return $ RInt reply - recv_bulk :: String -> IO Reply - recv_bulk rest = let size = read rest :: Int + -- recv_bulk :: ByteString -> IO Reply + recv_bulk rest = let size = read (U.toString rest) :: Int in do body <- recv_bulk_body size - return $ RBulk body + return $ RBulk (fromBS `fmap` body) - recv_bulk_body :: Int -> IO (Maybe String) + -- 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 = U.toString $ B.take size body + let reply = B.take size body return $ Just reply - recv_multi :: String -> IO Reply - recv_multi rest = let cnt = read rest :: Int + -- 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 :: Int -> IO (Maybe [Reply]) recv_multi_n (-1) = return Nothing recv_multi_n 0 = return $ Just [] recv_multi_n n = do this <- recv r @@ -300,49 +324,51 @@ -- | ping - pong -- -- RPong returned if no errors happends -ping :: Redis -> IO Reply +ping :: Redis -> IO (Reply ()) ping r = sendCommand r (CInline "PING") >> recv r -- | Password authentication -- -- ROk returned -auth :: Redis - -> String -- ^ password - -> IO Reply -auth r pwd = sendCommand r (CMInline ["AUTH", pwd] ) >> recv r +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 Reply -shutdown r = sendCommand r (CInline "SHUTDOWN") >> recv r +shutdown :: Redis -> IO () +shutdown r = sendCommand r (CInline "SHUTDOWN") >> disconnect r -- | Begin the multi-exec block -- -- ROk returned -multi :: Redis -> IO Reply +multi :: Redis -> IO (Reply ()) multi r = sendCommand r (CInline "MULTI") >> recv r -- | Execute queued commands -- -- RMulti returned - replys for all executed commands -exec :: Redis -> IO Reply +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 :: 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 :: Redis - -> [IO Reply] -- ^ IO actions to run - -> IO Reply +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' @@ -351,63 +377,69 @@ -- | Test if the key exists -- -- (RInt 1) returned if the key exists and (RInt 0) otherwise -exists :: Redis - -> String -- ^ target key - -> IO Reply -exists r key = sendCommand r (CMBulk ["EXISTS", key]) >> recv r +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 :: Redis - -> String -- ^ target key - -> IO Reply -del r key = sendCommand r (CMBulk ["DEL", key]) >> recv r +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" returned -getType :: Redis - -> String -- ^ target key - -> IO Reply -getType r key = sendCommand r (CMBulk ["TYPE", key]) >> recv r +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 :: Redis - -> String -- ^ target keys pattern - -> IO Reply -keys r pattern = sendCommand r (CMInline ["KEYS", pattern]) >> recv r +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 :: Redis -> IO Reply +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 :: Redis - -> String -- ^ source key - -> String -- ^ destination key - -> IO Reply -rename r from to = sendCommand r (CMBulk ["RENAME", from, to]) >> recv r +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 :: Redis - -> String -- ^ source key - -> String -- ^ destination key - -> IO Reply -renameNx r from to = sendCommand r (CMBulk ["RENAMENX", from, to]) >> recv r +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 +dbsize :: Redis -> IO (Reply Int) dbsize r = sendCommand r (CInline "DBSIZE") >> recv r -- | Set an expiration timeout in seconds on the specified key. @@ -415,61 +447,65 @@ -- For more information see -- -- (RInt 1) returned if timeout was set and (RInt 0) otherwise -expire :: Redis - -> String -- ^ target key +expire :: BS s => + Redis + -> s -- ^ target key -> Int -- ^ timeout in seconds - -> IO Reply -expire r key seconds = sendCommand r (CMBulk ["EXPIRE", key, show seconds]) >> recv r + -> 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 -- -- (RInt 1) returned if timeout was set and (RInt 0) otherwise -expireAt :: Redis - -> String -- ^ target key +expireAt :: BS s => + Redis + -> s -- ^ target key -> Int -- ^ timeout in seconds - -> IO Reply -expireAt r key timestamp = sendCommand r (CMBulk ["EXPIRE", key, show timestamp]) >> recv r + -> 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 :: Redis - -> String -- ^ target key - -> IO Reply -ttl r key = sendCommand r (CMBulk ["TTL", key]) >> recv r +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", show db]) >> recv r + -> 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 :: Redis - -> String -- ^ target key +move :: BS s => + Redis + -> s -- ^ target key -> Int -- ^ destination database number - -> IO Reply -move r key db = sendCommand r (CMBulk ["MOVE", key, show db]) >> recv r + -> 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 :: 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 :: Redis -> IO (Reply ()) flushAll r = sendCommand r (CInline "FLUSHALL") >> recv r -- | Returns different information and statistics about the server @@ -477,143 +513,170 @@ -- for more information see -- -- RBulk returned -info :: Redis -> IO Reply +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 :: Redis - -> String -- ^ target key - -> String -- ^ value - -> IO Reply -set r key val = sendCommand r (CMBulk ["SET", key, val]) >> recv r +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 :: Redis - -> String -- ^ target key - -> String -- ^ value - -> IO Reply -setNx r key val = sendCommand r (CMBulk ["SETNX", key, val]) >> recv r +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 :: Redis - -> [(String, String)] -- ^ (key, value) pairs - -> IO Reply +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 (a:b: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 :: Redis - -> [(String, String)] -- ^ (key, value) pairs - -> IO Reply +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 (a:b: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 :: Redis - -> String -- ^ target key - -> IO Reply -get r key = sendCommand r (CMBulk ["GET", key]) >> recv r +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 :: Redis - -> String -- ^ target key - -> String -- ^ value - -> IO Reply -getSet r key val = sendCommand r (CMBulk ["GETSET", key, val]) >> recv r +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 :: Redis - -> [String] -- ^ target keys - -> IO Reply -mGet r keys = sendCommand r (CMBulk ("MGET" : keys)) >> recv r +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 :: Redis - -> String -- ^ target key - -> IO Reply -incr r key = sendCommand r (CMBulk ["INCR", key]) >> recv r +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 :: Redis - -> String -- ^ target key +incrBy :: BS s => + Redis + -> s -- ^ target key -> Int -- ^ increment - -> IO Reply -incrBy r key n = sendCommand r (CMBulk ["INCRBY", key, show n]) >> recv r + -> 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 :: Redis - -> String -- ^ target key - -> IO Reply -decr r key = sendCommand r (CMBulk ["DECR", key]) >> recv r +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 :: Redis - -> String -- ^ target key +decrBy :: BS s => + Redis + -> s -- ^ target key -> Int -- ^ decrement - -> IO Reply -decrBy r key n = sendCommand r (CMBulk ["DECRBY", key, show n]) >> recv r + -> 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 :: Redis - -> String -- ^ target key - -> String -- ^ value - -> IO Reply -append r key str = sendCommand r (CMBulk ["APPEND", key, str]) >> recv r +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 --- | Add string value to the head of the list-type key +-- | Get a substring. Indexes are zero-based. -- --- ROk returned or RError if key is not a list -rpush :: Redis - -> String -- ^ target key - -> String -- ^ value - -> IO Reply -rpush r key val = sendCommand r (CMBulk ["RPUSH", key, val]) >> recv r +-- 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 tail of the list-type key +-- | Add string value to the head of the list-type key. New list +-- length returned -- --- ROk returned or RError if key is not a list -lpush :: Redis - -> String -- ^ target key - -> String -- ^ value - -> IO Reply -lpush r key val = sendCommand r (CMBulk ["LPUSH", key, val]) >> recv r +-- 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 :: Redis - -> String -- ^ target key - -> IO Reply -llen r key = sendCommand r (CMBulk ["LLEN", key]) >> recv r +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\" @@ -625,225 +688,254 @@ -- list, -2 - is the second from the end and so on. -- -- RMulti filled with RBulk returned -lrange :: Redis - -> String -- ^ traget key +lrange :: (BS s1, BS s2) => + Redis + -> s1 -- ^ traget key -> (Int, Int) -- ^ (from, to) pair - -> IO Reply -lrange r key (from, to) = sendCommand r (CMBulk ["LRANGE", key, show from, show to]) >> recv r + -> 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 :: Redis - -> String -- ^ target key +ltrim :: BS s => + Redis + -> s -- ^ target key -> (Int, Int) -- ^ (from, to) pair - -> IO Reply -ltrim r key (from, to) = sendCommand r (CMBulk ["LTRIM", key, show from, show to]) >> recv r + -> 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 :: Redis - -> String -- ^ target key +lindex :: (BS s1, BS s2) => + Redis + -> s1 -- ^ target key -> Int -- ^ index - -> IO Reply -lindex r key index = sendCommand r (CMBulk ["LINDEX", key, show index]) >> recv r + -> 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 :: Redis -> String -> Int -> String -> IO Reply -lset r key index val = sendCommand r (CMBulk ["LSET", key, show index, val]) >> recv r +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 :: Redis - -> String -- ^ target key +lrem :: (BS s1, BS s2) => + Redis + -> s1 -- ^ target key -> Int -- ^ occurrences - -> String -- ^ value - -> IO Reply -lrem r key count value = sendCommand r (CMBulk ["LREM", key, show count, value]) >> recv r + -> 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 :: Redis - -> String -- ^ target key - -> IO Reply -lpop r key = sendCommand r (CMBulk ["LPOP", key]) >> recv r +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 :: Redis - -> String -- ^ target key - -> IO Reply -rpop r key = sendCommand r (CMBulk ["RPOP", key]) >> recv r +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 :: Redis - -> String -- ^ source key - -> String -- ^ destination key - -> IO Reply -rpoplpush r src dst = sendCommand r (CMBulk ["RPOPLPUSH", src, dst]) >> recv r +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 -- -- RMulti returned filled with key name and popped value -blpop :: Redis - -> [String] -- ^ keys list +blpop :: (BS s1, BS s2) => + Redis + -> [s1] -- ^ keys list -> Int -- ^ timeout - -> IO Reply -blpop r keys timeout = sendCommand r (CMBulk (("BLPOP" : keys) ++ [show timeout])) >> recv r + -> IO (Reply s2) +blpop r keys timeout = sendCommand r (CMBulk (("BLPOP" : map toBS keys) ++ [toBS timeout])) >> recv r -- | Blocking rpop -- -- For more information see -- -- RMulti returned filled with key name and popped value -brpop :: Redis - -> [String] -- ^ keys list +brpop :: (BS s1, BS s2) => + Redis + -> [s1] -- ^ keys list -> Int -- ^ timeout - -> IO Reply -brpop r keys timeout = sendCommand r (CMBulk (("BRPOP" : keys) ++ [show timeout])) >> recv r + -> 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 :: Redis - -> String -- ^ target key - -> String -- ^ value - -> IO Reply -sadd r key val = sendCommand r (CMBulk ["SADD", key, val]) >> recv r +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 :: Redis - -> String -- ^ target key - -> String -- ^ value - -> IO Reply -srem r key val = sendCommand r (CMBulk ["SREM", key, val]) >> recv r +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 :: Redis - -> String -- ^ target key - -> IO Reply -spop r key = sendCommand r (CMBulk ["SPOP", key]) >> recv r +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 :: Redis - -> String -- ^ source key - -> String -- ^ destination key - -> String -- ^ value - -> IO Reply -smove r src dst member = sendCommand r (CMBulk ["SMOVE", src, dst, member]) >> recv r +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 :: Redis - -> String -- ^ target key - -> IO Reply -scard r key = sendCommand r (CMBulk ["SCARD", key]) >> recv r +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 :: Redis - -> String -- ^ target key - -> IO Reply -sismember r key = sendCommand r (CMBulk ["SISMEMBER", key]) >> recv r +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 :: Redis - -> String -- ^ target key - -> IO Reply -smembers r key = sendCommand r (CMBulk ["SMEMBERS", key]) >> recv r +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 :: Redis - -> String -- ^ target key - -> IO Reply -srandmember r key = sendCommand r (CMBulk ["SRANDMEMBER", key]) >> recv r +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 :: Redis - -> [String] -- ^ keys list - -> IO Reply -sinter r keys = sendCommand r (CMBulk ("SINTER" : keys)) >> recv r +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 :: Redis - -> String -- ^ where to store resulting set - -> [String] -- ^ sets list - -> IO Reply -sinterStore r dst keys = sendCommand r (CMBulk ("SINTERSTORE" : dst : keys)) >> recv r +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 :: Redis - -> [String] -- ^ keys list - -> IO Reply -sunion r keys = sendCommand r (CMBulk ("SUNION" : keys)) >> recv r +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 :: Redis - -> String -- ^ where to store resulting set - -> [String] -- ^ sets list - -> IO Reply -sunionStore r dst keys = sendCommand r (CMBulk ("SUNIONSTORE" : dst : keys)) >> recv r +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 :: Redis - -> [String] -- ^ keys list - -> IO Reply -sdiff r keys = sendCommand r (CMBulk ("SDIFF" : keys)) >> recv r +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 :: Redis - -> String -- ^ where to store resulting set - -> [String] -- ^ sets list - -> IO Reply -sdiffStore r dst keys = sendCommand r (CMBulk ("SDIFFSTORE" : dst : keys)) >> recv r +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 @@ -851,22 +943,24 @@ -- (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 :: Redis - -> String -- ^ target key +zadd :: (BS s1, BS s2) => + Redis + -> s1 -- ^ target key -> Double -- ^ score - -> String -- ^ value - -> IO Reply -zadd r key score member = sendCommand r (CMBulk ["ZADD", key, show score, member]) >> recv r + -> 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 :: Redis - -> String -- ^ target key - -> String -- ^ value - -> IO Reply -zrem r key member = sendCommand r (CMBulk ["ZREM", key, member]) >> recv r +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 @@ -875,12 +969,13 @@ -- virtually zero). The new score of the member is returned. -- -- RBulk returned -zincrBy :: Redis - -> String -- ^ target key +zincrBy :: (BS s1, BS s2, BS s3) => + Redis + -> s1 -- ^ target key -> Double -- ^ increment - -> String -- ^ value - -> IO Reply -zincrBy r key increment member = sendCommand r (CMBulk ["ZINCRBY", key, show increment, member]) >> recv r + -> 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 @@ -889,12 +984,13 @@ -- value2, score2 and so on. -- -- RMulti filled with RBulk returned -zrange :: Redis - -> String -- ^ target key +zrange :: (BS s1, BS s2) => + Redis + -> s1 -- ^ target key -> (Int, Int) -- ^ (from, to) pair -> Bool -- ^ withscores option - -> IO Reply -zrange r key limit withscores = let cmd' = ["ZRANGE", key, show $ fst limit, show $ snd limit] + -> 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 @@ -904,12 +1000,13 @@ -- lowerest score -- -- RMulti filled with RBulk returned -zrevrange :: Redis - -> String -- ^ target key +zrevrange :: (BS s1, BS s2) => + Redis + -> s1 -- ^ target key -> (Int, Int) -- ^ (from, to) pair -> Bool -- ^ withscores option - -> IO Reply -zrevrange r key limit withscores = let cmd' = ["ZREVRANGE", key, show $ fst limit, show $ snd limit] + -> 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 @@ -962,13 +1059,13 @@ -- lays within a given interval -- -- RMulti filled with RBulk returned -zrangebyscore :: IsInterval i Double => +zrangebyscore :: (IsInterval i Double, BS s1, BS s2) => Redis - -> String -- ^ target key + -> s1 -- ^ target key -> i -- ^ scores interval -> Bool -- ^ withscores option - -> IO Reply -zrangebyscore r key i withscores = let cmd' = i' `seq` ["ZRANGEBYSCORE", key, from i', to i'] + -> 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 @@ -978,55 +1075,69 @@ -- lays within a given interval -- -- RInt returned -zcount :: IsInterval i Double => +zcount :: (IsInterval i Double, BS s) => Redis - -> String -- ^ target key + -> s -- ^ target key -> i -- ^ scores interval - -> IO Reply -zcount r key i = let cmd = i' `seq` ["ZCOUNT", key, from i', to i'] + -> 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 +-- within a given interval. For now this command doesn't supports open +-- and semi-open intervals -- -- RInt returned - the number of elements removed -zremrangebyscore :: Redis - -> String -- ^ target key +zremrangebyscore :: BS s => + Redis + -> s -- ^ target key -> (Double, Double) -- ^ (from, to) pair. zremrangebyscore -- currently doesn't supports -- open intervals - -> IO Reply -zremrangebyscore r key (from, to) = sendCommand r (CMBulk ["ZREMRANGEBYSCORE", key, show from, show to]) >> recv r + -> 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 :: Redis - -> String -- ^ target key - -> IO Reply -zcard r key = sendCommand r (CMBulk ["ZCARD", key]) >> recv r +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 :: Redis - -> String -- ^ target key - -> String -- ^ value - -> IO Reply -zscore r key member = sendCommand r (CMBulk ["ZSCORE", key, member]) >> recv r +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 + -- | Options data type for the 'sort' command -data SortOptions = SortOptions { desc :: Bool, -- ^ sort with descending order - limit :: (Int, Int), -- ^ return (from, to) elements - alpha :: Bool, -- ^ sort alphabetically - sort_by :: String, -- ^ sort by value from this key - get_obj :: [String], -- ^ return this keys values - store :: String -- ^ store result to this key - } +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 +sortDefaults :: SortOptions ByteString sortDefaults = SortOptions { desc = False, limit = takeAll, alpha = False, @@ -1039,66 +1150,69 @@ -- for more information see -- -- RMulti filled with RBulk returned -sort :: Redis - -> String -- ^ target key - -> SortOptions -- ^ options - -> IO Reply +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", (show $ fst $ limit opt), (show $ snd $ limit opt)] + | otherwise = ["LIMIT", (toBS $ fst $ limit opt), (toBS $ snd $ limit opt)] alpha_s | alpha opt = ["ALPHA"] | otherwise = [] sort_by_s - | null $ sort_by opt = [] - | otherwise = ["BY",(sort_by opt)] + | B.null $ toBS (sort_by opt) = [] + | otherwise = ["BY",(toBS $ sort_by opt)] get_obj_s | null $ get_obj opt = [] - | otherwise = "GET" : get_obj opt + | otherwise = "GET" : map toBS (get_obj opt) store_s - | null $ store opt = [] - | otherwise = ["STORE", store opt] + | 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" : key : opt_s)) >> recv r + 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 :: Redis - -> String -- ^ target key - -> String -- ^ key returned +listRelated :: (BS s1, BS s2, BS s3) => + Redis + -> s1 -- ^ related key + -> s2 -- ^ index key -> (Int, Int) -- ^ range - -> IO Reply + -> IO (Reply s3) listRelated r related key l = let opts = sortDefaults { sort_by = "x", - get_obj = [related], + get_obj = [toBS related], limit = l } in sort r key opts -- | Save the whole dataset on disk -- -- ROk returned -save :: Redis -> IO Reply +save :: Redis -> IO (Reply ()) save r = sendCommand r (CInline "SAVE") >> recv r -- | Save the DB in background -- -- ROk returned -bgsave :: Redis -> IO Reply +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 +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 :: Redis -> IO (Reply ()) bgrewriteaof r = sendCommand r (CInline "BGREWRITEAOF") >> recv r diff --git a/Database/Redis/Utils/Lock.hs b/Database/Redis/Utils/Lock.hs --- a/Database/Redis/Utils/Lock.hs +++ b/Database/Redis/Utils/Lock.hs @@ -26,16 +26,18 @@ import Control.Concurrent (threadDelay) import Database.Redis.Redis +import Database.Redis.ByteStringClass import System.Time -- | Acquire lock. This function is not reentrant so thread can be -- locked by itself if it try to acquire the same lock before it was -- released. -acquire :: Redis - -> String -- ^ The lock's name - -> Int -- ^ Timeout in milliseconds. - -> Int -- ^ Time interval between attempts to lock on - -> IO Bool -- ^ True if lock was acquired +acquire :: BS s => + Redis + -> s -- ^ The lock's name + -> Int -- ^ Timeout in milliseconds. + -> Int -- ^ Time interval between attempts to lock on + -> IO Bool -- ^ True if lock was acquired acquire r name 0 _ = acquireOnce r name acquire r name timeout retry_timeout = do res <- acquireOnce r name if res then return True else getClockTime >>= trylock @@ -59,7 +61,7 @@ -- | Release lock. There is no any guarantees that lock was acquired -- in this thread. Just release this lock and go forth. -release :: Redis -> String -> IO () +release :: BS s => Redis -> s -> IO () release r name = del r name >>= noError diffClockTimesMs :: ClockTime -> ClockTime -> Int diff --git a/Database/Redis/Utils/Monad/Lock.hs b/Database/Redis/Utils/Monad/Lock.hs --- a/Database/Redis/Utils/Monad/Lock.hs +++ b/Database/Redis/Utils/Monad/Lock.hs @@ -26,8 +26,9 @@ import Control.Monad.Trans import qualified Database.Redis.Utils.Lock as L import Database.Redis.Monad (WithRedis(..)) +import Database.Redis.ByteStringClass -acquire :: WithRedis m => String -> Int -> Int -> m Bool +acquire :: (WithRedis m, BS s) => s -> Int -> Int -> m Bool acquire name timeout retry_timeout = do r <- getRedis liftIO $ L.acquire r name timeout retry_timeout @@ -36,5 +37,5 @@ acquireOnce name = getRedis >>= liftIO . flip L.acquireOnce name -release :: WithRedis m => String -> m () +release :: (WithRedis m, BS s) => s -> m () release name = getRedis >>= liftIO . flip L.release name diff --git a/redis.cabal b/redis.cabal --- a/redis.cabal +++ b/redis.cabal @@ -1,5 +1,5 @@ Name: redis -Version: 0.2 +Version: 0.3 License: MIT Maintainer: Alexander Bogdanov Author: Alexander Bogdanov @@ -11,7 +11,17 @@ but the dataset is not volatile. Values can be strings, exactly like in memcached, but also lists, sets, and ordered sets. . - This library is a Haskell driver for Redis. + This library is a Haskell driver for Redis. Note that this library + supports the most recent (actually the git one) version of Redis + protocol. Most of the functions will work correctly with stable version + but not all. + . + Changes from v0.2: + . + - (!) A lot of data and function types changed. Now it is posible to get not only + String result but also a ByteString and other. + . + - New protocol functions added: substr, zrank Stability: beta Build-Type: Simple @@ -19,9 +29,10 @@ Library Build-Depends: base < 5, bytestring, utf8-string, - network, mtl, old-time + network, mtl, old-time, binary Exposed-modules: Database.Redis.Redis Database.Redis.Monad + Database.Redis.ByteStringClass Database.Redis.Monad.State Database.Redis.Utils.Lock Database.Redis.Utils.Monad.Lock