BeginBlock / EndBlock handlers

hs-abci-docs/nameservice/src/Nameservice/Application.hs

@@ -24,6 +24,8 @@ handlersContext :: HandlersContext Secp256k1 NameserviceModules BA.CoreEffs
 handlersContext = HandlersContext
   { signatureAlgP = Proxy @Secp256k1
   , modules = nameserviceModules
+  , beginBlocker = BA.defaultBeginBlocker
+  , endBlocker = BA.defaultEndBlocker
   , compileToCore  = BA.defaultCompileToCore
   , anteHandler = baseAppAnteHandler
   }

hs-abci-docs/nameservice/tutorial/Tutorial/Nameservice/08-Application.md

@@ -19,6 +19,8 @@ and ultimately our configuration of modules must be converted to this format. Th
 data HandlersContext alg ms core = HandlersContext
   { signatureAlgP :: Proxy alg
   , modules       :: M.ModuleList ms (Effs ms core)
+  , beginBlocker  :: Req.BeginBlock -> Sem (M.Effs ms core) ()
+  , endBlocker    :: Req.EndBlock -> Sem (M.Effs ms core) EndBlockResult
   , anteHandler   :: BA.AnteHandler (Effs ms core)
   , compileToCore :: forall a. Sem (BA.BaseAppEffs core) a -> Sem core a
   }
@@ -60,7 +62,7 @@ import Network.ABCI.Server.App (App)
 import Polysemy (Sem)
 import Tendermint.SDK.Modules.Auth (Auth, authModule)
 import Tendermint.SDK.Application (ModuleList(..), HandlersContext(..), baseAppAnteHandler, makeApp, createIOApp)
-import Tendermint.SDK.BaseApp (CoreEffs, Context, defaultCompileToCore, runCoreEffs)
+import Tendermint.SDK.BaseApp (CoreEffs, Context, defaultBeginBlocker, defaultEndBlocker, defaultCompileToCore, runCoreEffs)
 import Tendermint.SDK.Crypto (Secp256k1)
 import Tendermint.SDK.Modules.Bank (Bank, bankModule)
 ~~~
@@ -83,6 +85,8 @@ handlersContext :: HandlersContext Secp256k1 NameserviceModules CoreEffs
 handlersContext = HandlersContext
   { signatureAlgP = Proxy @Secp256k1
   , modules = nameserviceModules
+  , beginBlocker = defaultBeginBlocker
+  , endBlocker = defaultEndBlocker
   , compileToCore  = defaultCompileToCore
   , anteHandler = baseAppAnteHandler
   }

hs-abci-docs/simple-storage/src/SimpleStorage/Application.hs

@@ -23,6 +23,8 @@ handlersContext :: HandlersContext Secp256k1 SimpleStorageModules BA.CoreEffs
 handlersContext = HandlersContext
   { signatureAlgP = Proxy @Secp256k1
   , modules = simpleStorageModules
+  , beginBlocker = BA.defaultBeginBlocker
+  , endBlocker = BA.defaultEndBlocker
   , compileToCore  = BA.defaultCompileToCore
   , anteHandler = baseAppAnteHandler
   }

hs-abci-sdk/src/Tendermint/SDK/Application/Handlers.hs

@@ -11,6 +11,7 @@ import           Crypto.Hash.Algorithms                   (SHA256)
 import qualified Data.ByteArray.Base64String              as Base64
 import           Data.Default.Class                       (Default (..))
 import           Data.Proxy
