PLT-8827 - Check token names and currency symbols (#64)

* Write acceptance tests
* Implement string length checking
* Update swap example
* Add changelog entry

changelog.d/20240117_023242_pablo.lamela_PLT_8827.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
+
+- Added linting for token names and currency symbols.
+
+
+<!--
+### 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/generated/Examples/Haskell/Contracts.purs

@@ -344,7 +344,7 @@ adaDepositTimeout = TimeParam "Timeout for Ada deposit"
 dollarDepositTimeout = TimeParam "Timeout for dollar deposit"
 
 dollars :: Token
-dollars = Token "85bb65" "dollar"
+dollars = Token "85bb65085bb65085bb65085bb65085bb65085bb65085bb65085bb650" "dollar"
 
 data SwapParty = SwapParty { party    :: Party
                            , currency :: Token

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

@@ -210,7 +210,7 @@ swap =
      (When [
         (Case
            (Deposit (Role "Dollar provider") (Role "Dollar provider")
-              (Token "85bb65" "dollar")
+              (Token "85bb65085bb65085bb65085bb65085bb65085bb65085bb65085bb650" "dollar")
               (ConstantParam "Amount of dollars"))
            (Pay (Role "Ada provider")
               (Party (Role "Dollar provider"))
@@ -220,7 +220,7 @@ swap =
                  (ConstantParam "Amount of Ada"))
               (Pay (Role "Dollar provider")
                  (Party (Role "Ada provider"))
-                 (Token "85bb65" "dollar")
+                 (Token "85bb65085bb65085bb65085bb65085bb65085bb65085bb65085bb650" "dollar")
                  (ConstantParam "Amount of dollars") Close)))] (TimeParam "Timeout for dollar deposit") Close))] (TimeParam "Timeout for Ada deposit") Close"""
 
 contractForDifferences :: String

marlowe-playground-client/spago.dhall

@@ -8,6 +8,7 @@
   , "argonaut-codecs"
   , "argonaut-core"
   , "argonaut-generic"
+  , "arraybuffer"
   , "arraybuffer-types"
   , "arrays"
   , "bifunctors"
@@ -20,6 +21,7 @@
   , "dom-indexed"
   , "effect"
   , "either"
+  , "encoding"
   , "enums"
   , "exceptions"
   , "filterable"

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

@@ -292,7 +292,7 @@ swap =
     const adaDepositTimeout: Timeout = TimeParam("Timeout for Ada deposit");
     const dollarDepositTimeout: Timeout = TimeParam("Timeout for dollar deposit");
 
-    const dollars: Token = Token("85bb65", "dollar")
+    const dollars: Token = Token("85bb65085bb65085bb65085bb65085bb65085bb65085bb65085bb650", "dollar")
 
     type SwapParty = {
         party: Party;

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

@@ -15,6 +15,7 @@ module Marlowe.Linter
 import Prologue
 
 import Control.Monad.State as CMS
+import Data.ArrayBuffer.Typed (length)
 import Data.Bifunctor (bimap)
 import Data.BigInt.Argonaut (BigInt)
 import Data.DateTime.Instant (Instant)
@@ -34,14 +35,25 @@ import Data.Ord.Generic (genericCompare)
 import Data.Set (Set)
 import Data.Set as Set
 import Data.Set.Ordered.OSet as OSet
+import Data.String (length) as String
+import Data.TextEncoder (encodeUtf8)
 import Data.Tuple.Nested (type (/\), (/\))
 import Humanize (humanizeValue)
 import Language.Marlowe.Core.V1.Semantics
   ( emptyState
   , evalValue
   , makeEnvironment
   )
-import Language.Marlowe.Core.V1.Semantics.Types as S
+import Language.Marlowe.Core.V1.Semantics.Types
+  ( AccountId
+  , ChoiceId
+  , CurrencySymbol
+  , State(..)
+  , Token
+  , TokenName
+  , Value(..)
+  , ValueId
+  ) as S
 import Language.Marlowe.Extended.V1 as EM
 import Language.Marlowe.Extended.V1.Metadata.Lenses
   ( _choiceNames
@@ -122,6 +134,9 @@ data WarningDetail
   | UndefinedChoice
   | UndefinedUse
   | ShadowedLet
+  | RoleNameTooLong
+  | PolicyIdWrongLength
+  | TokenNameTooLong
   | SimplifiableValue (Term Value) (Term Value)
   | SimplifiableObservation (Term Observation) (Term Observation)
   | PayBeforeDeposit S.AccountId
@@ -145,6 +160,12 @@ instance showWarningDetail :: Show WarningDetail where
   show UndefinedUse =
     "The contract uses a ValueId that has not been defined in a Let, so (Constant 0) will be used"
   show ShadowedLet = "Let is redefining a ValueId that already exists"
+  show RoleNameTooLong =
+    "Role name is too long (role names are limited to 32 bytes)"
+  show PolicyIdWrongLength =
+    "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 (SimplifiableValue oriVal newVal) = "The value \"" <> show oriVal
     <> "\" can be simplified to \""
     <> show newVal
@@ -374,6 +395,16 @@ constToObs false = Term FalseObs NoLocation
 constToVal :: BigInt -> Term Value
 constToVal x = Term (Constant x) NoLocation
 
+validTokenName :: S.TokenName -> Boolean
+validTokenName tn = length (encodeUtf8 tn) <= 32
+
+validCurrencySymbol :: S.CurrencySymbol -> Boolean
+validCurrencySymbol cs =
+  let
+    csLen = String.length cs
+  in
+    csLen == 56 || csLen == 0
+
 addMoneyToEnvAccount :: BigInt -> S.AccountId -> S.Token -> LintEnv -> LintEnv
 addMoneyToEnvAccount amountToAdd accTerm tokenTerm = over _deposits
   (Map.alter (addMoney amountToAdd) (accTerm /\ tokenTerm))
@@ -411,15 +442,27 @@ lintParty (Term (Address addr) pos) =
   if validPaymentShelleyAddress addr then pure unit
   else addWarning (InvalidAddress addr) pos
 
-lintParty (Term (Role role) _) =
+lintParty (Term (Role role) pos) = do
+  if validTokenName role then pure unit
+  else addWarning RoleNameTooLong pos
   modifying (_metadataHints <<< _roles) $ Set.insert role
 
 lintParty _ = pure unit
 
+lintToken :: Term MH.Token -> CMS.State State Unit
+lintToken (Term (MH.Token currencySymbol tokenName) pos) = do
+  if validTokenName tokenName then pure unit
+  else addWarning TokenNameTooLong pos
+  if validCurrencySymbol currencySymbol then pure unit
+  else addWarning PolicyIdWrongLength pos
+
+lintToken _ = 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
+  lintToken token
   lintParty acc
   case payee of
     Term (Account party) _ -> lintParty party
@@ -672,6 +715,7 @@ lintValue
   -> Term Value
   -> CMS.State State (TemporarySimplification BigInt Value)
 lintValue _ t@(Term (AvailableMoney acc token) pos) = do
+  lintToken token
   lintParty acc
   let
     gatherHoles = getHoles acc <> getHoles token
@@ -863,6 +907,7 @@ lintAction env (Term (Deposit acc party token value) pos) = do
       (fromTerm token)
 
     isReachable = view _isReachable env
+  lintToken token
   lintParty acc
   lintParty party
   modifying _holes (getHoles acc <> getHoles party <> getHoles token)

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

@@ -189,6 +189,9 @@ warningType (Warning { warning }) = case warning of
   UndefinedChoice -> "UndefinedChoice"
   UndefinedUse -> "UndefinedUse"
   ShadowedLet -> "ShadowedLet"
+  RoleNameTooLong -> "RoleNameTooLong"
+  PolicyIdWrongLength -> "PolicyIdWrongLength"
+  TokenNameTooLong -> "TokenNameTooLong"
   (SimplifiableValue _ _) -> "SimplifiableValue"
   (SimplifiableObservation _ _) -> "SimplifiableObservation"
   (PayBeforeDeposit _) -> "PayBeforeDeposit"

marlowe-playground-client/test/Marlowe/LintTests.purs

@@ -4,10 +4,12 @@ import Prologue
 
 import Control.Monad.Error.Class (class MonadThrow)
 import Data.Array (singleton)
-import Data.Foldable (for_)
-import Data.List (List(..))
+import Data.List (List(..), fold)
+import Data.List.Lazy (replicate)
 import Data.Map as Map
 import Data.Set (toUnfoldable)
+import Data.String.CodeUnits as S
+import Data.Traversable (class Foldable, foldMap, for_)
 import Data.Tuple (uncurry)
 import Data.Tuple.Nested (type (/\), (/\))
 import Effect.Aff (Error)
@@ -47,6 +49,18 @@ all = do
     it "reports simplication of DivValue with constant" divConstantSimplified
     it "reports simplication Invalid bound in Case" unreachableCaseInvalidBound
     it "reports bad practices Let shadowing" letShadowing
+    it "reports role name too many characters" roleTooLongWarning
+    it "reports role name too many bytes" roleTooLongBytesWarning
+    it "does not report 32 ANSI-characters role name" roleOkNoWarning
+    it "does not report 32 bytes role name" roleOkBytesNoWarning
+    it "reports currency symbol is too short" currencySymbolTooShortWarning
+    it "reports currency symbol is too long" currencySymbolTooLongWarning
+    it "does not report currency symbol is the right length"
+      currencySymbolOkNoWarning
+    it "reports token name too many characters" tokenNameTooLongWarning
+    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 bad practices Non-increasing timeouts" nonIncreasingTimeouts
     it "reports unreachable code Unreachable If branch (then)" unreachableThen
     it "reports unreachable code Unreachable If branch (else)" unreachableElse
@@ -425,6 +439,122 @@ letShadowing = testWarningSimple
   "Let \"value\" (Constant 1) (Let \"value\" (Constant 1) Close)"
   "Let is redefining a ValueId that already exists"
 
+fromChars :: forall f. Foldable f => f Char -> String
+fromChars = foldMap S.singleton
+
+roleTooLongWarning :: forall m. MonadThrow Error m => m Unit
+roleTooLongWarning = testWarningSimple contract
+  "Role name is too long (role names are limited to 32 bytes)"
+  where
+  roleTooLong = fromChars $ replicate 33 'r'
+  contract =
+    "When [Case (Deposit (Role " <> show roleTooLong <>
+      ") (Role \"alice\") (Token \"\" \"\") (Constant 10)) Close] 2 Close"
+
+roleTooLongBytesWarning :: forall m. MonadThrow Error m => m Unit
+roleTooLongBytesWarning = testWarningSimple contract
+  "Role name is too long (role names are limited to 32 bytes)"
+  where
+  roleTooLong = S.singleton 'r' <> (fold $ replicate 16 "ü")
+  contract =
+    "When [Case (Deposit (Role " <> show roleTooLong <>
+      ") (Role \"alice\") (Token \"\" \"\") (Constant 10)) Close] 2 Close"
+
+roleOkNoWarning :: forall m. MonadThrow Error m => m Unit
+roleOkNoWarning = testNoWarning contract
+  where
+  roleOk = fromChars $ replicate 32 'r'
+  contract =
+    "When [Case (Deposit (Role " <> show roleOk <>
+      ") (Role \"alice\") (Token \"\" \"\") (Constant 10)) Close] 2 Close"
+
+roleOkBytesNoWarning :: forall m. MonadThrow Error m => m Unit
+roleOkBytesNoWarning = testNoWarning contract
+  where
+  roleOk = fold $ replicate 16 "ü"
+  contract =
+    "When [Case (Deposit (Role " <> show roleOk <>
+      ") (Role \"alice\") (Token \"\" \"\") (Constant 10)) Close] 2 Close"
+
+currencySymbolTooLongWarning :: forall m. MonadThrow Error m => m Unit
+currencySymbolTooLongWarning = testWarningSimple contract
+  "Policy ID is the wrong length (policy IDs must consist of 56 hexadecimal characters or 0 for ADA)"
+  where
+  currencySymbolTooLong = fromChars $ replicate 58 '0'
+  contract =
+    "When [Case (Deposit (Role \"alice\") (Role \"alice\") (Token "
+      <> show currencySymbolTooLong
+      <> " \"\") (Constant 10)) Close] 2 Close"
+
+currencySymbolTooShortWarning :: forall m. MonadThrow Error m => m Unit
+currencySymbolTooShortWarning = testWarningSimple contract
+  "Policy ID is the wrong length (policy IDs must consist of 56 hexadecimal characters or 0 for ADA)"
+  where
+  currencySymbolTooLong = fromChars $ replicate 54 '0'
+  contract =
+    "When [Case (Deposit (Role \"alice\") (Role \"alice\") (Token "
+      <> show currencySymbolTooLong
+      <> " \"\") (Constant 10)) Close] 2 Close"
+
+currencySymbolOkNoWarning :: forall m. MonadThrow Error m => m Unit
+currencySymbolOkNoWarning = testNoWarning contract
+  where
+  currencySymbolOk = fromChars $ replicate 56 '0'
+  contract =
+    "When [Case (Deposit (Role \"alice\") (Role \"alice\") (Token "
+      <> show currencySymbolOk
+      <> " \"\") (Constant 10)) Close] 2 Close"
+
+tokenNameTooLongWarning :: forall m. MonadThrow Error m => m Unit
+tokenNameTooLongWarning = testWarningSimple contract
+  "Token name is too long (token names are limited to 32 bytes)"
+  where
+  currencySymbolOk = fromChars $ replicate 56 '0'
+  tokenNameTooLong = fromChars $ replicate 33 'r'
+  contract =
+    "When [Case (Deposit (Role \"alice\") (Role \"alice\") (Token "
+      <> show currencySymbolOk
+      <> " "
+      <> show tokenNameTooLong
+      <> ") (Constant 10)) Close] 2 Close"
+
+tokenNameTooLongBytesWarning :: forall m. MonadThrow Error m => m Unit
+tokenNameTooLongBytesWarning = testWarningSimple contract
+  "Token name is too long (token names are limited to 32 bytes)"
+  where
+  currencySymbolOk = fromChars $ replicate 56 '0'
+  tokenNameTooLong = S.singleton 'r' <> (fold $ replicate 16 "ü")
+  contract =
+    "When [Case (Deposit (Role \"alice\") (Role \"alice\") (Token "
+      <> show currencySymbolOk
+      <> " "
+      <> show tokenNameTooLong
+      <> ") (Constant 10)) Close] 2 Close"
+
+tokenNameOkNoWarning :: forall m. MonadThrow Error m => m Unit
+tokenNameOkNoWarning = testNoWarning contract
+  where
+  currencySymbolOk = fromChars $ replicate 56 '0'
+  tokenNameOk = fromChars $ replicate 32 'r'
+  contract =
+    "When [Case (Deposit (Role \"alice\") (Role \"alice\") (Token "
+      <> show currencySymbolOk
+      <> " "
+      <> show tokenNameOk
+      <> ") (Constant 10)) Close] 2 Close"
+
+tokenNameOkBytesNoWarning :: forall m. MonadThrow Error m => m Unit
+tokenNameOkBytesNoWarning = testNoWarning contract
+  where
+  currencySymbolOk = fromChars $ replicate 56 '0'
+  tokenNameOk = fold $ replicate 16 "ü"
+  contract =
+    "When [Case (Deposit (Role \"alice\") (Role \"alice\") (Token "
+      <> show currencySymbolOk
+      <> " "
+      <> show tokenNameOk
+      <> ") (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"

marlowe-playground-server/contracts/Swap.hs

@@ -22,7 +22,7 @@ adaDepositTimeout = TimeParam "Timeout for Ada deposit"
 dollarDepositTimeout = TimeParam "Timeout for dollar deposit"
 
 dollars :: Token
-dollars = Token "85bb65" "dollar"
+dollars = Token "85bb65085bb65085bb65085bb65085bb65085bb65085bb65085bb650" "dollar"
 
 data SwapParty = SwapParty { party    :: Party
                            , currency :: Token