diff --git a/Database/Redis/Internal.hs b/Database/Redis/Internal.hs --- a/Database/Redis/Internal.hs +++ b/Database/Redis/Internal.hs @@ -1,13 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} module Database.Redis.Internal where -import Prelude hiding (putStrLn, catch) +import Prelude hiding (putStrLn, putStr, catch) import Control.Concurrent (ThreadId, myThreadId) import Control.Concurrent.MVar import Data.IORef import qualified Network.Socket as S import qualified System.IO as IO -import System.IO.UTF8 (putStrLn) +import System.IO.UTF8 (putStrLn, putStr) import qualified Data.ByteString as B import Data.ByteString (ByteString) import Data.ByteString.Char8 () @@ -19,7 +19,8 @@ import Database.Redis.ByteStringClass -tracebs bs = putStrLn (U.toString bs) +tracebs = putStrLn . U.toString +tracebs' = putStr . U.toString data RedisState = RedisState { server :: (String, String), -- ^ hostname and port pair database :: Int, -- ^ currently selected database diff --git a/Database/Redis/Monad.hs b/Database/Redis/Monad.hs --- a/Database/Redis/Monad.hs +++ b/Database/Redis/Monad.hs @@ -49,7 +49,7 @@ multi, exec, discard, run_multi, exists, del, getType, keys, randomKey, rename, renameNx, dbsize, expire, expireAt, - ttl, select, move, flushDb, + persist, ttl, select, move, flushDb, flushAll, info, -- ** Strings @@ -57,6 +57,7 @@ get, getSet, mGet, incr, incrBy, decr, decrBy, append, substr, + strlen, -- ** Lists rpush, lpush, llen, lrange, ltrim, @@ -208,6 +209,9 @@ expireAt key timestamp = do r <- getRedis liftIO $ R.expireAt r key timestamp +persist :: (WithRedis m, BS s) => s -> m (R.Reply Int) +persist key = getRedis >>= liftIO . flip R.persist key + ttl :: (WithRedis m, BS s) => s -> m (R.Reply Int) ttl key = getRedis >>= liftIO . flip R.ttl key @@ -277,6 +281,9 @@ substr key range = do r <- getRedis liftIO $ R.substr r key range +strlen :: (WithRedis m, BS s) => s -> m (R.Reply Int) +strlen key = getRedis >>= liftIO . flip R.strlen key + 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 @@ -395,9 +402,9 @@ zrevrange key limit withscores = do r <- getRedis liftIO $ R.zrevrange r key limit withscores -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 +zrangebyscore :: (WithRedis m, IsInterval i Double, BS s1, BS s2) => s1 -> i -> Maybe (Int, Int) -> Bool -> m (R.Reply s2) +zrangebyscore key i limit withscores = do r <- getRedis + liftIO $ R.zrangebyscore r key i limit withscores zcount :: (WithRedis m, IsInterval i Double, BS s) => s -> i -> m (R.Reply Int) zcount key limit = do r <- getRedis diff --git a/Database/Redis/Redis.hs b/Database/Redis/Redis.hs --- a/Database/Redis/Redis.hs +++ b/Database/Redis/Redis.hs @@ -49,7 +49,7 @@ watch, unwatch, run_cas, exists, del, getType, keys, randomKey, rename, renameNx, dbsize, expire, expireAt, - ttl, select, move, flushDb, + persist, ttl, select, move, flushDb, flushAll, info, -- ** Strings @@ -57,6 +57,7 @@ get, getSet, mGet, incr, incrBy, decr, decrBy, append, substr, + strlen, -- ** Lists rpush, lpush, llen, lrange, ltrim, @@ -100,7 +101,9 @@ import qualified Data.ByteString as B import Data.ByteString (ByteString) import Data.Maybe (fromJust, isNothing) +import Data.List (intersperse) import Control.Monad (when) +import Control.Exception (onException) import Database.Redis.ByteStringClass import Database.Redis.Internal @@ -281,11 +284,12 @@ -> [IO (Reply ())] -- ^ IO actions to run -> IO (Reply s) run_multi r cs = let cs' = map (>>= noError) cs - in withState' (\rs -> do sendCommand rs (CInline "MULTI") - (recv rs :: IO (Reply ())) >>= fromROk - sequence_ cs' - sendCommand rs (CInline "EXEC") - recv rs) r + in withState r (\rs -> do sendCommand rs (CInline "MULTI") + (recv rs :: IO (Reply ())) >>= fromROk + (sequence_ cs') `onException` do sendCommand rs (CInline "DISCARD") + recv rs :: IO (Reply ()) + sendCommand rs (CInline "EXEC") + recv rs) -- | Add keys to a watch list for Check-and-Set operation. -- @@ -321,7 +325,9 @@ run_cas r keys cs = let keys' = map toBS keys in withState r (\rs -> do sendCommand rs (CMBulk ("WATCH" : keys')) (recv rs :: IO (Reply ())) >>= fromROk - res <- cs + res <- cs `onException` do sendCommand rs (CInline "DISCARD") + sendCommand rs (CInline "UNWATCH") + recv rs :: IO (Reply ()) sendCommand rs (CInline "UNWATCH") (recv rs :: IO (Reply ())) >>= fromROk return res) @@ -420,6 +426,15 @@ -> IO (Reply Int) expireAt r key timestamp = withState r (\rs -> sendCommand rs (CMBulk ["EXPIREAT", toBS key, toBS timestamp]) >> recv rs) +-- | Remove the timeout from a key +-- +-- (RInt 1) returned if the timeout was removed and (RInt 0) otherwise +persist :: BS s => + Redis + -> s -- ^ target key + -> IO (Reply Int) +persist r key = withState r (\rs -> sendCommand rs (CMBulk ["PERSIST", toBS key]) >> recv rs) + -- | Return the remining time to live of the key or -1 if key has no -- associated timeout -- @@ -591,7 +606,7 @@ -- RInt returned with new key value decrBy :: BS s => Redis - -> s -- ^ target key + -> s -- ^ target key -> Int -- ^ decrement -> IO (Reply Int) decrBy r key n = withState r (\rs -> sendCommand rs (CMBulk ["DECRBY", toBS key, toBS n]) >> recv rs) @@ -611,11 +626,20 @@ -- RBulk returned substr :: (BS s1, BS s2) => Redis - -> s1 - -> (Int, Int) + -> s1 -- ^ traget key + -> (Int, Int) -- ^ (start, end) -> IO (Reply s2) substr r key (from, to) = withState r (\rs -> sendCommand rs (CMBulk ["SUBSTR", toBS key, toBS from, toBS to]) >> recv rs) +-- | Returns a length of a string-typed key +-- +-- RInt returned +strlen :: BS s => + Redis + -> s -- ^ target key + -> IO (Reply Int) +strlen r key = withState r (\rs -> sendCommand rs (CMBulk ["STRLEN", toBS key]) >> recv rs) + -- | Add string value to the head of the list-type key. New list -- length returned -- @@ -1032,15 +1056,17 @@ -- RMulti filled with RBulk returned zrangebyscore :: (IsInterval i Double, BS s1, BS s2) => Redis - -> s1 -- ^ target key - -> i -- ^ scores interval - -> Bool -- ^ withscores option + -> s1 -- ^ target key + -> i -- ^ scores interval + -> Maybe (Int, Int) -- ^ limits (offset, count) + -> 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` withState r (\rs -> sendCommand rs (CMBulk cmd) >> recv rs) +zrangebyscore r key i limit withscores = let cmd' = i' `seq` ["ZRANGEBYSCORE", toBS key, toBS (from i'), toBS (to i')] + cmd'' = maybe cmd' (\(a, b) -> cmd' ++ ["LIMIT", toBS a, toBS b]) limit + cmd | withscores = cmd'' ++ ["WITHSCORES"] + | otherwise = cmd'' + i' = toInterval i + in cmd `seq` withState r (\rs -> sendCommand rs (CMBulk cmd) >> recv rs) -- | Count a number of elements of the sorted set with a score that -- lays within a given interval @@ -1339,7 +1365,7 @@ | otherwise = ["BY",(toBS $ sort_by opt)] get_obj_s | null $ get_obj opt = [] - | otherwise = "GET" : map toBS (get_obj opt) + | otherwise = "GET" : (intersperse "GET" . map toBS $ get_obj opt) store_s | B.null $ toBS (store opt) = [] | otherwise = ["STORE", toBS $ store opt] diff --git a/redis.cabal b/redis.cabal --- a/redis.cabal +++ b/redis.cabal @@ -1,5 +1,5 @@ Name: redis -Version: 0.7.2 +Version: 0.8 License: MIT Maintainer: Alexander Bogdanov Author: Alexander Bogdanov @@ -16,15 +16,13 @@ protocol. Most of the functions will work correctly with stable version but not all. . - Changes from v0.6: - . - - new commands added: watch, unwatch + Changes from v0.7: . - - new batch command: run_cas + - new commands added: strlen, persist . - - fixed bug with expireAt - thanks to Alex Suraci + - zrangebyscore now supports LIMIT argument. Warning! Backward incompatible change! . - - fixed bug with sismember - thanks to Michael Snoyman + - fixed behaviour of sort with multiple GET keys . Stability: beta