{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE CPP, OverloadedStrings, FlexibleInstances, MultiParamTypeClasses,
    GeneralizedNewtypeDeriving #-}

module Database.Redis.Transactions (
    watch, unwatch, multiExec,
    Queued(), TxResult(..), RedisTx(),
) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Monad.State.Strict
import Control.DeepSeq
import GHC.Generics
import Data.ByteString (ByteString)
import Data.Vector (Vector, fromList, (!))

import Database.Redis.Core
import Database.Redis.Protocol
import Database.Redis.Types


-- |Command-context inside of MULTI\/EXEC transactions. Use 'multiExec' to run
--  actions of this type.
--
--  In the 'RedisTx' context, all commands return a 'Queued' value. It is a
--  proxy object for the /actual/ result, which will only be available after
--  finishing the transaction.
newtype RedisTx a = RedisTx (StateT Int Redis a)
    deriving (Applicative RedisTx
forall a. a -> RedisTx a
forall a b. RedisTx a -> RedisTx b -> RedisTx b
forall a b. RedisTx a -> (a -> RedisTx b) -> RedisTx b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> RedisTx a
$creturn :: forall a. a -> RedisTx a
>> :: forall a b. RedisTx a -> RedisTx b -> RedisTx b
$c>> :: forall a b. RedisTx a -> RedisTx b -> RedisTx b
>>= :: forall a b. RedisTx a -> (a -> RedisTx b) -> RedisTx b
$c>>= :: forall a b. RedisTx a -> (a -> RedisTx b) -> RedisTx b
Monad, Monad RedisTx
forall a. IO a -> RedisTx a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> RedisTx a
$cliftIO :: forall a. IO a -> RedisTx a
MonadIO, forall a b. a -> RedisTx b -> RedisTx a
forall a b. (a -> b) -> RedisTx a -> RedisTx b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> RedisTx b -> RedisTx a
$c<$ :: forall a b. a -> RedisTx b -> RedisTx a
fmap :: forall a b. (a -> b) -> RedisTx a -> RedisTx b
$cfmap :: forall a b. (a -> b) -> RedisTx a -> RedisTx b
Functor, Functor RedisTx
forall a. a -> RedisTx a
forall a b. RedisTx a -> RedisTx b -> RedisTx a
forall a b. RedisTx a -> RedisTx b -> RedisTx b
forall a b. RedisTx (a -> b) -> RedisTx a -> RedisTx b
forall a b c. (a -> b -> c) -> RedisTx a -> RedisTx b -> RedisTx c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. RedisTx a -> RedisTx b -> RedisTx a
$c<* :: forall a b. RedisTx a -> RedisTx b -> RedisTx a
*> :: forall a b. RedisTx a -> RedisTx b -> RedisTx b
$c*> :: forall a b. RedisTx a -> RedisTx b -> RedisTx b
liftA2 :: forall a b c. (a -> b -> c) -> RedisTx a -> RedisTx b -> RedisTx c
$cliftA2 :: forall a b c. (a -> b -> c) -> RedisTx a -> RedisTx b -> RedisTx c
<*> :: forall a b. RedisTx (a -> b) -> RedisTx a -> RedisTx b
$c<*> :: forall a b. RedisTx (a -> b) -> RedisTx a -> RedisTx b
pure :: forall a. a -> RedisTx a
$cpure :: forall a. a -> RedisTx a
Applicative)

runRedisTx :: RedisTx a -> Redis a
runRedisTx :: forall a. RedisTx a -> Redis a
runRedisTx (RedisTx StateT Int Redis a
r) = forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT StateT Int Redis a
r Int
0

instance MonadRedis RedisTx where
    liftRedis :: forall a. Redis a -> RedisTx a
liftRedis = forall a. StateT Int Redis a -> RedisTx a
RedisTx forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance RedisCtx RedisTx Queued where
    returnDecode :: forall a. RedisResult a => Reply -> RedisTx (Queued a)
returnDecode Reply
_queued = forall a. StateT Int Redis a -> RedisTx a
RedisTx forall a b. (a -> b) -> a -> b
$ do
        -- future index in EXEC result list
        Int
i <- forall s (m :: * -> *). MonadState s m => m s
get
        forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
iforall a. Num a => a -> a -> a
+Int
1)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (Vector Reply -> Either Reply a) -> Queued a
Queued (forall a. RedisResult a => Reply -> Either Reply a
decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Vector a -> Int -> a
! Int
i))

-- |A 'Queued' value represents the result of a command inside a transaction. It
--  is a proxy object for the /actual/ result, which will only be available
--  after returning from a 'multiExec' transaction.
--
--  'Queued' values are composable by utilizing the 'Functor', 'Applicative' or
--  'Monad' interfaces.
data Queued a = Queued (Vector Reply -> Either Reply a)

instance Functor Queued where
    fmap :: forall a b. (a -> b) -> Queued a -> Queued b
fmap a -> b
f (Queued Vector Reply -> Either Reply a
g) = forall a. (Vector Reply -> Either Reply a) -> Queued a
Queued (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Reply -> Either Reply a
g)

instance Applicative Queued where
    pure :: forall a. a -> Queued a
pure a
x                = forall a. (Vector Reply -> Either Reply a) -> Queued a
Queued (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right a
x)
    Queued Vector Reply -> Either Reply (a -> b)
f <*> :: forall a b. Queued (a -> b) -> Queued a -> Queued b
<*> Queued Vector Reply -> Either Reply a
x = forall a. (Vector Reply -> Either Reply a) -> Queued a
Queued forall a b. (a -> b) -> a -> b
$ \Vector Reply
rs -> do
                                        a -> b
