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

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

    import Control.Applicative
    import Control.Monad.State.Strict
    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 (Monad, MonadIO, Functor, Applicative)

    runRedisTx :: RedisTx a -> Redis a
    runRedisTx (RedisTx r) = evalStateT r 0

    instance MonadRedis RedisTx where
        liftRedis = RedisTx . lift

    instance RedisCtx RedisTx Queued where
        returnDecode _queued = RedisTx $ do
            -- future index in EXEC result list
            i <- get
            put (i+1)
            return $ Queued (decode . (!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 f (Queued g) = Queued (fmap f . g)

    instance Applicative Queued where
        pure x                = Queued (const $ Right x)
        Queued f <*> Queued x = Queued $ \rs -> do
                                            f' <- f rs
                                            x' <- x rs
                                            return (f' x')

    instance Monad Queued where
        return         = pure
        Queued x >>= f = Queued $ \rs -> do
                                    x' <- x rs
                                    let Queued f' = f x'
                                    f' 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 (Show, Eq)

    -- |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 key = sendRequest ("WATCH" : key)

    -- |Forget about all watched keys (<http://redis.io/commands/unwatch>).
    unwatch :: Redis (Either Reply Status)
    unwatch  = sendRequest ["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 rtx = do
        -- We don't need to catch exceptions and call DISCARD. The pool will close
        -- the connection anyway.
        _        <- multi
        Queued f <- runRedisTx rtx
        r        <- exec
        case r of
            MultiBulk rs ->
                return $ maybe
                    TxAborted
                    (either (TxError . show) TxSuccess . f . fromList)
                    rs
            _ -> error $ "hedis: EXEC returned " ++ show r

    multi :: Redis (Either Reply Status)
    multi = sendRequest ["MULTI"]

    exec :: Redis Reply
    exec = either id id <$> sendRequest ["EXEC"]