From f6dd2d58ccd69b5339c3ba77e6f823a1ce728a98 Mon Sep 17 00:00:00 2001 From: Kris Jenkins Date: Thu, 9 Jul 2020 16:59:11 +0100 Subject: [PATCH] SCB: Removing the `ContractStateTransition` event. It's a confusing duplicate of `ContractStateTransition`. --- plutus-scb-client/src/View/Pretty.purs | 1 - plutus-scb/src/Plutus/SCB/Command.hs | 7 +----- .../src/Plutus/SCB/Core/ContractInstance.hs | 5 ++-- plutus-scb/src/Plutus/SCB/Events/Contract.hs | 4 ++++ plutus-scb/src/Plutus/SCB/Events/User.hs | 15 +++++------- plutus-scb/src/Plutus/SCB/Query.hs | 23 ++++++++++--------- 6 files changed, 25 insertions(+), 30 deletions(-) diff --git a/plutus-scb-client/src/View/Pretty.purs b/plutus-scb-client/src/View/Pretty.purs index c95e22f732f..4fe984c98c5 100644 --- a/plutus-scb-client/src/View/Pretty.purs +++ b/plutus-scb-client/src/View/Pretty.purs @@ -43,7 +43,6 @@ eventWithPrefix prefix content = instance prettyUserEvent :: Pretty t => Pretty (UserEvent t) where pretty (InstallContract contract) = span_ [ text $ "Install", nbsp, pretty contract ] - pretty (ContractStateTransition instanceState) = pretty instanceState instance prettyContractExe :: Pretty ContractExe where pretty ((ContractExe { contractPath })) = text contractPath diff --git a/plutus-scb/src/Plutus/SCB/Command.hs b/plutus-scb/src/Plutus/SCB/Command.hs index f834763abd4..80131bd7df1 100644 --- a/plutus-scb/src/Plutus/SCB/Command.hs +++ b/plutus-scb/src/Plutus/SCB/Command.hs @@ -20,15 +20,13 @@ module Plutus.SCB.Command ( installCommand , saveBalancedTx , saveBalancedTxResult - , saveContractState -- * Commands related to updating the contract state , sendContractEvent ) where import Eventful (Aggregate (Aggregate), aggregateCommandHandler, aggregateProjection) import qualified Ledger -import Plutus.SCB.Events (ChainEvent (ContractEvent, UserEvent), ContractInstanceState, - UserEvent (ContractStateTransition, InstallContract)) +import Plutus.SCB.Events (ChainEvent (ContractEvent, UserEvent), UserEvent (InstallContract)) import qualified Plutus.SCB.Events as Events import Plutus.SCB.Query (nullProjection) @@ -55,8 +53,5 @@ saveBalancedTx = sendEvents (return . Events.WalletEvent . Events.BalancedTx) saveBalancedTxResult :: forall t. Aggregate () (ChainEvent t) Ledger.Tx saveBalancedTxResult = sendEvents (return . Events.NodeEvent . Events.SubmittedTx) -saveContractState :: forall t. Aggregate () (ChainEvent t) (ContractInstanceState t) -saveContractState = sendEvents (return . UserEvent . ContractStateTransition) - sendContractEvent :: forall t. Aggregate () (ChainEvent t) (Events.Contract.ContractEvent t) sendContractEvent = sendEvents (return . ContractEvent) diff --git a/plutus-scb/src/Plutus/SCB/Core/ContractInstance.hs b/plutus-scb/src/Plutus/SCB/Core/ContractInstance.hs index 270b32acb0e..8ebd78a3863 100644 --- a/plutus-scb/src/Plutus/SCB/Core/ContractInstance.hs +++ b/plutus-scb/src/Plutus/SCB/Core/ContractInstance.hs @@ -58,7 +58,7 @@ import Wallet.Effects (ChainIndexEffe import Wallet.Emulator.LogMessages (TxBalanceMsg) import Plutus.SCB.Command (saveBalancedTx, saveBalancedTxResult, - saveContractState, sendContractEvent) + sendContractEvent) import Plutus.SCB.Effects.Contract (ContractCommand (..), ContractEffect) import qualified Plutus.SCB.Effects.Contract as Contract import Plutus.SCB.Effects.EventLog (EventLogEffect, runCommand, runGlobalQuery) @@ -71,7 +71,7 @@ import Plutus.SCB.Events.Contract (ContractEvent unContractHandlersResponse) import qualified Plutus.SCB.Events.Contract as Events.Contract import qualified Plutus.SCB.Query as Query -import Plutus.SCB.Types (SCBError (..), Source (ContractEventSource, NodeEventSource, UserEventSource, WalletEventSource)) +import Plutus.SCB.Types (SCBError (..), Source (ContractEventSource, NodeEventSource, WalletEventSource)) import Plutus.SCB.Utils (tshow) import qualified Plutus.SCB.Core.Projections as Projections @@ -142,7 +142,6 @@ sendContractStateMessages is = do void $ runCommand (sendContractEvent @t) ContractEventSource $ ContractInstanceStateUpdateEvent is - void $ runCommand (saveContractState @t) UserEventSource is sendContractMessage :: forall t effs. diff --git a/plutus-scb/src/Plutus/SCB/Events/Contract.hs b/plutus-scb/src/Plutus/SCB/Events/Contract.hs index 34f0860f9b9..772e31640ab 100644 --- a/plutus-scb/src/Plutus/SCB/Events/Contract.hs +++ b/plutus-scb/src/Plutus/SCB/Events/Contract.hs @@ -15,6 +15,7 @@ module Plutus.SCB.Events.Contract( , ContractHandlersResponse(..) , ContractResponse(..) , PartiallyDecodedResponse(..) + , hasActiveRequests , ContractInstanceState(..) -- * Prisms -- ** ContractRequest @@ -221,3 +222,6 @@ instance Pretty t => Pretty (ContractEvent t) where makePrisms ''ContractSCBRequest makePrisms ''ContractResponse makePrisms ''ContractEvent + +hasActiveRequests :: ContractInstanceState t -> Bool +hasActiveRequests = not . null . hooks . csCurrentState diff --git a/plutus-scb/src/Plutus/SCB/Events/User.hs b/plutus-scb/src/Plutus/SCB/Events/User.hs index 65d1de0f0c9..213fc9cb3c6 100644 --- a/plutus-scb/src/Plutus/SCB/Events/User.hs +++ b/plutus-scb/src/Plutus/SCB/Events/User.hs @@ -1,25 +1,22 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StrictData #-} module Plutus.SCB.Events.User where -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson (FromJSON, ToJSON) import Data.Text.Prettyprint.Doc -import GHC.Generics (Generic) -import Plutus.SCB.Events.Contract (ContractInstanceState) +import GHC.Generics (Generic) -- | Users can install contracts and transition them to a new state. -- Contracts are identified by values of 't'. -data UserEvent t - = InstallContract !t - | ContractStateTransition !(ContractInstanceState t) +newtype UserEvent t + = InstallContract t deriving (Show, Eq, Generic) - deriving anyclass (FromJSON, ToJSON) + deriving newtype (FromJSON, ToJSON) instance Pretty t => Pretty (UserEvent t) where pretty = \case InstallContract t -> "InstallContract:" <+> pretty t - ContractStateTransition s -> "ContractStateTransition:" <+> pretty s diff --git a/plutus-scb/src/Plutus/SCB/Query.hs b/plutus-scb/src/Plutus/SCB/Query.hs index 5c470e341a9..88d9881db0b 100644 --- a/plutus-scb/src/Plutus/SCB/Query.hs +++ b/plutus-scb/src/Plutus/SCB/Query.hs @@ -54,7 +54,7 @@ import Ledger (Address, Tx, TxId, TxO txOutRefId, txOutTxOut, txOutTxTx) import Ledger.Index (UtxoIndex (UtxoIndex)) import Plutus.SCB.Events (ChainEvent (..), NodeEvent (SubmittedTx), - UserEvent (ContractStateTransition, InstallContract)) + UserEvent (InstallContract), hasActiveRequests) import Plutus.SCB.Events.Contract (ContractEvent (..), ContractInstanceId, ContractInstanceState (..), ContractResponse (..), IterationID) @@ -184,16 +184,17 @@ contractStates IteratedContractState{icsContractIterations=ContractIterationStat -- | IDs of active contracts by contract type activeContractsProjection :: - forall t key position. Ord t => - Projection (Map t (Set ContractInstanceId)) (StreamEvent key position (ChainEvent t)) + forall t key position. Ord t + => Projection (Map t (Set ContractInstanceId)) (StreamEvent key position (ChainEvent t)) activeContractsProjection = - let projectionEventHandler m (StreamEvent _ _ (UserEvent (ContractStateTransition state))) = - Map.insertWith (<>) (csContractDefinition state) (Set.singleton (csContract state)) m - projectionEventHandler m _ = m - in Projection - { projectionSeed = Map.empty - , projectionEventHandler - } + let projectionEventHandler m = \case + (StreamEvent _ _ (ContractEvent (ContractInstanceStateUpdateEvent state))) -> + let key = csContractDefinition state + in if hasActiveRequests state + then Map.insertWith (<>) key (Set.singleton (csContract state)) m + else Map.delete key m + _ -> m + in Projection {projectionSeed = Map.empty, projectionEventHandler} -- | Transactions submitted to the node. txHistoryProjection :: @@ -212,7 +213,7 @@ activeContractHistoryProjection :: activeContractHistoryProjection cid = projectionMapMaybe contractPaths monoidProjection where - contractPaths (StreamEvent _ _ (UserEvent (ContractStateTransition state))) = + contractPaths (StreamEvent _ _ (ContractEvent (ContractInstanceStateUpdateEvent state))) = if csContract state == cid then Just [state] else Nothing