redis-0.5.1: Database/Redis/Monad.hs

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

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

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

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

{-# LANGUAGE FlexibleContexts, OverloadedStrings #-}

-- | Monadic wrapper for "Database.Redis.Redis"
module Database.Redis.Monad (
       -- * Types ans Constructors
       WithRedis(..),
       R.Redis(..),
       R.Reply(..),
       R.Message(..),
       R.Interval(..),
       R.IsInterval(..),
       R.SortOptions(..),
       R.Aggregate(..),
       R.sortDefaults,

       R.fromRInline, R.fromRBulk, R.fromRMulti, R.fromRMultiBulk,
       R.fromRInt, R.fromROk, R.noError, R.parseMessage, R.takeAll,

       -- * Database connection
        R.localhost, R.defaultPort,
       connect, disconnect, isConnected,
       getServer, getDatabase,

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

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

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

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

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

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

       -- ** Sorting
       sort, listRelated,

       -- ** Publish/Subscribe
       subscribed, subscribe, unsubscribe,
       psubscribe, punsubscribe, publish,
       listen,

       -- ** 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 Control.Monad.CatchIO

import qualified Database.Redis.Redis as R
import Database.Redis.Redis (IsInterval)
import Database.Redis.ByteStringClass
import qualified Database.Redis.Internal as Internal

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

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

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 ()
shutdown = getRedis >>= liftIO . R.shutdown

multi :: WithRedis m => m (R.Reply ())
multi = getRedis >>= liftIO . R.multi

exec :: (WithRedis m, BS s) => m (R.Reply s)
exec = getRedis >>= liftIO . R.exec

discard :: WithRedis m => m (R.Reply ())
discard = getRedis >>= liftIO . R.discard

run_multi :: (MonadCatchIO m, WithRedis m, BS s) => [m (R.Reply ())] -> m (R.Reply s)
run_multi cs = let cs' = map (>>= R.noError) cs
               in do r <- getRedis
                     bracket (liftIO $ Internal.takeState r)
                             (\_ -> liftIO $ Internal.putStateUnmodified r)
                             (\rs -> do liftIO $ (Internal.sendCommand rs (Internal.CInline "MULTI") >> (Internal.recv rs :: IO (Internal.Reply ())))
                                        sequence_ cs'
                                        liftIO $ Internal.sendCommand rs (Internal.CInline "EXEC")
                                        liftIO $ Internal.recv rs)

exists :: (WithRedis m, BS s) => s -> m (R.Reply Int)
exists key = getRedis >>= liftIO . flip R.exists key

del :: (WithRedis m, BS s) => s -> m (R.Reply Int)
del key = getRedis >>= liftIO . flip R.del key

getType :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2)
getType key = getRedis >>= liftIO . flip R.getType key

keys :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2)
keys pattern = getRedis >>= liftIO . flip R.keys pattern

randomKey :: (WithRedis m, BS s) => m (R.Reply s)
randomKey = getRedis >>= liftIO . R.randomKey

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, 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 Int)
dbsize = getRedis >>= liftIO . R.dbsize

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, BS s) => s -> Int -> m (R.Reply Int)
expireAt key timestamp = do r <- getRedis
                            liftIO $ R.expireAt r key timestamp

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 db = getRedis >>= liftIO . flip R.select db

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 = getRedis >>= liftIO . R.flushDb

flushAll :: WithRedis m => m (R.Reply ())
flushAll = getRedis >>= liftIO . R.flushAll

info :: (WithRedis m, BS s) => m (R.Reply s)
info = getRedis >>= liftIO . R.info

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, 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, BS s1, BS s2) => [(s1, s2)] -> m (R.Reply ())
mSet ks = getRedis >>= liftIO . flip R.mSet ks

mSetNx :: (WithRedis m, BS s1, BS s2) => [(s1, s2)] -> m (R.Reply Int)
mSetNx ks = getRedis >>= liftIO . flip R.mSetNx ks

get :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2)
get key = getRedis >>= liftIO . flip R.get key

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, BS s1, BS s2) => [s1] -> m (R.Reply s2)
mGet keys = getRedis >>= liftIO . flip R.mGet keys

incr :: (WithRedis m, BS s) => s -> m (R.Reply Int)
incr key = getRedis >>= liftIO . flip R.incr key

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, BS s) => s -> m (R.Reply Int)
decr key = getRedis >>= liftIO . flip R.decr key

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, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int)
append key str = do r <- getRedis
                    liftIO $ R.append r key str

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, 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, BS s) => s -> m (R.Reply Int)
llen key = getRedis >>= liftIO . flip R.llen key

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, BS s) => s -> (Int, Int) -> m (R.Reply ())
ltrim key limit = do r <- getRedis
                     liftIO $ R.ltrim r key limit

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, 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, 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, BS s1, BS s2) => s1 -> m (R.Reply s2)
lpop key = getRedis >>= liftIO . flip R.lpop key

