update unValueData to reject non-canonical input

plutus-conformance/agda/Spec.hs

@@ -239,7 +239,8 @@ failingEvaluationTests =
   , "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-zero-quantity"
   , "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-zero-sum"
   , "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-empty-tokens"
-  , "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-unordered"
+  , "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-unordered-currencies"
+  , "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-unordered-tokens"
   , "test-cases/uplc/evaluation/builtin/semantics/unValueData/non-map-integer"
   , "test-cases/uplc/evaluation/builtin/semantics/unValueData/non-map-constr"
   , "test-cases/uplc/evaluation/builtin/semantics/unValueData/non-map-list"
@@ -391,7 +392,8 @@ failingBudgetTests =
   , "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-zero-quantity"
   , "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-zero-sum"
   , "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-empty-tokens"
-  , "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-unordered"
+  , "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-unordered-currencies"
+  , "test-cases/uplc/evaluation/builtin/semantics/unValueData/data-unordered-tokens"
   , "test-cases/uplc/evaluation/builtin/semantics/unValueData/non-map-integer"
   , "test-cases/uplc/evaluation/builtin/semantics/unValueData/non-map-constr"
   , "test-cases/uplc/evaluation/builtin/semantics/unValueData/non-map-list"

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-duplicate-currencies-cancel/data-duplicate-currencies-cancel.uplc.budget.expected

@@ -1,2 +1 @@
-({cpu: 4352525
-| mem: 432})
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-duplicate-currencies-cancel/data-duplicate-currencies-cancel.uplc.expected

