Implement properties that test if we can decode double encoded plutus

scripts correctly
IntersectMBO · Jan 16, 2025 · cf94fec · cf94fec
1 parent e1fd7f2
commit cf94fec
Show file tree

Hide file tree

Showing 3 changed files with 196 additions and 17 deletions.
diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal
@@ -321,6 +321,7 @@ test-suite cardano-api-test
     QuickCheck,
     aeson >=1.5.6.0,
     bytestring,
+    base16-bytestring,
     cardano-api,
     cardano-api:gen,
     cardano-api:internal,

diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs
@@ -46,8 +46,12 @@ module Test.Gen.Cardano.Api.Typed
   , genHashableScriptData
   , genReferenceScript
   , genScript
+  , genValidScript
   , genSimpleScript
   , genPlutusScript
+  , genPlutusV1Script
+  , genPlutusV2Script
+  , genPlutusV3Script
   , genScriptInAnyLang
   , genScriptInEra
   , genScriptHash
@@ -159,6 +163,7 @@ import qualified Data.ByteString.Short as SBS
 import           Data.Coerce
 import           Data.Int (Int64)
 import           Data.Maybe
+import qualified Data.ByteString.Base16 as Base16
 import           Data.Ratio (Ratio, (%))
 import           Data.String
 import           Data.Word (Word16, Word32, Word64)
@@ -211,6 +216,14 @@ genPositiveLovelace = L.Coin <$> Gen.integral (Range.linear 1 5000)
 -- SimpleScript generators
 --
 
+-- This generator does not generate the deprecated double encoded plutus scripts
+genValidScript :: ScriptLanguage lang -> Gen (Script lang)
+genValidScript SimpleScriptLanguage =
+  SimpleScript <$> genSimpleScript
+genValidScript (PlutusScriptLanguage lang) =
+  PlutusScript lang <$> genValidPlutusScript lang
+
+-- This generator will also generate the deprecated double encoded plutus scripts
 genScript :: ScriptLanguage lang -> Gen (Script lang)
 genScript SimpleScriptLanguage =
   SimpleScript <$> genSimpleScript
@@ -240,10 +253,89 @@ genSimpleScript =
         return (RequireMOf m ts)
     ]
 
+-- | 'genPlutusScript' will generate the deprecated double encoded
+-- plutus scripts as well as valid plutus scripts.
 genPlutusScript :: PlutusScriptVersion lang -> Gen (PlutusScript lang)