f' <- Vector Reply -> Either Reply (a -> b)
f Vector Reply
rs
                                        a
x' <- Vector Reply -> Either Reply a
x Vector Reply
rs
                                        forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f' a
x')

instance Monad Queued where
    return :: forall a. a -> Queued a
return         = forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Queued Vector Reply -> Either Reply a
x >>= :: forall a b. Queued a -> (a -> Queued b) -> Queued b
>>= a -> Queued b
f = forall a. (Vector Reply -> Either Reply a) -> Queued a
Queued forall a b. (a -> b) -> a -> b
$ \Vector Reply
rs -> do
                                a
x' <- Vector Reply -> Either Reply a
x Vector Reply
rs
                                let Queued Vector Reply -> Either Reply b
f' = a -> Queued b
f a
x'
                                Vector Reply -> Either Reply b
f' Vector Reply
rs

-- | Result of a 'multiExec' transaction.
data TxResult a
    = TxSuccess a
    -- ^ Transaction completed successfully. The wrapped value corresponds to
    --   the 'Queued' value returned from the 'multiExec' argument action.
    | TxAborted
    -- ^ Transaction aborted due to an earlier 'watch' command.
    | TxError String
    -- ^ At least one of the commands returned an 'Error' reply.
    deriving (Int -> TxResult a -> ShowS
forall a. Show a => Int -> TxResult a -> ShowS
forall a. Show a => [TxResult a] -> ShowS
forall a. Show a => TxResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TxResult a] -> ShowS
$cshowList :: forall a. Show a => [TxResult a] -> ShowS
show :: TxResult a -> String
$cshow :: forall a. Show a => TxResult a -> String
showsPrec :: Int -> TxResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> TxResult a -> ShowS
Show, TxResult a -> TxResult a -> Bool
forall a. Eq a => TxResult a -> TxResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TxResult a -> TxResult a -> Bool
$c/= :: forall a. Eq a => TxResult a -> TxResult a -> Bool
== :: TxResult a -> TxResult a -> Bool
$c== :: forall a. Eq a => TxResult a -> TxResult a -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (TxResult a) x -> TxResult a
forall a x. TxResult a -> Rep (TxResult a) x
$cto :: forall a x. Rep (TxResult a) x -> TxResult a
$cfrom :: forall a x. TxResult a -> Rep (TxResult a) x
Generic)

instance NFData a => NFData (TxResult a)

-- |Watch the given keys to determine execution of the MULTI\/EXEC block
--  (<http://redis.io/commands/watch>).
watch
    :: [ByteString] -- ^ key
    -> Redis (Either Reply Status)
watch :: [ByteString] -> Redis (Either Reply Status)
watch [ByteString]
key = forall (m :: * -> *) (f :: * -> *) a.
(RedisCtx m f, RedisResult a) =>
[ByteString] -> m (f a)
sendRequest (ByteString
"WATCH" forall a. a -> [a] -> [a]
: [ByteString]
key)

-- |Forget about all watched keys (<http://redis.io/commands/unwatch>).
unwatch :: Redis (Either Reply Status)
unwatch :: Redis (Either Reply Status)
unwatch  = forall (m :: * -> *) (f :: * -> *) a.
(RedisCtx m f, RedisResult a) =>
[ByteString] -> m (f a)
sendRequest [ByteString
"UNWATCH"]


-- |Run commands inside a transaction. For documentation on the semantics of
--  Redis transaction see <http://redis.io/topics/transactions>.
--
--  Inside the transaction block, command functions return their result wrapped
--  in a 'Queued'. The 'Queued' result is a proxy object for the actual
--  command\'s result, which will only be available after @EXEC@ing the
--  transaction.
--
--  Example usage (note how 'Queued' \'s 'Applicative' instance is used to
--  combine the two individual results):
--
--  @
--  runRedis conn $ do
--      set \"hello\" \"hello\"
--      set \"world\" \"world\"
--      helloworld <- 'multiExec' $ do
--          hello <- get \"hello\"
--          world <- get \"world\"
--          return $ (,) \<$\> hello \<*\> world
--      liftIO (print helloworld)
--  @
multiExec :: RedisTx (Queued a) -> Redis (TxResult a)
multiExec :: forall a. RedisTx (Queued a) -> Redis (TxResult a)
multiExec RedisTx (Queued a)
rtx = do
    -- We don't need to catch exceptions and call DISCARD. The pool will close
    -- the connection anyway.
    Either Reply Status
_        <- Redis (Either Reply Status)
multi
    Queued Vector Reply -> Either Reply a
f <- forall a. RedisTx a -> Redis a
runRedisTx RedisTx (Queued a)
rtx
    Reply
r        <- Redis Reply
exec
    case Reply
r of
        MultiBulk Maybe [Reply]
rs ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                forall a. TxResult a
TxAborted
                (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. String -> TxResult a
TxError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall a. a -> TxResult a
TxSuccess forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Reply -> Either Reply a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
fromList)
                Maybe [Reply]
rs
        Reply
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"hedis: EXEC returned " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Reply
r

multi :: Redis (Either Reply Status)
multi :: Redis (Either Reply Status)
multi = forall (m :: * -> *) (f :: * -> *) a.
(RedisCtx m f, RedisResult a) =>
[ByteString] -> m (f a)
sendRequest [ByteString
"MULTI"]

exec :: Redis Reply
exec :: Redis Reply
exec = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (f :: * -> *) a.
(RedisCtx m f, RedisResult a) =>
[ByteString] -> m (f a)
sendRequest [ByteString
"EXEC"]