PLT-8828 - Check that contract is not mixing mainnet and testnet addr…

…esses before sending to Runner (#66)

* Add test to linter to check different networks give a warning
* Add warning when using addresses of different networks
* Forbid contract is not mixing mainnet and testnet before sending to Runner
* Add changelog entry

changelog.d/20240127_213938_pablo.lamela_PLT_8828.md

@@ -0,0 +1,41 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+-->
+
+<!--
+### Removed
+
+- A bullet item for the Removed category.
+
+-->
+### Added
+
+- Added a linter warning for whenever there are networks from both testnet and mainnet.
+- Forbid sending contracts to Marlowe Runner when networks mismatch.
+
+<!--
+### Changed
+
+- A bullet item for the Changed category.
+
+-->
+<!--
+### Deprecated
+
+- A bullet item for the Deprecated category.
+
+-->
+<!--
+### Fixed
+
+- A bullet item for the Fixed category.
+
+-->
+<!--
+### Security
+
+- A bullet item for the Security category.
+
+-->

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

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"

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")
+

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)) =

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
   }
 

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