-genPlutusScript _ =
-  -- We make no attempt to create a valid script
-  PlutusScriptSerialised . SBS.toShort <$> Gen.bytes (Range.linear 0 32)
+genPlutusScript l =
+  case l of 
+    PlutusScriptV1 -> do 
+      PlutusScript _ s <- genPlutusV1Script
+      return s
+    PlutusScriptV2 -> do 
+      PlutusScript _ s <- genPlutusV2Script
+      return s
+    PlutusScriptV3 -> do 
+      PlutusScript _ s <- genPlutusV3Script
+      return s
+
+genValidPlutusScript :: PlutusScriptVersion lang -> Gen (PlutusScript lang)
+genValidPlutusScript l =
+  case l of 
+    PlutusScriptV1 -> do 
+      PlutusScript _ s <- genValidPlutusV1Script
+      return s
+    PlutusScriptV2 -> do 
+      PlutusScript _ s <- genValidPlutusV2Script
+      return s
+    PlutusScriptV3 -> do 
+      PlutusScript _ s <- genValidPlutusV3Script
+      return s
+
+genPlutusV1Script :: Gen (Script PlutusScriptV1)
+genPlutusV1Script = do 
+  v1Script <- Gen.element [v1Loop2024PlutusScriptHexDoubleEncoded,v1Loop2024PlutusScriptHex]
+  let v1ScriptBytes = Base16.decodeLenient v1Script
+  return . PlutusScript PlutusScriptV1 . PlutusScriptSerialised $ SBS.toShort v1ScriptBytes
+
+genValidPlutusV1Script :: Gen (Script PlutusScriptV1)
+genValidPlutusV1Script = do 
+  v1Script <- Gen.element [v1Loop2024PlutusScriptHex]
+  let v1ScriptBytes = Base16.decodeLenient v1Script
+  return . PlutusScript PlutusScriptV1 . PlutusScriptSerialised $ SBS.toShort v1ScriptBytes
+
+genPlutusV2Script :: Gen (Script PlutusScriptV2)
+genPlutusV2Script = do
+  v2Script <- Gen.element [v2EcdsaLoopPlutusScriptHexDoubleEncoded, v2EcdsaLoopPlutusScriptHex]
+  let v2ScriptBytes = Base16.decodeLenient v2Script
+  return . PlutusScript PlutusScriptV2 . PlutusScriptSerialised $ SBS.toShort v2ScriptBytes
+
+genValidPlutusV2Script :: Gen (Script PlutusScriptV2)
+genValidPlutusV2Script = do
+  v2Script <- Gen.element [v2EcdsaLoopPlutusScriptHex]
+  let v2ScriptBytes = Base16.decodeLenient v2Script
+  return . PlutusScript PlutusScriptV2 . PlutusScriptSerialised $ SBS.toShort v2ScriptBytes
+
+genPlutusV3Script :: Gen (Script PlutusScriptV3)
+genPlutusV3Script = do
+  v3AlwaysSucceedsPlutusScriptHex 
+   <- Gen.element [v3AlwaysSucceedsPlutusScriptDoubleEncoded, v3AlwaysSucceedsPlutusScript]
+  let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex
+  return . PlutusScript PlutusScriptV3 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes
+
+genValidPlutusV3Script :: Gen (Script PlutusScriptV3)
+genValidPlutusV3Script = do
+  v3AlwaysSucceedsPlutusScriptHex 
+   <- Gen.element [v3AlwaysSucceedsPlutusScript]
+  let v3ScriptBytes = Base16.decodeLenient v3AlwaysSucceedsPlutusScriptHex
+  return . PlutusScript PlutusScriptV3 . PlutusScriptSerialised $ SBS.toShort v3ScriptBytes
+
+v1Loop2024PlutusScriptHexDoubleEncoded :: ByteString
+v1Loop2024PlutusScriptHexDoubleEncoded = "5850584e010000332232222325335333573466e200052080897a0070061613005001375a00464600200244a66a666ae68cdc3a410112f40020080062240022646600600600266e0400520021220021220011"
+
+v1Loop2024PlutusScriptHex :: ByteString
+v1Loop2024PlutusScriptHex = BS.drop 4 v1Loop2024PlutusScriptHexDoubleEncoded
+
+v2EcdsaLoopPlutusScriptHexDoubleEncoded :: ByteString 
+v2EcdsaLoopPlutusScriptHexDoubleEncoded = "59023f59023c01000033223232322225335332233333233001005225335333573466e1d200000200d00c153323533335573e0044a00c4600e660046ae8400cd5d1001806109a80091299a9999998038011128051280492804918050009280490a99a9999aab9f0022500a2300b33006357420066ae8800c04084d4004894cd4cccccc02c0088940389403494034940348c038004854cd4cccd55cf8011280711807998051aba100335744006028426a00244a66a66666601e00444a0244a0224a0224a0224602400242a66a6666aae7c008940488c8c8c054008d5d10021aba10030182153353333330110012250142501325013250132301400121301412333300100c0080040021501215011150101500d1500c150091500822123300100300215004150042222223333333574800c4646600e6aae74004d55cf0009baa00723005375600e460086eb001c8c00cdd6803918011bae00700e25002250022500225002212230020031122001213500122225335333573466e200112080897a00d00c1300a4911572656465656d6572206973203c20313030303030300013333009004003002001130054911d5472616365206572726f723a20496e76616c69642072656465656d657200323001001222225335333573466e1d2080897a0040090081007153353335734666ed000c0080040240204cccc8cc018018004cdc0802240040060040022600c921245472616365206572726f723a2045434453412076616c69646174696f6e206661696c6564002326335738002004240022440042440021"
+
+v2EcdsaLoopPlutusScriptHex :: ByteString 
+v2EcdsaLoopPlutusScriptHex = BS.drop 6 v2EcdsaLoopPlutusScriptHexDoubleEncoded
+
+v3AlwaysSucceedsPlutusScriptDoubleEncoded :: ByteString 
+v3AlwaysSucceedsPlutusScriptDoubleEncoded = "590b2c590b29010100323232323232323232232498c8c8c954ccd5cd19b874800000844c8c8c8c8c8c8c8ca002646464aa666ae68cdc3a4000004226464646464646464646464646464646466666666666646664664664444444444444445001010807c03a01b00c805c02a013008803c01a00b004801c00a00230013574202860026ae8404cc0908c8c8c954ccd5cd19b87480000084600260406ae84006600a6ae84d5d1000844c0b52401035054310035573c0046aae74004dd5000998120009aba1011232323255333573466e1d20000021132328009919192a999ab9a3370e900000108c004c08cd5d0800ccc0848c8c8c954ccd5cd19b874800000846002604e6ae8400422aa666ae68cdc3a40040042265003375a6ae8400a6eb4d5d0800cdd69aba1357440023574400222606a9201035054310035573c0046aae74004dd50009aba135744002113031491035054310035573c0046aae74004dd51aba100398039aba10029919192a999ab9a3370e900000108c0004554ccd5cd19b87480080084600a6eb8d5d080084554ccd5cd19b8748010008460066ae840042260629201035054310035573c0046aae74004dd51aba10019980f3ae357426ae880046ae88004d5d1000889816249035054310035573c0046aae74004dd50009bad3574201e60026ae84038c004c005d69981100b1aba100c33301501975a6ae8402cc8c8c954ccd5cd19b874800000846002646464aa666ae68cdc3a4000004230013302b75a6ae8400660546ae84d5d1000844c0b5241035054310035573c0046aae74004dd51aba10019919192a999ab9a3370e900000108c004cc0add69aba100198151aba13574400211302d4901035054310035573c0046aae74004dd51aba13574400211302a4901035054310035573c0046aae74004dd51aba100a3302275c6ae84024ccc0548c8c8c954ccd5cd19b8748000008460066eb8d5d080084554ccd5cd19b874800800846012603c6ae8400422aa666ae68cdc3a400800423007301d357420021155333573466e1d2006002118009bad35742003301a357426ae8800422aa666ae68cdc3a40100042300b301c357420021155333573466e1d200a002118029bad357420033018357426ae880042260569201035054310035573c0046aae74004dd50008119aba1008330010233574200e6eb8d5d080319980a80c1980a81311919192a999ab9a3370e900000108c0084554ccd5cd19b87480080084600822aa666ae68cdc3a40080042300011302b491035054310035573c0046aae74004dd50009aba1005330220143574200860046ae8400cc008d5d09aba2003301475c602aeb4d5d10009aba2001357440026ae88004d5d10009aba2001357440026ae88004d5d10009aba2001357440026ae88004d5d10009aba20011130174901035054310035573c0046aae74004dd51aba10099aba10089919192a999ab9a3370e900000108c00cdd71aba100108aa999ab9a3370e900100108c024c028d5d0800ccc01c04cd5d09aba200108aa999ab9a3370e900200108c01cc024d5d080084554ccd5cd19b8748018008460026eb4d5d0800cc018d5d09aba200108aa999ab9a3370e900400108c02cc020d5d080084554ccd5cd19b87480280084600a6eb4d5d0800cc010d5d09aba200108980ba481035054310035573c0046aae74004dd51aba135744010232323255333573466e1d200000211328009bad35742005300a3574200332323255333573466e1d200000211328049980600d9aba10029aba1001998063ae357426ae880046ae880044554ccd5cd19b874800800846002660160346ae84006646464aa666ae68cdc3a400000423001375a6ae840066eb4d5d09aba200108980f2481035054310035573c0046aae74004dd51aba1357440021155333573466e1d200400211805999804806bad357420033300b75c6ae84d5d100084554ccd5cd19b87480180084600e660160346ae8400422aa666ae68cdc3a401000422646500d3300d01c357420073301800f3574200533300b00f75a6ae840072646464aa666ae68cdc3a400000423001375a6ae840066eb4d5d09aba20010898102481035054310035573c0046aae74004dd51aba13574400322330180020010d5d10009aba20011155333573466e1d200a002118029980580d1aba10019919192a999ab9a3370e900000108998073ae3574200222603c9201035054310035573c0046aae74004dd51aba1357440021155333573466e1d200c0021180108980da481035054310035573c0046aae74004dd51aba1357440023574400222602e9201035054310035573c0046aae74004dd50009119118011bab00130152233335573e0025000232801c004c018d55ce800cc014d55cf000a60086ae8800c6ae8400a0004646464aa666ae68cdc3a40000042300d3007357420033300575a6ae84d5d100084554ccd5cd19b874800800846026600e6ae840066600aeb4d5d09aba200108a992999ab9a3370e900200188c00cc020d5d08014c004d5d09aba200208aa999ab9a3370e90030018899402cc024d5d0801cc008d5d0800cdd69aba1357440023574400422aa666ae68cdc3a401000623009300835742005375a6ae84d5d100104554ccd5cd19b874802800c4602a60106ae8400822aa666ae68cdc3a401800623011300835742005375a6ae84d5d100104554ccd5cd19b874803800c4600a6eb8d5d08014dd71aba1357440041155333573466e1d2010003118039bae35742005375a6ae84d5d100104554ccd5cd19b874804800c4600260106ae8400a60106ae84d5d100104554ccd5cd19b874805000c4601e60106ae8400822602c9210350543100232323255333573466e1d2000002118009bae35742002115325333573466e1d20020031180298009aba100208aa999ab9a3370e900200188c00cdd71aba100298009aba13574400411301a49010350543100232323255333573466e1d20000021180098079aba100108aa999ab9a3370e900100108c0084554ccd5cd19b87480100084600822603a9201035054310035573c0046aae74004dd50009aab9e00235573a0026ea8004d55cf0011aab9d001375400244646464aa666ae68cdc3a4004004230021155333573466e1d20000021180098029aba100108980aa49035054310035573c0046aae74004dd500091919192a999ab9a3370e900000108c004c014d5d080084554ccd5cd19b874800800846006600a6ae8400422aa666ae68cdc3a400800423005375c6ae840042260269201035054310035573c0046aae74004dd500091919192a999ab9a3370e900000108c004dd71aba100108aa999ab9a3370e900100108c00cdd71aba1001089809249035054310035573c0046aae74004dd500091919192a999ab9a3370e900000108c004dd71aba10019bad357426ae880042260229201035054310035573c0046aae74004dd50009aba200111300c4901035054310035573c0046aae74004dd500098041112a999ab9a3370e9000000889805248103505433001155333573466e200052000113300333702900000119b814800000444ca00266e1000c00666e1000800466008004002600e444aa666ae68cdc3a400000222004226600600266e180080048c88c008dd60009803911999aab9f00128001400cc010d5d08014c00cd5d1001200040024646464aa666ae68cdc3a4000004230021155333573466e1d200200211800089803a481035054310035573c0046aae74004dd5000911919192a999ab9a3370e900000108c0084554ccd5cd19b874800800846002600a6ae8400422aa666ae68cdc3a400800423004113007491035054310035573c0046aae74004dd500091919192a999ab9a3370e900000108c004dd71aba10019bad357426ae8800422600a9201035054310035573c0046aae74004dd5000919319ab9c0018001191800800918011198010010009"
+
+v3AlwaysSucceedsPlutusScript :: ByteString
+v3AlwaysSucceedsPlutusScript = BS.drop 6 v3AlwaysSucceedsPlutusScriptDoubleEncoded
 
 genScriptDataSchema :: Gen ScriptDataJsonSchema
 genScriptDataSchema = Gen.element [ScriptDataJsonNoSchema, ScriptDataJsonDetailedSchema]
