{-# 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
a -> RedisTx a
Applicative RedisTx
-> (forall a b. RedisTx a -> (a -> RedisTx b) -> RedisTx b)
-> (forall a b. RedisTx a -> RedisTx b -> RedisTx b)
-> (forall a. a -> RedisTx a)
-> Monad RedisTx
RedisTx a -> (a -> RedisTx b) -> RedisTx b
RedisTx a -> RedisTx b -> RedisTx b
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 :: a -> RedisTx a
$creturn :: forall a. a -> RedisTx a
>> :: RedisTx a -> RedisTx b -> RedisTx b
$c>> :: forall a b. RedisTx a -> RedisTx b -> RedisTx b
>>= :: RedisTx a -> (a -> RedisTx b) -> RedisTx b
$c>>= :: forall a b. RedisTx a -> (a -> RedisTx b) -> RedisTx b
$cp1Monad :: Applicative RedisTx
Monad, Monad RedisTx
Monad RedisTx -> (forall a. IO a -> RedisTx a) -> MonadIO RedisTx
IO a -> RedisTx a
forall a. IO a -> RedisTx a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> RedisTx a
$cliftIO :: forall a. IO a -> RedisTx a
$cp1MonadIO :: Monad RedisTx
MonadIO, a -> RedisTx b -> RedisTx a
(a -> b) -> RedisTx a -> RedisTx b
(forall a b. (a -> b) -> RedisTx a -> RedisTx b)
-> (forall a b. a -> RedisTx b -> RedisTx a) -> Functor RedisTx
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
<$ :: a -> RedisTx b -> RedisTx a
$c<$ :: forall a b. a -> RedisTx b -> RedisTx a
fmap :: (a -> b) -> RedisTx a -> RedisTx b
$cfmap :: forall a b. (a -> b) -> RedisTx a -> RedisTx b
Functor, Functor RedisTx
a -> RedisTx a
Functor RedisTx
-> (forall a. a -> RedisTx a)
-> (forall a b. RedisTx (a -> b) -> RedisTx a -> RedisTx b)
-> (forall a b c.
    (a -> b -> c) -> RedisTx a -> RedisTx b -> RedisTx c)
-> (forall a b. RedisTx a -> RedisTx b -> RedisTx b)
-> (forall a b. RedisTx a -> RedisTx b -> RedisTx a)
-> Applicative RedisTx
RedisTx a -> RedisTx b -> RedisTx b
RedisTx a -> RedisTx b -> RedisTx a
RedisTx (a -> b) -> RedisTx a -> RedisTx b
(a -> b -> c) -> RedisTx a -> RedisTx b -> RedisTx c
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
<* :: RedisTx a -> RedisTx b -> RedisTx a
$c<* :: forall a b. RedisTx a -> RedisTx b -> RedisTx a
*> :: RedisTx a -> RedisTx b -> RedisTx b
$c*> :: forall a b. RedisTx a -> RedisTx b -> RedisTx b
liftA2 :: (a -> b -> c) -> RedisTx a -> RedisTx b -> RedisTx c
$cliftA2 :: forall a b c. (a -> b -> c) -> RedisTx a -> RedisTx b -> RedisTx c
<*> :: RedisTx (a -> b) -> RedisTx a -> RedisTx b
$c<*> :: forall a b. RedisTx (a -> b) -> RedisTx a -> RedisTx b
pure :: a -> RedisTx a
$cpure :: forall a. a -> RedisTx a
$cp1Applicative :: Functor RedisTx
Applicative)

runRedisTx :: RedisTx a -> Redis a
runRedisTx :: RedisTx a -> Redis a
runRedisTx (RedisTx StateT Int Redis a
r) = StateT Int Redis a -> Int -> Redis a
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 :: Redis a -> RedisTx a
liftRedis = StateT Int Redis a -> RedisTx a
forall a. StateT Int Redis a -> RedisTx a
RedisTx (StateT Int Redis a -> RedisTx a)
-> (Redis a -> StateT Int Redis a) -> Redis a -> RedisTx a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Redis a -> StateT Int Redis a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance RedisCtx RedisTx Queued where
    returnDecode :: Reply -> RedisTx (Queued a)
returnDecode Reply
_queued = StateT Int Redis (Queued a) -> RedisTx (Queued a)
forall a. StateT Int Redis a -> RedisTx a
RedisTx (StateT Int Redis (Queued a) -> RedisTx (Queued a))
-> StateT Int Redis (Queued a) -> RedisTx (Queued a)
forall a b. (a -> b) -> a -> b
$ do
        -- future index in EXEC result list
        Int
i <- StateT Int Redis Int
forall s (m :: * -> *). MonadState s m => m s
get
        Int -> StateT Int Redis ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        Queued a -> StateT Int Redis (Queued a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Queued a -> StateT Int Redis (Queued a))
