PLT-8912: Fix unsafety in the "safe" Data decoding code (#5671)

* Add test for decoding the problematic data object * Fix unsafe decoding bug * changelog * Use CBOR instead
IntersectMBO · Dec 11, 2023 · 67b7d90 · 67b7d90
1 parent 2f3b9ed
commit 67b7d90
Show file tree

Hide file tree

Showing 11 changed files with 94 additions and 25 deletions.
diff --git a/plutus-benchmark/ed25519-costs/test/9.6/ed25519-costs.golden b/plutus-benchmark/ed25519-costs/test/9.6/ed25519-costs.golden
@@ -1,20 +1,20 @@
     n     Script size             CPU usage               Memory usage
   ----------------------------------------------------------------------
-    0     431   (2.6%)         5309576   (0.1%)           20058   (0.1%) 
-   10    2158  (13.2%)       723602616   (7.2%)          488248   (3.5%) 
-   20    3885  (23.7%)      1441895656  (14.4%)          956438   (6.8%) 
-   30    5612  (34.3%)      2160188696  (21.6%)         1424628  (10.2%) 
-   40    7339  (44.8%)      2878481736  (28.8%)         1892818  (13.5%) 
-   50    9065  (55.3%)      3596774776  (36.0%)         2361008  (16.9%) 
-   60   10792  (65.9%)      4315067816  (43.2%)         2829198  (20.2%) 
-   70   12519  (76.4%)      5033360856  (50.3%)         3297388  (23.6%) 
-   80   14245  (86.9%)      5751653896  (57.5%)         3765578  (26.9%) 
-   90   15972  (97.5%)      6469946936  (64.7%)         4233768  (30.2%) 
-  100   17699 (108.0%)      7188239976  (71.9%)         4701958  (33.6%) 
-  110   19426 (118.6%)      7906533016  (79.1%)         5170148  (36.9%) 
-  120   21152 (129.1%)      8624826056  (86.2%)         5638338  (40.3%) 
-  130   22879 (139.6%)      9343119096  (93.4%)         6106528  (43.6%) 
-  140   24606 (150.2%)     10061412136 (100.6%)         6574718  (47.0%) 
-  150   26333 (160.7%)     10779705176 (107.8%)         7042908  (50.3%) 
+    0     481   (2.9%)         6124112   (0.1%)           22722   (0.2%) 
+   10    2208  (13.5%)       732562512   (7.3%)          517552   (3.7%) 
+   20    3935  (24.0%)      1459000912  (14.6%)         1012382   (7.2%) 
+   30    5662  (34.6%)      2185439312  (21.9%)         1507212  (10.8%) 
+   40    7389  (45.1%)      2911877712  (29.1%)         2002042  (14.3%) 
+   50    9115  (55.6%)      3638316112  (36.4%)         2496872  (17.8%) 
+   60   10842  (66.2%)      4364754512  (43.6%)         2991702  (21.4%) 
+   70   12569  (76.7%)      5091192912  (50.9%)         3486532  (24.9%) 
+   80   14295  (87.2%)      5817631312  (58.2%)         3981362  (28.4%) 
+   90   16022  (97.8%)      6544069712  (65.4%)         4476192  (32.0%) 
+  100   17749 (108.3%)      7270508112  (72.7%)         4971022  (35.5%) 
+  110   19476 (118.9%)      7996946512  (80.0%)         5465852  (39.0%) 
+  120   21202 (129.4%)      8723384912  (87.2%)         5960682  (42.6%) 
+  130   22929 (139.9%)      9449823312  (94.5%)         6455512  (46.1%) 
+  140   24656 (150.5%)     10176261712 (101.8%)         6950342  (49.6%) 
+  150   26383 (161.0%)     10902700112 (109.0%)         7445172  (53.2%) 
 
 Off-chain version succeeded on 100 inputs
diff --git a/plutus-core/plutus-core/src/PlutusCore/Data.hs b/plutus-core/plutus-core/src/PlutusCore/Data.hs
@@ -44,7 +44,7 @@ data Data =
     | List [Data]
     | I Integer
     | B BS.ByteString
-    deriving stock (Show, Eq, Ord, Generic, Data.Data.Data)
+    deriving stock (Show, Read, Eq, Ord, Generic, Data.Data.Data)
     deriving anyclass (Hashable, NFData, NoThunks)
 
 instance Pretty Data where

diff --git a/plutus-ledger-api/plutus-ledger-api.cabal b/plutus-ledger-api/plutus-ledger-api.cabal
@@ -145,6 +145,7 @@ test-suite plutus-ledger-api-test
   hs-source-dirs: test
   other-modules:
     Spec.CBOR.DeserialiseFailureInfo
+    Spec.ContextDecoding
     Spec.CostModelParams
     Spec.Eval
     Spec.Interval
@@ -165,6 +166,7 @@ test-suite plutus-ledger-api-test
     , plutus-core:{plutus-core, plutus-core-testlib}                    ^>=1.18
     , plutus-ledger-api:{plutus-ledger-api, plutus-ledger-api-testlib}  ^>=1.18
     , plutus-tx:{plutus-tx, plutus-tx-testlib}                          ^>=1.18
+    , serialise
     , tasty
     , tasty-hedgehog
     , tasty-hunit

diff --git a/plutus-ledger-api/test/Spec.hs b/plutus-ledger-api/test/Spec.hs
@@ -7,6 +7,7 @@ import PlutusLedgerApi.Test.V1.EvaluationContext qualified as V1
 import PlutusLedgerApi.V1 as V1
 import PlutusPrelude
 import Spec.CBOR.DeserialiseFailureInfo qualified
+import Spec.ContextDecoding qualified
 import Spec.CostModelParams qualified
 import Spec.Eval qualified
 import Spec.Interval qualified
@@ -105,5 +106,6 @@ tests = testGroup "plutus-ledger-api" [
     , Spec.CostModelParams.tests
     , Spec.NoThunks.tests
     , Spec.CBOR.DeserialiseFailureInfo.tests
+    , Spec.ContextDecoding.tests
     , Value.test_Value
     ]
diff --git a/plutus-ledger-api/test/Spec/ContextDecoding.hs b/plutus-ledger-api/test/Spec/ContextDecoding.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE TypeApplications #-}
+module Spec.ContextDecoding where
+
+import Codec.Serialise qualified as S
+import Data.ByteString.Lazy as BSL
+import Data.Maybe
+import PlutusCore.Data
+import PlutusLedgerApi.V1 qualified as V1
+import PlutusLedgerApi.V2 qualified as V2
+import PlutusLedgerApi.V3 qualified as V3
+import PlutusTx.IsData
+import Test.Tasty
+import Test.Tasty.HUnit
+
+tests :: TestTree
+tests = testGroup "context decoding" [ test_v1Context ]
+
+test_v1Context :: TestTree
+test_v1Context = testCase "v1context" $ do
+  input <- BSL.readFile "test/Spec/v1-context-data"
+  let (d :: Data) = S.deserialise input
+  assertBool "can't parse as V1 context"
+    (isJust $ fromBuiltinData @V1.ScriptContext (V1.BuiltinData d))
+  -- Note, these should return Nothing and not throw
+  assertBool "can parse as V2 context"
+    (isNothing $ fromBuiltinData @V2.ScriptContext (V2.BuiltinData d))
+  assertBool "can parse as V3 context"
+    (isNothing $ fromBuiltinData @V3.ScriptContext (V3.BuiltinData d))
diff --git a/plutus-ledger-api/test/Spec/v1-context-data b/plutus-ledger-api/test/Spec/v1-context-data
diff --git a/plutus-tx-plugin/test/IsData/9.6/deconstructData.pir.golden b/plutus-tx-plugin/test/IsData/9.6/deconstructData.pir.golden
@@ -126,21 +126,49 @@ let
                                ds
                                {Maybe (Tuple2 a b)}
                                (\(ds : data) (ds : list data) ->
+                                  let
+                                    !l : list data = ds
+                                  in
                                   Maybe_match
                                     {a}
                                     (`$dFromData` ds)
                                     {all dead. Maybe (Tuple2 a b)}
                                     (\(arg : a) ->
                                        /\dead ->
                                          Maybe_match
-                                           {b}
-                                           (`$dFromData` (head {data} ds))
+                                           {data}
+                                           (chooseList
+                                              {data}
+                                              {Unit -> Maybe data}
+                                              l
+                                              (\(ds : Unit) -> Nothing {data})
+                                              (\(ds : Unit) ->
+                                                 let
+                                                   !h : data = head {data} l
+                                                   !ds : list data
+                                                     = tail {data} l
+                                                 in
+                                                 Just {data} h)
+                                              Unit)
                                            {all dead. Maybe (Tuple2 a b)}
-                                           (\(arg : b) ->
+                                           (\(ds : data) ->
                                               /\dead ->
-                                                Just
-                                                  {Tuple2 a b}
-                                                  (Tuple2 {a} {b} arg arg))
+                                                Maybe_match
+                                                  {b}
+                                                  (`$dFromData` ds)
+                                                  {all dead. Maybe (Tuple2 a b)}
+                                                  (\(arg : b) ->
+                                                     /\dead ->
+                                                       Just
+                                                         {Tuple2 a b}
+                                                         (Tuple2
+                                                            {a}
+                                                            {b}
+                                                            arg
+                                                            arg))
+                                                  (/\dead ->
+                                                     Nothing {Tuple2 a b})
+                                                  {all dead. dead})
                                            (/\dead -> Nothing {Tuple2 a b})
                                            {all dead. dead})
                                     (/\dead -> Nothing {Tuple2 a b})

diff --git a/plutus-tx-plugin/test/size/fromBuiltinData.size.golden b/plutus-tx-plugin/test/size/fromBuiltinData.size.golden
@@ -1 +1 @@
-320
+349
diff --git a/plutus-tx/changelog.d/20231208_144400_michael.peyton-jones_fromData_bugs.md b/plutus-tx/changelog.d/20231208_144400_michael.peyton-jones_fromData_bugs.md
@@ -0,0 +1,4 @@
+### Fixed
+
+- The "safe" version of `fromData` was using an unsafe `head` function, so would 
+  crash on some malformed input instead of returning `Nothing`.
diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs
@@ -69,6 +69,7 @@ module PlutusTx.Builtins (
                          , pairToPair
                          -- * Lists
                          , matchList
+                         , headMaybe
                          , BI.head
                          , BI.tail
                          , uncons
@@ -382,6 +383,10 @@ encodeUtf8 = BI.encodeUtf8
 matchList :: forall a r . BI.BuiltinList a -> r -> (a -> BI.BuiltinList a -> r) -> r
 matchList l nilCase consCase = BI.chooseList l (const nilCase) (\_ -> consCase (BI.head l) (BI.tail l)) ()
 
+{-# INLINE headMaybe #-}
+headMaybe :: BI.BuiltinList a -> Maybe a
+headMaybe l = matchList l Nothing (\h _ -> Just h)
+
 {-# INLINE uncons #-}
 -- | Uncons a builtin list, failing if the list is empty, useful in patterns.
 uncons :: BI.BuiltinList a -> Maybe (a, BI.BuiltinList a)

diff --git a/plutus-tx/src/PlutusTx/IsData/TH.hs b/plutus-tx/src/PlutusTx/IsData/TH.hs
@@ -49,7 +49,7 @@ mkConstrPartsMatchPattern conIx extractFieldNames =
     extractArgsPat = go extractArgPats
       where
         go []     = [p| _ |]
-        go [x]    = [p| (BI.head -> $x) |]
+        go [x]    = [p| (Builtins.headMaybe -> Just $x) |]
         go (x:xs) = [p| (Builtins.uncons -> Just ($x, $(go xs))) |]
     pat = [p| ($ixMatchPat, $extractArgsPat) |]
   in pat