module Tendermint.SDK.BaseApp.Block
  ( BlockEffs
  , evalBeginBlockHandler
  , evalEndBlockHandler
  , EndBlockResult (..)
  , defaultBeginBlocker
  , defaultEndBlocker
  ) where

import           Control.Lens                              ((^.))
import           Control.Monad.IO.Class                    (liftIO)
import           Data.IORef                                (newIORef)
import           Data.Proxy                                (Proxy (Proxy))
import           Network.ABCI.Types.Messages.FieldTypes    (ConsensusParams,
                                                            ValidatorUpdate)
import qualified Network.ABCI.Types.Messages.Request       as Req
import qualified Network.ABCI.Types.Messages.Response      as Resp
import           Polysemy                                  (Embed, Members, Sem)
import           Polysemy.Tagged                           (Tagged (..))
import           Tendermint.SDK.BaseApp.Errors             (AppError,
                                                            txResultAppError)
import qualified Tendermint.SDK.BaseApp.Store              as Store
import qualified Tendermint.SDK.BaseApp.Transaction.Cache  as Cache
import           Tendermint.SDK.BaseApp.Transaction.Effect (TxEffs, runTx)
import           Tendermint.SDK.BaseApp.Transaction.Types  (TransactionContext (..))
import           Tendermint.SDK.Codec                      (HasCodec (..))
import           Tendermint.SDK.Types.Effects              ((:&))
import           Tendermint.SDK.Types.TxResult             (txResultEvents)


data BlockContext = BlockContext TransactionContext

newBlockContext :: IO BlockContext
newBlockContext :: IO BlockContext
newBlockContext = do
  IORef Cache
initialCache <- Cache -> IO (IORef Cache)
forall a. a -> IO (IORef a)
newIORef Cache
Cache.emptyCache
  IORef GasAmount
gasRemaining <- GasAmount -> IO (IORef GasAmount)
forall a. a -> IO (IORef a)
newIORef 0
  IORef [Event]
es <- [Event] -> IO (IORef [Event])
forall a. a -> IO (IORef a)
newIORef []
  BlockContext -> IO BlockContext
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockContext -> IO BlockContext)
-> (TransactionContext -> BlockContext)
-> TransactionContext
-> IO BlockContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransactionContext -> BlockContext
BlockContext (TransactionContext -> IO BlockContext)
-> TransactionContext -> IO BlockContext
forall a b. (a -> b) -> a -> b
$
    TransactionContext :: IORef GasAmount
-> Bool -> IORef Cache -> IORef [Event] -> TransactionContext
TransactionContext
      { IORef GasAmount
gasRemaining :: IORef GasAmount
gasRemaining :: IORef GasAmount
gasRemaining
      , txRequiresGas :: Bool
txRequiresGas = Bool
False
      , storeCache :: IORef Cache
storeCache = IORef Cache
initialCache
      , events :: IORef [Event]
events = IORef [Event]
es
      }

type BlockEffs = TxEffs

----------------------

evalBeginBlockHandler
  :: Members [Embed IO, Tagged 'Store.Consensus Store.ReadStore, Tagged 'Store.Consensus Store.WriteStore] r
  => Sem (BlockEffs :& r) ()
  -> Sem r (Either AppError Resp.BeginBlock)
