PLT-8827 - Implement string length checking

input-output-hk · Jan 17, 2024 · c16bb11 · c16bb11
1 parent f3bcf45
commit c16bb11
Show file tree

Hide file tree

Showing 4 changed files with 96 additions and 3 deletions.
diff --git a/marlowe-playground-client/spago.dhall b/marlowe-playground-client/spago.dhall
@@ -11,6 +11,7 @@
   , "arraybuffer-types"
   , "arrays"
   , "bifunctors"
+  , "bytestrings"
   , "console"
   , "control"
   , "coroutines"

diff --git a/marlowe-playground-client/src/Marlowe/Linter.purs b/marlowe-playground-client/src/Marlowe/Linter.purs
@@ -17,6 +17,7 @@ import Prologue
 import Control.Monad.State as CMS
 import Data.Bifunctor (bimap)
 import Data.BigInt.Argonaut (BigInt)
+import Data.ByteString (length, toUTF8) as BS
 import Data.DateTime.Instant (Instant)
 import Data.Eq.Generic (genericEq)
 import Data.Foldable (any, foldM)
@@ -34,14 +35,24 @@ 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.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
@@ -383,6 +394,16 @@ constToObs false = Term FalseObs NoLocation
 constToVal :: BigInt -> Term Value
 constToVal x = Term (Constant x) NoLocation
 
+validTokenName :: S.TokenName -> Boolean
+validTokenName tn = BS.length (BS.toUTF8 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))
@@ -420,15 +441,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
@@ -681,6 +714,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
@@ -872,6 +906,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/nix/spago-packages.nix b/nix/spago-packages.nix
@@ -197,6 +197,18 @@ let
       installPhase = "ln -s $src $out";
     };
 
+    "bytestrings" = pkgs.stdenv.mkDerivation {
+      name = "bytestrings";
+      version = "6733a32fca306015b3428e9985ffac65325a9864";
+      src = pkgs.fetchgit {
+        url = "https://github.com/rightfold/purescript-bytestrings.git";
+        rev = "6733a32fca306015b3428e9985ffac65325a9864";
+        sha256 = "1y8aymlw9sw8jr48b7f6l118kv3z691975wbzmmxidr8q3swsqbs";
+      };
+      phases = "installPhase";
+      installPhase = "ln -s $src $out";
+    };
+
     "catenable-lists" = pkgs.stdenv.mkDerivation {
       name = "catenable-lists";
       version = "v7.0.0";
@@ -773,6 +785,18 @@ let
       installPhase = "ln -s $src $out";
     };
 
+    "leibniz" = pkgs.stdenv.mkDerivation {
+      name = "leibniz";
+      version = "v5.0.0";
+      src = pkgs.fetchgit {
+        url = "https://github.com/paf31/purescript-leibniz.git";
+        rev = "ed1fa97012a01126c499f2d0e28dfea2919296b3";
+        sha256 = "1xxc84jx9qd4z89mlhjw602l6350cilvw8kd67ixsmsnd0krnl3f";
+      };
+      phases = "installPhase";
+      installPhase = "ln -s $src $out";
+    };
+
     "lists" = pkgs.stdenv.mkDerivation {
       name = "lists";
       version = "v7.0.0";
@@ -1109,6 +1133,18 @@ let
       installPhase = "ln -s $src $out";
     };
 
+    "quotient" = pkgs.stdenv.mkDerivation {
+      name = "quotient";
+      version = "v3.0.0";
+      src = pkgs.fetchgit {
+        url = "https://github.com/rightfold/purescript-quotient.git";
+        rev = "cd7ab1fd0ece7f14ba85a0e6a5b87d863426c054";
+        sha256 = "0qkdw2kyf0p7mchi84dw8wm2jw58a2gii7wfjnddgn3j5jg36l2y";
+      };
+      phases = "installPhase";
+      installPhase = "ln -s $src $out";
+    };
+
     "random" = pkgs.stdenv.mkDerivation {
       name = "random";
       version = "v6.0.0";

diff --git a/packages.dhall b/packages.dhall
@@ -39,7 +39,6 @@ in  upstream
         , "const"
         , "control"
         , "datetime"
-        , "effect"
         , "either"
         , "enums"
         , "foldable-traversable"
@@ -181,6 +180,27 @@ in  upstream
         ]
         "https://github.com/tweag/purescript-unlift"
         "c05bf5f8b29059dc568b34999eb0a5714305076c"
+  with bytestrings =
+      mkPackage
+        [ "arrays"
+        , "console"
+        , "effect"
+        , "exceptions"
+        , "foldable-traversable"
+        , "integers"
+        , "leibniz"
+        , "maybe"
+        , "newtype"
+        , "node-buffer"
+        , "partial"
+        , "prelude"
+        , "quickcheck"
+        , "quickcheck-laws"
+        , "quotient"
+        , "unsafe-coerce"
+        ]
+        "https://github.com/rightfold/purescript-bytestrings.git"
+        "6733a32fca306015b3428e9985ffac65325a9864"
   with marlowe =
       mkPackage
         [ "argonaut"
@@ -189,6 +209,7 @@ in  upstream
         , "arrays"
         , "bifunctors"
         , "bigints"
+        , "bytestrings"
         , "contravariant"
         , "control"
         , "datetime"