From 887d362282ae32c17b07312948cbe9bda36e75bd Mon Sep 17 00:00:00 2001 From: Pablo Lamela Date: Tue, 23 Jan 2024 14:05:35 +0100 Subject: [PATCH] PLT-8827 - Check token names and currency symbols (#64) * Write acceptance tests * Implement string length checking * Update swap example * Add changelog entry --- .../20240117_023242_pablo.lamela_PLT_8827.md | 42 ++++++ .../generated/Examples/Haskell/Contracts.purs | 2 +- .../generated/Examples/Marlowe/Contracts.purs | 4 +- marlowe-playground-client/spago.dhall | 2 + .../src/Examples/JS/Contracts.purs | 2 +- .../src/Marlowe/Linter.purs | 49 ++++++- .../src/Marlowe/LinterText.purs | 3 + .../test/Marlowe/LintTests.purs | 134 +++++++++++++++++- marlowe-playground-server/contracts/Swap.hs | 2 +- nix/spago-packages.nix | 48 +++++++ packages.dhall | 2 + .../src/Examples/PureScript/Swap.purs | 4 +- 12 files changed, 284 insertions(+), 10 deletions(-) create mode 100644 changelog.d/20240117_023242_pablo.lamela_PLT_8827.md diff --git a/changelog.d/20240117_023242_pablo.lamela_PLT_8827.md b/changelog.d/20240117_023242_pablo.lamela_PLT_8827.md new file mode 100644 index 000000000..c0a3f7558 --- /dev/null +++ b/changelog.d/20240117_023242_pablo.lamela_PLT_8827.md @@ -0,0 +1,42 @@ + + + + +### Added + +- Added linting for token names and currency symbols. + + + + + + diff --git a/marlowe-playground-client/generated/Examples/Haskell/Contracts.purs b/marlowe-playground-client/generated/Examples/Haskell/Contracts.purs index 7385e7465..6c8ca8684 100644 --- a/marlowe-playground-client/generated/Examples/Haskell/Contracts.purs +++ b/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 diff --git a/marlowe-playground-client/generated/Examples/Marlowe/Contracts.purs b/marlowe-playground-client/generated/Examples/Marlowe/Contracts.purs index e31510ac1..3c9c6b7e2 100644 --- a/marlowe-playground-client/generated/Examples/Marlowe/Contracts.purs +++ b/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 diff --git a/marlowe-playground-client/spago.dhall b/marlowe-playground-client/spago.dhall index c6b65db8e..e04db8d03 100644 --- a/marlowe-playground-client/spago.dhall +++ b/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" diff --git a/marlowe-playground-client/src/Examples/JS/Contracts.purs b/marlowe-playground-client/src/Examples/JS/Contracts.purs index 454edad6e..3e262e967 100644 --- a/marlowe-playground-client/src/Examples/JS/Contracts.purs +++ b/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; diff --git a/marlowe-playground-client/src/Marlowe/Linter.purs b/marlowe-playground-client/src/Marlowe/Linter.purs index 5c66d2cb2..6cf9e9bcf 100644 --- a/marlowe-playground-client/src/Marlowe/Linter.purs +++ b/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,6 +35,8 @@ 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 @@ -41,7 +44,16 @@ import Language.Marlowe.Core.V1.Semantics , 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) diff --git a/marlowe-playground-client/src/Marlowe/LinterText.purs b/marlowe-playground-client/src/Marlowe/LinterText.purs index aa2ac824b..c46bd3eea 100644 --- a/marlowe-playground-client/src/Marlowe/LinterText.purs +++ b/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" diff --git a/marlowe-playground-client/test/Marlowe/LintTests.purs b/marlowe-playground-client/test/Marlowe/LintTests.purs index a9ec42c7f..d8552fbfe 100644 --- a/marlowe-playground-client/test/Marlowe/LintTests.purs +++ b/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" diff --git a/marlowe-playground-server/contracts/Swap.hs b/marlowe-playground-server/contracts/Swap.hs index 194b20bde..9ad9af3e4 100644 --- a/marlowe-playground-server/contracts/Swap.hs +++ b/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 diff --git a/nix/spago-packages.nix b/nix/spago-packages.nix index 3becb8d34..f55606be9 100644 --- a/nix/spago-packages.nix +++ b/nix/spago-packages.nix @@ -125,6 +125,18 @@ let installPhase = "ln -s $src $out"; }; + "arraybuffer" = pkgs.stdenv.mkDerivation { + name = "arraybuffer"; + version = "v13.0.0"; + src = pkgs.fetchgit { + url = "https://github.com/purescript-contrib/purescript-arraybuffer.git"; + rev = "3b5ba3040f060057e864805546a50f319853517d"; + sha256 = "0cfi15r95zd7ikvs8v3pf2i3rzxjqxk7209j96d8qs6jzqlypbwd"; + }; + phases = "installPhase"; + installPhase = "ln -s $src $out"; + }; + "arraybuffer-types" = pkgs.stdenv.mkDerivation { name = "arraybuffer-types"; version = "v3.0.2"; @@ -353,6 +365,18 @@ let installPhase = "ln -s $src $out"; }; + "encoding" = pkgs.stdenv.mkDerivation { + name = "encoding"; + version = "v0.0.8"; + src = pkgs.fetchgit { + url = "https://github.com/menelaos/purescript-encoding.git"; + rev = "a9d1913de736821c133ecd7944a08b2ab07ad774"; + sha256 = "0c23bpfw67ik1n821bq3s0w036sk7yqi4fy5fd7dgf4325abk6zn"; + }; + phases = "installPhase"; + installPhase = "ln -s $src $out"; + }; + "enums" = pkgs.stdenv.mkDerivation { name = "enums"; version = "v6.0.0"; @@ -413,6 +437,18 @@ let installPhase = "ln -s $src $out"; }; + "float32" = pkgs.stdenv.mkDerivation { + name = "float32"; + version = "v2.0.0"; + src = pkgs.fetchgit { + url = "https://github.com/purescript-contrib/purescript-float32.git"; + rev = "3b70984d823c12c1b84a45a9b3d45199a4fcc67d"; + sha256 = "0a1lvga6bbhbb8g3crp3fr0kmpkzjmffhfq71ig6flin13xijgys"; + }; + phases = "installPhase"; + installPhase = "ln -s $src $out"; + }; + "foldable-traversable" = pkgs.stdenv.mkDerivation { name = "foldable-traversable"; version = "v6.0.0"; @@ -1349,6 +1385,18 @@ let installPhase = "ln -s $src $out"; }; + "uint" = pkgs.stdenv.mkDerivation { + name = "uint"; + version = "v7.0.0"; + src = pkgs.fetchgit { + url = "https://github.com/purescript-contrib/purescript-uint.git"; + rev = "9e4f76ffd5192472f75583844172fe8ab3c0cb9f"; + sha256 = "173bhrd006q53s7agwyasxhfbr89x9jpz5b47vm2fr74l3jcw3lq"; + }; + phases = "installPhase"; + installPhase = "ln -s $src $out"; + }; + "undefined-or" = pkgs.stdenv.mkDerivation { name = "undefined-or"; version = "5822ab71acc9ed276afd6fa96f1cb3135e376719"; diff --git a/packages.dhall b/packages.dhall index fcffa36ea..2cb29ecac 100644 --- a/packages.dhall +++ b/packages.dhall @@ -186,6 +186,7 @@ in upstream [ "argonaut" , "argonaut-codecs" , "argonaut-core" + , "arraybuffer" , "arrays" , "bifunctors" , "bigints" @@ -193,6 +194,7 @@ in upstream , "control" , "datetime" , "either" + , "encoding" , "foldable-traversable" , "foreign-object" , "functions" diff --git a/web-common-marlowe/src/Examples/PureScript/Swap.purs b/web-common-marlowe/src/Examples/PureScript/Swap.purs index 7eca521ec..1a5137794 100644 --- a/web-common-marlowe/src/Examples/PureScript/Swap.purs +++ b/web-common-marlowe/src/Examples/PureScript/Swap.purs @@ -114,7 +114,9 @@ dollarDepositTimeout :: Timeout dollarDepositTimeout = TimeParam "Timeout for dollar deposit" dollars :: Token -dollars = Token "85bb65" "dollar" +dollars = Token + "85bb65085bb65085bb65085bb65085bb65085bb65085bb65085bb650" + "dollar" type SwapParty = { party :: Party