Restrict Value quantities to signed 128-bit integer range (#7389)

Author: Unisay

plutus-core/plutus-core/src/PlutusCore/Builtin/Result.hs

@@ -1,12 +1,10 @@
 -- editorconfig-checker-disable-file
-{-# LANGUAGE FlexibleInstances      #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE LambdaCase             #-}
-{-# LANGUAGE MultiParamTypeClasses  #-}
-{-# LANGUAGE OverloadedStrings      #-}
-{-# LANGUAGE RankNTypes             #-}
-{-# LANGUAGE StrictData             #-}
-{-# LANGUAGE TemplateHaskell        #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE StrictData            #-}
 
 module PlutusCore.Builtin.Result
     ( EvaluationError (..)

plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs

@@ -2063,7 +2063,7 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
             (runCostingFunThreeArguments . unimplementedCostingFun)
 
     toBuiltinMeaning _semvar UnionValue =
-      let unionValueDenotation :: Value -> Value -> Value
+      let unionValueDenotation :: Value -> Value -> BuiltinResult Value
           unionValueDenotation = Value.unionValue
           {-# INLINE unionValueDenotation #-}
        in makeBuiltinMeaning

plutus-core/plutus-core/src/PlutusCore/Parser/Builtin.hs

@@ -5,6 +5,7 @@ module PlutusCore.Parser.Builtin where
 
 import PlutusPrelude (Word8, reoption, void)
 
+import PlutusCore.Builtin.Result qualified
 import PlutusCore.Crypto.BLS12_381.G1 qualified as BLS12_381.G1
 import PlutusCore.Crypto.BLS12_381.G2 qualified as BLS12_381.G2
 import PlutusCore.Data
@@ -91,13 +92,22 @@ conArray uniA = Vector.fromList <$> conList uniA
 -- | Parser for values.
 conValue :: Parser PLC.Value
 conValue = do
-  Value.fromList <$> (traverse validateKeys =<< conList knownUni)
+  keys <- traverse validateKeys =<< conList knownUni
+  case Value.fromList keys of
+    PlutusCore.Builtin.Result.BuiltinSuccess v -> pure v
+    PlutusCore.Builtin.Result.BuiltinSuccessWithLogs _logs v -> pure v
+    PlutusCore.Builtin.Result.BuiltinFailure logs _trace ->
+      fail $ "Failed to construct Value: " <> show logs
  where
   validateToken (token, amt) = do
-    tk <- maybe (fail $ "Invalid token: " <> show (unpack token)) pure (Value.k token)
-    pure (tk, amt)
+    tk <- maybe (fail $ "Token name exceeds maximum length of 32 bytes: " <> show (unpack token))
+               pure (Value.k token)
+    qty <- maybe (fail $ "Token quantity out of signed 128-bit integer bounds: " <> show amt)
+                pure (Value.quantity amt)
+    pure (tk, qty)
   validateKeys (currency, tokens) = do
-    ck <- maybe (fail $ "Invalid currency: " <> show (unpack currency)) pure (Value.k currency)
+    ck <- maybe (fail $ "Currency symbol exceeds maximum length of 32 bytes: " <> show (unpack currency))
+                pure (Value.k currency)
     tks <- traverse validateToken tokens
     pure (ck, tks)
 

plutus-core/plutus-core/src/PlutusCore/Pretty/PrettyConst.hs

@@ -113,7 +113,7 @@ instance NonDefaultPrettyBy ConstConfig T.Text where
     nonDefaultPrettyListBy conf = Prettyprinter.list . Prelude.map (nonDefaultPrettyBy conf)
     nonDefaultPrettyBy = inContextM $ \t -> pure $ pretty $ "\"" <> escape t <> "\""
         where
-            escape t = T.foldr' prettyChar "" t
+            escape = T.foldr' prettyChar ""
             prettyChar c acc
                 | c == '"' = "\\\"" <> acc -- Not handled by 'showLitChar'
                 | c == '\\' = "\\\\" <> acc -- Not handled by 'showLitChar'
@@ -162,6 +162,9 @@ instance PrettyBy ConstConfig Data where
 instance PrettyBy ConstConfig Value.K where
     prettyBy config = prettyBy config . Value.unK
 
+instance PrettyBy ConstConfig Value.Quantity where
+    prettyBy config = prettyBy config . Value.unQuantity
+
 instance PrettyBy ConstConfig Value where
     prettyBy config = prettyBy config . Value.toList