-> Queued a -> StateT Int Redis (Queued a)
forall a b. (a -> b) -> a -> b
$ (Vector Reply -> Either Reply a) -> Queued a
forall a. (Vector Reply -> Either Reply a) -> Queued a
Queued (Reply -> Either Reply a
forall a. RedisResult a => Reply -> Either Reply a
decode (Reply -> Either Reply a)
-> (Vector Reply -> Reply) -> Vector Reply -> Either Reply a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vector Reply -> Int -> Reply
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 :: (a -> b) -> Queued a -> Queued b
fmap a -> b
f (Queued Vector Reply -> Either Reply a
g) = (Vector Reply -> Either Reply b) -> Queued b
forall a. (Vector Reply -> Either Reply a) -> Queued a
Queued ((a -> b) -> Either Reply a -> Either Reply b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Either Reply a -> Either Reply b)
-> (Vector Reply -> Either Reply a)
-> Vector Reply
-> Either Reply b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Reply -> Either Reply a
g)

instance Applicative Queued where
    pure :: a -> Queued a
pure a
x                = (Vector Reply -> Either Reply a) -> Queued a
forall a. (Vector Reply -> Either Reply a) -> Queued a
Queued (Either Reply a -> Vector Reply -> Either Reply a
forall a b. a -> b -> a
const (Either Reply a -> Vector Reply -> Either Reply a)
-> Either Reply a -> Vector Reply -> Either Reply a
forall a b. (a -> b) -> a -> b
$ a -> Either Reply a
forall a b. b -> Either a b
Right a
x)
    Queued Vector Reply -> Either Reply (a -> b)
f <*> :: Queued (a -> b) -> Queued a -> Queued b
<*> Queued Vector Reply -> Either Reply a
x = (Vector Reply -> Either Reply b) -> Queued b
forall a. (Vector Reply -> Either Reply a) -> Queued a
Queued ((Vector Reply -> Either Reply b) -> Queued b)
-> (Vector Reply -> Either Reply b) -> Queued b
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
                                        b -> Either Reply b
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f' a
x')

instance Monad Queued where
    return :: a -> Queued a
return         = a -> Queued a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Queued Vector Reply -> Either Reply a
x >>= :: Queued a -> (a -> Queued b) -> Queued b
>>= a -> Queued b
f = (Vector Reply -> Either Reply b) -> Queued b
forall a. (Vector Reply -> Either Reply a) -> Queued a
Queued ((Vector Reply -> Either Reply b) -> Queued b)
-> (Vector Reply -> Either Reply b) -> Queued b
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
[TxResult a] -> ShowS
TxResult a -> String
(Int -> TxResult a -> ShowS)
-> (TxResult a -> String)
-> ([TxResult a] -> ShowS)
-> Show (TxResult a)
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
(TxResult a -> TxResult a -> Bool)
-> (TxResult a -> TxResult a -> Bool) -> Eq (TxResult a)
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 x. TxResult a -> Rep (TxResult a) x)
-> (forall x. Rep (TxResult a) x -> TxResult a)
-> Generic (TxResult a)
forall x. Rep (TxResult a) x -> TxResult a
forall x. TxResult a -> Rep (TxResult a) x
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 = [ByteString] -> Redis (Either Reply Status)
forall (m :: * -> *) (f :: * -> *) a.
(RedisCtx m f, RedisResult a) =>
[ByteString] -> m (f a)
sendRequest (ByteString
"WATCH" ByteString -> [ByteString] -> [ByteString]
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  = [ByteString] -> Redis (Either Reply Status)
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 :: 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 <- RedisTx (Queued a) -> Redis (Queued a)
forall a. RedisTx a -> Redis a
runRedisTx RedisTx (Queued a)
rtx
    Reply
r        <- Redis Reply
exec
    case Reply
r of
        MultiBulk Maybe [Reply]
rs ->
            TxResult a -> Redis (TxResult a)
forall (m :: * -> *) a. Monad m => a -> m a
return (TxResult a -> Redis (TxResult a))
-> TxResult a -> Redis (TxResult a)
forall a b. (a -> b) -> a -> b
$ TxResult a
-> ([Reply] -> TxResult a) -> Maybe [Reply] -> TxResult a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                TxResult a
forall a. TxResult a
TxAborted
                ((Reply -> TxResult a)
-> (a -> TxResult a) -> Either Reply a -> TxResult a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> TxResult a
forall a. String -> TxResult a
TxError (String -> TxResult a) -> (Reply -> String) -> Reply -> TxResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reply -> String
forall a. Show a => a -> String
show) a -> TxResult a
forall a. a -> TxResult a
TxSuccess (Either Reply a -> TxResult a)
-> ([Reply] -> Either Reply a) -> [Reply] -> TxResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Reply -> Either Reply a
f (Vector Reply -> Either Reply a)
-> ([Reply] -> Vector Reply) -> [Reply] -> Either Reply a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Reply] -> Vector Reply
forall a. [a] -> Vector a
fromList)
                Maybe [Reply]
rs
        Reply
_ -> String -> Redis (TxResult a)
forall a. HasCallStack => String -> a
error (String -> Redis (TxResult a)) -> String -> Redis (TxResult a)
forall a b. (a -> b) -> a -> b
$ String
"hedis: EXEC returned " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Reply -> String
forall a. Show a => a -> String
show Reply
r

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

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