@@ -320,7 +412,7 @@ genScriptInAnyLang =
 genScriptInEra :: ShelleyBasedEra era -> Gen (ScriptInEra era)
 genScriptInEra era =
   Gen.choice
-    [ ScriptInEra langInEra <$> genScript lang
+    [ ScriptInEra langInEra <$> genValidScript lang
     | AnyScriptLanguage lang <- [minBound .. maxBound]
     , Just langInEra <- [scriptLanguageSupportedInEra era lang]
     ]

diff --git a/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs b/cardano-api/test/cardano-api-test/Test/Cardano/Api/CBOR.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
 -- TODO remove when serialiseTxLedgerCddl is removed
 {-# OPTIONS_GHC -Wno-deprecations #-}
 
@@ -10,10 +11,14 @@ module Test.Cardano.Api.CBOR
 where
 
 import           Cardano.Api
+import           Cardano.Api.Script
 import           Cardano.Api.SerialiseLedgerCddl (cddlTypeToEra)
 import           Cardano.Api.SerialiseTextEnvelope (TextEnvelopeDescr (TextEnvelopeDescr))
 import           Cardano.Api.Shelley (AsType (..))
 
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Short as SBS
 import           Data.Proxy (Proxy (..))
 import qualified Data.Text as T
 
@@ -169,15 +174,84 @@ prop_roundtrip_script_SimpleScriptV2_CBOR = H.property $ do
   x <- H.forAll $ genScript SimpleScriptLanguage
   H.trippingCbor (AsScript AsSimpleScript) x
 
-prop_roundtrip_script_PlutusScriptV1_CBOR :: Property
-prop_roundtrip_script_PlutusScriptV1_CBOR = H.property $ do
-  x <- H.forAll $ genScript (PlutusScriptLanguage PlutusScriptV1)
-  H.trippingCbor (AsScript AsPlutusScriptV1) x
-
-prop_roundtrip_script_PlutusScriptV2_CBOR :: Property
-prop_roundtrip_script_PlutusScriptV2_CBOR = H.property $ do
-  x <- H.forAll $ genScript (PlutusScriptLanguage PlutusScriptV2)
-  H.trippingCbor (AsScript AsPlutusScriptV2) x
+{-
+Plutus CBOR Encoding tests - Double decoding fix
+
+Because the SerialiseAsCBOR instance for 'Plutus lang' was double encoding the plutus script bytes
+we need to confirm that the removal of this double encoding does not break backwards compatibility.
+
+The double encoding took the form of encoding the plutus script bytes as a CBOR in CBOR bytestring.
+This has cropped up a number of times from users who wanted to directly use the plutus script payload
+generated by the cardano-cli but first had to run a CBOR deserialization step on the bytes before they
+could access the (unadultered) plutus script bytes.
+
+As such we need to confirm the following:
+1. Deserializing double encoded script bytes and "normal" script bytes deserialise to the same byte sequence.
+2. The resulting bytes are both valid plutus scripts (confirmed via PlutusScriptInEra which calls ledger
+   functions to confirm the validity of the plutus bytes).
+3. The updated SerialiseAsCBOR instance for 'Plutus lang' does not double encode the plutus script bytes.
+
+How are these properties confirmed?
+
+- 1. and 2. are confirmed by the decodeOnlyPlutusScriptBytes tests.
+- 3. Is confirmed by a roundtrip test using non-double endcoded plutus script bytes.
+
+Note that the SerialiseAsCBOR instances for 'Plutus lang' and `PlutusScript lang` will forever
+be asymmetric with respect to double encoded plutus scripts.
+So CBOR roundtrip tests are not expected to pass in the double encoded plutus script case.
+-}
+
+-- This property will succeed because the bytes are not double encoded.
+-- This property confirms that when it comes to non double encoded plutus script bytes
+-- the SerialiseAsCBOR instance for 'Plutus lang' (and therefore Script lang) is symmetric.
+prop_roundtrip_non_double_encoded_always_succeeds_plutus_V3_CBOR :: Property
+prop_roundtrip_non_double_encoded_always_succeeds_plutus_V3_CBOR = H.property $ do
+  let alwaysSucceedsUnwrapped = PlutusScriptSerialised $ SBS.toShort $ Base16.decodeLenient "450101002499"
+  H.trippingCbor
+    (AsPlutusScriptInEra @ConwayEra AsPlutusScriptV3)
+    (PlutusScriptInEra alwaysSucceedsUnwrapped)
+
+prop_decode_only_double_wrapped_plutus_script_bytes_CBOR :: Property
+prop_decode_only_double_wrapped_plutus_script_bytes_CBOR = H.property $ do
+  let alwaysSucceedsDoubleEncoded = Base16.decodeLenient "46450101002499"
+  decodeOnlyPlutusScriptBytes
+    ShelleyBasedEraConway
+    PlutusScriptV3
+    alwaysSucceedsDoubleEncoded
+    (AsScript AsPlutusScriptV3)
+
+prop_decode_only_wrapped_plutus_script_V1_CBOR :: Property
+prop_decode_only_wrapped_plutus_script_V1_CBOR = H.property $ do
+  PlutusScriptSerialised shortBs <- H.forAll $ genPlutusScript PlutusScriptV1
+  decodeOnlyPlutusScriptBytes
+    ShelleyBasedEraConway
+    PlutusScriptV1
+    (SBS.fromShort shortBs)
+    (AsScript AsPlutusScriptV1)
+
+prop_decode_only_wrapped_plutus_script_V2_CBOR :: Property
+prop_decode_only_wrapped_plutus_script_V2_CBOR = H.property $ do
+  PlutusScriptSerialised shortBs <- H.forAll $ genPlutusScript PlutusScriptV2
+  decodeOnlyPlutusScriptBytes
+    ShelleyBasedEraConway
+    PlutusScriptV2
+    (SBS.fromShort shortBs)
+    (AsScript AsPlutusScriptV2)
+
+prop_decode_only_wrapped_plutus_script_V3_CBOR :: Property
+prop_decode_only_wrapped_plutus_script_V3_CBOR = H.property $ do
+  PlutusScriptSerialised shortBs <- H.forAll $ genPlutusScript PlutusScriptV3
+  decodeOnlyPlutusScriptBytes
+    ShelleyBasedEraConway
+    PlutusScriptV3
+    (SBS.fromShort shortBs)
+    (AsScript AsPlutusScriptV3)
+
+prop_double_encoded_sanity_check :: Property
+prop_double_encoded_sanity_check = H.propertyOnce $ do
+  let fixed = removePlutusScriptDoubleEncoding exampleDoubleEncodedBytes
+
+  LBS.fromStrict fixed H./== exampleDoubleEncodedBytes
 
 prop_roundtrip_ScriptData_CBOR :: Property
 prop_roundtrip_ScriptData_CBOR = H.property $ do
@@ -302,11 +376,23 @@ tests =
         "roundtrip script SimpleScriptV2 CBOR"
         prop_roundtrip_script_SimpleScriptV2_CBOR
     , testProperty
-        "roundtrip script PlutusScriptV1 CBOR"
-        prop_roundtrip_script_PlutusScriptV1_CBOR
+        "roundtrip non double encoded always succeeds plutus V3 CBOR"
+        prop_roundtrip_non_double_encoded_always_succeeds_plutus_V3_CBOR
+    , testProperty
+        "decode only double wrapped plutus script bytes CBOR"
+        prop_decode_only_double_wrapped_plutus_script_bytes_CBOR
+    , testProperty
+        "decode only wrapped plutus script V1 CBOR"
+        prop_decode_only_wrapped_plutus_script_V1_CBOR
+    , testProperty
+        "decode only wrapped plutus script V2 CBOR"
+        prop_decode_only_wrapped_plutus_script_V2_CBOR
+    , testProperty
+        "decode only wrapped plutus script V3 CBOR"
+        prop_decode_only_wrapped_plutus_script_V3_CBOR
     , testProperty
-        "roundtrip script PlutusScriptV2 CBOR"
-        prop_roundtrip_script_PlutusScriptV2_CBOR
+        "double encoded sanity check"
+        prop_double_encoded_sanity_check
     , testProperty
         "cddlTypeToEra for Tx types"
         prop_Tx_cddlTypeToEra