evalBeginBlockHandler :: Sem (BlockEffs :& r) () -> Sem r (Either AppError BeginBlock)
evalBeginBlockHandler action :: Sem (BlockEffs :& r) ()
action = do
  (BlockContext txCtx :: TransactionContext
txCtx)  <- IO BlockContext -> Sem r BlockContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO BlockContext
newBlockContext
  (res :: Maybe ((), Cache)
res, txres :: TxResult
txres)  <- Proxy 'Consensus
-> TransactionContext
-> Sem (BlockEffs :& r) ()
-> Sem r (Maybe ((), Cache), TxResult)
forall k (scope :: k) (r :: [(* -> *) -> * -> *]) a.
(Members '[Embed IO, Tagged scope ReadStore] r, HasCodec a) =>
Proxy scope
-> TransactionContext
-> Sem (BlockEffs :& r) a
-> Sem r (Maybe (a, Cache), TxResult)
runTx (Proxy 'Consensus
forall k (t :: k). Proxy t
Proxy @'Store.Consensus) TransactionContext
txCtx Sem (BlockEffs :& r) ()
action
  case Maybe ((), Cache)
res of
    Just (_, c :: Cache
c) -> do
      Cache -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member (Tagged 'Consensus WriteStore) r =>
Cache -> Sem r ()
Cache.writeCache Cache
c
      Either AppError BeginBlock -> Sem r (Either AppError BeginBlock)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either AppError BeginBlock -> Sem r (Either AppError BeginBlock))
-> Either AppError BeginBlock -> Sem r (Either AppError BeginBlock)
forall a b. (a -> b) -> a -> b
$ BeginBlock -> Either AppError BeginBlock
forall a b. b -> Either a b
Right (BeginBlock -> Either AppError BeginBlock)
-> BeginBlock -> Either AppError BeginBlock
forall a b. (a -> b) -> a -> b
$ [Event] -> BeginBlock
Resp.BeginBlock (TxResult
txres TxResult -> Getting [Event] TxResult [Event] -> [Event]
forall s a. s -> Getting a s a -> a
^. Getting [Event] TxResult [Event]
Lens' TxResult [Event]
txResultEvents)
    Nothing -> Either AppError BeginBlock -> Sem r (Either AppError BeginBlock)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either AppError BeginBlock -> Sem r (Either AppError BeginBlock))
-> Either AppError BeginBlock -> Sem r (Either AppError BeginBlock)
forall a b. (a -> b) -> a -> b
$ AppError -> Either AppError BeginBlock
forall a b. a -> Either a b
Left (TxResult
txres TxResult -> Getting AppError TxResult AppError -> AppError
forall s a. s -> Getting a s a -> a
^. Getting AppError TxResult AppError
Lens' TxResult AppError
txResultAppError)


defaultBeginBlocker :: Req.BeginBlock -> Sem r ()
defaultBeginBlocker :: BeginBlock -> Sem r ()
defaultBeginBlocker = Sem r () -> BeginBlock -> Sem r ()
forall a b. a -> b -> a
const (Sem r () -> BeginBlock -> Sem r ())
-> Sem r () -> BeginBlock -> Sem r ()
forall a b. (a -> b) -> a -> b
$ () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

----------------------

data EndBlockResult = EndBlockResult [ValidatorUpdate] (Maybe ConsensusParams)

instance HasCodec EndBlockResult where
  encode :: EndBlockResult -> ByteString
encode _ = ""
  decode :: ByteString -> Either Text EndBlockResult
decode _ = Text -> Either Text EndBlockResult
forall a b. a -> Either a b
Left ""


evalEndBlockHandler
  :: Members [Embed IO, Tagged 'Store.Consensus Store.ReadStore, Tagged 'Store.Consensus Store.WriteStore] r
  => Sem (BlockEffs :& r) EndBlockResult
  -> Sem r (Either AppError Resp.EndBlock)
evalEndBlockHandler :: Sem (BlockEffs :& r) EndBlockResult
-> Sem r (Either AppError EndBlock)
evalEndBlockHandler action :: Sem (BlockEffs :& r) EndBlockResult
action = do
  (BlockContext txCtx :: TransactionContext
txCtx) <- IO BlockContext -> Sem r BlockContext
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO BlockContext
newBlockContext
  (res :: Maybe (EndBlockResult, Cache)
res, txres :: TxResult
txres) <- Proxy 'Consensus
-> TransactionContext
-> Sem (BlockEffs :& r) EndBlockResult
-> Sem r (Maybe (EndBlockResult, Cache), TxResult)
forall k (scope :: k) (r :: [(* -> *) -> * -> *]) a.
(Members '[Embed IO, Tagged scope ReadStore] r, HasCodec a) =>
Proxy scope
-> TransactionContext
-> Sem (BlockEffs :& r) a
-> Sem r (Maybe (a, Cache), TxResult)
runTx (Proxy 'Consensus
forall k (t :: k). Proxy t
Proxy @'Store.Consensus) TransactionContext
txCtx Sem (BlockEffs :& r) EndBlockResult
action
  case Maybe (EndBlockResult, Cache)
res of
    Just (EndBlockResult updates :: [ValidatorUpdate]
updates params :: Maybe ConsensusParams
params, c :: Cache
c) -> do
      Cache -> Sem r ()
forall (r :: [(* -> *) -> * -> *]).
Member (Tagged 'Consensus WriteStore) r =>
Cache -> Sem r ()
Cache.writeCache Cache
c
      Either AppError EndBlock -> Sem r (Either AppError EndBlock)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either AppError EndBlock -> Sem r (Either AppError EndBlock))
-> Either AppError EndBlock -> Sem r (Either AppError EndBlock)
forall a b. (a -> b) -> a -> b
$ EndBlock -> Either AppError EndBlock
forall a b. b -> Either a b
Right (EndBlock -> Either AppError EndBlock)
-> EndBlock -> Either AppError EndBlock
forall a b. (a -> b) -> a -> b
$ [ValidatorUpdate] -> Maybe ConsensusParams -> [Event] -> EndBlock
Resp.EndBlock [ValidatorUpdate]
updates Maybe ConsensusParams
params (TxResult
txres TxResult -> Getting [Event] TxResult [Event] -> [Event]
forall s a. s -> Getting a s a -> a
^. Getting [Event] TxResult [Event]
Lens' TxResult [Event]
txResultEvents)
    Nothing -> Either AppError EndBlock -> Sem r (Either AppError EndBlock)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either AppError EndBlock -> Sem r (Either AppError EndBlock))
-> Either AppError EndBlock -> Sem r (Either AppError EndBlock)
forall a b. (a -> b) -> a -> b
$ AppError -> Either AppError EndBlock
forall a b. a -> Either a b
Left (TxResult
txres TxResult -> Getting AppError TxResult AppError -> AppError
forall s a. s -> Getting a s a -> a
^. Getting AppError TxResult AppError
Lens' TxResult AppError
txResultAppError)



defaultEndBlocker :: Req.EndBlock -> Sem r EndBlockResult
defaultEndBlocker :: EndBlock -> Sem r EndBlockResult
defaultEndBlocker = Sem r EndBlockResult -> EndBlock -> Sem r EndBlockResult
forall a b. a -> b -> a
const (Sem r EndBlockResult -> EndBlock -> Sem r EndBlockResult)
-> Sem r EndBlockResult -> EndBlock -> Sem r EndBlockResult
forall a b. (a -> b) -> a -> b
$ EndBlockResult -> Sem r EndBlockResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ValidatorUpdate] -> Maybe ConsensusParams -> EndBlockResult
EndBlockResult [] Maybe ConsensusParams
forall a. Maybe a
Nothing)