redis (empty) → 0.1
raw patch · 7 files changed
+1542/−0 lines, 7 filesdep +basedep +bytestringdep +mtlsetup-changed
Dependencies added: base, bytestring, mtl, network, old-time, utf8-string
Files
- Database/Redis/Monad.hs +353/−0
- Database/Redis/Monad/State.hs +17/−0
- Database/Redis/Redis.hs +1076/−0
- Database/Redis/Utils/Lock.hs +44/−0
- Database/Redis/Utils/Monad/Lock.hs +22/−0
- Setup.lhs +3/−0
- redis.cabal +27/−0
+ Database/Redis/Monad.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE FlexibleContexts #-}++-- | Monadic wrapper for "Database.Redis.Redis"+module Database.Redis.Monad (+ -- * Types ans Constructors+ WithRedis(..),+ R.Redis(..),+ R.Reply(..),+ R.Interval(..),+ R.IsInterval(..),+ R.SortOptions(..),+ R.sortDefaults,++ R.fromRInline, R.fromRBulk, R.fromRMulti, R.fromRMultiBulk,+ R.fromRInt, R.fromROk, R.noError, R.takeAll,++ -- * Database connection+ R.localhost, R.defaultPort,+ connect, disconnect, isConnected,++ -- * Redis commands+ -- ** Generic+ ping, auth, quit, shutdown,+ multi, exec, 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,++ -- ** 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,++ -- ** Sorting+ sort, listRelated,++ -- ** Persistent control+ save, bgsave, lastsave, bgrewriteaof+)+where++import Control.Monad.Trans+import qualified Control.Monad.State as St+import Control.Monad.State (StateT(..))+import Control.Applicative++import qualified Database.Redis.Redis as R+import Database.Redis.Redis (IsInterval)++class MonadIO m => WithRedis m where+ getRedis :: m (R.Redis)+ setRedis :: R.Redis -> m ()++connect :: WithRedis m => String -> String -> m ()+connect host port = liftIO (R.connect host port) >>= setRedis++disconnect :: WithRedis m => m ()+disconnect = getRedis >>= liftIO . R.disconnect++isConnected :: WithRedis m => m Bool+isConnected = getRedis >>= liftIO . R.isConnected++ping :: WithRedis m => m R.Reply+ping = getRedis >>= liftIO . R.ping++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 = getRedis >>= liftIO . R.shutdown++multi :: WithRedis m => m R.Reply+multi = getRedis >>= liftIO . R.multi++exec :: WithRedis m => m R.Reply+exec = getRedis >>= liftIO . R.exec++run_multi :: WithRedis m => [m R.Reply] -> m R.Reply+run_multi cs = let cs' = map (>>= R.noError) cs+ in do multi+ sequence_ cs'+ exec++exists :: WithRedis m => String -> m R.Reply+exists key = getRedis >>= liftIO . flip R.exists key++del :: WithRedis m => String -> m R.Reply+del key = getRedis >>= liftIO . flip R.del key++getType :: WithRedis m => String -> m R.Reply+getType key = getRedis >>= liftIO . flip R.getType key++keys :: WithRedis m => String -> m R.Reply+keys pattern = getRedis >>= liftIO . flip R.keys pattern++randomKey :: WithRedis m => m R.Reply+randomKey = getRedis >>= liftIO . R.randomKey++rename :: WithRedis m => String -> String -> m R.Reply+rename from to = do r <- getRedis+ liftIO $ R.rename r from to++renameNx :: WithRedis m => String -> String -> m R.Reply+renameNx from to = do r <- getRedis+ liftIO $ R.renameNx r from to++dbsize :: WithRedis m => m R.Reply+dbsize = getRedis >>= liftIO . R.dbsize++expire :: WithRedis m => String -> Int -> m R.Reply+expire key seconds = do r <- getRedis+ liftIO $ R.expire r key seconds++expireAt :: WithRedis m => String -> Int -> m R.Reply+expireAt key timestamp = do r <- getRedis+ liftIO $ R.expireAt r key timestamp++ttl :: WithRedis m => String -> m R.Reply+ttl key = getRedis >>= liftIO . flip R.ttl key++select :: WithRedis m => Int -> m R.Reply+select db = getRedis >>= liftIO . flip R.select db++move :: WithRedis m => String -> Int -> m R.Reply+move key db = do r <- getRedis+ liftIO $ R.move r key db++flushDb :: WithRedis m => m R.Reply+flushDb = getRedis >>= liftIO . R.flushDb++flushAll :: WithRedis m => m R.Reply+flushAll = getRedis >>= liftIO . R.flushAll++info :: WithRedis m => m R.Reply+info = getRedis >>= liftIO . R.info++set :: WithRedis m => String -> String -> m R.Reply+set key val = do r <- getRedis+ liftIO $ R.set r key val++setNx :: WithRedis m => String -> String -> m R.Reply+setNx key val = do r <- getRedis+ liftIO $ R.setNx r key val++mSet :: WithRedis m => [(String, String)] -> m R.Reply+mSet ks = getRedis >>= liftIO . flip R.mSet ks++mSetNx :: WithRedis m => [(String, String)] -> m R.Reply+mSetNx ks = getRedis >>= liftIO . flip R.mSetNx ks++get :: WithRedis m => String -> m R.Reply+get key = getRedis >>= liftIO . flip R.get key++getSet :: WithRedis m => String -> String -> m R.Reply+getSet key val = do r <- getRedis+ liftIO $ R.getSet r key val++mGet :: WithRedis m => [String] -> m R.Reply+mGet keys = getRedis >>= liftIO . flip R.mGet keys++incr :: WithRedis m => String -> m R.Reply+incr key = getRedis >>= liftIO . flip R.incr key++incrBy :: WithRedis m => String -> Int -> m R.Reply+incrBy key n = do r <- getRedis+ liftIO $ R.incrBy r key n++decr :: WithRedis m => String -> m R.Reply+decr key = getRedis >>= liftIO . flip R.decr key++decrBy :: WithRedis m => String -> Int -> m R.Reply+decrBy key n = do r <- getRedis+ liftIO $ R.decrBy r key n++append :: WithRedis m => String -> String -> m R.Reply+append key str = do r <- getRedis+ liftIO $ R.append r key str++rpush :: WithRedis m => String -> String -> m R.Reply+rpush key val = do r <- getRedis+ liftIO $ R.rpush r key val++lpush :: WithRedis m => String -> String -> m R.Reply+lpush key val = do r <- getRedis+ liftIO $ R.lpush r key val++llen :: WithRedis m => String -> m R.Reply+llen key = getRedis >>= liftIO . flip R.llen key++lrange :: WithRedis m => String -> (Int, Int) -> m R.Reply+lrange key limit = do r <- getRedis+ liftIO $ R.lrange r key limit++ltrim :: WithRedis m => String -> (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 key index = do r <- getRedis+ liftIO $ R.lindex r key index++lset :: WithRedis m => String -> Int -> String -> 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 key count value = do r <- getRedis+ liftIO $ R.lrem r key count value++lpop :: WithRedis m => String -> m R.Reply+lpop key = getRedis >>= liftIO . flip R.lpop key++rpop :: WithRedis m => String -> m R.Reply+rpop key = getRedis >>= liftIO . flip R.rpop key++rpoplpush :: WithRedis m => String -> String -> m R.Reply+rpoplpush src dst = do r <- getRedis+ liftIO $ R.rpoplpush r src dst++blpop :: WithRedis m => [String] -> Int -> m R.Reply+blpop keys timeout = do r <- getRedis+ liftIO $ R.blpop r keys timeout++brpop :: WithRedis m => [String] -> Int -> m R.Reply+brpop keys timeout = do r <- getRedis+ liftIO $ R.brpop r keys timeout++sadd :: WithRedis m => String -> String -> m R.Reply+sadd key val = do r <- getRedis+ liftIO $ R.sadd r key val++srem :: WithRedis m => String -> String -> m R.Reply+srem key val = do r <- getRedis+ liftIO $ R.srem r key val++spop :: WithRedis m => String -> m R.Reply+spop key = getRedis >>= liftIO . flip R.spop key++smove :: WithRedis m => String -> String -> String -> m R.Reply+smove src dst member = do r <- getRedis+ liftIO $ R.smove r src dst member++scard :: WithRedis m => String -> m R.Reply+scard key = getRedis >>= liftIO . flip R.scard key++sismember :: WithRedis m => String -> m R.Reply+sismember key = getRedis >>= liftIO . flip R.sismember key++smembers :: WithRedis m => String -> m R.Reply+smembers key = getRedis >>= liftIO . flip R.smembers key++srandmember :: WithRedis m => String -> m R.Reply+srandmember key = getRedis >>= liftIO . flip R.srandmember key++sinter :: WithRedis m => [String] -> m R.Reply+sinter key = getRedis >>= liftIO . flip R.sinter key++sinterStore :: WithRedis m => String -> [String] -> m R.Reply+sinterStore dst keys = do r <- getRedis+ liftIO $ R.sinterStore r dst keys++sunion :: WithRedis m => [String] -> m R.Reply+sunion keys = getRedis >>= liftIO . flip R.sunion keys++sunionStore :: WithRedis m => String -> [String] -> m R.Reply+sunionStore dst keys = do r <- getRedis+ liftIO $ R.sunionStore r dst keys++sdiff :: WithRedis m => [String] -> m R.Reply+sdiff keys = getRedis >>= liftIO . flip R.sdiff keys++sdiffStore :: WithRedis m => String -> [String] -> 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 key score member = do r <- getRedis+ liftIO $ R.zadd r key score member++zrem :: WithRedis m => String -> String -> m R.Reply+zrem key member = do r <- getRedis+ liftIO $ R.zrem r key member++zincrBy :: WithRedis m => String -> Double -> String -> m R.Reply+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 key limit withscores = do r <- getRedis+ liftIO $ R.zrange r key limit withscores++zrevrange :: WithRedis m => String -> (Int, Int) -> Bool -> m R.Reply+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 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 key limit = do r <- getRedis+ liftIO $ R.zcount r key limit++zremrangebyscore :: WithRedis m => String -> (Double, Double) -> m R.Reply+zremrangebyscore key limit = do r <- getRedis+ liftIO $ R.zremrangebyscore r key limit++zcard :: WithRedis m => String -> m R.Reply+zcard key = getRedis >>= liftIO . flip R.zcard key++zscore :: WithRedis m => String -> String -> m R.Reply+zscore key member = do r <- getRedis+ liftIO $ R.zscore r key member++sort :: WithRedis m => String -> R.SortOptions -> m R.Reply+sort key opt = do r <- getRedis+ liftIO $ R.sort r key opt++listRelated :: WithRedis m => String -> String -> (Int, Int) -> m R.Reply+listRelated related key l = do r <- getRedis+ liftIO $ R.listRelated r related key l++save :: WithRedis m => m R.Reply+save = getRedis >>= liftIO . R.save++bgsave :: WithRedis m => m R.Reply+bgsave = getRedis >>= liftIO . R.bgsave++lastsave :: WithRedis m => m R.Reply+lastsave = getRedis >>= liftIO . R.lastsave++bgrewriteaof :: WithRedis m => m R.Reply+bgrewriteaof = getRedis >>= liftIO . R.bgrewriteaof
+ Database/Redis/Monad/State.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE TypeSynonymInstances #-}+-- | This module is mainly an example of posible 'WithRedis'+-- implementation+module Database.Redis.Monad.State where++import Control.Monad.State+import Database.Redis.Monad (WithRedis(..), Redis)++-- | Trivial WithRedis instance storing Redis descriptor in StateT+type RedisM = StateT Redis IO++instance WithRedis RedisM where+ getRedis = get+ setRedis = put++runWithRedis :: Redis -> (RedisM a) -> IO a+runWithRedis = flip evalStateT
+ Database/Redis/Redis.hs view
@@ -0,0 +1,1076 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, FlexibleContexts #-}++-- | Main Redis API and protocol implementation+module Database.Redis.Redis (+ -- * Types ans Constructors+ Redis(..),+ Reply(..),+ Interval(..),+ IsInterval(..),+ SortOptions(..),+ 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, 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,++ -- ** 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,++ -- ** Sorting+ sort, listRelated,++ -- ** Persistent control+ save, bgsave, lastsave, bgrewriteaof+)+where++import qualified Network.Socket as S+import qualified System.IO as IO+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as U+import Data.Maybe (fromJust)++-- | 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 String+ | CMInline [String]+ | CBulk [String] String+ | CMBulk [String]++-- | 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)++-- | Unwraps RInline reply.+--+-- Throws an exception when called with something different from RInline+fromRInline :: (Monad m) => Reply -> m String+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) => Reply -> m (Maybe String)+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) => Reply -> m (Maybe [Reply])+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) => Reply -> m (Maybe [Maybe String])+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 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) => Reply -> 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) => Reply -> 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 -> [String] -> 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++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 (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 (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+ 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+ where+ h = handle r+ bsToStr = (takeWhile (\c -> c /= '\r' && c /= '\n')) . U.toString++ recv_err :: String -> IO Reply+ recv_err rest = return $ RError rest++ recv_inline :: String -> IO Reply+ recv_inline rest = return $ case rest of+ "OK" -> ROk+ "PONG" -> RPong+ "QUEUED" -> RQueued+ _ -> RInline rest++ recv_int :: String -> IO Reply+ recv_int rest = let reply = read rest :: Int+ in return $ RInt reply++ recv_bulk :: String -> IO Reply+ recv_bulk rest = let size = read rest :: Int+ in do body <- recv_bulk_body size+ return $ RBulk body++ recv_bulk_body :: Int -> IO (Maybe String)+ 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+ return $ Just reply++ recv_multi :: String -> IO Reply+ recv_multi rest = let cnt = read 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 :: Redis+ -> String -- ^ password+ -> IO Reply+auth r pwd = sendCommand r (CMInline ["AUTH", 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++-- | 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 :: Redis -> IO Reply+exec r = sendCommand r (CInline "EXEC") >> 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 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 :: Redis+ -> String -- ^ target key+ -> IO Reply+exists r key = sendCommand r (CMBulk ["EXISTS", 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++-- | 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++-- | Returns all the keys matching the glob-style pattern as space separated strings+--+-- RBulk returned+keys :: Redis+ -> String -- ^ target key+ -> IO Reply+keys r pattern = sendCommand r (CMInline ["KEYS", pattern]) >> recv r++-- | Return random key name+--+-- RInline returned+randomKey :: Redis -> IO Reply+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 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++-- | Get the number of keys in the currently selected database+--+-- RInt returned+dbsize :: Redis -> IO Reply+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 :: Redis+ -> String -- ^ target key+ -> Int -- ^ timeout in seconds+ -> IO Reply+expire r key seconds = sendCommand r (CMBulk ["EXPIRE", key, show 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 :: Redis+ -> String -- ^ target key+ -> Int -- ^ timeout in seconds+ -> IO Reply+expireAt r key timestamp = sendCommand r (CMBulk ["EXPIRE", key, show 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++-- | 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++-- | 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+ -> Int -- ^ destination database number+ -> IO Reply+move r key db = sendCommand r (CMBulk ["MOVE", key, show 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 :: Redis -> IO Reply+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 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++-- | Atomically set multiple keys+--+-- ROk returned+mSet :: Redis+ -> [(String, String)] -- ^ (key, value) pairs+ -> IO Reply+mSet r ks = let interlace' [] ls = ls+ interlace' ((a, b):rest) ls = interlace' rest (a: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 r ks = let interlace' [] ls = ls+ interlace' ((a, b):rest) ls = interlace' rest (a: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++-- | 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++-- | 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++-- | 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++-- | Increment the key value by N+--+-- RInt returned with new key value+incrBy :: Redis+ -> String -- ^ target key+ -> Int -- ^ increment+ -> IO Reply+incrBy r key n = sendCommand r (CMBulk ["INCRBY", key, show 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++-- | Decrement the key value by N+--+-- RInt returned with new key value+decrBy :: Redis+ -> String -- ^ target key+ -> Int -- ^ decrement+ -> IO Reply+decrBy r key n = sendCommand r (CMBulk ["DECRBY", key, show 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++-- | Add string value to the head of the list-type key+--+-- 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++-- | Add string value to the tail of the list-type key+--+-- 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++-- | 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++-- | 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 :: Redis+ -> String -- ^ 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++-- | Trim list so that it will contain only the specified range of elements.+--+-- ROk returned+ltrim :: Redis+ -> String -- ^ 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++-- | Return the specified element of the list by its index+--+-- RBulk returned+lindex :: Redis+ -> String -- ^ target key+ -> Int -- ^ index+ -> IO Reply+lindex r key index = sendCommand r (CMBulk ["LINDEX", key, show 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++-- | Remove the first /count/ occurrences of the /value/ element from the list+--+-- RInt returned - the number of elements removed+lrem :: Redis+ -> String -- ^ target key+ -> Int -- ^ occurrences+ -> String -- ^ value+ -> IO Reply+lrem r key count value = sendCommand r (CMBulk ["LREM", key, show count, 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++-- | 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++-- | 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++-- | Blocking lpop+--+-- For more information see <http://code.google.com/p/redis/wiki/BlpopCommand>+--+-- RMulti returned filled with key name and popped value+blpop :: Redis+ -> [String] -- ^ keys list+ -> Int -- ^ timeout+ -> IO Reply+blpop r keys timeout = sendCommand r (CMBulk (("BLPOP" : keys) ++ [show 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 :: Redis+ -> [String] -- ^ keys list+ -> Int -- ^ timeout+ -> IO Reply+brpop r keys timeout = sendCommand r (CMBulk (("BRPOP" : keys) ++ [show 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++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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++-- | 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 :: Redis+ -> String -- ^ target key+ -> Double -- ^ score+ -> String -- ^ value+ -> IO Reply+zadd r key score member = sendCommand r (CMBulk ["ZADD", key, show score, 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++-- | 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 :: Redis+ -> String -- ^ target key+ -> Double -- ^ increment+ -> String -- ^ value+ -> IO Reply+zincrBy r key increment member = sendCommand r (CMBulk ["ZINCRBY", key, show increment, 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 :: Redis+ -> String -- ^ 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]+ 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 :: Redis+ -> String -- ^ 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]+ 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 =>+ Redis+ -> String -- ^ 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']+ 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 =>+ Redis+ -> String -- ^ target key+ -> i -- ^ scores interval+ -> IO Reply+zcount r key i = let cmd = i' `seq` ["ZCOUNT", key, from i', 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+--+-- RInt returned - the number of elements removed+zremrangebyscore :: Redis+ -> String -- ^ 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++-- | 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++-- | 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++-- | 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+ }++-- | Default options for the 'sort' command+sortDefaults :: SortOptions+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 :: Redis+ -> String -- ^ target key+ -> SortOptions -- ^ options+ -> IO Reply+sort r key opt = let opt_s = buildOptions opt+ 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)]+ alpha_s+ | alpha opt = ["ALPHA"]+ | otherwise = []+ sort_by_s+ | null $ sort_by opt = []+ | otherwise = ["BY",(sort_by opt)]+ get_obj_s+ | null $ get_obj opt = []+ | otherwise = "GET" : get_obj opt+ store_s+ | null $ store opt = []+ | otherwise = ["STORE", 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++-- | 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+ -> (Int, Int) -- ^ range+ -> IO Reply+listRelated r related key l = let opts = sortDefaults { sort_by = "x",+ get_obj = [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+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
+ Database/Redis/Utils/Lock.hs view
@@ -0,0 +1,44 @@+-- | Emulating locking primitives+module Database.Redis.Utils.Lock ( acquire, acquire', acquireOnce, release )+where++import Control.Concurrent (threadDelay)+import Database.Redis.Redis+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 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++ where trylock t = do now <- getClockTime+ if diffClockTimesMs t now >= timeout+ then return False+ else do res <- acquireOnce r name+ if res+ then return True+ else threadDelay rt >> trylock t++ rt = retry_timeout * 1000++-- | acquire with default last parameter set to 50 milliseconds+acquire' r name timeout = acquire r name timeout 50++-- | Try to acquire lock once and return result without any timeout+acquireOnce r name = do res <- setNx r name "1" >>= fromRInt+ return (res == 1)++-- | 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 r name = del r name >>= noError++diffClockTimesMs :: ClockTime -> ClockTime -> Int+diffClockTimesMs (TOD t1s t1m) (TOD t2s t2m) = fromIntegral $ (t2s - t1s) * 1000 + (t2m - t1m) `div` 1000000000
+ Database/Redis/Utils/Monad/Lock.hs view
@@ -0,0 +1,22 @@+-- | Same as "Database.Redis.Utils.Lock" but with monadic wrapped+module Database.Redis.Utils.Monad.Lock (acquire, acquire', acquireOnce, release) where++import Control.Monad.Trans+import qualified Database.Redis.Utils.Lock as L+import Database.Redis.Monad (WithRedis(..))++{-+ timeout - сколько пытаться захватить лок, ms+ retry_timeout - сколько ждать между попытками, ms+ -}+acquire :: WithRedis m => String -> Int -> Int -> m Bool+acquire name timeout retry_timeout =+ do r <- getRedis+ liftIO $ L.acquire r name timeout retry_timeout++acquire' name timeout = acquire name timeout 1++acquireOnce name = getRedis >>= liftIO . flip L.acquireOnce name++release :: WithRedis m => String -> m ()+release name = getRedis >>= liftIO . flip L.release name
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ redis.cabal view
@@ -0,0 +1,27 @@+Name: redis+Version: 0.1+License: MIT+Maintainer: Alexander Bogdanov <andorn@gmail.com>+Author: Alexander Bogdanov <andorn@gmail.com>+Copyright: Copyright (c) 2009-2010 Alexander Bogdanov+Category: Database+Synopsis: A driver for Redis key-value database+Description:+ Redis is an advanced key-value store. It is similar to memcached+ 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.++Stability: beta+Build-Type: Simple+Cabal-Version: >= 1.4++Library+ Build-Depends: base < 5, bytestring, utf8-string,+ network, mtl, old-time+ Exposed-modules: Database.Redis.Redis+ Database.Redis.Monad+ Database.Redis.Monad.State+ Database.Redis.Utils.Lock+ Database.Redis.Utils.Monad.Lock