diff --git a/Database/Redis/Internal.hs b/Database/Redis/Internal.hs --- a/Database/Redis/Internal.hs +++ b/Database/Redis/Internal.hs @@ -70,6 +70,8 @@ data (BS s) => Message s = MSubscribe s Int | MUnsubscribe s Int + | MPSubscribe s Int + | MPUnsubscribe s Int | MMessage s s deriving Show diff --git a/Database/Redis/Monad.hs b/Database/Redis/Monad.hs --- a/Database/Redis/Monad.hs +++ b/Database/Redis/Monad.hs @@ -41,6 +41,7 @@ -- * Database connection R.localhost, R.defaultPort, connect, disconnect, isConnected, + getServer, getDatabase, -- * Redis commands -- ** Generic @@ -84,7 +85,8 @@ -- ** Publish/Subscribe subscribed, subscribe, unsubscribe, - publish, listen, + psubscribe, punsubscribe, publish, + listen, -- ** Persistent control save, bgsave, lastsave, bgrewriteaof @@ -115,6 +117,12 @@ isConnected :: WithRedis m => m Bool isConnected = getRedis >>= liftIO . R.isConnected +getServer :: WithRedis m => m (String, String) +getServer = getRedis >>= liftIO . R.getServer + +getDatabase :: WithRedis m => m Int +getDatabase = getRedis >>= liftIO . R.getDatabase + ping :: WithRedis m => m (R.Reply ()) ping = getRedis >>= liftIO . R.ping @@ -461,6 +469,12 @@ unsubscribe :: (WithRedis m, BS s1, BS s2) => [s1] -> m [R.Message s2] unsubscribe classes = getRedis >>= liftIO . flip R.unsubscribe classes + +psubscribe :: (WithRedis m, BS s1, BS s2) => [s1] -> m [R.Message s2] +psubscribe classes = getRedis >>= liftIO . flip R.psubscribe classes + +punsubscribe :: (WithRedis m, BS s1, BS s2) => [s1] -> m [R.Message s2] +punsubscribe classes = getRedis >>= liftIO . flip R.punsubscribe classes publish :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int) publish klass msg = 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 @@ -40,6 +40,7 @@ -- * Database connection localhost, defaultPort, connect, disconnect, isConnected, + getServer, getDatabase, -- * Redis commands -- ** Generic @@ -83,7 +84,8 @@ -- ** Publish/Subscribe subscribed, subscribe, unsubscribe, - publish, listen, + psubscribe, punsubscribe, publish, + listen, -- ** Persistent control save, bgsave, lastsave, bgrewriteaof @@ -184,9 +186,11 @@ mtype <- fromRBulk $ head rm' when (isNothing mtype) $ error $ "error parsing message: " ++ (show reply) return $ case fromJust mtype of - "subscribe" -> mksub MSubscribe $ tail rm' - "unsubscribe" -> mksub MUnsubscribe $ tail rm' - "message" -> mkmsg $ tail rm' + "subscribe" -> mksub MSubscribe $ tail rm' + "unsubscribe" -> mksub MUnsubscribe $ tail rm' + "psubscribe" -> mksub MPSubscribe $ tail rm' + "punsubscribe" -> mksub MPUnsubscribe $ tail rm' + "message" -> mkmsg $ tail rm' where mksub f [RBulk (Just k), RInt n] = f (fromBS k) n mkmsg [RBulk (Just k), RBulk (Just msg)] = MMessage (fromBS k) (fromBS msg) @@ -216,6 +220,14 @@ isConnected :: Redis -> IO Bool isConnected = withState' (IO.hIsOpen . handle) +-- | Returns connection host and port +getServer :: Redis -> IO (String, String) +getServer = withState' (return . server) + +-- | Returns currently selected database +getDatabase :: Redis -> IO Int +getDatabase = withState' (return . database) + {- ============ Just commands ============= -} -- | ping - pong -- @@ -1291,51 +1303,90 @@ subscribed :: Redis -> IO Int subscribed r = withState r $ \rs -> return $ isSubscribed rs +recv_ rs ls 0 = return ls +recv_ rs ls n = do l <- recv rs + ll <- recv_ rs ls (n - 1) + return $ l:ll + -- | Subscribe to channels -- -- list of Message with subscribtion information returned subscribe :: (BS s1, BS s2) => Redis - -> [s1] + -> [s1] -- ^ channels to subscribe -> IO [Message s2] subscribe r classes = inState r $ \rs -> do sendCommand rs (CMBulk ("SUBSCRIBE" : map toBS classes)) res <- recv_ rs [] (length classes) >>= mapM parseMessage - let MSubscribe _ n = last res + let !(MSubscribe _ n) = last res return (rs {isSubscribed = n}, res) - where recv_ rs ls 0 = return ls - recv_ rs ls n = do l <- recv rs - ll <- recv_ rs ls (n - 1) - return $ l:ll --- | Unsubscribe from channels +-- | Unsubscribe from channels. If called with an empty list then +-- unsubscribe all channels -- -- list of Message with subscribtion information returned unsubscribe :: (BS s1, BS s2) => Redis - -> [s1] + -> [s1] -- ^ channels to unsubscribe -> IO [Message s2] +unsubscribe r [] = inState r $ \rs -> let subs = isSubscribed rs + in if subs == 0 + then return (rs, []) + else do sendCommand rs (CInline "UNSUBSCRIBE") + res <- recv_ rs [] subs >>= mapM parseMessage + let !(MUnsubscribe _ n) = last res + return (rs {isSubscribed = n}, res) + unsubscribe r classes = inState r $ \rs -> do sendCommand rs (CMBulk ("UNSUBSCRIBE" : map toBS classes)) res <- recv_ rs [] (length classes) >>= mapM parseMessage let !(MUnsubscribe _ n) = last res return (rs {isSubscribed = n}, res) - where recv_ rs ls 0 = return ls - recv_ rs ls n = do l <- recv rs - ll <- recv_ rs ls (n - 1) - return $ l:ll +-- | Subscribe to patterns +-- +-- list of Message with subscribtion information returned +psubscribe :: (BS s1, BS s2) => + Redis + -> [s1] -- ^ patterns to subscribe + -> IO [Message s2] +psubscribe r patterns = inState r $ \rs -> do sendCommand rs (CMBulk ("PSUBSCRIBE" : map toBS patterns)) + res <- recv_ rs [] (length patterns) >>= mapM parseMessage + let !(MPSubscribe _ n) = last res + return (rs {isSubscribed = n}, res) + +-- | Unsubscribe from patterns. If called with an empty list then +-- unsubscribe all patterns +-- +-- list of Message with subscribtion information returned +punsubscribe :: (BS s1, BS s2) => + Redis + -> [s1] -- ^ patterns to unsubscribe + -> IO [Message s2] +punsubscribe r [] = inState r $ \rs -> let subs = isSubscribed rs + in if subs == 0 + then return (rs, []) + else do sendCommand rs (CInline "PUNSUBSCRIBE") + res <- recv_ rs [] subs >>= mapM parseMessage + let !(MPUnsubscribe _ n) = last res + return (rs {isSubscribed = n}, res) + +punsubscribe r patterns = inState r $ \rs -> do sendCommand rs (CMBulk ("PUNSUBSCRIBE" : map toBS patterns)) + res <- recv_ rs [] (length patterns) >>= mapM parseMessage + let !(MPUnsubscribe _ n) = last res + return (rs {isSubscribed = n}, res) + -- | Publish message to target channel -- --- RInt returned - a number of clients +-- RInt returned - a number of clients that recieves the message publish :: (BS s1, BS s2) => Redis - -> s1 - -> s2 + -> s1 -- ^ channel + -> s2 -- ^ message -> IO (Reply Int) publish r klass msg = withState r $ \rs -> sendCommand rs (CMBulk ["PUBLISH", toBS klass, toBS msg]) >> recv rs -- | Wait for a messages. -- --- Important! Client will be blocken untill some message recieved! +-- Important! Client will be blocked untill some message recieved! -- -- Message returned listen :: BS s => diff --git a/redis.cabal b/redis.cabal --- a/redis.cabal +++ b/redis.cabal @@ -1,5 +1,5 @@ Name: redis -Version: 0.5 +Version: 0.5.1 License: MIT Maintainer: Alexander Bogdanov Author: Alexander Bogdanov @@ -20,7 +20,9 @@ . - new hash commands added: hmset, hmget, hincrby . - - initial support for subscribe\/unsubscribe\/publish + - initial support for (p)subscribe\/(p)unsubscribe\/publish + . + - getServer and getDatabase accessors added Stability: beta Build-Type: Simple