PLT-7305 - Improve error message on invalid addresses (#59)

* Implement Shelley address checking
* Add linting and more tests
* Prevent static analysis on invalid addresses
* Check length of addresses
* Make burn address the right length
* Add change log entries
* Update generated files
* Add citations

changelog.d/20231129_061349_pablo.lamela_PLT_7305.md

@@ -0,0 +1,42 @@
+<!--
+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
+
+- A bullet item for the Added category.
+
+-->
+<!--
+### Changed
+
+- A bullet item for the Changed category.
+
+-->
+<!--
+### Deprecated
+
+- A bullet item for the Deprecated category.
+
+-->
+
+### Fixed
+
+- Added linting warning when addresses are invalid.
+- Improved error message when trying to do static analysis with invalid addresses.
+
+<!--
+### Security
+
+- A bullet item for the Security category.
+
+-->

marlowe-playground-client/generated/Examples/Marlowe/Contracts.purs

@@ -91,11 +91,11 @@ escrowWithCollateral =
                                          (ChoiceId "Dispute problem" (Role "Seller")) [
                                          (Bound 0 0)])
                                       (Pay (Role "Seller")
-                                         (Party (Address "addr_test1vqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq3lgle2"))
+                                         (Party (Address "addr_test1vqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqd9tg5t"))
                                          (Token "" "")
                                          (ConstantParam "Collateral amount")
                                          (Pay (Role "Buyer")
-                                            (Party (Address "addr_test1vqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq3lgle2"))
+                                            (Party (Address "addr_test1vqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqd9tg5t"))
                                             (Token "" "")
                                             (ConstantParam "Collateral amount") Close)))] (TimeParam "Complaint deadline") Close)))] (TimeParam "Dispute by buyer timeout") Close))] (TimeParam "Deposit of price by buyer timeout") Close))] (TimeParam "Deposit of collateral by buyer timeout") Close))] (TimeParam "Collateral deposit by seller timeout") Close"""
 
@@ -357,4 +357,4 @@ contractForDifferencesWithOracle =
                                                   (UseValue "Increase in price")
                                                   (ConstantParam "Amount paid by party"))
                                                (UseValue "Increase in price")
-                                               (ConstantParam "Amount paid by party")) Close)) Close))))] (TimeParam "Second window deadline") Close)))] (TimeParam "First window deadline") Close)))] (TimeParam "Counterparty deposit deadline") Close))] (TimeParam "Party deposit deadline") Close"""
+                                               (ConstantParam "Amount paid by party")) Close)) Close))))] (TimeParam "Second window deadline") Close)))] (TimeParam "First window deadline") Close)))] (TimeParam "Counterparty deposit deadline") Close))] (TimeParam "Party deposit deadline") Close"""

marlowe-playground-client/src/Examples/JS/Contracts.purs

@@ -90,7 +90,7 @@ escrowWithCollateral =
 
     const buyer: Party = Role("Buyer");
     const seller: Party = Role("Seller");
-    const burnAddress: Party = Address("addr_test1vqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqq3lgle2");
+    const burnAddress: Party = Address("addr_test1vqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqqd9tg5t");
 
     const price: Value = ConstantParam("Price");
     const collateral: Value = ConstantParam("Collateral amount");

marlowe-playground-client/src/Marlowe/Linter.purs

@@ -9,6 +9,7 @@ module Marlowe.Linter
   , _warnings
   , _metadataHints
   , _location
+  , hasInvalidAddresses
   ) where
 
 import Prologue
@@ -18,13 +19,13 @@ import Data.Bifunctor (bimap)
 import Data.BigInt.Argonaut (BigInt)
 import Data.DateTime.Instant (Instant)
 import Data.Eq.Generic (genericEq)
-import Data.Foldable (foldM)
+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.Iso.Newtype (_Newtype)
 import Data.Lens.Record (prop)
-import Data.List (List)
+import Data.List (List(..))
 import Data.Map (Map)
 import Data.Map as Map
 import Data.Maybe (isNothing, maybe)
@@ -49,6 +50,7 @@ import Language.Marlowe.Extended.V1.Metadata.Lenses
   , _valueParameters
   )
 import Language.Marlowe.Extended.V1.Metadata.Types (MetadataHintInfo)
+import Language.Marlowe.ToTerm (toTerm)
 import Marlowe.Holes
   ( Action(..)
   , Bound(..)
@@ -73,8 +75,9 @@ import Marlowe.Holes as MH
 import Marlowe.Time (unixEpoch)
 import Monaco (TextEdit)
 import Pretty (showPrettyParty)
-import StaticAnalysis.Reachability (initializePrefixMap, stepPrefixMap)
+import StaticAnalysis.ReachabilityTools (initializePrefixMap, stepPrefixMap)
 import StaticAnalysis.Types (ContractPath, ContractPathStep(..), PrefixMap)
+import Text.Bech32 (validPaymentShelleyAddress)
 import Text.Pretty (hasArgs, pretty)
 import Type.Proxy (Proxy(..))
 
@@ -111,6 +114,7 @@ data WarningDetail
   = NegativePayment
   | NegativeDeposit
   | TimeoutNotIncreasing
+  | InvalidAddress String
   | UnreachableCaseEmptyChoice
   | InvalidBound
   | UnreachableCaseFalseNotify
@@ -127,6 +131,8 @@ instance showWarningDetail :: Show WarningDetail where
   show NegativePayment = "The contract can make a non-positive payment"
   show NegativeDeposit = "The contract can make a non-positive deposit"
   show TimeoutNotIncreasing = "Timeouts should always increase in value"
+  show (InvalidAddress addr) = show addr <>
+    " is not a valid Shelley payment key address"
   show UnreachableCaseEmptyChoice =
     "This case will never be used, because there are no options to choose from"
   show InvalidBound =
@@ -211,12 +217,6 @@ _metadataHints = _Newtype <<< prop (Proxy :: _ "metadataHints")
 hasHoles :: State -> Boolean
 hasHoles = not MH.isEmpty <<< view _holes
 
-addRoleFromPartyTerm :: Term Party -> CMS.State State Unit
-addRoleFromPartyTerm (Term (Role role) _) =
-  modifying (_metadataHints <<< _roles) $ Set.insert role
-
-addRoleFromPartyTerm _ = pure unit
-
 addTimeParameter :: String -> CMS.State State Unit
 addTimeParameter timeParam = modifying (_metadataHints <<< _timeParameters) $
   OSet.insert timeParam
@@ -406,14 +406,24 @@ lint unreachablePaths contract =
   in
     CMS.execState (lintContract env contract) mempty
 
+lintParty :: Term Party -> CMS.State State Unit
+lintParty (Term (Address addr) pos) =
+  if validPaymentShelleyAddress addr then pure unit
+  else addWarning (InvalidAddress addr) pos
+
+lintParty (Term (Role role) _) =
+  modifying (_metadataHints <<< _roles) $ Set.insert role
+
+lintParty _ = pure unit
+
 lintContract :: LintEnv -> Term Contract -> CMS.State State Unit
 lintContract _ (Term Close _) = pure unit
 
 lintContract env (Term (Pay acc payee token payment cont) pos) = do
-  addRoleFromPartyTerm acc
+  lintParty acc
   case payee of
-    Term (Account party) _ -> addRoleFromPartyTerm party
-    Term (Party party) _ -> addRoleFromPartyTerm party
+    Term (Account party) _ -> lintParty party
+    Term (Party party) _ -> lintParty party
     _ -> pure unit
   modifying _holes (getHoles acc <> getHoles payee <> getHoles token) -- First we calculate the value and warn for non positive values
   sa <- lintValue env payment
@@ -590,7 +600,7 @@ lintObservation
   _
   t@(Term (ChoseSomething choiceId@(ChoiceId choiceName party)) pos) = do
   addChoiceName choiceName
-  addRoleFromPartyTerm party
+  lintParty party
   modifying _holes (getHoles choiceId)
   pure (ValueSimp pos false t)
 
@@ -662,7 +672,7 @@ lintValue
   -> Term Value
   -> CMS.State State (TemporarySimplification BigInt Value)
 lintValue _ t@(Term (AvailableMoney acc token) pos) = do
-  addRoleFromPartyTerm acc
+  lintParty acc
   let
     gatherHoles = getHoles acc <> getHoles token
   modifying _holes gatherHoles
@@ -757,7 +767,7 @@ lintValue env t@(Term (DivValue a b) pos) = do
 lintValue env t@(Term (ChoiceValue choiceId@(ChoiceId choiceName party)) pos) =
   do
     addChoiceName choiceName
-    addRoleFromPartyTerm party
+    lintParty party
     when
       ( case fromTerm choiceId of
           Just semChoiceId -> not $ Set.member semChoiceId
@@ -853,8 +863,8 @@ lintAction env (Term (Deposit acc party token value) pos) = do
       (fromTerm token)
 
     isReachable = view _isReachable env
-  addRoleFromPartyTerm acc
-  addRoleFromPartyTerm party
+  lintParty acc
+  lintParty party
   modifying _holes (getHoles acc <> getHoles party <> getHoles token)
   sa <- lintValue env value
   (\effect -> effect /\ isReachable)
@@ -881,7 +891,7 @@ lintAction env (Term (Choice choiceId@(ChoiceId choiceName party) bounds) pos) =
 
       isReachable = view _isReachable env
     addChoiceName choiceName
-    addRoleFromPartyTerm party
+    lintParty party
     modifying _holes (getHoles choiceId <> getHoles bounds)
     allInvalid <- foldM lintBounds true bounds
     when (allInvalid && isReachable) $ addWarning UnreachableCaseEmptyChoice pos
@@ -906,3 +916,14 @@ lintAction env hole@(Hole _ _) = do
     isReachable = view _isReachable env
   modifying _holes (insertHole hole)
   pure $ NoEffect /\ isReachable
+
+isAddressWarning :: Warning -> Boolean
+isAddressWarning (Warning { warning: InvalidAddress _ }) = true
+isAddressWarning _ = false
+
+hasInvalidAddresses :: EM.Contract -> Boolean
+hasInvalidAddresses ec =
+  let
+    State { warnings } = lint Nil (toTerm ec)
+  in
+    any isAddressWarning warnings

marlowe-playground-client/src/Marlowe/LinterText.purs

@@ -181,6 +181,7 @@ warningType (Warning { warning }) = case warning of
   NegativePayment -> "NegativePayment"
   NegativeDeposit -> "NegativeDeposit"
   TimeoutNotIncreasing -> "TimeoutNotIncreasing"
+  (InvalidAddress _) -> "InvalidAddress"
   UnreachableCaseEmptyChoice -> "UnreachableCaseEmptyChoice"
   InvalidBound -> "InvalidBound"
   UnreachableCaseFalseNotify -> "UnreachableCaseFalseNotify"

marlowe-playground-client/src/StaticAnalysis/BottomPanel.purs

@@ -250,6 +250,19 @@ warningAnalysisResult tzOffset staticSubResult = div
               ]
           ]
       ]
+    Failure WarningWrongAddressesInContract ->
+      [ h3 [ classes [ ClassName "analysis-result-title" ] ]
+          [ text "Error during warning analysis" ]
+      , text "Analysis failed for the following reason:"
+      , ul [ classes [ ClassName "indented-enum-initial" ] ]
+          [ li_
+              [ b_
+                  [ spanText
+                      "The code has invalid addresses. Please check the Warnings tab."
+                  ]
+              ]
+          ]
+      ]
     Loading -> [ text "" ]
 
 reachabilityAnalysisResult

marlowe-playground-client/src/StaticAnalysis/CloseAnalysis.purs

@@ -22,6 +22,7 @@ import Language.Marlowe.Core.V1.Semantics.Types as S
 import Language.Marlowe.Extended.V1 (toCore)
 import Language.Marlowe.Extended.V1 as EM
 import Marlowe (Api)
+import Marlowe.Linter (hasInvalidAddresses)
 import Marlowe.Template (fillTemplate)
 import Servant.PureScript (class MonadAjax)
 import StaticAnalysis.StaticTools
@@ -50,22 +51,28 @@ analyseClose
        Unit
 analyseClose extendedContract = do
   templateContent <- use (_analysisState <<< _templateContent)
-  case toCore $ fillTemplate templateContent extendedContract of
-    Just contract -> do
-      assign (_analysisState <<< _analysisExecutionState)
-        (CloseAnalysis AnalysisNotStarted)
-      -- when editor and simulator were together the analyse contract could be made
-      -- at any step of the simulator. Now that they are separate, it can only be done
-      -- with initial state
-      let
-        emptySemanticState = emptyState
-      newCloseAnalysisState <- startCloseAnalysis contract emptySemanticState
-      assign (_analysisState <<< _analysisExecutionState)
-        (CloseAnalysis newCloseAnalysisState)
-    Nothing -> assign (_analysisState <<< _analysisExecutionState)
-      ( CloseAnalysis $ AnalysisFailure
-          "The code has templates. Static analysis can only be run in core Marlowe code."
-      )
+  if hasInvalidAddresses extendedContract then
+    assign (_analysisState <<< _analysisExecutionState)
+      $ CloseAnalysis
+      $ AnalysisFailure
+          "The code has invalid addresses. Please check the Warnings tab."
+  else
+    case toCore $ fillTemplate templateContent extendedContract of
+      Just contract -> do
+        assign (_analysisState <<< _analysisExecutionState)
+          (CloseAnalysis AnalysisNotStarted)
+        -- when editor and simulator were together the analyse contract could be made
+        -- at any step of the simulator. Now that they are separate, it can only be done
+        -- with initial state
+        let
+          emptySemanticState = emptyState
+        newCloseAnalysisState <- startCloseAnalysis contract emptySemanticState
+        assign (_analysisState <<< _analysisExecutionState)
+          (CloseAnalysis newCloseAnalysisState)
+      Nothing -> assign (_analysisState <<< _analysisExecutionState)
+        ( CloseAnalysis $ AnalysisFailure
+            "The code has templates. Static analysis can only be run in core Marlowe code."
+        )
 
 extractAccountIdsFromZipper :: ContractZipper -> Set (AccountId /\ Token)
 extractAccountIdsFromZipper = go