{-# 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
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
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))
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
data TxResult a
= TxSuccess a
| TxAborted
| TxError String
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
:: [ByteString]
-> 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)
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"]
multiExec :: RedisTx (Queued a) -> Redis (TxResult a)
multiExec :: forall a. RedisTx (Queued a) -> Redis (TxResult a)
multiExec RedisTx (Queued a)
rtx = do
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"]