Merge pull request #2126 from raduom/raduom/chain-control

Separate `ProcessBlock` into a control effect.
IntersectMBO · Jul 1, 2020 · 4c54249 · 4c54249
2 parents bd16fc0 + 1e66442
commit 4c54249
Show file tree

Hide file tree

Showing 5 changed files with 22 additions and 13 deletions.
diff --git a/plutus-contract/src/Wallet/Emulator/Chain.hs b/plutus-contract/src/Wallet/Emulator/Chain.hs
@@ -60,12 +60,14 @@ emptyChainState = ChainState [] [] mempty 0
 
 makeLenses ''ChainState
 
+data ChainControlEffect r where
+    ProcessBlock :: ChainControlEffect Block
+
 data ChainEffect r where
-    ProcessBlock :: ChainEffect Block
     QueueTx :: Tx -> ChainEffect ()
     GetCurrentSlot :: ChainEffect Slot
 
-processBlock :: Member ChainEffect effs => Eff effs Block
+processBlock :: Member ChainControlEffect effs => Eff effs Block
 processBlock = send ProcessBlock
 
 queueTx :: Member ChainEffect effs => Tx -> Eff effs ()
@@ -76,8 +78,8 @@ getCurrentSlot = send GetCurrentSlot
 
 type ChainEffs = '[State ChainState, Writer [ChainEvent]]
 