@@ -1 +1 @@
-(program 1.0.0 (con value [(#bb, [(#bb, 2)]), (#cc, [(#cc, 2)])]))
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-duplicate-currencies-merge/data-duplicate-currencies-merge.uplc.budget.expected

@@ -1,2 +1 @@
-({cpu: 4352525
-| mem: 432})
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-duplicate-currencies-merge/data-duplicate-currencies-merge.uplc.expected

@@ -1 +1 @@
-(program 1.0.0 (con value [(#aa, [(#aa, 246)]), (#bb, [(#bb, 2)]), (#cc, [(#cc, 2)])]))
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-duplicate-currencies/data-duplicate-currencies.uplc.budget.expected

@@ -1,2 +1 @@
-({cpu: 1893317
-| mem: 420})
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-duplicate-currencies/data-duplicate-currencies.uplc.expected

@@ -1 +1 @@
-(program 1.0.0 (con value [(#aa, [(#bb, 100), (#cc, 50)])]))
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-duplicate-tokens/data-duplicate-tokens.uplc.budget.expected

@@ -1,2 +1 @@
-({cpu: 1483477
-| mem: 418})
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-duplicate-tokens/data-duplicate-tokens.uplc.expected

@@ -1 +1 @@
-(program 1.0.0 (con value [(#aa, [(#bb, 150)])]))
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-empty-tokens/data-empty-tokens.uplc.budget.expected

@@ -1,2 +1 @@
-({cpu: 663821
-| mem: 414})
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-empty-tokens/data-empty-tokens.uplc.expected

@@ -1 +1 @@
-(program 1.0.0 (con value []))
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-unordered-currencies/data-unordered-currencies.uplc.budget.expected

@@ -0,0 +1 @@
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-unordered-currencies/data-unordered-currencies.uplc.expected

@@ -0,0 +1 @@
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-unordered-tokens/data-unordered-tokens.uplc

@@ -0,0 +1,5 @@
+(program 1.0.0
+  [(builtin unValueData)
+   (con data (Map [(B #aa, Map [(B #cc, I 100), (B #bb, I 50)])]))
+  ]
+)

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-unordered-tokens/data-unordered-tokens.uplc.budget.expected

@@ -0,0 +1 @@
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-unordered-tokens/data-unordered-tokens.uplc.expected

@@ -0,0 +1 @@
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-zero-quantity/data-zero-quantity.uplc.budget.expected

@@ -1,2 +1 @@
-({cpu: 1483477
-| mem: 418})
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-zero-quantity/data-zero-quantity.uplc.expected

@@ -1 +1 @@
-(program 1.0.0 (con value [(#aa, [(#cc, 100)])]))
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-zero-sum/data-zero-sum.uplc.budget.expected

@@ -1,2 +1 @@
-({cpu: 1483477
-| mem: 418})
+evaluation failure

plutus-conformance/test-cases/uplc/evaluation/builtin/semantics/unValueData/data-zero-sum/data-zero-sum.uplc.expected

@@ -1 +1 @@
-(program 1.0.0 (con value []))
+evaluation failure

plutus-core/changelog.d/20260120_183522_unsafeFixIO_unValueData.md

@@ -0,0 +1,4 @@
+
+### Changed
+
+- Updated `unValueData` to reject non-canonical input, based on https://github.com/cardano-foundation/CIPs/pull/1134

plutus-core/cost-model/budgeting-bench/Benchmarks/Values.hs

@@ -23,7 +23,6 @@ import GHC.Stack (HasCallStack)
 import PlutusCore (DefaultFun (InsertCoin, LookupCoin, ScaleValue, UnValueData, UnionValue, ValueContains, ValueData))
 import PlutusCore.Builtin (BuiltinResult (BuiltinFailure, BuiltinSuccess, BuiltinSuccessWithLogs))
 
-import PlutusCore.Data qualified as Data
 import PlutusCore.Evaluation.Machine.ExMemoryUsage
   ( DataNodeCount (..)
   , ValueMaxDepth (..)
@@ -280,10 +279,7 @@ unValueDataBenchmark gen =
     DataNodeCount
     UnValueData
     []
-    (f . Value.valueData <$> generateTestValues gen)
-  where
-    f (Data.Map l) = Data.Map (reverse l)
-    f _ = error "NO"
+    (Value.valueData <$> generateTestValues gen)
 
 ----------------------------------------------------------------------------------------------------
 -- InsertCoin --------------------------------------------------------------------------------------

plutus-core/plutus-core/src/PlutusCore/Value.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -38,8 +39,8 @@ module PlutusCore.Value
 
 import Codec.Serialise qualified as CBOR
 import Control.DeepSeq (NFData)
+import Control.Monad.Extra (unless, when, whenJust)
 import Data.Bifunctor
-import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as B
 import Data.ByteString.Base64 qualified as Base64
@@ -217,20 +218,20 @@ pack = pack' . normalize
 
 -- | Like `pack` but does not normalize.
 pack' :: NestedMap -> Value
-pack' v = Value v sizes size neg
+pack' v = Value v sizes total neg
   where
-    (sizes, size, neg) = Map.foldl' alg (mempty, 0, 0) v
-    alg (ss, s, n) inner =
+    (sizes, total, neg) = Map.foldl' alg (mempty, 0, 0) v
+    alg (ss, t, n) inner =
       ( IntMap.alter (maybe (Just 1) (Just . (+ 1))) (Map.size inner) ss
-      , s + Map.size inner
+      , t + Map.size inner
       , n + Map.size (Map.filter (< zeroQuantity) inner)
       )
 {-# INLINEABLE pack' #-}
 
 {-| Total size, i.e., the number of distinct `(currency symbol, token name)` pairs
 contained in the `Value`. -}
 totalSize :: Value -> Int
-totalSize (Value _ _ size _) = size
+totalSize (Value _ _ total _) = total
 {-# INLINE totalSize #-}
 
 -- | Size of the largest inner map.
@@ -297,7 +298,7 @@ instance Pretty Value where
 {-| \(O(\log \max(m, k))\), where \(m\) is the size of the outer map, and \(k\) is
 the size of the largest inner map. -}
 insertCoin :: ByteString -> ByteString -> Integer -> Value -> BuiltinResult Value
-insertCoin unsafeCurrency unsafeToken unsafeAmount v@(Value outer sizes size neg)
+insertCoin unsafeCurrency unsafeToken unsafeAmount v@(Value outer sizes total neg)
   | unsafeAmount == 0 = pure $ deleteCoin unsafeCurrency unsafeToken v
   | otherwise = case (k unsafeCurrency, k unsafeToken, quantity unsafeAmount) of
       (Nothing, _, _) -> fail $ "insertCoin: invalid currency: " <> show (B.unpack unsafeCurrency)
@@ -318,38 +319,38 @@ insertCoin unsafeCurrency unsafeToken unsafeAmount v@(Value outer sizes size neg
                       Map.insertLookupWithKey (\_ _ _ -> qty) token qty inner
                  in (maybe (Left (Map.size inner)) Right mOldQuantity, Just inner')
             (res, outer') = Map.alterF f currency outer
-            (sizes', size', neg') = case res of
+            (sizes', total', neg') = case res of
               Left oldSize ->
                 ( updateSizes oldSize (oldSize + 1) sizes
-                , size + 1
+                , total + 1
                 , if qty < zeroQuantity then neg + 1 else neg
                 )
               Right oldQuantity ->
                 ( sizes
-                , size
+                , total
                 , if oldQuantity < zeroQuantity && qty > zeroQuantity
                     then neg - 1
                     else
                       if oldQuantity > zeroQuantity && qty < zeroQuantity
                         then neg + 1
                         else neg
                 )
-         in pure $ Value outer' sizes' size' neg'
+         in pure $ Value outer' sizes' total' neg'
 {-# INLINEABLE insertCoin #-}
 
 -- | \(O(\log \max(m, k))\)
 deleteCoin :: ByteString -> ByteString -> Value -> Value
-deleteCoin (UnsafeK -> currency) (UnsafeK -> token) (Value outer sizes size neg) =
-  Value outer' sizes' size' neg'
+deleteCoin (UnsafeK -> currency) (UnsafeK -> token) (Value outer sizes total neg) =
+  Value outer' sizes' total' neg'
   where
     (mold, outer') = Map.alterF f currency outer
-    (sizes', size', neg') = case mold of
+    (sizes', total', neg') = case mold of
       Just (oldSize, oldQuantity) ->
         ( updateSizes oldSize (oldSize - 1) sizes
-        , size - 1
+        , total - 1
         , if oldQuantity < zeroQuantity then neg - 1 else neg
         )
-      Nothing -> (sizes, size, neg)
+      Nothing -> (sizes, total, neg)
     f
       :: Maybe (Map K Quantity)
       -> ( -- Just (old size of inner map, old quantity) if the total size shrinks by 1,
@@ -440,33 +441,85 @@ valueData = Map . fmap (bimap (B . unK) tokensData) . Map.toList . unpack
     tokensData = Map . fmap (bimap (B . unK) (I . unQuantity)) . Map.toList
 {-# INLINEABLE valueData #-}
 
-{-| \(O(n \log n)\). Decodes `Data` into `Value`, in the same way as non-builtin @Value@.
+{-| \(O(n)\). Decodes `Data` into `Value`.
 This is the denotation of @UnValueData@ in Plutus V1, V2 and V3. -}
 unValueData :: Data -> BuiltinResult Value
-unValueData =
-  fmap pack . \case
-    Map cs -> do
-      -- Use unchecked addition during construction
-      outerMap <-
-        Map.fromListWith (Map.unionWith unsafeAddQuantity) <$> traverse (bitraverse unB unTokens) cs
-      -- Validate all quantities are within bounds
-      validateQuantities outerMap
-    _ -> fail "unValueData: non-Map constructor"
+unValueData = \case
+  Map cs -> do
+    (outerList, sizes, total, neg) <- goCurrencies cs
+    pure $ Value (Map.fromDistinctDescList outerList) sizes total neg
+  _ -> fail "unValueData: non-Map constructor"
   where
     unB :: Data -> BuiltinResult K
     unB = \case
       B b -> maybe (fail $ "unValueData: invalid key: " <> show (B.unpack b)) pure (k b)
       _ -> fail "unValueData: non-B constructor"
+    {-# INLINEABLE unB #-}
 
     unQ :: Data -> BuiltinResult Quantity
     unQ = \case
-      I i -> pure (UnsafeQuantity i)
+      I i
+        | i == 0 || i < unQuantity minBound || i > unQuantity maxBound ->
+            fail "unValueData: invalid quantity"
+        | otherwise -> pure (UnsafeQuantity i)
       _ -> fail "unValueData: non-I constructor"
+    {-# INLINEABLE unQ #-}
 
-    unTokens :: Data -> BuiltinResult (Map K Quantity)
+    -- Returns the inner map and the number of negative quantities in it.
+    unTokens :: Data -> BuiltinResult (Map K Quantity, Int)
     unTokens = \case
-      Map ts -> fmap (Map.fromListWith unsafeAddQuantity) (traverse (bitraverse unB unQ) ts)
+      Map ts -> do
+        when (null ts) $ fail "unValueData: empty inner map"
+        (innerList, neg) <- goTokens ts
+        pure (Map.fromDistinctDescList innerList, neg)
       _ -> fail "unValueData: non-Map constructor"
+    {-# INLINEABLE unTokens #-}
+
+    -- Returns outer map's list, plus stats (sizes, total, neg).
+    goCurrencies
+      :: [(Data, Data)]
+      -> BuiltinResult ([(K, Map K Quantity)], IntMap Int, Int, Int)
+    goCurrencies = go Nothing mempty mempty 0 0
+      where
+        go !prev !acc !sizes !total !neg = \case
+          [] -> pure (acc, sizes, total, neg)
+          (cData, tsData) : rest -> do
+            !c <- unB cData
+            -- Verify that currencies are strictly ascending
+            whenJust
+              prev
+              ( \p ->
+                  unless
+                    (p < c)
+                    (fail "unValueData: currency symbols not strictly ascending")
+              )
+            (!inner, !innerNeg) <- unTokens tsData
+            let sizes' = IntMap.alter (maybe (Just 1) (Just . (+ 1))) (Map.size inner) sizes
+                total' = total + Map.size inner
+                neg' = neg + innerNeg
+                acc' = (c, inner) : acc
+            go (Just c) acc' sizes' total' neg' rest
+
+    -- Returns inner map's list, plus the number of negative quantities in the inner map.
+    goTokens :: [(Data, Data)] -> BuiltinResult ([(K, Quantity)], Int)
+    goTokens = go Nothing mempty 0
+      where
+        go !prev !acc !neg = \case
+          [] -> pure (acc, neg)
+          (tData, qData) : rest -> do
+            !t <- unB tData
+            -- Verify that token names within an inner map are strictly ascending
+            whenJust
+              prev
+              ( \p ->
+                  unless
+                    (p < t)
+                    (fail "unValueData: token names not strictly ascending")
+              )
+            !q <- unQ qData
+            let neg' = if q < zeroQuantity then neg + 1 else neg
+                acc' = (t, q) : acc
+            go (Just t) acc' neg' rest
 {-# INLINEABLE unValueData #-}
 
 -- | Decrement bucket @old@, and increment bucket @new@.

plutus-core/plutus-core/test/Value/Spec.hs

@@ -10,6 +10,7 @@ import Data.ByteString (ByteString)
 import Data.ByteString qualified as B
 import Data.Either
 import Data.Foldable qualified as F
+import Data.List.Extra (nubOrdOn, sortOn)
 import Data.Map.Strict qualified as Map
 import Data.Maybe
 import Safe.Foldable (maximumMay)
@@ -241,6 +242,13 @@ prop_oppositeScaleIsInverse c v =
       BuiltinSuccess r -> r == V.empty
       _ -> scaleIncorrectlyBound c v
 
+prop_dataRoundtrip :: Value -> Property
+prop_dataRoundtrip v = case V.unValueData d of
+  BuiltinSuccess v' -> (v === v') .&&. (V.valueData v' === d)
+  _ -> property False
+  where
+    d = V.valueData v
+
 prop_flatRoundtrip :: Value -> Property
 prop_flatRoundtrip v = Flat.unflat (Flat.flat v) === Right v
 
@@ -353,7 +361,7 @@ prop_unValueDataValidatesMixedQuantities =
     genValueDataWithMixedQuantities :: Gen (Data, Bool)
     genValueDataWithMixedQuantities = do
       numEntries <- chooseInt (1, 10)
-      entries <- vectorOf numEntries $ do
+      entries <- fmap (nubOrdOn fst . sortOn fst) . vectorOf numEntries $ do
         c <- gen32BytesOrFewer
         t <- gen32BytesOrFewer
         -- 90% valid, 10% invalid
@@ -364,7 +372,10 @@ prop_unValueDataValidatesMixedQuantities =
             ]
         pure (B c, Map [(B t, I quantity)])
       let hasInvalid = any (\(_, Map inner) -> any isInvalidQuantity inner) entries
-          isInvalidQuantity (_, I q) = q < V.unQuantity minBound || q > V.unQuantity maxBound
+          isInvalidQuantity (_, I q) =
+            q < V.unQuantity minBound
+              || q > V.unQuantity maxBound
+              || q == 0
           isInvalidQuantity _ = False
       pure (Map entries, hasInvalid)
 
@@ -494,6 +505,9 @@ tests =
     , testProperty
         "oppositeScaleIsInverse"
         prop_oppositeScaleIsInverse
+    , testProperty
+        "dataRoundtrip"
+        prop_dataRoundtrip
     , testProperty
         "flatRoundtrip"
         prop_flatRoundtrip