diff --git a/changelog.d/20240127_213938_pablo.lamela_PLT_8828.md b/changelog.d/20240127_213938_pablo.lamela_PLT_8828.md new file mode 100644 index 000000000..1500237f4 --- /dev/null +++ b/changelog.d/20240127_213938_pablo.lamela_PLT_8828.md @@ -0,0 +1,41 @@ + + + +### Added + +- Added a linter warning for whenever there are networks from both testnet and mainnet. +- Forbid sending contracts to Marlowe Runner when networks mismatch. + + + + + diff --git a/marlowe-playground-client/src/Marlowe/Linter.purs b/marlowe-playground-client/src/Marlowe/Linter.purs index 6cf9e9bcf..b97b348b3 100644 --- a/marlowe-playground-client/src/Marlowe/Linter.purs +++ b/marlowe-playground-client/src/Marlowe/Linter.purs @@ -1,5 +1,6 @@ module Marlowe.Linter ( lint + , Networks(..) , State(..) , MaxTimeout(..) , Warning(..) @@ -9,7 +10,10 @@ module Marlowe.Linter , _warnings , _metadataHints , _location + , _network , hasInvalidAddresses + , isSeveralNetworks + , getNetworkFor ) where import Prologue @@ -23,18 +27,19 @@ import Data.Eq.Generic (genericEq) import Data.Foldable (any, foldM) import Data.FoldableWithIndex (traverseWithIndex_) import Data.Generic.Rep (class Generic) -import Data.Lens (Lens', modifying, over, set, view) +import Data.Lens (Lens', modifying, over, set, use, view) import Data.Lens.Iso.Newtype (_Newtype) import Data.Lens.Record (prop) import Data.List (List(..)) import Data.Map (Map) import Data.Map as Map -import Data.Maybe (isNothing, maybe) +import Data.Maybe (isJust, isNothing, maybe) import Data.Newtype (class Newtype) import Data.Ord.Generic (genericCompare) import Data.Set (Set) import Data.Set as Set import Data.Set.Ordered.OSet as OSet +import Data.String (Pattern(..), stripPrefix) import Data.String (length) as String import Data.TextEncoder (encodeUtf8) import Data.Tuple.Nested (type (/\), (/\)) @@ -137,6 +142,7 @@ data WarningDetail | RoleNameTooLong | PolicyIdWrongLength | TokenNameTooLong + | NetworkMismatch | SimplifiableValue (Term Value) (Term Value) | SimplifiableObservation (Term Observation) (Term Observation) | PayBeforeDeposit S.AccountId @@ -166,6 +172,8 @@ instance showWarningDetail :: Show WarningDetail where "Policy ID is the wrong length (policy IDs must consist of 56 hexadecimal characters or 0 for ADA)" show TokenNameTooLong = "Token name is too long (token names are limited to 32 bytes)" + show NetworkMismatch = + "The contract uses addresses from both mainnet and testned. This is very dangerous and can make the Marlowe validator fail to run." show (SimplifiableValue oriVal newVal) = "The value \"" <> show oriVal <> "\" can be simplified to \"" <> show newVal @@ -214,12 +222,39 @@ instance ordWarning :: Ord Warning where instance showWarning :: Show Warning where show (Warning warn) = show warn.warning +data Networks + = Unknown + | Mainnet + | Testnet + | SeveralNetworks + +derive instance eqNetwork :: Eq Networks + +derive instance ordNetwork :: Ord Networks + +instance semigroupNetworks :: Semigroup Networks where + append :: Networks -> Networks -> Networks + append Unknown x = x + append x Unknown = x + append x y + | x /= y = SeveralNetworks + | otherwise = x + +instance monoideNetwork :: Monoid Networks where + mempty :: Networks + mempty = Unknown + newtype State = State { holes :: Holes , warnings :: Set Warning , metadataHints :: MetadataHintInfo + , network :: Networks } +isSeveralNetworks :: Networks -> Boolean +isSeveralNetworks SeveralNetworks = true +isSeveralNetworks _ = false + derive instance newtypeState :: Newtype State _ derive newtype instance semigroupState :: Semigroup State @@ -235,6 +270,9 @@ _warnings = _Newtype <<< prop (Proxy :: _ "warnings") _metadataHints :: Lens' State MetadataHintInfo _metadataHints = _Newtype <<< prop (Proxy :: _ "metadataHints") +_network :: Lens' State Networks +_network = _Newtype <<< prop (Proxy :: _ "network") + hasHoles :: State -> Boolean hasHoles = not MH.isEmpty <<< view _holes @@ -250,6 +288,23 @@ addChoiceName :: String -> CMS.State State Unit addChoiceName choiceName = modifying (_metadataHints <<< _choiceNames) $ Set.insert choiceName +addNetwork :: Networks -> CMS.State State Unit +addNetwork network = modifying _network (\x -> x <> network) + +getNetwork :: String -> Networks +getNetwork str = + let + startsWith pre = isJust $ stripPrefix (Pattern pre) str + in + case unit of + _ + | startsWith "addr1" -> Mainnet + | startsWith "addr_test1" -> Testnet + | otherwise -> Unknown + +addAddressNetwork :: String -> CMS.State State Unit +addAddressNetwork addr = addNetwork (getNetwork addr) + newtype LintEnv = LintEnv { choicesMade :: Set S.ChoiceId , deposits :: Map (S.AccountId /\ S.Token) (Maybe BigInt) @@ -435,11 +490,26 @@ lint unreachablePaths contract = let env = emptyEnvironment unreachablePaths in - CMS.execState (lintContract env contract) mempty + CMS.execState (addNetworkMismatchWarning (lintContract env contract)) mempty + +addNetworkMismatchWarning :: CMS.State State Unit -> CMS.State State Unit +addNetworkMismatchWarning m = do + m + n <- use _network + if isSeveralNetworks n then addWarning NetworkMismatch + ( Range + ( { startLineNumber: 0 + , startColumn: 0 + , endLineNumber: 0 + , endColumn: 0 + } + ) + ) + else pure unit lintParty :: Term Party -> CMS.State State Unit lintParty (Term (Address addr) pos) = - if validPaymentShelleyAddress addr then pure unit + if validPaymentShelleyAddress addr then addAddressNetwork addr else addWarning (InvalidAddress addr) pos lintParty (Term (Role role) pos) = do @@ -972,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/Marlowe/LinterText.purs b/marlowe-playground-client/src/Marlowe/LinterText.purs index c46bd3eea..afa970cc1 100644 --- a/marlowe-playground-client/src/Marlowe/LinterText.purs +++ b/marlowe-playground-client/src/Marlowe/LinterText.purs @@ -192,6 +192,7 @@ warningType (Warning { warning }) = case warning of RoleNameTooLong -> "RoleNameTooLong" PolicyIdWrongLength -> "PolicyIdWrongLength" TokenNameTooLong -> "TokenNameTooLong" + NetworkMismatch -> "NetworkMismatch" (SimplifiableValue _ _) -> "SimplifiableValue" (SimplifiableObservation _ _) -> "SimplifiableObservation" (PayBeforeDeposit _) -> "PayBeforeDeposit" diff --git a/marlowe-playground-client/src/Page/Simulation/Lenses.purs b/marlowe-playground-client/src/Page/Simulation/Lenses.purs index b7ad87641..695c4b64d 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 6514382f4..cce0f0db2 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 d4ed1657a..13e645971 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 8c78d9aef..e60584f22 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 diff --git a/marlowe-playground-client/test/Marlowe/LintTests.purs b/marlowe-playground-client/test/Marlowe/LintTests.purs index d8552fbfe..eb92236ab 100644 --- a/marlowe-playground-client/test/Marlowe/LintTests.purs +++ b/marlowe-playground-client/test/Marlowe/LintTests.purs @@ -61,6 +61,12 @@ all = do it "reports token name too many bytes" tokenNameTooLongBytesWarning it "does not report 32 ANSI-characters token name" tokenNameOkNoWarning it "does not report 32 bytes token name" tokenNameOkBytesNoWarning + it "reports contract with addresses from different network" + networkMismatchWarning + it "does not report contract with only addresses from mainnet" + mainnetNetworkNoWarning + it "does not report contract with only addresses from testnet" + testnetNetworkNoWarning it "reports bad practices Non-increasing timeouts" nonIncreasingTimeouts it "reports unreachable code Unreachable If branch (then)" unreachableThen it "reports unreachable code Unreachable If branch (else)" unreachableElse @@ -555,6 +561,45 @@ tokenNameOkBytesNoWarning = testNoWarning contract <> show tokenNameOk <> ") (Constant 10)) Close] 2 Close" +networkMismatchWarning :: forall m. MonadThrow Error m => m Unit +networkMismatchWarning = testWarningSimple contract + "The contract uses addresses from both mainnet and testned. This is very dangerous and can make the Marlowe validator fail to run." + where + addressMainnet = + "Address \"addr1qxn6u4ffhafpfvsw876wxllvvae88wekwhsnvpuh4s8fgf0xjsn7s0z25ycztthswazwj7wj0yta5m7d0y32q5aseyys63phd5\"" + addressTestnet = + "Address \"addr_test1qzn6u4ffhafpfvsw876wxllvvae88wekwhsnvpuh4s8fgf0xjsn7s0z25ycztthswazwj7wj0yta5m7d0y32q5aseyyse8uhpt\"" + contract = + "When [Case (Deposit (" + <> addressMainnet + <> ") (" + <> addressTestnet + <> ") (Token \"\" \"\") (Constant 10)) Close] 2 Close" + +mainnetNetworkNoWarning :: forall m. MonadThrow Error m => m Unit +mainnetNetworkNoWarning = testNoWarning contract + where + addressMainnet = + "Address \"addr1qxn6u4ffhafpfvsw876wxllvvae88wekwhsnvpuh4s8fgf0xjsn7s0z25ycztthswazwj7wj0yta5m7d0y32q5aseyys63phd5\"" + contract = + "When [Case (Deposit (" + <> addressMainnet + <> ") (" + <> addressMainnet + <> ") (Token \"\" \"\") (Constant 10)) Close] 2 Close" + +testnetNetworkNoWarning :: forall m. MonadThrow Error m => m Unit +testnetNetworkNoWarning = testNoWarning contract + where + addressTestnet = + "Address \"addr_test1qzn6u4ffhafpfvsw876wxllvvae88wekwhsnvpuh4s8fgf0xjsn7s0z25ycztthswazwj7wj0yta5m7d0y32q5aseyyse8uhpt\"" + contract = + "When [Case (Deposit (" + <> addressTestnet + <> ") (" + <> addressTestnet + <> ") (Token \"\" \"\") (Constant 10)) Close] 2 Close" + nonIncreasingTimeouts :: forall m. MonadThrow Error m => m Unit nonIncreasingTimeouts = testWarningSimple "When [] 5 (When [] 5 Close)" "Timeouts should always increase in value"