diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index 2d189f6e6a..14d5395b43 100644 --- a/cardano-api/cardano-api.cabal +++ b/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, diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Hardcoded.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Hardcoded.hs new file mode 100644 index 0000000000..5c3fd4099a --- /dev/null +++ b/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 diff --git a/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs b/cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs index 4081e38724..a723fe00ff 100644 --- 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,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] ] diff --git a/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs b/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs index 1c543b3318..1bc7e27727 100644 --- a/cardano-api/gen/Test/Hedgehog/Roundtrip/CBOR.hs +++ b/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 diff --git a/cardano-api/internal/Cardano/Api/Script.hs b/cardano-api/internal/Cardano/Api/Script.hs index 0ba0c92068..8b9dd93410 100644 --- a/cardano-api/internal/Cardano/Api/Script.hs +++ b/cardano-api/internal/Cardano/Api/Script.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} @@ -14,6 +13,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {- HLINT ignore "Avoid lambda using `infix`" -} {- HLINT ignore "Use section" -} @@ -30,13 +30,16 @@ module Cardano.Api.Script , AnyPlutusScriptVersion (..) , IsPlutusScriptLanguage (..) , IsScriptLanguage (..) + , ToLedgerPlutusLanguage -- * Scripts in a specific language , Script (..) + , PlutusScriptInEra (..) -- * Scripts in any language , ScriptInAnyLang (..) , toScriptInAnyLang + , removePlutusScriptDoubleEncoding -- * Scripts in an era , ScriptInEra (..) @@ -153,11 +156,13 @@ import Cardano.Slotting.Slot (SlotNo) import Ouroboros.Consensus.Shelley.Eras (StandardCrypto) import qualified PlutusLedgerApi.Test.Examples as Plutus +import qualified Codec.CBOR.Read as CBOR import Control.Applicative import Control.Monad import Data.Aeson (Value (..), object, (.:), (.=)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson +import Data.Bifunctor import qualified Data.ByteString.Lazy as LBS import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as SBS @@ -171,8 +176,10 @@ import qualified Data.Text.Encoding as Text import Data.Type.Equality (TestEquality (..), (:~:) (Refl)) import Data.Typeable (Typeable) import Data.Vector (Vector) +import qualified Formatting as B import GHC.Exts (IsList (..)) import Numeric.Natural (Natural) +import Prettyprinter -- ---------------------------------------------------------------------------- -- Types for script language and version @@ -428,12 +435,12 @@ instance HasTypeProxy lang => HasTypeProxy (Script lang) where instance IsScriptLanguage lang => SerialiseAsCBOR (Script lang) where serialiseToCBOR (SimpleScript s) = CBOR.serialize' (toAllegraTimelock s :: Timelock.Timelock (ShelleyLedgerEra AllegraEra)) - serialiseToCBOR (PlutusScript PlutusScriptV1 s) = - CBOR.serialize' s - serialiseToCBOR (PlutusScript PlutusScriptV2 s) = - CBOR.serialize' s - serialiseToCBOR (PlutusScript PlutusScriptV3 s) = - CBOR.serialize' s + serialiseToCBOR (PlutusScript PlutusScriptV1 (PlutusScriptSerialised s)) = + SBS.fromShort s + serialiseToCBOR (PlutusScript PlutusScriptV2 (PlutusScriptSerialised s)) = + SBS.fromShort s + serialiseToCBOR (PlutusScript PlutusScriptV3 (PlutusScriptSerialised s)) = + SBS.fromShort s deserialiseFromCBOR _ bs = case scriptLanguage :: ScriptLanguage lang of @@ -443,13 +450,28 @@ instance IsScriptLanguage lang => SerialiseAsCBOR (Script lang) where <$> Binary.decodeFullAnnotator version "Script" Binary.decCBOR (LBS.fromStrict bs) PlutusScriptLanguage PlutusScriptV1 -> PlutusScript PlutusScriptV1 - <$> CBOR.decodeFull' bs + <$> deserialiseFromCBOR (AsPlutusScript AsPlutusScriptV1) bs PlutusScriptLanguage PlutusScriptV2 -> PlutusScript PlutusScriptV2 - <$> CBOR.decodeFull' bs + <$> deserialiseFromCBOR (AsPlutusScript AsPlutusScriptV2) bs PlutusScriptLanguage PlutusScriptV3 -> PlutusScript PlutusScriptV3 - <$> CBOR.decodeFull' bs + <$> deserialiseFromCBOR (AsPlutusScript AsPlutusScriptV3) bs + +-- | Previously we were double encoding the plutus script +-- bytes. This function removes a layer of encoding to return +-- the original plutus script bytes if it exists. +removePlutusScriptDoubleEncoding :: LBS.ByteString -> Crypto.ByteString +removePlutusScriptDoubleEncoding plutusScriptBytes = + case CBOR.deserialiseFromBytes CBOR.decodeBytes plutusScriptBytes of + Left _ -> LBS.toStrict plutusScriptBytes + Right (_, unwrapped) -> + -- 'unwrapped' is potentially valid plutus bytes i.e it is no longer double encoded + case CBOR.deserialiseFromBytes CBOR.decodeBytes $ LBS.fromStrict unwrapped of + Left _ -> LBS.toStrict plutusScriptBytes + -- We were able to decode a cbor in cbor bytes value. Therefore the original bytes + -- were likely a double encoded plutus script so we can now return the unwrapped bytes. + Right{} -> unwrapped instance IsScriptLanguage lang => HasTextEnvelope (Script lang) where textEnvelopeType _ = @@ -1002,19 +1024,24 @@ data PlutusScript lang where deriving stock Show -- TODO: would be nice to use via UsingRawBytesHex -- however that adds an awkward HasTypeProxy lang => -- constraint to other Show instances elsewhere - deriving (ToCBOR, FromCBOR) via (UsingRawBytes (PlutusScript lang)) - deriving anyclass SerialiseAsCBOR + +instance HasTypeProxy lang => SerialiseAsCBOR (PlutusScript lang) where + serialiseToCBOR (PlutusScriptSerialised sbs) = SBS.fromShort sbs + deserialiseFromCBOR _ bs = + Right $ PlutusScriptSerialised $ SBS.toShort $ removePlutusScriptDoubleEncoding $ LBS.fromStrict bs instance HasTypeProxy lang => HasTypeProxy (PlutusScript lang) where data AsType (PlutusScript lang) = AsPlutusScript (AsType lang) proxyToAsType _ = AsPlutusScript (proxyToAsType (Proxy :: Proxy lang)) +-- We re-use the 'SerialiseAsCBOR' instance for the raw bytes serialisation +-- because the CBOR serialisation is just the raw bytes. I.e we don't +-- do any additional transformation on Plutus script bytes. instance HasTypeProxy lang => SerialiseAsRawBytes (PlutusScript lang) where - serialiseToRawBytes (PlutusScriptSerialised sbs) = SBS.fromShort sbs - - deserialiseFromRawBytes (AsPlutusScript _) bs = - -- TODO alonzo: validate the script syntax and fail decoding if invalid - Right (PlutusScriptSerialised (SBS.toShort bs)) + serialiseToRawBytes = serialiseToCBOR + deserialiseFromRawBytes asType bs = + first (SerialiseAsRawBytesError . show . B.sformat B.build) $ + deserialiseFromCBOR asType bs instance IsPlutusScriptLanguage lang => HasTextEnvelope (PlutusScript lang) where textEnvelopeType _ = @@ -1292,6 +1319,44 @@ fromAllegraTimelock = go go (Shelley.RequireAnyOf s) = RequireAnyOf (map go (toList s)) go (Shelley.RequireMOf i s) = RequireMOf i (map go (toList s)) +type family ToLedgerPlutusLanguage lang where + ToLedgerPlutusLanguage PlutusScriptV1 = Plutus.PlutusV1 + ToLedgerPlutusLanguage PlutusScriptV2 = Plutus.PlutusV2 + ToLedgerPlutusLanguage PlutusScriptV3 = Plutus.PlutusV3 + +data PlutusScriptInEra era lang where + PlutusScriptInEra :: PlutusScript lang -> PlutusScriptInEra era lang + +deriving instance Eq (PlutusScriptInEra era lang) + +deriving instance Show (PlutusScriptInEra era lang) + +instance (HasTypeProxy era, HasTypeProxy lang) => HasTypeProxy (PlutusScriptInEra era lang) where + data AsType (PlutusScriptInEra era lang) = AsPlutusScriptInEra (AsType lang) + proxyToAsType _ = AsPlutusScriptInEra (proxyToAsType (Proxy :: Proxy lang)) + +instance + ( Ledger.Era (ShelleyLedgerEra era) + , HasTypeProxy (PlutusScriptInEra era lang) + , Plutus.PlutusLanguage (ToLedgerPlutusLanguage lang) + ) + => SerialiseAsCBOR (PlutusScriptInEra era lang) + where + serialiseToCBOR (PlutusScriptInEra (PlutusScriptSerialised s)) = + SBS.fromShort s + deserialiseFromCBOR _ bs = do + let v = Ledger.eraProtVerLow @(ShelleyLedgerEra era) + scriptShortBs = SBS.toShort $ removePlutusScriptDoubleEncoding $ LBS.fromStrict bs + let plutusScript :: Plutus.Plutus (ToLedgerPlutusLanguage lang) + plutusScript = PlutusScriptBinary scriptShortBs + plutusScriptInEra = PlutusScriptInEra $ PlutusScriptSerialised scriptShortBs + + case Plutus.decodePlutusRunnable v plutusScript of + Left e -> + Left $ + CBOR.DecoderErrorCustom "PlutusLedgerApi.Common.ScriptDecodeError" (Text.pack . show $ pretty e) + Right{} -> Right plutusScriptInEra + -- ---------------------------------------------------------------------------- -- JSON serialisation -- diff --git a/cardano-api/src/Cardano/Api.hs b/cardano-api/src/Cardano/Api.hs index 64c29775e8..84c12434b9 100644 --- a/cardano-api/src/Cardano/Api.hs +++ b/cardano-api/src/Cardano/Api.hs @@ -555,6 +555,7 @@ module Cardano.Api -- ** Scripts in a specific language , Script (..) + , PlutusScriptInEra (..) -- ** Scripts in any language , ScriptInAnyLang (..) 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 index 15356340d0..177918a60d 100644 --- 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,13 +11,18 @@ 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 +import Test.Gen.Cardano.Api.Hardcoded import Test.Gen.Cardano.Api.Typed import Test.Cardano.Api.Orphans () @@ -169,15 +175,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 +377,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