rpop :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2)
rpop key = getRedis >>= liftIO . flip R.rpop key

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, 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, 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, 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, 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, BS s1, BS s2) => s1 -> m (R.Reply s2)
spop key = getRedis >>= liftIO . flip R.spop key

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, BS s) => s -> m (R.Reply Int)
scard key = getRedis >>= liftIO . flip R.scard key

sismember :: (WithRedis m, BS s) => s -> m (R.Reply Int)
sismember key = getRedis >>= liftIO . flip R.sismember key

smembers :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2)
smembers key = getRedis >>= liftIO . flip R.smembers key

srandmember :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2)
srandmember key = getRedis >>= liftIO . flip R.srandmember key

sinter :: (WithRedis m, BS s1, BS s2) => [s1] -> m (R.Reply s2)
sinter key = getRedis >>= liftIO . flip R.sinter key

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, BS s1, BS s2) => [s1] -> m (R.Reply s2)
sunion keys = getRedis >>= liftIO . flip R.sunion keys

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, BS s1, BS s2) => [s1] -> m (R.Reply s2)
sdiff keys = getRedis >>= liftIO . flip R.sdiff keys

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, 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, 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, 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, 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, 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, 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, BS s) => s -> i -> m (R.Reply Int)
zcount key limit = do r <- getRedis
                      liftIO $ R.zcount r key limit

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, BS s) => s -> m (R.Reply Int)
zcard key = getRedis >>= liftIO . flip R.zcard key

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

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

zrevrank :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int)
zrevrank key member = do r <- getRedis
                         liftIO $ R.zrevrank r key member

zremrangebyrank :: (WithRedis m, BS s) => s -> (Int, Int) -> m (R.Reply Int)
zremrangebyrank key limit = do r <- getRedis
                               liftIO $ R.zremrangebyrank r key limit

zunion :: (WithRedis m, BS s1, BS s2) => s1 -> [s2] -> [Double] -> R.Aggregate -> m (R.Reply Int)
zunion dst src weights aggregate = do r <- getRedis
                                      liftIO $ R.zunion r dst src weights aggregate

zinter :: (WithRedis m, BS s1, BS s2) => s1 -> [s2] -> [Double] -> R.Aggregate -> m (R.Reply Int)
zinter dst src weights aggregate = do r <- getRedis
                                      liftIO $ R.zinter r dst src weights aggregate

hset :: (WithRedis m, BS s1, BS s2, BS s3) => s1 -> s2 -> s3 -> m (R.Reply Int)
hset key field value = do r <- getRedis
                          liftIO $ R.hset r key field value

hget :: (WithRedis m, BS s1, BS s2, BS s3) => s1 -> s2 -> m (R.Reply s3)
hget key field = do r <- getRedis
                    liftIO $ R.hget r key field

hdel :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int)
hdel key field = do r <- getRedis
                    liftIO $ R.hdel r key field

hmset :: (WithRedis m, BS s1, BS s2, BS s3) => s1 -> [(s2, s3)] -> m (R.Reply ())
hmset key fields = do r <- getRedis
                      liftIO $ R.hmset r key fields

hmget :: (WithRedis m, BS s1, BS s2, BS s3) => s1 -> [s2] -> m (R.Reply s3)
hmget key fields = do r <- getRedis
                      liftIO $ R.hmget r key fields

hincrby :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> Int -> m (R.Reply Int)
hincrby key field n = do r <- getRedis
                         liftIO $ R.hincrby r key field n

hexists :: (WithRedis m, BS s1, BS s2) => s1 -> s2 -> m (R.Reply Int)
hexists key field = do r <- getRedis
                       liftIO $ R.hexists r key field

hlen :: (WithRedis m, BS s) => s -> m (R.Reply Int)
hlen key = do r <- getRedis
              liftIO $ R.hlen r key

hkeys :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2)
hkeys key = do r <- getRedis
               liftIO $ R.hkeys r key

hvals :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2)
hvals key = do r <- getRedis
               liftIO $ R.hvals r key

hgetall :: (WithRedis m, BS s1, BS s2) => s1 -> m (R.Reply s2)
hgetall key = do r <- getRedis
                 liftIO $ R.hgetall r key

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, 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

subscribed :: (WithRedis m) => m Int
subscribed = getRedis >>= liftIO . R.subscribed

subscribe :: (WithRedis m, BS s1, BS s2) => [s1] -> m [R.Message s2]
subscribe classes = getRedis >>= liftIO . flip R.subscribe classes

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
                       liftIO $ R.publish r klass msg

listen :: (WithRedis m, BS s) => m (Maybe (R.Message s))
listen = getRedis >>= liftIO . R.listen

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 Int)
lastsave = getRedis >>= liftIO . R.lastsave

bgrewriteaof :: WithRedis m => m (R.Reply ())
bgrewriteaof = getRedis >>= liftIO . R.bgrewriteaof