From d10fa99fabd7a3ad4f90b2e7cc0585c4d32bb38b Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Sat, 27 Jan 2024 21:36:31 +0100 Subject: [PATCH] PLT-8828 - Forbid contract is not mixing mainnet and testnet before sending to Runner --- .../src/Marlowe/Linter.purs | 4 +++ .../src/Page/Simulation/Lenses.purs | 5 ++++ .../src/Page/Simulation/State.purs | 7 +++-- .../src/Page/Simulation/Types.purs | 2 ++ .../src/Page/Simulation/View.purs | 30 ++++++++++++++----- 5 files changed, 39 insertions(+), 9 deletions(-) diff --git a/marlowe-playground-client/src/Marlowe/Linter.purs b/marlowe-playground-client/src/Marlowe/Linter.purs index 41784d667b..b97b348b3e 100644 --- a/marlowe-playground-client/src/Marlowe/Linter.purs +++ b/marlowe-playground-client/src/Marlowe/Linter.purs @@ -13,6 +13,7 @@ module Marlowe.Linter , _network , hasInvalidAddresses , isSeveralNetworks + , getNetworkFor ) where import Prologue @@ -1041,3 +1042,6 @@ hasInvalidAddresses ec = State { warnings } = lint Nil (toTerm ec) in any isAddressWarning warnings + +getNetworkFor :: Term Contract -> Networks +getNetworkFor c = let State { network: n } = lint Nil c in n diff --git a/marlowe-playground-client/src/Page/Simulation/Lenses.purs b/marlowe-playground-client/src/Page/Simulation/Lenses.purs index b7ad876410..695c4b64db 100644 --- a/marlowe-playground-client/src/Page/Simulation/Lenses.purs +++ b/marlowe-playground-client/src/Page/Simulation/Lenses.purs @@ -4,6 +4,7 @@ import Component.BottomPanel.Types as BottomPanel import Data.Lens (Lens') import Data.Lens.Record (prop) import Help (HelpContext) +import Marlowe.Linter (Networks) import Page.Simulation.Types (BottomPanelView, State) import Type.Proxy (Proxy(..)) @@ -18,3 +19,7 @@ _bottomPanelState = prop (Proxy :: _ "bottomPanelState") _decorationIds :: Lens' State (Array String) _decorationIds = prop (Proxy :: _ "decorationIds") + +_network :: Lens' State Networks +_network = prop (Proxy :: _ "networks") + diff --git a/marlowe-playground-client/src/Page/Simulation/State.purs b/marlowe-playground-client/src/Page/Simulation/State.purs index 6514382f42..cce0f0db2c 100644 --- a/marlowe-playground-client/src/Page/Simulation/State.purs +++ b/marlowe-playground-client/src/Page/Simulation/State.purs @@ -56,6 +56,7 @@ import Marlowe (Api) import Marlowe as Server import Marlowe.Holes (Contract) as Term import Marlowe.Holes (Location(..), Term, fromTerm, getLocation) +import Marlowe.Linter (getNetworkFor) import Marlowe.Monaco as MM import Marlowe.Parser (parseContract) import Marlowe.Template (_timeContent, _valueContent, fillTemplate) @@ -65,6 +66,7 @@ import Page.Simulation.Lenses ( _bottomPanelState , _decorationIds , _helpContext + , _network , _showRightPanel ) import Page.Simulation.Types (Action(..), BottomPanelView(..), State, StateBase) @@ -112,6 +114,7 @@ mkStateBase tzOffset = , helpContext: MarloweHelp , bottomPanelState: BottomPanel.initialState CurrentStateView , decorationIds: [] + , networks: mempty } toBottomPanel @@ -248,14 +251,14 @@ handleAction metadata (LoadContract contents) = do _ -> pure Nothing let mTermContract = hush $ parseContract contents - for_ mTermContract \termContract -> + for_ mTermContract \termContract -> do + assign _network (getNetworkFor termContract) assign _marloweState ( NEL.singleton $ initialMarloweState currentTime termContract metadata prevTemplateContent ) - editorSetValue contents handleAction metadata (BottomPanelAction (BottomPanel.PanelAction action)) = diff --git a/marlowe-playground-client/src/Page/Simulation/Types.purs b/marlowe-playground-client/src/Page/Simulation/Types.purs index d4ed1657a9..13e6459714 100644 --- a/marlowe-playground-client/src/Page/Simulation/Types.purs +++ b/marlowe-playground-client/src/Page/Simulation/Types.purs @@ -20,6 +20,7 @@ import Language.Marlowe.Core.V1.Semantics.Types , ChosenNum , InputContent ) +import Marlowe.Linter (Networks) import Marlowe.Symbolic.Types.Response (Result) import Network.RemoteData (RemoteData) import Simulator.Types (MarloweState) @@ -32,6 +33,7 @@ type StateBase r = , helpContext :: HelpContext -- List of decoration ids used by the monaco editor to track the running contract , decorationIds :: Array String + , networks :: Networks | r } diff --git a/marlowe-playground-client/src/Page/Simulation/View.purs b/marlowe-playground-client/src/Page/Simulation/View.purs index 8c78d9aefb..e60584f229 100644 --- a/marlowe-playground-client/src/Page/Simulation/View.purs +++ b/marlowe-playground-client/src/Page/Simulation/View.purs @@ -94,7 +94,7 @@ import Halogen.HTML , ul ) import Halogen.HTML.Events (onClick) -import Halogen.HTML.Properties (class_, classes, disabled, enabled, id) +import Halogen.HTML.Properties (class_, classes, disabled, enabled, id, title) import Halogen.HTML.Properties.ARIA (label, role) import Halogen.Monaco (monacoComponent) import Humanize @@ -129,6 +129,7 @@ import MainFrame.Types ) import Marlowe.Holes (TransactionInputContent(..)) import Marlowe.Holes as Holes +import Marlowe.Linter (Networks(..)) import Marlowe.Monaco as MM import Marlowe.Template (TemplateContent(..), orderContentUsingMetadata) import Marlowe.Time (unixEpoch) @@ -329,13 +330,14 @@ sidebar => MetaData -> State -> Array (ComponentHTML Action ChildSlots m) -sidebar metadata state = +sidebar metadata state@({ networks: netw }) = case preview (_marloweState <<< _Head <<< _executionState) state of Just (SimulationNotStarted notStartedRecord) -> [ startSimulationWidget metadata notStartedRecord state.tzOffset + netw ] Just (SimulationRunning _) -> [ div [ class_ smallSpaceBottom ] [ simulationStateWidget state ] @@ -360,13 +362,15 @@ startSimulationWidget => MetaData -> InitialConditionsRecord -> Minutes + -> Networks -> ComponentHTML Action ChildSlots m startSimulationWidget metadata { initialTime , templateContent } - tzOffset = + tzOffset + netwrks = cardWidget "Simulation has not started yet" $ div_ [ div @@ -395,10 +399,22 @@ startSimulationWidget ] [ text "Download as JSON" ] , button - [ classNames - [ "btn", "bold", "flex-1", "max-w-[15rem]", "mx-2" ] - , onClick $ const ExportToRunner - ] + ( [ classNames + [ "btn", "bold", "flex-1", "max-w-[15rem]", "mx-2" ] + , onClick $ const ExportToRunner + ] <> case netwrks of + Unknown -> [ enabled true ] + Mainnet -> + [ enabled false + , title "Exporting to mainnet Runner not supported" + ] + Testnet -> [ enabled true ] + SeveralNetworks -> + [ enabled false + , title + "Addresses from both mainnet and testnet were found in the contract" + ] + ) [ text "Export to Marlowe Runner" ] , button [ classNames