From 67b7d90a8a73215c73c1b209829f03d23a7cdd3a Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Mon, 11 Dec 2023 15:41:59 +0000 Subject: [PATCH] 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 --- .../test/9.6/ed25519-costs.golden | 32 +++++++------- .../plutus-core/src/PlutusCore/Data.hs | 2 +- plutus-ledger-api/plutus-ledger-api.cabal | 2 + plutus-ledger-api/test/Spec.hs | 2 + .../test/Spec/ContextDecoding.hs | 28 ++++++++++++ plutus-ledger-api/test/Spec/v1-context-data | Bin 0 -> 1000 bytes .../IsData/9.6/deconstructData.pir.golden | 40 +++++++++++++++--- .../test/size/fromBuiltinData.size.golden | 2 +- ...4400_michael.peyton-jones_fromData_bugs.md | 4 ++ plutus-tx/src/PlutusTx/Builtins.hs | 5 +++ plutus-tx/src/PlutusTx/IsData/TH.hs | 2 +- 11 files changed, 94 insertions(+), 25 deletions(-) create mode 100644 plutus-ledger-api/test/Spec/ContextDecoding.hs create mode 100644 plutus-ledger-api/test/Spec/v1-context-data create mode 100644 plutus-tx/changelog.d/20231208_144400_michael.peyton-jones_fromData_bugs.md diff --git a/plutus-benchmark/ed25519-costs/test/9.6/ed25519-costs.golden b/plutus-benchmark/ed25519-costs/test/9.6/ed25519-costs.golden index 26a98c0c75c..0752cb93bfb 100644 --- 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 index 7553fde0ccb..347f4a8c709 100644 --- 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 index 58509fb80a5..a6337206982 100644 --- 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 index f25b0132146..378028cf531 100644 --- 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 new file mode 100644 index 00000000000..5a4bc255d67 --- /dev/null +++ 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 new file mode 100644 index 0000000000000000000000000000000000000000..eb9db311502b98b5e21ef08e0d05c7abf917787a GIT binary patch literal 1000 zcmcanIsZoGd=Q492nE4clT0IuF8J(GUsC*YgVpxOW;5(eV#{3GJ_yca4Ro#k&-fpz zx@vxe%%Sx+>VKGh^HMl$dno8dz}c(uhDo(4jJli&t@;0NR5kox?6A;5ib0%ZN`#Ey z>;3z$X||qTS8T8|q+{ouk9DWxidvkQg_G7cF7)##%}Xz;bj~kVHnlJ{XN-_pZ(FeD z%id_K-G;MjOHa(-{4{U<*(=$4v%?pK)-Q}u_?Dnw&A6*)dC-^E36ricUk`re6p;A3 zVvq3dxki0TVjNNh`Z-)cmqsWw{jh$?955wNWT*K;wevN(yAux_wRWo8weuU7=J{jC z761Q-`3R&sZ-QlPV5MpqeX4HHhOrSjeG5ntnP!^HoaSol5x+nzAg|x(V)s7QJk|z!6)Xx z^r>@z_Wxf93MMA^6*izS`~QDFB0^*)U*3Ai|HH0+JC>_IDoZbKu?asaA8gLSwqojy z0&oz6^)jfbE&%Brc5#Cg64VWBIfd`wz=i}LbK+7EgQ1}TW?=&?IIF>||G?Ca*8!k7 zBb?X>7y^pF2nFuv6SwgPTRAcu`<=Vzb?q%a_u~#iS_cdK#1x + let + !l : list data = ds + in Maybe_match {a} (`$dFromData` ds) @@ -133,14 +136,39 @@ let (\(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 index 194ba8cc759..235adf8bd8f 100644 --- a/plutus-tx-plugin/test/size/fromBuiltinData.size.golden +++ b/plutus-tx-plugin/test/size/fromBuiltinData.size.golden @@ -1 +1 @@ -320 \ No newline at end of file +349 \ No newline at end of file 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 new file mode 100644 index 00000000000..2538884d023 --- /dev/null +++ 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 index d73340e46a8..9c5d86ec58b 100644 --- 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 index c636ac677d2..1ce990c17c0 100644 --- 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