+import           Data.Text
 import           Network.ABCI.Server.App                  (App (..),
                                                            MessageType (..),
                                                            Request (..),
@@ -22,6 +23,9 @@ import           Polysemy
 import           Polysemy.Error                           (catch)
 import qualified Tendermint.SDK.Application.Module        as M
 import qualified Tendermint.SDK.BaseApp                   as BA
+import           Tendermint.SDK.BaseApp.Block             (EndBlockResult,
+                                                           evalBeginBlockHandler,
+                                                           evalEndBlockHandler)
 import           Tendermint.SDK.BaseApp.Errors            (SDKError (..),
                                                            queryAppError,
                                                            throwSDKError,
@@ -72,17 +76,20 @@ defaultHandlers = Handlers
 
 
 data HandlersContext alg ms core = HandlersContext
-  { signatureAlgP :: Proxy alg
-  , modules       :: M.ModuleList ms (M.Effs ms core)
-  , anteHandler   :: BA.AnteHandler (M.Effs ms core)
-  , compileToCore :: forall a. Sem (BA.BaseAppEffs core) a -> Sem core a
-  }
+    { signatureAlgP :: Proxy alg
+    , modules       :: M.ModuleList ms (M.Effs ms core)
+    , beginBlocker  :: Req.BeginBlock -> Sem (M.Effs ms core) ()
+    , endBlocker    :: Req.EndBlock -> Sem (M.Effs ms core) EndBlockResult
+    , anteHandler   :: BA.AnteHandler (M.Effs ms core)
+    , compileToCore :: forall a . Sem (BA.BaseAppEffs core) a -> Sem core a
+    }
 
 -- Common function between checkTx and deliverTx
 makeHandlers
   :: forall alg ms core.
      RecoverableSignatureSchema alg
   => Message alg ~ Digest SHA256
+  => Member (Embed IO) core
   => M.ToApplication ms (M.Effs ms core)
   => T.HasTxRouter (M.ApplicationC ms) (M.Effs ms core) 'Store.QueryAndMempool
   => T.HasTxRouter (M.ApplicationC ms) (BA.BaseAppEffs core) 'Store.QueryAndMempool
@@ -105,7 +112,7 @@ makeHandlers (HandlersContext{..} :: HandlersContext alg ms core) =
 
       app :: M.Application (M.ApplicationC ms) (M.ApplicationD ms) (M.ApplicationQ ms)
                (T.TxEffs BA.:& BA.BaseAppEffs core) (Q.QueryEffs BA.:& BA.BaseAppEffs core)
-      app = M.makeApplication cProxy anteHandler modules
+      app = M.makeApplication cProxy anteHandler modules beginBlocker endBlocker
 
       txParser bs = case parseTx signatureAlgP bs of
         Left err -> throwSDKError $ ParseError err
@@ -165,18 +172,41 @@ makeHandlers (HandlersContext{..} :: HandlersContext alg ms core) =
         return . ResponseCommit $ def
           & Resp._commitData .~ Base64.fromBytes rootHash
 
+      beginBlock :: Handler 'MTBeginBlock (BA.BaseAppEffs core)
+      beginBlock (RequestBeginBlock bb) = do
+        res <- evalBeginBlockHandler $ M.applicationBeginBlocker app bb
+        case res of
+          Right bbr ->
+            return . ResponseBeginBlock $ bbr
+          Left e ->
+            return . ResponseException . Resp.Exception . pack $ "Fatal Error in handling of BeginBlock: " ++ show e
+
+      endBlock :: Handler 'MTEndBlock (BA.BaseAppEffs core)
+      endBlock (RequestEndBlock eb) = do
+        res <- evalEndBlockHandler $ M.applicationEndBlocker app eb
+        case res of
+          Right ebr ->
+            return . ResponseEndBlock $ ebr
+          Left e ->
+            return . ResponseException . Resp.Exception . pack $ "Fatal Error in handling of EndBlock: " ++ show e
+
+
+
   in defaultHandlers
-       { query = query
-       , checkTx = checkTx
-       , deliverTx = deliverTx
-       , commit = commit
+       { query
+       , checkTx
+       , deliverTx
+       , commit
+       , beginBlock
+       , endBlock
        }
 
 makeApp
   :: forall alg ms core.
 
      RecoverableSignatureSchema alg
   => Message alg ~ Digest SHA256
+  => Member (Embed IO) core
   => M.ToApplication ms (M.Effs ms core)
   => T.HasTxRouter (M.ApplicationC ms) (M.Effs ms core) 'Store.QueryAndMempool
   => T.HasTxRouter (M.ApplicationC ms) (BA.BaseAppEffs core) 'Store.QueryAndMempool

hs-abci-sdk/src/Tendermint/SDK/Application/Module.hs

@@ -14,17 +14,20 @@ module Tendermint.SDK.Application.Module
 
   ) where
 
-import           Data.Kind                          (Type)
+import           Data.Kind                           (Type)
 import           Data.Proxy
-import           GHC.TypeLits                       (ErrorMessage (..), Symbol,
-                                                     TypeError)
-import           Polysemy                           (EffectRow, Members, Sem)
-import           Servant.API                        ((:<|>) (..), (:>))
-import           Tendermint.SDK.BaseApp             ((:&), BaseAppEffs,
-                                                     BaseEffs)
-import qualified Tendermint.SDK.BaseApp.Query       as Q
-import           Tendermint.SDK.BaseApp.Store       (Scope (..))
-import qualified Tendermint.SDK.BaseApp.Transaction as T
+import           GHC.TypeLits                        (ErrorMessage (..), Symbol,
+                                                      TypeError)
+import qualified Network.ABCI.Types.Messages.Request as Req
+import           Polysemy                            (EffectRow, Members, Sem)
+import           Servant.API                         ((:<|>) (..), (:>))
+import           Tendermint.SDK.BaseApp              ((:&), BaseAppEffs,
+                                                      BaseEffs)
+import           Tendermint.SDK.BaseApp.Block
+import qualified Tendermint.SDK.BaseApp.Query        as Q
+import           Tendermint.SDK.BaseApp.Store        (Scope (..))
+import qualified Tendermint.SDK.BaseApp.Transaction  as T
+-- import qualified Network.ABCI.Types.Messages.Response     as Resp
 
 type Component = EffectRow -> Type
 
@@ -55,9 +58,11 @@ data ModuleList (ms :: [Component]) r where
 infixr 5 :+
 
 data Application check deliver query r s = Application
-  { applicationTxChecker   :: T.RouteTx check r
-  , applicationTxDeliverer :: T.RouteTx deliver r
-  , applicationQuerier     :: Q.RouteQ query s
+  { applicationTxChecker    :: T.RouteTx check r
+  , applicationTxDeliverer  :: T.RouteTx deliver r
+  , applicationQuerier      :: Q.RouteQ query s
+  , applicationBeginBlocker :: Req.BeginBlock -> Sem r ()
+  , applicationEndBlocker   :: Req.EndBlock -> Sem r EndBlockResult
   }
 
 class ToApplication ms r where
@@ -77,6 +82,8 @@ instance ToApplication '[Module name check deliver query es deps] r where
       { applicationTxChecker = moduleTxChecker
       , applicationTxDeliverer = moduleTxDeliverer
       , applicationQuerier = moduleQuerier
+      , applicationBeginBlocker = defaultBeginBlocker
+      , applicationEndBlocker = defaultEndBlocker
       }
 
 instance ToApplication (m' ': ms) r => ToApplication (Module name check deliver query es deps ': m' ': ms) r where
@@ -90,6 +97,8 @@ instance ToApplication (m' ': ms) r => ToApplication (Module name check deliver
          { applicationTxChecker = moduleTxChecker :<|> applicationTxChecker app
          , applicationTxDeliverer = moduleTxDeliverer :<|> applicationTxDeliverer app
          , applicationQuerier = moduleQuerier :<|> applicationQuerier app
+         , applicationBeginBlocker = defaultBeginBlocker
+         , applicationEndBlocker = defaultEndBlocker
          }
 
 hoistApplication
@@ -105,6 +114,8 @@ hoistApplication natT natQ (app :: Application check deliver query r s) =
     { applicationTxChecker = T.hoistTxRouter (Proxy @check) (Proxy @r) (Proxy @'QueryAndMempool) natT $ applicationTxChecker app
     , applicationTxDeliverer = T.hoistTxRouter (Proxy @deliver) (Proxy @r) (Proxy @'Consensus) natT $ applicationTxDeliverer app
     , applicationQuerier = Q.hoistQueryRouter (Proxy @query) (Proxy @s) natQ $ applicationQuerier app
+    , applicationBeginBlocker = natT . applicationBeginBlocker app
+    , applicationEndBlocker = natT . applicationEndBlocker app
     }
 
 class Eval ms (core :: EffectRow) where
@@ -137,11 +148,13 @@ makeApplication
   => Proxy core
   -> T.AnteHandler (Effs ms core)
   -> ModuleList ms (Effs ms core)
+  -> (Req.BeginBlock -> Sem (Effs ms core) ())
+  -> (Req.EndBlock -> Sem (Effs ms core) EndBlockResult)
   -> Application (ApplicationC ms) (ApplicationD ms) (ApplicationQ ms) (T.TxEffs :& BaseAppEffs core) (Q.QueryEffs :& BaseAppEffs core)
-makeApplication p@(Proxy :: Proxy core) ah (ms :: ModuleList ms (Effs ms core)) =
+makeApplication p@(Proxy :: Proxy core) ah (ms :: ModuleList ms (Effs ms core)) beginBlocker endBlocker =
   let app = applyAnteHandler ah $ toApplication ms :: Application (ApplicationC ms) (ApplicationD ms) (ApplicationQ ms) (Effs ms core) (Effs ms core)
       -- WEIRD: if you move the eval into a separate let binding then it doesn't typecheck...
-  in hoistApplication (eval @ms @core p ms) (T.evalReadOnly . eval @ms @core p ms) app
+  in hoistApplication (eval @ms @core p ms) (T.evalReadOnly . eval @ms @core p ms) (app{applicationBeginBlocker = beginBlocker, applicationEndBlocker = endBlocker})
 
 applyAnteHandler
   :: T.HasTxRouter check r 'QueryAndMempool

hs-abci-sdk/src/Tendermint/SDK/BaseApp.hs

@@ -94,8 +94,15 @@ module Tendermint.SDK.BaseApp
   , storeQueryHandler
   , EmptyQueryServer(..)
   , RouterError(ResourceNotFound)
+
+  -- * Block
+  , BlockEffs
+  , EndBlockResult (..)
+  , defaultBeginBlocker
+  , defaultEndBlocker
   ) where
 
+import           Tendermint.SDK.BaseApp.Block
 import           Tendermint.SDK.BaseApp.Effects
 import           Tendermint.SDK.BaseApp.Errors
 import           Tendermint.SDK.BaseApp.Events

hs-abci-sdk/src/Tendermint/SDK/BaseApp/Block.hs

@@ -0,0 +1,92 @@
+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 = do
+  initialCache <- newIORef Cache.emptyCache
+  gasRemaining <- newIORef 0
+  es <- newIORef []
+  pure . BlockContext $
+    TransactionContext
+      { gasRemaining
+      , txRequiresGas = False
+      , storeCache = initialCache
+      , events = 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 action = do
+  (BlockContext txCtx)  <- liftIO newBlockContext
+  (res, txres)  <- runTx (Proxy @'Store.Consensus) txCtx action
+  case res of
+    Just (_, c) -> do
+      Cache.writeCache c
+      pure $ Right $ Resp.BeginBlock (txres ^. txResultEvents)
+    Nothing -> pure $ Left (txres ^. txResultAppError)
+
+
+defaultBeginBlocker :: Req.BeginBlock -> Sem r ()
+defaultBeginBlocker = const $ pure ()
+
+----------------------
+
+data EndBlockResult = EndBlockResult [ValidatorUpdate] (Maybe ConsensusParams)
+
+instance HasCodec EndBlockResult where
+  encode _ = ""
+  decode _ = 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 action = do
+  (BlockContext txCtx) <- liftIO newBlockContext
+  (res, txres) <- runTx (Proxy @'Store.Consensus) txCtx action
+  case res of
+    Just (EndBlockResult updates params, c) -> do
+      Cache.writeCache c
+      pure $ Right $ Resp.EndBlock updates params (txres ^. txResultEvents)
+    Nothing -> pure $ Left (txres ^. txResultAppError)
+
+
+
+defaultEndBlocker :: Req.EndBlock -> Sem r EndBlockResult
+defaultEndBlocker = const $ pure (EndBlockResult [] Nothing)

hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Effect.hs

@@ -59,10 +59,15 @@ eval ps TransactionContext{..} = do
     rewrite (Tagged @Cache.Cache) .
     evalCachedWriteStore storeCache .
     rewrite (Tagged @Cache.Cache) .
-    State.runStateIORef gasRemaining .
-    G.eval .
-    raiseUnder @(State.State G.GasAmount) .
+    runGas .
     runOutputMonoidIORef events (pure @[])
+  where
+    runGas =
+      if txRequiresGas
+        then State.runStateIORef gasRemaining .
+               G.eval .
+               raiseUnder @(State.State G.GasAmount)
+        else G.doNothing
 
 evalReadOnly
   :: forall r.
@@ -85,7 +90,7 @@ runTx
   => Proxy scope
   -> TransactionContext
   -> Sem (TxEffs :& r) a
-  -> Sem r (TxResult, Maybe Cache.Cache)
+  -> Sem r (Maybe (a, Cache.Cache), TxResult)
 runTx ps ctx@TransactionContext{..} tx = do
   initialGas <- liftIO $ readIORef gasRemaining
   eRes <- eval ps ctx tx
@@ -95,13 +100,13 @@ runTx ps ctx@TransactionContext{..} tx = do
         def & txResultGasWanted .~ G.unGasAmount initialGas
             & txResultGasUsed .~ G.unGasAmount gasUsed
   case eRes of
-    Left e -> return (baseResponse & txResultAppError .~ e, Nothing)
+    Left e -> return (Nothing, baseResponse & txResultAppError .~ e)
     Right a -> do
         es <- liftIO $ readIORef events
         c <- liftIO $ readIORef storeCache
-        return ( baseResponse & txResultEvents .~ es
+        return ( Just (a,c)
+               , baseResponse & txResultEvents .~ es
                               & txResultData .~ fromBytes (encode a)
-               , Just c
                )
 
 evalCachedReadStore

hs-abci-sdk/src/Tendermint/SDK/BaseApp/Transaction/Router.hs

@@ -90,8 +90,8 @@ methodRouter
   -> R.Router env r (RoutingTx msg) (TxResult, Maybe Cache)
 methodRouter ps action =
   let route' env tx = do
-        ctx <- liftIO $ newTransactionContext tx
-        let action' = runTx ps ctx <$> action
+        ctx <- liftIO $ newTransactionContext True tx
+        let action' = fmap (\(rc,res) -> (res,fmap snd rc)) . runTx ps ctx <$> action
         R.runAction action' env tx (pure . R.Route)
   in R.leafRouter route'