Merge pull request #720 from IntersectMBO/jordan/plutus-script-in-era

Fix plutus double CBOR encoding bug

Author: carbolymer

cardano-api/cardano-api.cabal

@@ -278,6 +278,7 @@ library gen
     Test.Gen.Cardano.Api
     Test.Gen.Cardano.Api.Byron
     Test.Gen.Cardano.Api.Era
+    Test.Gen.Cardano.Api.Hardcoded
     Test.Gen.Cardano.Api.Metadata
     Test.Gen.Cardano.Api.ProtocolParameters
     Test.Gen.Cardano.Api.Typed
@@ -320,6 +321,7 @@ test-suite cardano-api-test
   build-depends:
     QuickCheck,
     aeson >=1.5.6.0,
+    base16-bytestring,
     bytestring,
     cardano-api,
     cardano-api:gen,

cardano-api/gen/Test/Gen/Cardano/Api/Hardcoded.hs

@@ -0,0 +1,47 @@
+module Test.Gen.Cardano.Api.Hardcoded
+  ( exampleDoubleEncodedBytes
+  , exampleDoubleEncodedBytesEncoding
+  , v1Loop2024PlutusScriptHex
+  , v1Loop2024PlutusScriptHexDoubleEncoded
+  , v2EcdsaLoopPlutusScriptHex
+  , v2EcdsaLoopPlutusScriptHexDoubleEncoded
+  , v3AlwaysSucceedsPlutusScript
+  , v3AlwaysSucceedsPlutusScriptDoubleEncoded
+  )
+where
+
+import qualified Cardano.Binary as CBOR
+
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+
+exampleDoubleEncodedBytes :: LBS.ByteString
+exampleDoubleEncodedBytes = LBS.fromStrict $ CBOR.toStrictByteString exampleDoubleEncodedBytesEncoding
+
+exampleDoubleEncodedBytesEncoding :: CBOR.Encoding
+exampleDoubleEncodedBytesEncoding = do
+  CBOR.encodeBytes $
+    CBOR.toStrictByteString $
+      CBOR.encodeBytes "testBytes"
+
+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

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,8 +163,10 @@ 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 Test.Gen.Cardano.Api.Hardcoded
 import           Data.Word (Word16, Word32, Word64)
 import           GHC.Exts (IsList (..))
 import           GHC.Stack
@@ -211,6 +217,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 +254,72 @@ 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
+
 
 genScriptDataSchema :: Gen ScriptDataJsonSchema
 genScriptDataSchema = Gen.element [ScriptDataJsonNoSchema, ScriptDataJsonDetailedSchema]
@@ -320,7 +396,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]
     ]

cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs

@@ -1,18 +1,30 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Test.Hedgehog.Roundtrip.CBOR
-  ( trippingCbor
+  ( decodeOnlyPlutusScriptBytes
+  , trippingCbor
   )
 where
 
 import           Cardano.Api
+import           Cardano.Api.Eon.ShelleyBasedEra
+import           Cardano.Api.Script
 
+import qualified Cardano.Ledger.Core as Ledger
+import qualified Cardano.Ledger.Plutus.Language as Plutus
+
+import           Data.ByteString (ByteString)
+import qualified Data.ByteString.Short as SBS
+import           Data.Proxy
 import           GHC.Stack (HasCallStack)
 import qualified GHC.Stack as GHC
 
 import qualified Hedgehog as H
+import           Hedgehog.Internal.Property (failWith)
 
 {- HLINT ignore "Use camelCase" -}
 
@@ -30,3 +42,59 @@ trippingCbor
 trippingCbor typeProxy v =
   GHC.withFrozenCallStack $
     H.tripping v serialiseToCBOR (deserialiseFromCBOR typeProxy)
+
+-- | We need to confirm the existing 'SerialiseAsCBOR' instance for 'Script lang'
+-- no longer double serializes scripts but is backwards compatible with
+-- doubly serialized scripts.
+--
+-- We would also like to check that the deserialized bytes is a valid
+-- plutus script. We can do this by using the 'SerialiseAsCBOR' instance for
+-- 'PlutusScriptInEra'.
+--
+-- We will check the following:
+-- 1. Deserializing double encoded script bytes and "normal" script bytes
+--    decode to the same byte sequence.
+-- 2. The resulting bytes are both valid plutus scripts (via 'PlutusScriptInEra')
+--
+-- If these two properties hold we can be sure that existing double encoded scripts
+-- will deserialize correctly and newly created scripts will also deserialize correctly.
+decodeOnlyPlutusScriptBytes
+  :: forall era lang m
+   . HasCallStack
+  => Ledger.Era (ShelleyLedgerEra era)
+  => H.MonadTest m
+  => Plutus.PlutusLanguage (ToLedgerPlutusLanguage lang)
+  => IsPlutusScriptLanguage lang
+  => HasTypeProxy era
+  => ShelleyBasedEra era
+  -> PlutusScriptVersion lang
+  -> ByteString
+  -- ^ This can be a double encoded or "normal" plutus script
+  -> AsType (Script lang)
+  -> m ()
+decodeOnlyPlutusScriptBytes _ _ scriptBytes typeProxy = do
+  -- Decode a plutus script (double wrapped or "normal" plutus script) with the existing SerialiseAsCBOR instance for
+  -- 'Script lang'. This should produce plutus script bytes that are not double encoded.
+  (PlutusScriptSerialised expectedToBeValidScriptBytes) <- case deserialiseFromCBOR typeProxy scriptBytes of
+    Left e -> failWith Nothing $ "Plutus lang: Error decoding script bytes: " ++ show e
+    Right (SimpleScript _) -> failWith Nothing "Simple script found. Should be impossible."
+    Right (PlutusScript _ plutusScript) -> return plutusScript
+
+  -- We check that the script is "runnable" and of the expected language via the
+  -- 'PlutusScriptInEra era lang' SerialiseAsCBOR instance.
+  (PlutusScriptSerialised confirmedToBeValidScriptBytes) <-
+    case deserialiseFromCBOR (AsPlutusScriptInEra @era (proxyToAsType (Proxy :: Proxy lang))) $
+      SBS.fromShort expectedToBeValidScriptBytes of
+      Left e -> failWith Nothing $ "PlutusScriptInEra: Error decoding plutus script bytes: " ++ show e
+      Right (PlutusScriptInEra p) -> return p
+
+  -- We also confirm that PlutusScriptInEra SerialiseAsCBOR instance can handle double encoded
+  -- plutus scripts.
+  case deserialiseFromCBOR (AsPlutusScriptInEra @era (proxyToAsType (Proxy :: Proxy lang))) scriptBytes of
+    Left e -> failWith Nothing $ "PlutusScriptInEra: Error decoding double wrapped bytes: " ++ show e
+    Right (PlutusScriptInEra (PlutusScriptSerialised shouldAlsoBeValidScriptBytes)) -> do
+      confirmedToBeValidScriptBytes H.=== shouldAlsoBeValidScriptBytes
+
+  -- If we have fixed the double encoding issue, the bytes produced
+  -- should be the same.
+  expectedToBeValidScriptBytes H.=== confirmedToBeValidScriptBytes