-handleChain :: (Members ChainEffs effs) => Eff (ChainEffect ': effs) ~> Eff effs
-handleChain = interpret $ \case
+handleControlChain :: Members ChainEffs effs => Eff (ChainControlEffect ': effs) ~> Eff effs
+handleControlChain = interpret $ \case
     ProcessBlock -> do
         st <- get
         let pool  = st ^. txPool
@@ -94,6 +96,9 @@ handleChain = interpret $ \case
         tell events
 
         pure block
+
+handleChain :: (Members ChainEffs effs) => Eff (ChainEffect ': effs) ~> Eff effs
+handleChain = interpret $ \case
     QueueTx tx -> modify $ over txPool (tx :)
     GetCurrentSlot -> gets _currentSlot
 

diff --git a/plutus-contract/src/Wallet/Emulator/MultiAgent.hs b/plutus-contract/src/Wallet/Emulator/MultiAgent.hs
@@ -250,7 +250,7 @@ emulatorStateInitialDist mp = emulatorStatePool [tx] where
             , txData = mempty
             }
 
-type MultiAgentEffs = '[State EmulatorState, Error WAPI.WalletAPIError, Error AssertionError, Chain.ChainEffect]
+type MultiAgentEffs = '[State EmulatorState, Error WAPI.WalletAPIError, Error AssertionError, Chain.ChainEffect, Chain.ChainControlEffect]
 
 handleMultiAgent
     :: forall effs. Members MultiAgentEffs effs

diff --git a/plutus-contract/src/Wallet/Emulator/Types.hs b/plutus-contract/src/Wallet/Emulator/Types.hs
@@ -90,7 +90,7 @@ import           Wallet.Emulator.MultiAgent
 import           Wallet.Emulator.NodeClient
 import           Wallet.Emulator.Wallet
 
-type EmulatorEffs = '[MultiAgentEffect, ChainEffect]
+type EmulatorEffs = '[MultiAgentEffect, ChainEffect, ChainControlEffect]
 
 -- | Notify the given 'Wallet' of some blockchain events.
 walletRecvBlocks :: Eff.Members EmulatorEffs effs => Wallet -> [ChainClientNotification] -> Eff.Eff effs ()
@@ -133,9 +133,10 @@ newtype EmulatorAction e a = EmulatorAction { unEmulatorAction :: ExceptT e (Sta
 processEmulated :: forall m e a . (MonadEmulator e m) => Eff.Eff EmulatorEffs a -> m a
 processEmulated act =
     act
-        & Eff.raiseEnd2
+        & Eff.raiseEnd3
         & handleMultiAgent
         & handleChain
+        & handleControlChain
         & Eff.interpret (Eff.handleZoomedWriter p1)
         & Eff.interpret (Eff.handleZoomedState chainState)
         & Eff.interpret (Eff.writeIntoState emulatorLog)

diff --git a/plutus-scb/src/Cardano/Node/Mock.hs b/plutus-scb/src/Cardano/Node/Mock.hs
@@ -40,7 +40,7 @@ import           Plutus.SCB.Arbitrary          ()
 import           Plutus.SCB.Utils              (tshow)
 
 import qualified Wallet.Emulator               as EM
-import           Wallet.Emulator.Chain         (ChainEffect, ChainEvent, ChainState)
+import           Wallet.Emulator.Chain         (ChainControlEffect, ChainEffect, ChainEvent, ChainState)
 import qualified Wallet.Emulator.Chain         as Chain
 
 healthcheck :: Monad m => m NoContent
@@ -51,15 +51,15 @@ getCurrentSlot = Eff.gets (view EM.currentSlot)
 
 addBlock ::
     ( Member Log effs
-    , Member ChainEffect effs
+    , Member ChainControlEffect effs
     )
     => Eff effs ()
 addBlock = do
     logInfo "Adding slot"
     void Chain.processBlock
 
 getBlocksSince ::
-    ( Member ChainEffect effs
+    ( Member ChainControlEffect effs
     , Member (State ChainState) effs
     )
     => Slot
@@ -86,7 +86,7 @@ addTx tx = do
     pure NoContent
 
 type NodeServerEffects m
-     = '[ GenRandomTx, NodeFollowerEffect, ChainEffect, State NodeFollowerState, State ChainState, Writer [ChainEvent], State AppState, Log, m]
+     = '[ GenRandomTx, NodeFollowerEffect, ChainControlEffect, ChainEffect, State NodeFollowerState, State ChainState, Writer [ChainEvent], State AppState, Log, m]
 
 ------------------------------------------------------------
 runChainEffects ::
@@ -101,6 +101,7 @@ runChainEffects stateVar eff = do
         $ interpret (handleZoomedState T.chainState)
         $ interpret (handleZoomedState T.followerState)
         $ Chain.handleChain
+        $ Chain.handleControlChain
         $ handleNodeFollower
         $ runGenRandomTx
         $ do result <- eff

diff --git a/plutus-scb/src/Plutus/SCB/MockApp.hs b/plutus-scb/src/Plutus/SCB/MockApp.hs
@@ -63,7 +63,7 @@ import           Test.QuickCheck.Instances.UUID  ()
 import qualified Cardano.ChainIndex.Server       as ChainIndex
 import qualified Cardano.ChainIndex.Types        as ChainIndex
 import           Wallet.API                      (WalletAPIError)
-import           Wallet.Emulator.Chain           (ChainEffect, handleChain)
+import           Wallet.Emulator.Chain           (ChainControlEffect, ChainEffect, handleChain, handleControlChain)
 import qualified Wallet.Emulator.Chain
 import           Wallet.Emulator.MultiAgent      (EmulatorEvent, chainEvent)
 import           Wallet.Emulator.Wallet          (Wallet (..))
@@ -90,6 +90,7 @@ initialTestState =
 
 type MockAppEffects =
     '[ MultiAgentSCBEffect
+     , ChainControlEffect
      , ChainEffect
      , State TestState
      , Log
@@ -151,8 +152,9 @@ runMockApp state action =
     $ runStderrLog
     $ subsume
     $ handleChain
+    $ handleControlChain
     $ SCB.MultiAgent.handleMultiAgent
-    $ raiseEnd6
+    $ raiseEnd7
         -- interpret the 'MockAppEffects' using
         -- the following list of effects
         @'[ Writer [Wallet.Emulator.Chain.ChainEvent]