sketch

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

@@ -22,6 +22,7 @@ import           Polysemy
 import           Polysemy.Error                           (catch)
 import qualified Tendermint.SDK.Application.Module        as M
 import qualified Tendermint.SDK.BaseApp                   as BA
+import qualified Tendermint.SDK.BaseApp.Block             as Block
 import           Tendermint.SDK.BaseApp.Errors            (SDKError (..),
                                                            queryAppError,
                                                            throwSDKError,
@@ -83,6 +84,7 @@ 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
@@ -165,18 +167,32 @@ makeHandlers (HandlersContext{..} :: HandlersContext alg ms core) =
         return . ResponseCommit $ def
           & Resp._commitData .~ Base64.fromBytes rootHash
 
+      beginBlock :: Handler 'MTBeginBlock (BA.BaseAppEffs core)
+      beginBlock _ = do
+        catch
+          (do
+            _ <- Block.evalBlockHandler $ M.applicationBeginBlock app undefined
+            return . ResponseBeginBlock $ def
+          )
+          (\(_ :: BA.AppError) -> undefined
+          )
+
+
+
   in defaultHandlers
-       { query = query
-       , checkTx = checkTx
-       , deliverTx = deliverTx
-       , commit = commit
+       { query
+       , checkTx
+       , deliverTx
+       , commit
+       , beginBlock
        }
 
 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,19 @@ 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 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
 
@@ -39,6 +41,7 @@ data Module (name :: Symbol) (check :: Type) (deliver :: Type) (query :: Type) (
   { moduleTxChecker :: T.RouteTx check r
   , moduleTxDeliverer :: T.RouteTx deliver r
   , moduleQuerier :: Q.RouteQ query r
+  , moduleBeginBlock ::  Req.BeginBlock -> Sem r ()
   , moduleEval :: forall s. (Members T.TxEffs s, Members BaseEffs s, Members (DependencyEffs deps) s) => forall a. Sem (es :& s) a -> Sem s a
   }
 
@@ -58,6 +61,7 @@ data Application check deliver query r s = Application
   { applicationTxChecker   :: T.RouteTx check r
   , applicationTxDeliverer :: T.RouteTx deliver r
   , applicationQuerier     :: Q.RouteQ query s
+  , applicationBeginBlock  :: Req.BeginBlock -> Sem r ()
   }
 
 class ToApplication ms r where
@@ -77,6 +81,7 @@ instance ToApplication '[Module name check deliver query es deps] r where
       { applicationTxChecker = moduleTxChecker
       , applicationTxDeliverer = moduleTxDeliverer
       , applicationQuerier = moduleQuerier
+      , applicationBeginBlock = moduleBeginBlock
       }
 
 instance ToApplication (m' ': ms) r => ToApplication (Module name check deliver query es deps ': m' ': ms) r where
@@ -90,6 +95,7 @@ instance ToApplication (m' ': ms) r => ToApplication (Module name check deliver
          { applicationTxChecker = moduleTxChecker :<|> applicationTxChecker app
          , applicationTxDeliverer = moduleTxDeliverer :<|> applicationTxDeliverer app
          , applicationQuerier = moduleQuerier :<|> applicationQuerier app
+         , applicationBeginBlock = moduleBeginBlock >> applicationBeginBlock app
          }
 
 hoistApplication
@@ -105,6 +111,7 @@ 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
+    , applicationBeginBlock = natT . applicationBeginBlock app
     }
 
 class Eval ms (core :: EffectRow) where

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

@@ -0,0 +1,46 @@
+module Tendermint.SDK.BaseApp.Block
+  ( BlockEffs
+  , BlockContext(..)
+  , newBlockContext
+  , evalBlockHandler
+  ) where
+
+import           Data.IORef                                (newIORef)
+import           Data.Proxy
+--import qualified Network.ABCI.Types.Messages.Request       as Req
+--import qualified Network.ABCI.Types.Messages.Response      as Resp
+import           Polysemy
+import           Polysemy.Tagged                           (Tagged (..))
+--import qualified Tendermint.SDK.BaseApp.Events             as E
+import           Control.Monad.IO.Class                    (liftIO)
+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.Types.Effects              ((:&))
+
+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
+
+evalBlockHandler
+  :: Members [Embed IO, Tagged 'Store.Consensus Store.ReadStore, Tagged 'Store.Consensus Store.WriteStore] r
+  => Sem (BlockEffs :& r) ()
+  -> Sem r ()
+evalBlockHandler action = do
+  (BlockContext txCtx)  <- liftIO newBlockContext
+  (_,_,cache)  <- runTx (Proxy @'Store.Consensus) txCtx action
+  maybe (pure ()) Cache.writeCache cache

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, TxResult, Maybe Cache.Cache)
 runTx ps ctx@TransactionContext{..} tx = do
   initialGas <- liftIO $ readIORef gasRemaining
   eRes <- eval ps ctx tx
@@ -95,11 +100,12 @@ 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, Nothing)
     Right a -> do
         es <- liftIO $ readIORef events
         c <- liftIO $ readIORef storeCache
-        return ( baseResponse & txResultEvents .~ es
+        return ( Just a
+               , baseResponse & txResultEvents .~ es
                               & txResultData .~ fromBytes (encode a)
                , Just c
                )

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 (\(_,res,c) -> (res,c)) . runTx ps ctx <$> action
         R.runAction action' env tx (pure . R.Route)
   in R.leafRouter route'
 

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

@@ -49,20 +49,23 @@ instance HasPath (RoutingTx msg) where
     (\(RoutingTx tx) r -> RoutingTx tx {txRoute = r})
 
 data TransactionContext = TransactionContext
-  { gasRemaining :: IORef G.GasAmount
-  , storeCache   :: IORef Cache.Cache
-  , events       :: IORef [E.Event]
+  { gasRemaining  :: IORef G.GasAmount
+  , txRequiresGas :: Bool
+  , storeCache    :: IORef Cache.Cache
+  , events        :: IORef [E.Event]
   }
 
 newTransactionContext
-  :: RoutingTx msg
+  :: Bool
+  -> RoutingTx msg
   -> IO TransactionContext
-newTransactionContext (RoutingTx Tx{txGas}) = do
+newTransactionContext txRequiresGas (RoutingTx Tx{txGas}) = do
   initialGas <- newIORef $ G.GasAmount txGas
   initialCache <- newIORef Cache.emptyCache
   es <- newIORef []
   pure TransactionContext
     { gasRemaining = initialGas
+    , txRequiresGas
     , storeCache = initialCache
     , events = es
     }

hs-abci-sdk/src/Tendermint/SDK/Modules/Auth.hs

@@ -24,5 +24,6 @@ authModule = Module
   { moduleTxDeliverer = EmptyTxServer
   , moduleTxChecker = EmptyTxServer
   , moduleQuerier = querier
+  , moduleBeginBlock = const $ pure ()
   , moduleEval = eval
   }

hs-abci-sdk/src/Tendermint/SDK/Modules/Bank.hs

@@ -33,5 +33,6 @@ bankModule = Module
   { moduleTxDeliverer = messageHandlers
   , moduleTxChecker = defaultCheckTx (Proxy :: Proxy MessageApi) (Proxy :: Proxy r)
   , moduleQuerier = querier
+  , moduleBeginBlock = const $ endBlockF
   , moduleEval = eval
   }

hs-abci-sdk/src/Tendermint/SDK/Modules/Bank/Keeper.hs

@@ -8,6 +8,7 @@ module Tendermint.SDK.Modules.Bank.Keeper
   , burn
   , mint
   , eval
+  , endBlockF
   ) where
 
 import           Data.List                         (find)
@@ -102,6 +103,14 @@ mintF addr (Auth.Coin cid amount) = do
   (Auth.Coin _ bal) <- getCoinBalance addr cid
   putCoinBalance addr (Auth.Coin cid (bal + amount))
 
+endBlockF
+  :: Members Auth.AuthEffs r
+  => Member (Error BankError) r
+  => Sem r ()
+endBlockF = do
+  _ <- throw @Auth.AuthError undefined
+  throw @BankError undefined
+
 --------------------------------------------------------------------------------
 
 getCoinBalance