From 0cc82d9b00eb2b48f8ca9162fbc57eb3b45e3dc4 Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Thu, 28 May 2026 18:57:31 +0530 Subject: [PATCH 1/7] Replace Coders for some BaseTypes --- .../src/Cardano/Ledger/BaseTypes.hs | 20 +++++++++---- .../src/Cardano/Ledger/Credential.hs | 22 ++++++++++---- .../src/Cardano/Ledger/DRep.hs | 30 ++++++++++++++----- .../src/Cardano/Ledger/Plutus/Data.hs | 14 ++++++++- 4 files changed, 68 insertions(+), 18 deletions(-) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs index 3256783cdbe..970f9d1c017 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs @@ -115,6 +115,7 @@ import Cardano.Ledger.Binary ( cborError, decodeIntegralRational, decodeRecordNamed, + decodeRecordSum, encodeListLen, fromPlainDecoder, ifDecoderVersionAtLeast, @@ -580,11 +581,20 @@ instance EncCBOR Nonce where instance DecCBOR Nonce where decCBOR = - decode $ - Summands "Nonce" $ \case - 0 -> SumD NeutralNonce - 1 -> SumD Nonce Invalid k + ifDecoderVersionAtLeast (natVersion @12) decodeNonce $ + decode $ + Summands "Nonce" $ \case + 0 -> SumD NeutralNonce + 1 -> SumD Nonce Invalid k + where + decodeNonce = decodeRecordSum "Nonce" $ \case + 0 -> pure (1, NeutralNonce) + 1 -> do + n <- decCBOR + pure (2, Nonce n) + k -> invalidKey k + {-# INLINE decodeNonce #-} {-# INLINE decCBOR #-} instance ToJSON Nonce where diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Credential.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Credential.hs index 46943787598..1ca466eacb0 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Credential.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Credential.hs @@ -36,6 +36,7 @@ import Cardano.Ledger.BaseTypes ( ToKeyValuePairs (..), TxIx (..), integralToBounded, + invalidKey, ) import Cardano.Ledger.Binary ( CBORGroup (..), @@ -45,6 +46,7 @@ import Cardano.Ledger.Binary ( EncCBORGroup (..), FromCBOR (..), ToCBOR (..), + decodeRecordSum, encodeListLen, ifDecoderVersionAtLeast, natVersion, @@ -324,11 +326,21 @@ instance EncCBOR (Credential kr) where instance Typeable kr => DecCBOR (Credential kr) where decCBOR = - decode $ - Summands "Credential" $ \case - 0 -> SumD KeyHashObj SumD ScriptHashObj Invalid k + ifDecoderVersionAtLeast (natVersion @12) decodeCredential $ + decode $ + Summands "Credential" $ \case + 0 -> SumD KeyHashObj SumD ScriptHashObj Invalid k + where + decodeCredential = decodeRecordSum "Credential" $ \case + 0 -> do + kh <- decCBOR + pure (2, KeyHashObj kh) + 1 -> do + sh <- decCBOR + pure (2, ScriptHashObj sh) + k -> invalidKey k {-# INLINE decCBOR #-} instance Typeable kr => ToCBOR (Credential kr) where diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/DRep.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/DRep.hs index b69718ac68e..8df10a4bee6 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/DRep.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/DRep.hs @@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} @@ -27,6 +28,8 @@ import Cardano.Ledger.Binary ( EncCBOR (..), Interns, decNoShareCBOR, + decodeRecordSum, + ifDecoderVersionAtLeast, interns, internsFromSet, ) @@ -85,13 +88,26 @@ instance EncCBOR DRep where Sum DRepAlwaysNoConfidence 3 instance DecCBOR DRep where - decCBOR = decode $ - Summands "DRep" $ \case - 0 -> SumD DRepKeyHash SumD DRepScriptHash SumD DRepAlwaysAbstain - 3 -> SumD DRepAlwaysNoConfidence - k -> Invalid k + decCBOR = + ifDecoderVersionAtLeast (natVersion @12) decodeDRep $ + decode $ + Summands "DRep" $ \case + 0 -> SumD DRepKeyHash SumD DRepScriptHash SumD DRepAlwaysAbstain + 3 -> SumD DRepAlwaysNoConfidence + k -> Invalid k + where + decodeDRep = decodeRecordSum "DRep" $ \case + 0 -> do + kh <- decCBOR + pure (2, DRepKeyHash kh) + 1 -> do + sh <- decCBOR + pure (2, DRepScriptHash sh) + 2 -> pure (1, DRepAlwaysAbstain) + 3 -> pure (1, DRepAlwaysNoConfidence) + k -> invalidKey k instance DecShareCBOR DRep where type Share DRep = Interns (Credential DRepRole) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs index 4d9d69b34c7..b135f6bc8f9 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Data.hs @@ -50,6 +50,8 @@ import Cardano.Ledger.Binary ( encodeTag, fromPlainDecoder, fromPlainEncoding, + ifDecoderVersionAtLeast, + natVersion, ) import Cardano.Ledger.Binary.Coders import Cardano.Ledger.Core @@ -235,11 +237,21 @@ instance Era era => EncCBOR (Datum era) where NoDatum -> OmitC NoDatum instance Era era => DecCBOR (Datum era) where - decCBOR = decode (Summands "Datum" decodeDatum) + decCBOR = + ifDecoderVersionAtLeast (natVersion @12) decodeDatumPv12 $ + decode (Summands "Datum" decodeDatum) where decodeDatum 0 = SumD DatumHash do + dh <- decCBOR + pure (2, DatumHash dh) + 1 -> do + d <- decCBOR + pure (2, Datum d) + k -> invalidKey k instance Era era => ToJSON (Datum era) where toJSON d = From 81e9ea2803354f0b68538696176375102055cd10 Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Thu, 28 May 2026 19:00:38 +0530 Subject: [PATCH 2/7] Replace Coders for mkField in PParamsUpdate --- libs/cardano-ledger-core/src/Cardano/Ledger/Core/PParams.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core/PParams.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core/PParams.hs index 74a5b4e482a..e95bc090d70 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core/PParams.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core/PParams.hs @@ -123,7 +123,7 @@ import Cardano.Ledger.Binary ( ifDecoderVersionAtLeast, natVersion, ) -import Cardano.Ledger.Binary.Coders (Decode (..), Field (..), decode, field, invalidField) +import Cardano.Ledger.Binary.Coders (Decode (..), Field (..), decode, invalidField) import Cardano.Ledger.Coin ( Coin (..), CoinPerByte (..), @@ -287,7 +287,9 @@ instance EraPParams era => DecCBOR (PParamsUpdate era) where Maybe (EraDecoder t) -> Lens' (PParamsUpdate era) (StrictMaybe t) -> Field (PParamsUpdate era) - mkField Nothing ppuLens = field (set ppuLens . SJust) From + mkField Nothing ppuLens = + Field (set ppuLens . SJust) $ + ifDecoderVersionAtLeast (natVersion @12) decCBOR (decode From) mkField (Just (EraDecoder d)) ppuLens = Field (set ppuLens . SJust) d instance EraPParams era => ToCBOR (PParamsUpdate era) where From 88f21d37cfe6d8862ed33062f7b9d84bf008aafa Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Thu, 28 May 2026 19:04:04 +0530 Subject: [PATCH 3/7] Replace Summands for some more types --- .../impl/src/Cardano/Ledger/Alonzo/Scripts.hs | 23 ++++++++++- .../impl/src/Cardano/Ledger/Conway/TxCert.hs | 30 +++++++++++--- .../src/Cardano/Ledger/Dijkstra/Scripts.hs | 41 +++++++++++-------- 3 files changed, 70 insertions(+), 24 deletions(-) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs index baffd5b4778..827be21fa02 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs @@ -65,7 +65,7 @@ module Cardano.Ledger.Alonzo.Scripts ( import Cardano.Ledger.Allegra.Scripts import Cardano.Ledger.Alonzo.Era (AlonzoEra) import Cardano.Ledger.Alonzo.TxCert () -import Cardano.Ledger.BaseTypes (ProtVer (..), kindObject) +import Cardano.Ledger.BaseTypes (ProtVer (..), invalidKey, kindObject) import Cardano.Ledger.Binary ( Annotator, CBORGroup (..), @@ -76,8 +76,11 @@ import Cardano.Ledger.Binary ( EncCBORGroup (..), ToCBOR (toCBOR), Version, + decodeRecordSum, decodeWord8, encodeWord8, + ifDecoderVersionAtLeast, + natVersion, ) import Cardano.Ledger.Binary.Coders ( Decode (Ann, D, From, Invalid, SumD, Summands), @@ -628,7 +631,9 @@ encodeScript = \case SPlutusV4 -> Sum (PlutusScript . fromJust . mkPlutusScript . Plutus @'PlutusV4) 4 !> To pb instance AlonzoEraScript era => DecCBOR (Annotator (AlonzoScript era)) where - decCBOR = decode (Summands "AlonzoScript" decodeScript) + decCBOR = + ifDecoderVersionAtLeast (natVersion @12) decodeAlonzoScript $ + decode (Summands "AlonzoScript" decodeScript) where decodeAnnPlutus slang = Ann (SumD PlutusScript) <*! Ann (D (decodePlutusScript slang)) @@ -642,6 +647,20 @@ instance AlonzoEraScript era => DecCBOR (Annotator (AlonzoScript era)) where 4 -> decodeAnnPlutus SPlutusV4 n -> Invalid n {-# INLINE decodeScript #-} + decodePlutusVariant slang = do + ps <- decodePlutusScript slang + pure (2, pure (PlutusScript ps)) + {-# INLINE decodePlutusVariant #-} + decodeAlonzoScript = decodeRecordSum "AlonzoScript" $ \case + 0 -> do + ns <- decCBOR + pure (2, NativeScript <$> ns) + 1 -> decodePlutusVariant SPlutusV1 + 2 -> decodePlutusVariant SPlutusV2 + 3 -> decodePlutusVariant SPlutusV3 + 4 -> decodePlutusVariant SPlutusV4 + n -> invalidKey n + {-# INLINE decodeAlonzoScript #-} {-# INLINE decCBOR #-} -- | Verify that every `Script` represents a valid script. Force native scripts to Normal diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs index f2330e5b84b..82fe664d4d3 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs @@ -64,6 +64,8 @@ import Cardano.Ledger.Binary ( encodeListLen, encodeNullStrictMaybe, encodeWord8, + ifDecoderVersionAtLeast, + natVersion, toPlainEncoding, ) import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), ( Sum DelegStakeVote 2 !> To kh !> To dRep instance DecCBOR Delegatee where - decCBOR = decode $ - Summands "Delegatee" $ \case - 0 -> SumD DelegStake SumD DelegVote SumD DelegStakeVote Invalid k + decCBOR = + ifDecoderVersionAtLeast (natVersion @12) decodeDelegatee $ + decode $ + Summands "Delegatee" $ \case + 0 -> SumD DelegStake SumD DelegVote SumD DelegStakeVote Invalid k + where + decodeDelegatee = decodeRecordSum "Delegatee" $ \case + 0 -> do + kh <- decCBOR + pure (2, DelegStake kh) + 1 -> do + dRep <- decCBOR + pure (2, DelegVote dRep) + 2 -> do + kh <- decCBOR + dRep <- decCBOR + pure (3, DelegStakeVote kh dRep) + k -> invalidKey k + {-# INLINE decodeDelegatee #-} mkDelegatee :: Maybe (KeyHash StakePool) -> Maybe DRep -> Maybe Delegatee mkDelegatee mStakePool mDRep = diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Scripts.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Scripts.hs index bebf7c6a035..f611dd30dba 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Scripts.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Scripts.hs @@ -55,6 +55,7 @@ import Cardano.Ledger.Binary ( ToCBOR (..), cborError, decodeNullMaybe, + decodeRecordSum, decodeWord8, encodeListLen, encodeNull, @@ -62,14 +63,9 @@ import Cardano.Ledger.Binary ( enforceSize, ) import Cardano.Ledger.Binary.Coders ( - Decode (..), Encode (..), - Wrapped (..), - decode, encode, (!>), - ( EncCBOR (DijkstraNativeScriptRaw era) where DijkstraRequireGuard cred -> Sum DijkstraRequireGuard 6 !> To cred instance Era era => DecCBOR (Annotator (DijkstraNativeScriptRaw era)) where - decCBOR = decode (Summands "DijkstraNativeScriptRaw" decRaw) - where - decRaw :: Word -> Decode Open (Annotator (DijkstraNativeScriptRaw era)) - decRaw 0 = Ann (SumD DijkstraRequireSignature decCBOR) - decRaw 2 = Ann (SumD DijkstraRequireAnyOf) <*! D (sequence <$> decCBOR) - decRaw 3 = Ann (SumD DijkstraRequireMOf) <*! Ann From <*! D (sequence <$> decCBOR) - decRaw 4 = Ann (SumD DijkstraTimeStart do + hash <- decCBOR + pure (2, pure (DijkstraRequireSignature hash)) + 1 -> do + xs <- decCBOR + pure (2, DijkstraRequireAllOf <$> sequence xs) + 2 -> do + xs <- decCBOR + pure (2, DijkstraRequireAnyOf <$> sequence xs) + 3 -> do + m <- decCBOR + xs <- decCBOR + pure (3, DijkstraRequireMOf m <$> sequence xs) + 4 -> do + m <- decCBOR + pure (2, pure (DijkstraTimeStart m)) + 5 -> do + m <- decCBOR + pure (2, pure (DijkstraTimeExpire m)) + 6 -> do + cred <- decCBOR + pure (2, pure (DijkstraRequireGuard cred)) + n -> invalidKey n newtype DijkstraNativeScript era = MkDijkstraNativeScript (MemoBytes (DijkstraNativeScriptRaw era)) deriving (Eq, Generic) From 6d1d11b5bc473ddf8148e7e0aae21ec35f061360 Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Thu, 28 May 2026 19:06:11 +0530 Subject: [PATCH 4/7] Replace Coders for some governance procedures --- .../Ledger/Conway/Governance/Procedures.hs | 77 ++++++++++++++----- 1 file changed, 57 insertions(+), 20 deletions(-) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs index f535898f607..67827810b72 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs @@ -582,10 +582,15 @@ committeeThresholdL = lens committeeThreshold (\c q -> c {committeeThreshold = q instance Era era => DecCBOR (Committee era) where decCBOR = - decode $ - RecD Committee - decCBOR <*> decCBOR {-# INLINE decCBOR #-} instance Era era => EncCBOR (Committee era) where @@ -870,22 +875,54 @@ instance EraPParams era => ToJSON (GovAction era) instance EraPParams era => DecCBOR (GovAction era) where decCBOR = - decode $ Summands "GovAction" $ \case - 0 -> - SumD ParameterChange - - SumD HardForkInitiation - SumD TreasuryWithdrawals SumD NoConfidence SumD UpdateCommittee SumD NewConstitution SumD InfoAction - k -> Invalid k + ifDecoderVersionAtLeast (natVersion @12) decodeGovAction $ + decode $ + Summands "GovAction" $ \case + 0 -> + SumD ParameterChange + + SumD HardForkInitiation + SumD TreasuryWithdrawals SumD NoConfidence SumD UpdateCommittee SumD NewConstitution SumD InfoAction + k -> Invalid k + where + decodeGovAction = decodeRecordSum "GovAction" $ \case + 0 -> do + pGovActionId <- decodeNullStrictMaybe decCBOR + ppu <- decCBOR + govPolicy <- decodeNullStrictMaybe decCBOR + pure (4, ParameterChange pGovActionId ppu govPolicy) + 1 -> do + pGovActionId <- decodeNullStrictMaybe decCBOR + protVer <- decodeProtVer @era + pure (3, HardForkInitiation pGovActionId protVer) + 2 -> do + withdrawals <- decCBOR + govPolicy <- decodeNullStrictMaybe decCBOR + pure (3, TreasuryWithdrawals withdrawals govPolicy) + 3 -> do + pGovActionId <- decodeNullStrictMaybe decCBOR + pure (2, NoConfidence pGovActionId) + 4 -> do + pGovActionId <- decodeNullStrictMaybe decCBOR + ccToRemove <- decCBOR + ccToAdd <- decCBOR + threshold <- decCBOR + pure (5, UpdateCommittee pGovActionId ccToRemove ccToAdd threshold) + 5 -> do + pGovActionId <- decodeNullStrictMaybe decCBOR + constitution <- decCBOR + pure (3, NewConstitution pGovActionId constitution) + 6 -> pure (1, InfoAction) + k -> invalidKey k {-# INLINE decCBOR #-} instance EraPParams era => EncCBOR (GovAction era) where From 5f59f198ca49ef77f1d54549adaeab7ec6d77e9c Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Thu, 28 May 2026 19:09:01 +0530 Subject: [PATCH 5/7] Replace Coders in AlonzoTx(AuxData) forall branches --- .../impl/src/Cardano/Ledger/Alonzo/Tx.hs | 32 +++++++++++++++---- .../src/Cardano/Ledger/Alonzo/TxAuxData.hs | 6 +++- 2 files changed, 31 insertions(+), 7 deletions(-) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs index 3594daf0c2e..756cb39fd80 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs @@ -10,6 +10,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -101,12 +102,15 @@ import Cardano.Ledger.BaseTypes (ProtVer, integralToBounded) import Cardano.Ledger.Binary ( Annotator, DecCBOR (..), + Decoder, EncCBOR (encCBOR), Encoding, ToCBOR (..), decodeNullStrictMaybe, encodeListLen, encodeNullStrictMaybe, + ifDecoderVersionAtLeast, + natVersion, serialize, serialize', ) @@ -449,6 +453,21 @@ instance where toCBOR = toEraCBOR @era +decodeAlonzoTxPv12 :: + forall era s. + ( DecCBOR (Annotator (TxBody TopTx era)) + , DecCBOR (Annotator (TxWits era)) + , DecCBOR (Annotator (TxAuxData era)) + ) => + Decoder s (Annotator (AlonzoTx TopTx era)) +decodeAlonzoTxPv12 = decodeRecordNamed "AlonzoTx" (const 4) $ do + body <- decCBOR + wits <- decCBOR + isValid <- decCBOR + auxData <- decodeNullStrictMaybe decCBOR + pure $ AlonzoTx <$> body <*> wits <*> pure isValid <*> sequence auxData +{-# INLINE decodeAlonzoTxPv12 #-} + instance ( Typeable l , Era era @@ -464,12 +483,13 @@ instance decCBOR = withSTxTopLevelM @l @era $ \case STopTxOnly -> - decode $ - Ann (RecD AlonzoTx) - <*! From - <*! From - <*! Ann From - <*! D (sequence <$> decodeNullStrictMaybe decCBOR) + ifDecoderVersionAtLeast (natVersion @12) decodeAlonzoTxPv12 $ + decode $ + Ann (RecD AlonzoTx) + <*! From + <*! From + <*! Ann From + <*! D (sequence <$> decodeNullStrictMaybe decCBOR) {-# INLINE decCBOR #-} data AlonzoStAnnTx l era where diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs index 79b36e2ab8c..d33d0f18cdf 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxAuxData.hs @@ -204,7 +204,7 @@ instance where decCBOR = decodeTxAuxDataByTokenType @(Annotator (AlonzoTxAuxDataRaw era)) - decodeShelley + (ifDecoderVersionAtLeast (natVersion @12) decodeShelleyPv12 decodeShelley) (ifDecoderVersionAtLeast (natVersion @12) decodeDijkstra decodeAllegra) ( ifDecoderVersionAtLeast (natVersion @12) @@ -219,6 +219,10 @@ instance decodeAlonzo ) where + decodeShelleyPv12 = do + metadata <- decCBOR + pure $ pure $ AlonzoTxAuxDataRaw metadata StrictSeq.empty Map.empty + {-# INLINE decodeShelleyPv12 #-} decodeShelley = decode ( Ann (Emit AlonzoTxAuxDataRaw) From 07cf6908c831e28d392df1f32c17d16f12bceff6 Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Thu, 28 May 2026 19:11:33 +0530 Subject: [PATCH 6/7] Replace Coders in testlib types --- eras/alonzo/impl/cardano-ledger-alonzo.cabal | 1 + .../impl/src/Cardano/Ledger/Alonzo/TxWits.hs | 1 + .../Cardano/Ledger/Alonzo/Binary/Annotator.hs | 118 +++++++-- .../impl/cardano-ledger-dijkstra.cabal | 1 + .../Ledger/Dijkstra/Binary/Annotator.hs | 249 +++++++++--------- 5 files changed, 235 insertions(+), 135 deletions(-) diff --git a/eras/alonzo/impl/cardano-ledger-alonzo.cabal b/eras/alonzo/impl/cardano-ledger-alonzo.cabal index 7b6fbeeaf7d..b0b1f41c564 100644 --- a/eras/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/eras/alonzo/impl/cardano-ledger-alonzo.cabal @@ -225,6 +225,7 @@ library testlib HUnit, base, bytestring, + cardano-base, cardano-data:{cardano-data, testlib}, cardano-ledger-allegra:{cardano-ledger-allegra, testlib}, cardano-ledger-alonzo, diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs index b1e2889ffc8..1d0c5ecfb14 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs @@ -52,6 +52,7 @@ module Cardano.Ledger.Alonzo.TxWits ( emptyTxWitsRaw, addScriptsTxWitsRaw, decodeAlonzoPlutusScript, + alonzoPlutusScriptDecoder, asHashedScriptPair, ) where diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Annotator.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Annotator.hs index c8d217ebd14..30aaf49eed1 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Annotator.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Annotator.hs @@ -18,6 +18,7 @@ module Test.Cardano.Ledger.Alonzo.Binary.Annotator ( module Test.Cardano.Ledger.Mary.Binary.Annotator, ) where +import Cardano.Base.Typeable (TypeName (TypeName)) import Cardano.Ledger.Alonzo (AlonzoEra) import Cardano.Ledger.Alonzo.BlockBody.Internal import Cardano.Ledger.Alonzo.Scripts @@ -107,12 +108,21 @@ instance DecCBOR (AlonzoTx TopTx era) where decCBOR = - decode $ - RecD AlonzoTx - decCBOR <*> decCBOR <*> pure Map.empty + {-# INLINE decodeAllegraPv12 #-} decodeAllegra = decode (RecD AlonzoTxAuxDataRaw Word -> Maybe (Decoder s (AlonzoTxAuxDataRaw era)) + decoderByKey acc = \case + 0 -> Just $ do + metadata <- decCBOR + pure $ acc {atadrMetadata = metadata} + 1 -> Just $ do + scripts <- decCBOR + pure $ acc {atadrNativeScripts = atadrNativeScripts acc <> scripts} + 2 -> decodeAddPlutus PlutusV1 + 3 -> decodeAddPlutus PlutusV2 + 4 -> decodeAddPlutus PlutusV3 + 5 -> decodeAddPlutus PlutusV4 + _ -> Nothing + where + decodeAddPlutus lang = Just $ do + guardPlutus lang + ps <- decCBOR + pure $ addPlutusScripts lang ps acc + {-# INLINE decodeAddPlutus #-} + {-# INLINE decoderByKey #-} + auxDataField :: Word -> Field (AlonzoTxAuxDataRaw era) auxDataField 0 = field (\x ad -> ad {atadrMetadata = x}) From auxDataField 1 = field (\x ad -> ad {atadrNativeScripts = atadrNativeScripts ad <> x}) From @@ -149,12 +192,10 @@ deriving newtype instance (Era era, DecCBOR (NativeScript era)) => DecCBOR (Alon instance (AlonzoEraScript era, DecCBOR (NativeScript era)) => DecCBOR (AlonzoTxWitsRaw era) where decCBOR = - decode $ - SparseKeyed - "AlonzoTxWits" - emptyTxWitsRaw - txWitnessField - [] + ifDecoderVersionAtLeast + (natVersion @12) + (decodeSparseKeyed TypeName [] emptyTxWitsRaw decoderByKey) + (decode $ SparseKeyed "AlonzoTxWits" emptyTxWitsRaw txWitnessField []) where setDecoder :: (Ord a, DecCBOR a) => Decoder s (Set a) setDecoder = @@ -214,6 +255,35 @@ instance (AlonzoEraScript era, DecCBOR (NativeScript era)) => DecCBOR (AlonzoTxW txWitnessField n = invalidField n {-# INLINE txWitnessField #-} + decoderByKey :: AlonzoTxWitsRaw era -> Word -> Maybe (Decoder s (AlonzoTxWitsRaw era)) + decoderByKey acc = \case + 0 -> Just $ do + x <- addrWitsSetDecoder + pure $ acc {atwrAddrTxWits = x} + 1 -> Just $ do + x <- nativeScriptsDecoder + pure $ addScriptsTxWitsRaw x acc + 2 -> Just $ do + x <- setDecoder + pure $ acc {atwrBootAddrTxWits = x} + 3 -> Just $ do + x <- alonzoPlutusScriptDecoder SPlutusV1 + pure $ addScriptsTxWitsRaw x acc + 4 -> Just $ do + x <- decCBOR + pure $ acc {atwrDatsTxWits = x} + 5 -> Just $ do + x <- decCBOR + pure $ acc {atwrRdmrsTxWits = x} + 6 -> Just $ do + x <- alonzoPlutusScriptDecoder SPlutusV2 + pure $ addScriptsTxWitsRaw x acc + 7 -> Just $ do + x <- alonzoPlutusScriptDecoder SPlutusV3 + pure $ addScriptsTxWitsRaw x acc + _ -> Nothing + {-# INLINE decoderByKey #-} + noDuplicateNativeScriptsDecoder :: Decoder s (Map ScriptHash (Script era)) noDuplicateNativeScriptsDecoder = noDuplicateNonEmptySetAsMapDecoder @@ -291,7 +361,9 @@ instance AlonzoEraScript era => DecCBOR (RedeemersRaw era) where deriving newtype instance AlonzoEraScript era => DecCBOR (Redeemers era) instance (AlonzoEraScript era, DecCBOR (NativeScript era)) => DecCBOR (AlonzoScript era) where - decCBOR = decode (Summands "AlonzoScript" decodeScript) + decCBOR = + ifDecoderVersionAtLeast (natVersion @12) decodeAlonzoScriptPv12 $ + decode (Summands "AlonzoScript" decodeScript) where decodeScript = \case 0 -> SumD NativeScript DecCBOR (AlonzoScr n -> Invalid n decodePlutus slang = SumD PlutusScript do + ns <- decCBOR + pure (2, NativeScript ns) + 1 -> decodePlutusVariant SPlutusV1 + 2 -> decodePlutusVariant SPlutusV2 + 3 -> decodePlutusVariant SPlutusV3 + 4 -> decodePlutusVariant SPlutusV4 + n -> invalidKey n + {-# INLINE decodeAlonzoScriptPv12 #-} -- | Decodes a set of `a`'s and maps a function over it to get key-value pairs. -- If the key-value pairs create a non-empty Map without duplicates, then that map is returned, diff --git a/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal b/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal index f9750bd5bd6..fa19cf82e6f 100644 --- a/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal +++ b/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal @@ -177,6 +177,7 @@ library testlib build-depends: base, bytestring, + cardano-base, cardano-data, cardano-ledger-allegra:{cardano-ledger-allegra, testlib}, cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib}, diff --git a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Binary/Annotator.hs b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Binary/Annotator.hs index 082c86d4d07..48558be1b56 100644 --- a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Binary/Annotator.hs +++ b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Binary/Annotator.hs @@ -15,10 +15,10 @@ module Test.Cardano.Ledger.Dijkstra.Binary.Annotator ( ) where +import Cardano.Base.Typeable (TypeName (TypeName)) import Cardano.Ledger.Allegra.Scripts (invalidBeforeL, invalidHereAfterL) import Cardano.Ledger.BaseTypes import Cardano.Ledger.Binary -import Cardano.Ledger.Binary.Coders import Cardano.Ledger.Coin (decodePositiveCoin) import Cardano.Ledger.Conway.Governance (VotingProcedures (..)) import Cardano.Ledger.Dijkstra (DijkstraEra) @@ -32,8 +32,7 @@ import Cardano.Ledger.Dijkstra.Scripts import Cardano.Ledger.Dijkstra.Tx (DijkstraTx (..), Tx (..)) import Cardano.Ledger.Dijkstra.TxBody import Cardano.Ledger.MemoBytes (decodeMemoized) -import Cardano.Ledger.Val (Val (..)) -import Control.Monad (forM_, unless) +import Control.Monad (forM_, unless, when) import Data.Coerce (coerce) import Data.Foldable (Foldable (..)) import Data.IntSet (IntSet) @@ -52,108 +51,106 @@ deriving newtype instance Typeable l => DecCBOR (TxBody l DijkstraEra) instance Typeable l => DecCBOR (DijkstraTxBodyRaw l DijkstraEra) where decCBOR = withSTxBothLevels @l $ \sTxLevel -> - decode $ - SparseKeyed - "TxBodyRaw" - (basicDijkstraTxBodyRaw sTxLevel) - (bodyFields sTxLevel) - (requiredFields sTxLevel) + decodeSparseKeyed + TypeName + (requiredFields sTxLevel) + (basicDijkstraTxBodyRaw sTxLevel) + (decoderByKey sTxLevel) where - bodyFields :: STxBothLevels l DijkstraEra -> Word -> Field (DijkstraTxBodyRaw l DijkstraEra) - bodyFields sTxLevel = \case - 0 -> field (inputsDijkstraTxBodyRawL .~) From - 1 -> field (outputsDijkstraTxBodyRawL .~) From - 2 | STopTx <- sTxLevel -> field (feeDijkstraTxBodyRawL .~) From - 3 -> ofield (vldtDijkstraTxBodyRawL . invalidHereAfterL .~) From - 4 -> - fieldGuarded - (emptyFailure "Certificates" "non-empty") - OSet.null - (certsDijkstraTxBodyRawL .~) - From - 5 -> - fieldGuarded - (emptyFailure "Withdrawals" "non-empty") - (null . unWithdrawals) - (withdrawalsDijkstraTxBodyRawL .~) - From - 7 -> ofield (auxDataHashDijkstraTxBodyRawL .~) From - 8 -> ofield (vldtDijkstraTxBodyRawL . invalidBeforeL .~) From - 9 -> - fieldGuarded - (emptyFailure "Mint" "non-empty") - (== mempty) - (mintDijkstraTxBodyRawL .~) - From - 11 -> ofield (scriptIntegrityHashDijkstraTxBodyRawL .~) From - 13 - | STopTx <- sTxLevel -> - fieldGuarded - (emptyFailure "Collateral Inputs" "non-empty") - null - (collateralInputsDijkstraTxBodyRawL .~) - From - 14 -> - ofield - (\x -> guardsDijkstraTxBodyRawL .~ fromSMaybe mempty x) - (D decodeGuards) - 15 -> ofield (networkIdDijkstraTxBodyRawL .~) From - 16 - | STopTx <- sTxLevel -> - ofield (collateralReturnDijkstraTxBodyRawL .~) From - 17 - | STopTx <- sTxLevel -> - ofield (totalCollateralDijkstraTxBodyRawL .~) From - 18 -> - fieldGuarded - (emptyFailure "Reference Inputs" "non-empty") - null - (referenceInputsDijkstraTxBodyRawL .~) - From - 19 -> - fieldGuarded - (emptyFailure "VotingProcedures" "non-empty") - (null . unVotingProcedures) - (votingProceduresDijkstraTxBodyRawL .~) - From - 20 -> - fieldGuarded - (emptyFailure "ProposalProcedures" "non-empty") - OSet.null - (proposalProceduresDijkstraTxBodyRawL .~) - From - 21 -> ofield (currentTreasuryValueDijkstraTxBodyRawL .~) From - 22 -> - ofield - (\x -> treasuryDonationDijkstraTxBodyRawL .~ fromSMaybe zero x) - (D (decodePositiveCoin $ emptyFailure "Treasury Donation" "non-zero")) - 23 - | STopTx <- sTxLevel -> - fieldGuarded - (emptyFailure "Subtransactions" "non-empty") - OMap.null - (subTransactionsDijkstraTxBodyRawL .~) - (D $ allowTag setTag >> decCBOR) - 24 - | SSubTx <- sTxLevel -> - fieldGuarded - (emptyFailure "RequiredTopLevelGuards" "non-empty") - Map.null - (requiredTopLevelGuardsDijkstraTxBodyRawL .~) - (D (decodeMap decCBOR (decodeNullStrictMaybe decCBOR))) - 25 -> - fieldGuarded - (emptyFailure "DirectDeposits" "non-empty") - (null . unDirectDeposits) - (directDepositsDijkstraTxBodyRawL .~) - From - 26 -> - fieldGuarded - (emptyFailure "AccountBalanceIntervals" "non-empty") - (null . unAccountBalanceIntervals) - (accountBalanceIntervalsDijkstraTxBodyRawL .~) - From - n -> invalidField n + decoderByKey :: + STxBothLevels l DijkstraEra -> + DijkstraTxBodyRaw l DijkstraEra -> + Word -> + Maybe (Decoder s (DijkstraTxBodyRaw l DijkstraEra)) + decoderByKey sTxLevel acc = \case + 0 -> Just $ do + x <- decCBOR + pure $ inputsDijkstraTxBodyRawL .~ x $ acc + 1 -> Just $ do + x <- decCBOR + pure $ outputsDijkstraTxBodyRawL .~ x $ acc + 2 | STopTx <- sTxLevel -> Just $ do + x <- decCBOR + pure $ feeDijkstraTxBodyRawL .~ x $ acc + 3 -> Just $ do + x <- decCBOR + pure $ vldtDijkstraTxBodyRawL . invalidHereAfterL .~ SJust x $ acc + 4 -> Just $ do + x <- decCBOR + when (OSet.null x) $ fail (emptyFailure "Certificates" "non-empty") + pure $ certsDijkstraTxBodyRawL .~ x $ acc + 5 -> Just $ do + x <- decCBOR + when (null (unWithdrawals x)) $ fail (emptyFailure "Withdrawals" "non-empty") + pure $ withdrawalsDijkstraTxBodyRawL .~ x $ acc + 7 -> Just $ do + x <- decCBOR + pure $ auxDataHashDijkstraTxBodyRawL .~ SJust x $ acc + 8 -> Just $ do + x <- decCBOR + pure $ vldtDijkstraTxBodyRawL . invalidBeforeL .~ SJust x $ acc + 9 -> Just $ do + x <- decCBOR + when (x == mempty) $ fail (emptyFailure "Mint" "non-empty") + pure $ mintDijkstraTxBodyRawL .~ x $ acc + 11 -> Just $ do + x <- decCBOR + pure $ scriptIntegrityHashDijkstraTxBodyRawL .~ SJust x $ acc + 13 | STopTx <- sTxLevel -> Just $ do + x <- decCBOR + when (null x) $ fail (emptyFailure "Collateral Inputs" "non-empty") + pure $ collateralInputsDijkstraTxBodyRawL .~ x $ acc + 14 -> Just $ do + x <- decodeGuards + pure $ guardsDijkstraTxBodyRawL .~ x $ acc + 15 -> Just $ do + x <- decCBOR + pure $ networkIdDijkstraTxBodyRawL .~ SJust x $ acc + 16 | STopTx <- sTxLevel -> Just $ do + x <- decCBOR + pure $ collateralReturnDijkstraTxBodyRawL .~ SJust x $ acc + 17 | STopTx <- sTxLevel -> Just $ do + x <- decCBOR + pure $ totalCollateralDijkstraTxBodyRawL .~ SJust x $ acc + 18 -> Just $ do + x <- decCBOR + when (null x) $ fail (emptyFailure "Reference Inputs" "non-empty") + pure $ referenceInputsDijkstraTxBodyRawL .~ x $ acc + 19 -> Just $ do + x <- decCBOR + when (null (unVotingProcedures x)) $ fail (emptyFailure "VotingProcedures" "non-empty") + pure $ votingProceduresDijkstraTxBodyRawL .~ x $ acc + 20 -> Just $ do + x <- decCBOR + when (OSet.null x) $ fail (emptyFailure "ProposalProcedures" "non-empty") + pure $ proposalProceduresDijkstraTxBodyRawL .~ x $ acc + 21 -> Just $ do + x <- decCBOR + pure $ currentTreasuryValueDijkstraTxBodyRawL .~ SJust x $ acc + 22 -> Just $ do + x <- decodePositiveCoin $ emptyFailure "Treasury Donation" "non-zero" + pure $ treasuryDonationDijkstraTxBodyRawL .~ x $ acc + 23 | STopTx <- sTxLevel -> Just $ do + allowTag setTag + x <- decCBOR + when (OMap.null x) $ fail (emptyFailure "Subtransactions" "non-empty") + pure $ subTransactionsDijkstraTxBodyRawL .~ x $ acc + 24 | SSubTx <- sTxLevel -> Just $ do + x <- decodeMap decCBOR (decodeNullStrictMaybe decCBOR) + when (Map.null x) $ fail (emptyFailure "RequiredTopLevelGuards" "non-empty") + pure $ requiredTopLevelGuardsDijkstraTxBodyRawL .~ x $ acc + 25 -> Just $ do + x <- decCBOR + when (null (unDirectDeposits x)) $ fail (emptyFailure "DirectDeposits" "non-empty") + pure $ directDepositsDijkstraTxBodyRawL .~ x $ acc + 26 -> Just $ do + x <- decCBOR + when (null (unAccountBalanceIntervals x)) $ + fail (emptyFailure "AccountBalanceIntervals" "non-empty") + pure $ accountBalanceIntervalsDijkstraTxBodyRawL .~ x $ acc + _ -> Nothing + {-# INLINE decoderByKey #-} + requiredFields :: STxBothLevels l DijkstraEra -> [(Word, String)] requiredFields sTxLevel | STopTx <- sTxLevel = @@ -170,15 +167,30 @@ instance Typeable l => DecCBOR (DijkstraTxBodyRaw l DijkstraEra) where "TxBody: '" <> fieldName <> "' must be " <> requirement <> " when supplied" instance Era era => DecCBOR (DijkstraNativeScriptRaw era) where - decCBOR = decode $ Summands "DijkstraNativeScriptRaw" $ \case - 0 -> SumD DijkstraRequireSignature SumD DijkstraRequireAllOf SumD DijkstraRequireAnyOf SumD DijkstraRequireMOf SumD DijkstraTimeStart SumD DijkstraTimeExpire SumD DijkstraRequireGuard Invalid n + decCBOR = decodeRecordSum "DijkstraNativeScriptRaw" $ \case + 0 -> do + hash <- decCBOR + pure (2, DijkstraRequireSignature hash) + 1 -> do + xs <- decCBOR + pure (2, DijkstraRequireAllOf xs) + 2 -> do + xs <- decCBOR + pure (2, DijkstraRequireAnyOf xs) + 3 -> do + m <- decCBOR + xs <- decCBOR + pure (3, DijkstraRequireMOf m xs) + 4 -> do + m <- decCBOR + pure (2, DijkstraTimeStart m) + 5 -> do + m <- decCBOR + pure (2, DijkstraTimeExpire m) + 6 -> do + cred <- decCBOR + pure (2, DijkstraRequireGuard cred) + n -> invalidKey n instance Era era => DecCBOR (DijkstraNativeScript era) where decCBOR = MkDijkstraNativeScript <$> decodeMemoized decCBOR @@ -187,12 +199,11 @@ instance Typeable l => DecCBOR (DijkstraTx l DijkstraEra) where decCBOR = withSTxBothLevels @l $ \case STopTx -> decodeDijkstraTopTx True - SSubTx -> - decode $ - RecD DijkstraSubTx - decodeRecordNamed "DijkstraSubTx" (const 3) $ do + body <- decCBOR + wits <- decCBOR + aux <- decodeNullStrictMaybe decCBOR + pure $ DijkstraSubTx body wits aux {-# INLINE decCBOR #-} deriving newtype instance Typeable l => DecCBOR (Tx l DijkstraEra) From 42e425cbb0fdb9387e8969dd5bb3317c90cb1936 Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Mon, 1 Jun 2026 16:09:57 +0530 Subject: [PATCH 7/7] Update changelog --- eras/alonzo/impl/CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/eras/alonzo/impl/CHANGELOG.md b/eras/alonzo/impl/CHANGELOG.md index 98e6ca715d5..f3f4ea9b996 100644 --- a/eras/alonzo/impl/CHANGELOG.md +++ b/eras/alonzo/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.16.0.0 +* Export `alonzoPlutusScriptDecoder` from `Cardano.Ledger.Alonzo.TxWits` * Add `generate-cbor` executable * Replace `scriptsProvided` and `scriptsNeeded` in `mkScriptIntegrity` signature with `Set Language` * Add `plutusLanguagesUsedStAnnTx` to `AlonzoEraUTxO` and a helper to implement it `plutusLanguagesUsedAlonzoStAnnTx`