From f9aff135c7327d37e83b8ca612e4a6f1b2a9872b Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Fri, 18 Oct 2024 14:49:35 +0530 Subject: [PATCH 1/3] Add {To,From}Group to Coders for {Enc,Dec}CBORGroup Also, add {Enc,Dec}CBORGroup instances for Mismatch --- .../Cardano/Ledger/Binary/Decoding/Coders.hs | 11 ++++++-- .../Cardano/Ledger/Binary/Encoding/Coders.hs | 7 ++++++ .../src/Cardano/Ledger/Binary/Group.hs | 16 ++++++++++++ .../src/Cardano/Ledger/BaseTypes.hs | 25 +++++++++++++++++++ 4 files changed, 57 insertions(+), 2 deletions(-) diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Coders.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Coders.hs index 7430dd6c670..a9e046cdc8e 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Coders.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Coders.hs @@ -65,6 +65,7 @@ import Cardano.Ledger.Binary.Decoding.Annotated (Annotator (..), decodeAnnSet) import Cardano.Ledger.Binary.Decoding.DecCBOR (DecCBOR (decCBOR)) import Cardano.Ledger.Binary.Decoding.Decoder import Cardano.Ledger.Binary.Encoding.EncCBOR (EncCBOR (encCBOR)) +import Cardano.Ledger.Binary.Group (DecCBORGroup (..), EncCBORGroup (..)) import Cardano.Ledger.Binary.Version (Version) #if ! MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) @@ -75,7 +76,7 @@ import Data.Maybe.Strict (StrictMaybe (..)) import Data.Set (Set, insert, member) import qualified Data.Set as Set import qualified Data.Text as Text -import Data.Typeable (Typeable, typeOf) +import Data.Typeable (Proxy (..), Typeable, typeOf) import Data.Void (Void) -- ==================================================================== @@ -358,6 +359,9 @@ data Decode (w :: Wrapped) t where -- | Label a (component, field, argument). It will be decoded using the existing -- DecCBOR instance at @t@ From :: DecCBOR t => Decode w t + -- | Label components, fields, arguments. It will be decoded using the existing + -- DecCBORGroup instance at @t@ + FromGroup :: (EncCBORGroup t, DecCBORGroup t) => Decode w t -- | Label a (component, field, argument). It will be decoded using the given decoder. D :: (forall s. Decoder s t) -> Decode ('Closed 'Dense) t -- | Apply a functional decoding (arising from 'RecD' or 'SumD') to get (type wise) @@ -412,12 +416,13 @@ x <*! y = ApplyAnn x y f Int +hsize :: forall w t. Decode w t -> Int hsize (Summands _ _) = 1 hsize (SumD _) = 0 hsize (RecD _) = 0 hsize (KeyedD _) = 0 hsize From = 1 +hsize FromGroup = fromIntegral $ listLenBound $ Proxy @t hsize (D _) = 1 hsize (ApplyD f x) = hsize f + hsize x hsize (Invalid _) = 0 @@ -444,6 +449,7 @@ decodeCount (SumD cn) n = pure (n + 1, cn) decodeCount (KeyedD cn) n = pure (n + 1, cn) decodeCount (RecD cn) n = decodeRecordNamed "RecD" (const n) (pure (n, cn)) decodeCount From n = (n,) <$> decCBOR +decodeCount FromGroup n = (n,) <$> decCBORGroup decodeCount (D dec) n = (n,) <$> dec decodeCount (Invalid k) _ = invalidKey k decodeCount (Map f x) n = do (m, y) <- decodeCount x n; pure (m, f y) @@ -477,6 +483,7 @@ decodeClosed (Summands nm f) = decodeRecordSum nm (decodE . f) decodeClosed (KeyedD cn) = pure cn decodeClosed (RecD cn) = pure cn decodeClosed From = decCBOR +decodeClosed FromGroup = decCBORGroup decodeClosed (D dec) = dec decodeClosed (ApplyD cn g) = do f <- decodeClosed cn diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Encoding/Coders.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Encoding/Coders.hs index 192268d4fe0..1176d0e636c 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Encoding/Coders.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Encoding/Coders.hs @@ -68,6 +68,7 @@ import Cardano.Ledger.Binary.Encoding.Encoder ( encodeTag, encodeWord, ) +import Cardano.Ledger.Binary.Group (EncCBORGroup (..)) import Data.Maybe.Strict (StrictMaybe (SJust, SNothing)) -- ==================================================================== @@ -128,6 +129,8 @@ data Encode (w :: Wrapped) t where Keyed :: t -> Encode ('Closed 'Sparse) t -- | Label an (component, field, argument) to be encoded using an existing EncCBOR instance. To :: EncCBOR a => a -> Encode ('Closed 'Dense) a + -- | Label components, set of fields, or arguments to be encoded using an existing EncCBORGroup instance. + ToGroup :: EncCBORGroup t => t -> Encode ('Closed 'Dense) t -- | Label an (component, field, argument) to be encoded using an existing EncCBOR instance. E :: (t -> Encoding) -> t -> Encode ('Closed 'Dense) t -- | Lift one Encode to another with a different type. Used to make a Functor instance of (Encode w). @@ -161,6 +164,7 @@ runE (Sum cn _) = cn runE (Rec cn) = cn runE (ApplyE f x) = runE f (runE x) runE (To x) = x +runE (ToGroup x) = x runE (E _ x) = x runE (MapE f x) = f $ runE x runE (OmitC x) = x @@ -173,6 +177,7 @@ gsize :: Encode w t -> Word gsize (Sum _ _) = 0 gsize (Rec _) = 0 gsize (To _) = 1 +gsize (ToGroup x) = listLen x gsize (E _ _) = 1 gsize (MapE _ x) = gsize x gsize (ApplyE f x) = gsize f + gsize x @@ -192,6 +197,7 @@ encode = encodeCountPrefix 0 encodeCountPrefix n (Keyed _) = encodeMapLen n encodeCountPrefix n (Rec _) = encodeListLen n encodeCountPrefix _ (To x) = encCBOR x + encodeCountPrefix _ (ToGroup x) = encCBORGroup x encodeCountPrefix _ (E enc x) = enc x encodeCountPrefix n (MapE _ x) = encodeCountPrefix n x encodeCountPrefix _ (OmitC _) = mempty @@ -204,6 +210,7 @@ encode = encodeCountPrefix 0 encodeClosed :: Encode ('Closed d) t -> Encoding encodeClosed (Rec _) = mempty encodeClosed (To x) = encCBOR x + encodeClosed (ToGroup x) = encCBORGroup x encodeClosed (E enc x) = enc x encodeClosed (MapE _ x) = encodeClosed x encodeClosed (ApplyE f x) = encodeClosed f <> encodeClosed x diff --git a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Group.hs b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Group.hs index 96315a7dcef..ac5bd64748e 100644 --- a/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Group.hs +++ b/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Group.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -61,3 +62,18 @@ listLenInt x = fromIntegral (listLen x) class Typeable a => DecCBORGroup a where decCBORGroup :: Decoder s a + +instance EncCBOR a => EncCBORGroup (a, a) where + encCBORGroup (x, y) = + encCBOR x <> encCBOR y + encodedGroupSizeExpr size_ proxy = + encodedSizeExpr size_ (fst <$> proxy) + + encodedSizeExpr size_ (snd <$> proxy) + listLen _ = 2 + listLenBound _ = 2 + +instance DecCBOR a => DecCBORGroup (a, a) where + decCBORGroup = do + x <- decCBOR + y <- decCBOR + pure (x, y) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs index 409991a80d1..f6cda520d3b 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/BaseTypes.hs @@ -8,6 +8,7 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -76,6 +77,8 @@ module Cardano.Ledger.BaseTypes ( ShelleyBase, Relation (..), Mismatch (..), + swapMismatch, + unswapMismatch, -- * Injection Inject (..), @@ -737,6 +740,14 @@ data Mismatch (r :: Relation) a = Mismatch } deriving (Eq, Ord, Show, Generic, NFData, ToJSON, FromJSON, NoThunks) +-- | Convert a `Mismatch` to a tuple that has "supplied" and "expected" swapped places +swapMismatch :: Mismatch r a -> (a, a) +swapMismatch Mismatch {mismatchSupplied, mismatchExpected} = (mismatchExpected, mismatchSupplied) + +-- | Convert a tuple that has "supplied" and "expected" swapped places to a `Mismatch` type. +unswapMismatch :: (a, a) -> Mismatch r a +unswapMismatch (mismatchExpected, mismatchSupplied) = Mismatch {mismatchSupplied, mismatchExpected} + instance (EncCBOR a, Typeable r) => EncCBOR (Mismatch r a) where encCBOR (Mismatch supplied expected) = encode $ @@ -751,6 +762,20 @@ instance (DecCBOR a, Typeable r) => DecCBOR (Mismatch r a) where EncCBORGroup (Mismatch r a) where + encCBORGroup Mismatch {..} = encCBOR mismatchSupplied <> encCBOR mismatchExpected + encodedGroupSizeExpr size_ proxy = + encodedSizeExpr size_ (mismatchSupplied <$> proxy) + + encodedSizeExpr size_ (mismatchExpected <$> proxy) + listLen _ = 2 + listLenBound _ = 2 + +instance (Typeable r, DecCBOR a) => DecCBORGroup (Mismatch r a) where + decCBORGroup = do + mismatchSupplied <- decCBOR + mismatchExpected <- decCBOR + pure Mismatch {..} + data Network = Testnet | Mainnet From 1ae24f00cd835725ba107b5e50dece08fc7c4bfd Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Fri, 18 Oct 2024 14:51:31 +0530 Subject: [PATCH 2/3] Use Mismatch for Conway pred-failures. Rules: - BBODY - GOV - GOVCERT - LEDGER - UTXO - UTXOW --- .../src/Cardano/Ledger/Conway/Rules/Bbody.hs | 73 ++++---- .../src/Cardano/Ledger/Conway/Rules/Gov.hs | 57 +++--- .../Cardano/Ledger/Conway/Rules/GovCert.hs | 90 ++++------ .../src/Cardano/Ledger/Conway/Rules/Ledger.hs | 64 ++++--- .../src/Cardano/Ledger/Conway/Rules/Utxo.hs | 130 ++++++++------ .../src/Cardano/Ledger/Conway/Rules/Utxow.hs | 46 +++-- .../impl/src/Cardano/Ledger/Conway/UTxO.hs | 3 - .../Cardano/Ledger/Conway/Imp/BbodySpec.hs | 10 +- .../Cardano/Ledger/Conway/Imp/GovCertSpec.hs | 17 +- .../Test/Cardano/Ledger/Conway/Imp/GovSpec.hs | 24 ++- .../Cardano/Ledger/Conway/Imp/LedgerSpec.hs | 7 +- .../Test/Cardano/Ledger/Generic/PrettyCore.hs | 170 ++++++++++-------- 12 files changed, 368 insertions(+), 323 deletions(-) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs index 95bb251da70..79b94652a0c 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs @@ -39,16 +39,9 @@ import Cardano.Ledger.Alonzo.TxWits (AlonzoEraTxWits (..)) import Cardano.Ledger.BHeaderView (BHeaderView (..)) import Cardano.Ledger.Babbage.Core (BabbageEraTxBody) import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure) -import Cardano.Ledger.BaseTypes (Mismatch (..), ShelleyBase) +import Cardano.Ledger.BaseTypes (Mismatch (..), Relation (..), ShelleyBase) import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) -import Cardano.Ledger.Binary.Coders ( - Decode (..), - Encode (..), - decode, - encode, - (!>), - (), ( Sum WrongBlockBodySizeBBODY 0 !> To x !> To y - InvalidBodyHashBBODY x y -> Sum (InvalidBodyHashBBODY @era) 1 !> To x !> To y + WrongBlockBodySizeBBODY mm -> Sum WrongBlockBodySizeBBODY 0 !> ToGroup mm + InvalidBodyHashBBODY mm -> Sum (InvalidBodyHashBBODY @era) 1 !> ToGroup mm LedgersFailure x -> Sum (LedgersFailure @era) 2 !> To x - TooManyExUnits x y -> Sum TooManyExUnits 3 !> To x !> To y - BodyRefScriptsSizeTooBig x y -> Sum BodyRefScriptsSizeTooBig 4 !> To x !> To y + TooManyExUnits mm -> Sum TooManyExUnits 3 !> ToGroup mm + BodyRefScriptsSizeTooBig mm -> Sum BodyRefScriptsSizeTooBig 4 !> ToGroup mm instance ( Era era @@ -157,11 +134,11 @@ instance DecCBOR (ConwayBbodyPredFailure era) where decCBOR = decode . Summands "ConwayBbodyPred" $ \case - 0 -> SumD WrongBlockBodySizeBBODY SumD InvalidBodyHashBBODY SumD WrongBlockBodySizeBBODY SumD InvalidBodyHashBBODY SumD LedgersFailure SumD TooManyExUnits SumD BodyRefScriptsSizeTooBig SumD TooManyExUnits SumD BodyRefScriptsSizeTooBig Invalid n type instance EraRuleFailure "BBODY" (ConwayEra c) = ConwayBbodyPredFailure (ConwayEra c) @@ -238,11 +215,11 @@ shelleyToConwayBbodyPredFailure :: ShelleyBbodyPredFailure era -> ConwayBbodyPredFailure era shelleyToConwayBbodyPredFailure - (Shelley.WrongBlockBodySizeBBODY (Mismatch supplied expected)) = - WrongBlockBodySizeBBODY supplied expected + (Shelley.WrongBlockBodySizeBBODY m) = + WrongBlockBodySizeBBODY m shelleyToConwayBbodyPredFailure - (Shelley.InvalidBodyHashBBODY (Mismatch supplied expected)) = - InvalidBodyHashBBODY supplied expected + (Shelley.InvalidBodyHashBBODY m) = + InvalidBodyHashBBODY m shelleyToConwayBbodyPredFailure (Shelley.LedgersFailure x) = LedgersFailure x alonzoToConwayBbodyPredFailure :: @@ -250,7 +227,12 @@ alonzoToConwayBbodyPredFailure :: AlonzoBbodyPredFailure era -> ConwayBbodyPredFailure era alonzoToConwayBbodyPredFailure (ShelleyInAlonzoBbodyPredFailure x) = shelleyToConwayBbodyPredFailure x -alonzoToConwayBbodyPredFailure (Alonzo.TooManyExUnits x y) = TooManyExUnits x y +alonzoToConwayBbodyPredFailure (Alonzo.TooManyExUnits x y) = + TooManyExUnits $ + Mismatch + { mismatchSupplied = x + , mismatchExpected = y + } instance ( DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody) @@ -318,7 +300,12 @@ conwayBbodyTransition = do totalRefScriptSize <= maxRefScriptSizePerBlock ?! injectFailure - (BodyRefScriptsSizeTooBig totalRefScriptSize maxRefScriptSizePerBlock) + ( BodyRefScriptsSizeTooBig $ + Mismatch + { mismatchSupplied = totalRefScriptSize + , mismatchExpected = maxRefScriptSizePerBlock + } + ) pure state instance diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs index 316bf7a8fa0..6a1aa1a06a0 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs @@ -32,8 +32,10 @@ import Cardano.Ledger.Address (RewardAccount, raCredential, raNetwork) import Cardano.Ledger.BaseTypes ( EpochInterval (..), EpochNo (..), + Mismatch (..), Network, ProtVer, + Relation (..), ShelleyBase, StrictMaybe (SJust), addEpochInterval, @@ -94,9 +96,7 @@ import Cardano.Ledger.Conway.Governance ( toPrevGovActionIds, ) import Cardano.Ledger.Conway.Governance.Proposals (mapProposals) -import Cardano.Ledger.Conway.PParams ( - ConwayEraPParams (..), - ) +import Cardano.Ledger.Conway.PParams (ConwayEraPParams (..)) import Cardano.Ledger.Conway.TxCert import Cardano.Ledger.Core import Cardano.Ledger.Credential (Credential) @@ -166,11 +166,7 @@ data ConwayGovPredFailure era | MalformedProposal (GovAction era) | ProposalProcedureNetworkIdMismatch (RewardAccount (EraCrypto era)) Network | TreasuryWithdrawalsNetworkIdMismatch (Set.Set (RewardAccount (EraCrypto era))) Network - | ProposalDepositIncorrect - -- | Submitted deposit - Coin - -- | Expected deposit taken from `PParams` - Coin + | ProposalDepositIncorrect !(Mismatch 'RelEQ Coin) | -- | Some governance actions are not allowed to be voted on by certain types of -- Voters. This failure lists all governance action ids with their respective voters -- that are not allowed to vote on those governance actions. @@ -186,10 +182,8 @@ data ConwayGovPredFailure era | ProposalCantFollow -- | The PrevGovActionId of the HardForkInitiation that fails (StrictMaybe (GovPurposeId 'HardForkPurpose era)) - -- | Its protocol version - ProtVer - -- | The ProtVer of the Previous GovAction pointed to by the one proposed - ProtVer + -- | Its protocol version and the protocal version of the previous gov-action pointed to by the proposal + !(Mismatch 'RelGT ProtVer) | InvalidPolicyHash -- | The policy script hash in the proposal (StrictMaybe (ScriptHash (EraCrypto era))) @@ -224,13 +218,13 @@ instance EraPParams era => DecCBOR (ConwayGovPredFailure era) where 1 -> SumD MalformedProposal SumD ProposalProcedureNetworkIdMismatch SumD TreasuryWithdrawalsNetworkIdMismatch SumD ProposalDepositIncorrect SumD ProposalDepositIncorrect SumD DisallowedVoters SumD ConflictingCommitteeUpdate SumD ExpirationEpochTooSmall SumD InvalidPrevGovActionId SumD VotingOnExpiredGovAction SumD ProposalCantFollow SumD ProposalCantFollow SumD InvalidPolicyHash SumD DisallowedProposalDuringBootstrap SumD DisallowedVotesDuringBootstrap DecCBOR (ConwayGovPredFailure era) where instance EraPParams era => EncCBOR (ConwayGovPredFailure era) where encCBOR = encode . \case - GovActionsDoNotExist gid -> Sum GovActionsDoNotExist 0 !> To gid - MalformedProposal ga -> Sum MalformedProposal 1 !> To ga + GovActionsDoNotExist gid -> + Sum GovActionsDoNotExist 0 !> To gid + MalformedProposal ga -> + Sum MalformedProposal 1 !> To ga ProposalProcedureNetworkIdMismatch acnt nid -> Sum ProposalProcedureNetworkIdMismatch 2 !> To acnt !> To nid TreasuryWithdrawalsNetworkIdMismatch acnts nid -> Sum TreasuryWithdrawalsNetworkIdMismatch 3 !> To acnts !> To nid - ProposalDepositIncorrect submitted expected -> - Sum ProposalDepositIncorrect 4 !> To submitted !> To expected + ProposalDepositIncorrect mm -> + Sum ProposalDepositIncorrect 4 !> ToGroup mm DisallowedVoters votes -> Sum DisallowedVoters 5 !> To votes ConflictingCommitteeUpdate members -> @@ -261,15 +257,10 @@ instance EraPParams era => EncCBOR (ConwayGovPredFailure era) where Sum InvalidPrevGovActionId 8 !> To proposal VotingOnExpiredGovAction ga -> Sum VotingOnExpiredGovAction 9 !> To ga - ProposalCantFollow prevgaid pv1 pv2 -> - Sum ProposalCantFollow 10 - !> To prevgaid - !> To pv1 - !> To pv2 + ProposalCantFollow prevgaid mm -> + Sum ProposalCantFollow 10 !> To prevgaid !> ToGroup mm InvalidPolicyHash got expected -> - Sum InvalidPolicyHash 11 - !> To got - !> To expected + Sum InvalidPolicyHash 11 !> To got !> To expected DisallowedProposalDuringBootstrap proposal -> Sum DisallowedProposalDuringBootstrap 12 !> To proposal DisallowedVotesDuringBootstrap votes -> @@ -462,7 +453,13 @@ govTransition = do preceedingHardFork @era pProcGovAction pp prevGovActionIds st if pvCanFollow prevProtVer newProtVer then Nothing - else Just $ ProposalCantFollow @era prevGaid newProtVer prevProtVer + else + Just $ + ProposalCantFollow @era prevGaid $ + Mismatch + { mismatchSupplied = newProtVer + , mismatchExpected = prevProtVer + } failOnJust badHardFork id -- PParamsUpdate well-formedness check @@ -485,7 +482,11 @@ govTransition = do let expectedDep = pp ^. ppGovActionDepositL in pProcDeposit == expectedDep - ?! ProposalDepositIncorrect pProcDeposit expectedDep + ?! ProposalDepositIncorrect + Mismatch + { mismatchSupplied = pProcDeposit + , mismatchExpected = expectedDep + } -- Return address network id check raNetwork pProcReturnAddr diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/GovCert.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/GovCert.hs index 5b6dd84b755..cc8d1dfa669 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/GovCert.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/GovCert.hs @@ -25,12 +25,17 @@ where import Cardano.Ledger.BaseTypes ( EpochNo, + Mismatch (..), + Relation (..), ShelleyBase, StrictMaybe, addEpochInterval, strictMaybe, ) -import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), encodeListLen) +import Cardano.Ledger.Binary ( + DecCBOR (..), + EncCBOR (..), + ) import Cardano.Ledger.Binary.Coders import Cardano.Ledger.CertState ( CertState (..), @@ -80,7 +85,6 @@ import qualified Data.Map.Strict as Map import Data.Maybe (isJust) import Data.Typeable (Typeable) import Data.Void (Void) -import Data.Word (Word8) import GHC.Generics (Generic) import Lens.Micro ((&), (.~), (^.)) import NoThunks.Class (NoThunks (..)) @@ -113,9 +117,9 @@ deriving instance EraPParams era => Eq (ConwayGovCertEnv era) data ConwayGovCertPredFailure era = ConwayDRepAlreadyRegistered !(Credential 'DRepRole (EraCrypto era)) | ConwayDRepNotRegistered !(Credential 'DRepRole (EraCrypto era)) - | ConwayDRepIncorrectDeposit !Coin !Coin -- The first is the given and the second is the expected deposit + | ConwayDRepIncorrectDeposit !(Mismatch 'RelEQ Coin) | ConwayCommitteeHasPreviouslyResigned !(Credential 'ColdCommitteeRole (EraCrypto era)) - | ConwayDRepIncorrectRefund !Coin !Coin -- The first is the given and the second is the expected refund + | ConwayDRepIncorrectRefund !(Mismatch 'RelEQ Coin) | -- | Predicate failure whenever an update to an unknown committee member is -- attempted. Current Constitutional Committee and all available proposals will be -- searched before reporting this predicate failure. @@ -133,64 +137,30 @@ instance NoThunks (ConwayGovCertPredFailure era) instance NFData (ConwayGovCertPredFailure era) instance - (Typeable era, Crypto (EraCrypto era)) => + Era era => EncCBOR (ConwayGovCertPredFailure era) where - encCBOR = \case - ConwayDRepAlreadyRegistered cred -> - encodeListLen 2 - <> encCBOR (0 :: Word8) - <> encCBOR cred - ConwayDRepNotRegistered cred -> - encodeListLen 2 - <> encCBOR (1 :: Word8) - <> encCBOR cred - ConwayDRepIncorrectDeposit deposit expectedDeposit -> - encodeListLen 3 - <> encCBOR (2 :: Word8) - <> encCBOR deposit - <> encCBOR expectedDeposit - ConwayCommitteeHasPreviouslyResigned coldCred -> - encodeListLen 2 - <> encCBOR (3 :: Word8) - <> encCBOR coldCred - ConwayDRepIncorrectRefund refund expectedRefund -> - encodeListLen 3 - <> encCBOR (4 :: Word8) - <> encCBOR refund - <> encCBOR expectedRefund - ConwayCommitteeIsUnknown coldCred -> - encodeListLen 2 - <> encCBOR (5 :: Word8) - <> encCBOR coldCred + encCBOR = + encode @_ @(ConwayGovCertPredFailure era) . \case + ConwayDRepAlreadyRegistered cred -> Sum ConwayDRepAlreadyRegistered 0 !> To cred + ConwayDRepNotRegistered cred -> Sum ConwayDRepNotRegistered 1 !> To cred + ConwayDRepIncorrectDeposit mm -> Sum ConwayDRepIncorrectDeposit 2 !> ToGroup mm + ConwayCommitteeHasPreviouslyResigned coldCred -> Sum ConwayCommitteeHasPreviouslyResigned 3 !> To coldCred + ConwayDRepIncorrectRefund mm -> Sum ConwayDRepIncorrectRefund 4 !> ToGroup mm + ConwayCommitteeIsUnknown coldCred -> Sum ConwayCommitteeIsUnknown 5 !> To coldCred instance (Typeable era, Crypto (EraCrypto era)) => DecCBOR (ConwayGovCertPredFailure era) where - decCBOR = decodeRecordSum "ConwayGovCertPredFailure" $ - \case - 0 -> do - cred <- decCBOR - pure (2, ConwayDRepAlreadyRegistered cred) - 1 -> do - cred <- decCBOR - pure (2, ConwayDRepNotRegistered cred) - 2 -> do - deposit <- decCBOR - expectedDeposit <- decCBOR - pure (3, ConwayDRepIncorrectDeposit deposit expectedDeposit) - 3 -> do - coldCred <- decCBOR - pure (2, ConwayCommitteeHasPreviouslyResigned coldCred) - 4 -> do - refund <- decCBOR - expectedRefund <- decCBOR - pure (3, ConwayDRepIncorrectRefund refund expectedRefund) - 5 -> do - coldCred <- decCBOR - pure (2, ConwayCommitteeIsUnknown coldCred) - k -> invalidKey k + decCBOR = decode . Summands "ConwayGovCertPredFailure" $ \case + 0 -> SumD ConwayDRepAlreadyRegistered SumD ConwayDRepNotRegistered SumD ConwayDRepIncorrectDeposit SumD ConwayCommitteeHasPreviouslyResigned SumD ConwayDRepIncorrectRefund SumD ConwayCommitteeIsUnknown Invalid n instance ( ConwayEraPParams era @@ -252,7 +222,13 @@ conwayGovCertTransition = do case cert of ConwayRegDRep cred deposit mAnchor -> do Map.notMember cred vsDReps ?! ConwayDRepAlreadyRegistered cred - deposit == ppDRepDeposit ?! ConwayDRepIncorrectDeposit deposit ppDRepDeposit + deposit + == ppDRepDeposit + ?! ConwayDRepIncorrectDeposit + Mismatch + { mismatchSupplied = deposit + , mismatchExpected = ppDRepDeposit + } let drepState = DRepState { drepExpiry = @@ -279,7 +255,7 @@ conwayGovCertTransition = do guard (refund /= paidDeposit) pure paidDeposit isJust mDRepState ?! ConwayDRepNotRegistered cred - failOnJust drepRefundMismatch $ ConwayDRepIncorrectRefund refund + failOnJust drepRefundMismatch $ ConwayDRepIncorrectRefund . Mismatch refund let certState' = certState {certVState = vState {vsDReps = Map.delete cred vsDReps}} diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs index a254316d5ef..6c5dfb5ec14 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs @@ -39,7 +39,15 @@ import Cardano.Ledger.Babbage.Rules ( ) import Cardano.Ledger.Babbage.Tx (IsValid (..)) import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..)) -import Cardano.Ledger.BaseTypes (ShelleyBase, StrictMaybe (..), epochInfoPure) +import Cardano.Ledger.BaseTypes ( + Mismatch (..), + Relation (..), + ShelleyBase, + StrictMaybe (..), + epochInfoPure, + swapMismatch, + unswapMismatch, + ) import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) import Cardano.Ledger.Binary.Coders import Cardano.Ledger.Coin (Coin) @@ -140,16 +148,8 @@ data ConwayLedgerPredFailure era | ConwayCertsFailure (PredicateFailure (EraRule "CERTS" era)) | ConwayGovFailure (PredicateFailure (EraRule "GOV" era)) | ConwayWdrlNotDelegatedToDRep (NonEmpty (KeyHash 'Staking (EraCrypto era))) - | ConwayTreasuryValueMismatch - -- | Actual - Coin - -- | Submitted in transaction - Coin - | ConwayTxRefScriptsSizeTooBig - -- | Computed sum of reference script size - Int - -- | Maximum allowed total reference script size - Int + | ConwayTreasuryValueMismatch !(Mismatch 'RelEQ Coin) -- The serialisation order is in reverse + | ConwayTxRefScriptsSizeTooBig !(Mismatch 'RelLTEQ Int) | ConwayMempoolFailure Text deriving (Generic) @@ -264,11 +264,10 @@ instance ConwayUtxowFailure x -> Sum (ConwayUtxowFailure @era) 1 !> To x ConwayCertsFailure x -> Sum (ConwayCertsFailure @era) 2 !> To x ConwayGovFailure x -> Sum (ConwayGovFailure @era) 3 !> To x - ConwayWdrlNotDelegatedToDRep x -> - Sum (ConwayWdrlNotDelegatedToDRep @era) 4 !> To x - ConwayTreasuryValueMismatch actual submitted -> - Sum (ConwayTreasuryValueMismatch @era) 5 !> To actual !> To submitted - ConwayTxRefScriptsSizeTooBig x y -> Sum ConwayTxRefScriptsSizeTooBig 6 !> To x !> To y + ConwayWdrlNotDelegatedToDRep x -> Sum (ConwayWdrlNotDelegatedToDRep @era) 4 !> To x + ConwayTreasuryValueMismatch mm -> + Sum (ConwayTreasuryValueMismatch @era . unswapMismatch) 5 !> ToGroup (swapMismatch mm) + ConwayTxRefScriptsSizeTooBig mm -> Sum ConwayTxRefScriptsSizeTooBig 6 !> ToGroup mm ConwayMempoolFailure t -> Sum ConwayMempoolFailure 7 !> To t instance @@ -279,16 +278,15 @@ instance ) => DecCBOR (ConwayLedgerPredFailure era) where - decCBOR = - decode $ Summands "ConwayLedgerPredFailure" $ \case - 1 -> SumD ConwayUtxowFailure SumD ConwayCertsFailure SumD ConwayGovFailure SumD ConwayWdrlNotDelegatedToDRep SumD ConwayTreasuryValueMismatch SumD ConwayTxRefScriptsSizeTooBig SumD ConwayMempoolFailure Invalid n + decCBOR = decode . Summands "ConwayLedgerPredFailure" $ \case + 1 -> SumD ConwayUtxowFailure SumD ConwayCertsFailure SumD ConwayGovFailure SumD ConwayWdrlNotDelegatedToDRep SumD ConwayTreasuryValueMismatch FromGroup) + 6 -> SumD ConwayTxRefScriptsSizeTooBig SumD ConwayMempoolFailure Invalid n data ConwayLedgerEvent era = UtxowEvent (Event (EraRule "UTXOW" era)) @@ -406,12 +404,22 @@ ledgerTransition = do SJust submittedTreasuryValue -> submittedTreasuryValue == actualTreasuryValue - ?! ConwayTreasuryValueMismatch actualTreasuryValue submittedTreasuryValue + ?! ConwayTreasuryValueMismatch + ( Mismatch + { mismatchSupplied = submittedTreasuryValue + , mismatchExpected = actualTreasuryValue + } + ) let totalRefScriptSize = txNonDistinctRefScriptsSize (utxoState ^. utxosUtxoL) tx totalRefScriptSize <= maxRefScriptSizePerTx - ?! ConwayTxRefScriptsSizeTooBig totalRefScriptSize maxRefScriptSizePerTx + ?! ConwayTxRefScriptsSizeTooBig + ( Mismatch + { mismatchSupplied = totalRefScriptSize + , mismatchExpected = maxRefScriptSizePerTx + } + ) let govState = utxoState ^. utxosGovStateL committee = govState ^. committeeGovStateL diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxo.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxo.hs index beb14478b13..0606f007318 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxo.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxo.hs @@ -39,7 +39,15 @@ import qualified Cardano.Ledger.Babbage.Rules as Babbage ( BabbageUtxoPredFailure (..), utxoTransition, ) -import Cardano.Ledger.BaseTypes (Network, ShelleyBase, SlotNo) +import Cardano.Ledger.BaseTypes ( + Mismatch (..), + Network, + Relation (..), + ShelleyBase, + SlotNo, + swapMismatch, + unswapMismatch, + ) import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) import Cardano.Ledger.Binary.Coders ( Decode (..), @@ -62,10 +70,7 @@ import qualified Cardano.Ledger.Shelley.Rules as Shelley (UtxoEnv) import Cardano.Ledger.TxIn (TxIn) import Cardano.Ledger.UTxO (EraUTxO, UTxO (..)) import Control.DeepSeq (NFData) -import Control.State.Transition.Extended ( - Embed (..), - STS (..), - ) +import Control.State.Transition.Extended (Embed (..), STS (..)) import Data.List.NonEmpty (NonEmpty) import Data.Set (Set) import GHC.Generics (Generic) @@ -87,21 +92,12 @@ data ConwayUtxoPredFailure era -- | current slot !SlotNo | MaxTxSizeUTxO - -- | the actual transaction size - !Integer - -- | the max transaction size - !Integer + !(Mismatch 'RelLTEQ Integer) | InputSetEmptyUTxO | FeeTooSmallUTxO - -- | the minimum fee for this transaction - !Coin - -- | the fee supplied in this transaction - !Coin + !(Mismatch 'RelGTEQ Coin) -- The values are serialised in reverse order | ValueNotConservedUTxO - -- | the Coin consumed by this transaction - !(Value era) - -- | the Coin produced by this transaction - !(Value era) + !(Mismatch 'RelEQ (Value era)) -- Serialise consumed first, then produced | -- | the set of addresses with incorrect network IDs WrongNetwork -- | the expected network id @@ -131,27 +127,18 @@ data ConwayUtxoPredFailure era ScriptsNotPaidUTxO !(UTxO era) | ExUnitsTooBigUTxO - -- | Max EXUnits from the protocol parameters - !ExUnits - -- | EXUnits supplied - !ExUnits + !(Mismatch 'RelLTEQ ExUnits) -- The values are serialised in reverse order | -- | The inputs marked for use as fees contain non-ADA tokens CollateralContainsNonADA !(Value era) | -- | Wrong Network ID in body WrongNetworkInTxBody - -- | Actual Network ID - !Network - -- | Network ID in transaction body - !Network + !(Mismatch 'RelEQ Network) -- The values are serialised in reverse order | -- | slot number outside consensus forecast range OutsideForecast !SlotNo | -- | There are too many collateral inputs TooManyCollateralInputs - -- | Max allowed collateral inputs - !Natural - -- | Number of collateral inputs - !Natural + !(Mismatch 'RelLTEQ Natural) -- The values are serialised in reverse order | NoCollateralInputs | -- | The collateral is not equivalent to the total collateral asserted by the transaction IncorrectTotalCollateralField @@ -294,10 +281,10 @@ instance UtxosFailure a -> Sum (UtxosFailure @era) 0 !> To a BadInputsUTxO ins -> Sum (BadInputsUTxO @era) 1 !> To ins OutsideValidityIntervalUTxO a b -> Sum OutsideValidityIntervalUTxO 2 !> To a !> To b - MaxTxSizeUTxO a b -> Sum MaxTxSizeUTxO 3 !> To a !> To b + MaxTxSizeUTxO mm -> Sum MaxTxSizeUTxO 3 !> ToGroup mm InputSetEmptyUTxO -> Sum InputSetEmptyUTxO 4 - FeeTooSmallUTxO a b -> Sum FeeTooSmallUTxO 5 !> To a !> To b - ValueNotConservedUTxO a b -> Sum (ValueNotConservedUTxO @era) 6 !> To a !> To b + FeeTooSmallUTxO mm -> Sum (FeeTooSmallUTxO . unswapMismatch) 5 !> ToGroup (swapMismatch mm) + ValueNotConservedUTxO mm -> Sum (ValueNotConservedUTxO @era) 6 !> ToGroup mm WrongNetwork right wrongs -> Sum (WrongNetwork @era) 7 !> To right !> To wrongs WrongNetworkWithdrawal right wrongs -> Sum (WrongNetworkWithdrawal @era) 8 !> To right !> To wrongs OutputTooSmallUTxO outs -> Sum (OutputTooSmallUTxO @era) 9 !> To outs @@ -305,11 +292,11 @@ instance OutputTooBigUTxO outs -> Sum (OutputTooBigUTxO @era) 11 !> To outs InsufficientCollateral a b -> Sum InsufficientCollateral 12 !> To a !> To b ScriptsNotPaidUTxO a -> Sum ScriptsNotPaidUTxO 13 !> To a - ExUnitsTooBigUTxO a b -> Sum ExUnitsTooBigUTxO 14 !> To a !> To b + ExUnitsTooBigUTxO mm -> Sum (ExUnitsTooBigUTxO . unswapMismatch) 14 !> ToGroup (swapMismatch mm) CollateralContainsNonADA a -> Sum CollateralContainsNonADA 15 !> To a - WrongNetworkInTxBody a b -> Sum WrongNetworkInTxBody 16 !> To a !> To b + WrongNetworkInTxBody mm -> Sum (WrongNetworkInTxBody . unswapMismatch) 16 !> ToGroup (swapMismatch mm) OutsideForecast a -> Sum OutsideForecast 17 !> To a - TooManyCollateralInputs a b -> Sum TooManyCollateralInputs 18 !> To a !> To b + TooManyCollateralInputs mm -> Sum (TooManyCollateralInputs . unswapMismatch) 18 !> ToGroup (swapMismatch mm) NoCollateralInputs -> Sum NoCollateralInputs 19 IncorrectTotalCollateralField c1 c2 -> Sum IncorrectTotalCollateralField 20 !> To c1 !> To c2 BabbageOutputTooSmallUTxO x -> Sum BabbageOutputTooSmallUTxO 21 !> To x @@ -318,19 +305,20 @@ instance instance ( Era era , DecCBOR (TxOut era) + , EncCBOR (Value era) , DecCBOR (Value era) , DecCBOR (PredicateFailure (EraRule "UTXOS" era)) ) => DecCBOR (ConwayUtxoPredFailure era) where - decCBOR = decode . Summands "ConwayUtxoPred" $ \case + decCBOR = decode . Summands "ConwayUtxoPredFailure" $ \case 0 -> SumD UtxosFailure SumD BadInputsUTxO SumD OutsideValidityIntervalUTxO SumD MaxTxSizeUTxO SumD MaxTxSizeUTxO SumD InputSetEmptyUTxO - 5 -> SumD FeeTooSmallUTxO SumD ValueNotConservedUTxO SumD FeeTooSmallUTxO FromGroup) + 6 -> SumD ValueNotConservedUTxO SumD WrongNetwork SumD WrongNetworkWithdrawal SumD OutputTooSmallUTxO SumD OutputTooBigUTxO SumD InsufficientCollateral SumD ScriptsNotPaidUTxO decCBOR) - 14 -> SumD ExUnitsTooBigUTxO SumD ExUnitsTooBigUTxO FromGroup) 15 -> SumD CollateralContainsNonADA SumD WrongNetworkInTxBody SumD WrongNetworkInTxBody FromGroup) 17 -> SumD OutsideForecast SumD TooManyCollateralInputs SumD TooManyCollateralInputs FromGroup) 19 -> SumD NoCollateralInputs 20 -> SumD IncorrectTotalCollateralField SumD BabbageOutputTooSmallUTxO BadInputsUTxO x Alonzo.OutsideValidityIntervalUTxO vi slotNo -> OutsideValidityIntervalUTxO vi slotNo - Alonzo.MaxTxSizeUTxO x y -> MaxTxSizeUTxO x y + Alonzo.MaxTxSizeUTxO x y -> MaxTxSizeUTxO Mismatch {mismatchSupplied = x, mismatchExpected = y} Alonzo.InputSetEmptyUTxO -> InputSetEmptyUTxO - Alonzo.FeeTooSmallUTxO c1 c2 -> FeeTooSmallUTxO c1 c2 - Alonzo.ValueNotConservedUTxO vc vp -> ValueNotConservedUTxO vc vp + Alonzo.FeeTooSmallUTxO ppMinFee supplied -> + FeeTooSmallUTxO + Mismatch + { mismatchSupplied = supplied + , mismatchExpected = ppMinFee + } + Alonzo.ValueNotConservedUTxO consumed produced -> + ValueNotConservedUTxO + Mismatch + { mismatchSupplied = consumed + , mismatchExpected = produced + } Alonzo.WrongNetwork x y -> WrongNetwork x y Alonzo.WrongNetworkWithdrawal x y -> WrongNetworkWithdrawal x y Alonzo.OutputTooSmallUTxO x -> OutputTooSmallUTxO x @@ -392,11 +390,26 @@ alonzoToConwayUtxoPredFailure = \case OutputTooBigUTxO $ map toRestricted xs Alonzo.InsufficientCollateral c1 c2 -> InsufficientCollateral c1 c2 Alonzo.ScriptsNotPaidUTxO u -> ScriptsNotPaidUTxO u - Alonzo.ExUnitsTooBigUTxO e1 e2 -> ExUnitsTooBigUTxO e1 e2 + Alonzo.ExUnitsTooBigUTxO e1 e2 -> + ExUnitsTooBigUTxO + Mismatch + { mismatchSupplied = e2 + , mismatchExpected = e1 + } Alonzo.CollateralContainsNonADA v -> CollateralContainsNonADA v - Alonzo.WrongNetworkInTxBody nid nidb -> WrongNetworkInTxBody nid nidb + Alonzo.WrongNetworkInTxBody nid nidInTx -> + WrongNetworkInTxBody + Mismatch + { mismatchSupplied = nidInTx + , mismatchExpected = nid + } Alonzo.OutsideForecast sno -> OutsideForecast sno - Alonzo.TooManyCollateralInputs n1 n2 -> TooManyCollateralInputs n1 n2 + Alonzo.TooManyCollateralInputs maxI suppliedI -> + TooManyCollateralInputs + Mismatch + { mismatchSupplied = suppliedI + , mismatchExpected = maxI + } Alonzo.NoCollateralInputs -> NoCollateralInputs allegraToConwayUtxoPredFailure :: @@ -407,10 +420,25 @@ allegraToConwayUtxoPredFailure :: allegraToConwayUtxoPredFailure = \case Allegra.BadInputsUTxO x -> BadInputsUTxO x Allegra.OutsideValidityIntervalUTxO vi slotNo -> OutsideValidityIntervalUTxO vi slotNo - Allegra.MaxTxSizeUTxO x y -> MaxTxSizeUTxO x y + Allegra.MaxTxSizeUTxO supplied expected -> + MaxTxSizeUTxO + Mismatch + { mismatchSupplied = supplied + , mismatchExpected = expected + } Allegra.InputSetEmptyUTxO -> InputSetEmptyUTxO - Allegra.FeeTooSmallUTxO c1 c2 -> FeeTooSmallUTxO c1 c2 - Allegra.ValueNotConservedUTxO vc vp -> ValueNotConservedUTxO vc vp + Allegra.FeeTooSmallUTxO minFee suppliedFee -> + FeeTooSmallUTxO + Mismatch + { mismatchSupplied = suppliedFee + , mismatchExpected = minFee + } + Allegra.ValueNotConservedUTxO consumed produced -> + ValueNotConservedUTxO + Mismatch + { mismatchSupplied = consumed + , mismatchExpected = produced + } Allegra.WrongNetwork x y -> WrongNetwork x y Allegra.WrongNetworkWithdrawal x y -> WrongNetworkWithdrawal x y Allegra.OutputTooSmallUTxO x -> OutputTooSmallUTxO x diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxow.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxow.hs index d4d75415245..84a84e51c9b 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxow.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxow.hs @@ -44,16 +44,9 @@ import Cardano.Ledger.Babbage.Rules ( babbageUtxowTransition, ) import qualified Cardano.Ledger.Babbage.Rules as Babbage (BabbageUtxowPredFailure (..)) -import Cardano.Ledger.BaseTypes (Mismatch (..), ShelleyBase) +import Cardano.Ledger.BaseTypes (Mismatch (..), Relation (..), ShelleyBase) import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) -import Cardano.Ledger.Binary.Coders ( - Decode (..), - Encode (..), - decode, - encode, - (!>), - (), ( Sum ScriptWitnessNotValidatingUTXOW 4 !> To xs MissingTxBodyMetadataHash xs -> Sum MissingTxBodyMetadataHash 5 !> To xs MissingTxMetadata xs -> Sum MissingTxMetadata 6 !> To xs - ConflictingMetadataHash a b -> Sum ConflictingMetadataHash 7 !> To a !> To b + ConflictingMetadataHash mm -> Sum ConflictingMetadataHash 7 !> ToGroup mm InvalidMetadata -> Sum InvalidMetadata 8 ExtraneousScriptWitnessesUTXOW xs -> Sum ExtraneousScriptWitnessesUTXOW 9 !> To xs MissingRedeemers x -> Sum MissingRedeemers 10 !> To x MissingRequiredDatums x y -> Sum MissingRequiredDatums 11 !> To x !> To y NotAllowedSupplementalDatums x y -> Sum NotAllowedSupplementalDatums 12 !> To x !> To y - PPViewHashesDontMatch x y -> Sum PPViewHashesDontMatch 13 !> To x !> To y + PPViewHashesDontMatch mm -> Sum PPViewHashesDontMatch 13 !> ToGroup mm UnspendableUTxONoDatumHash x -> Sum UnspendableUTxONoDatumHash 14 !> To x ExtraRedeemers x -> Sum ExtraRedeemers 15 !> To x MalformedScriptWitnesses x -> Sum MalformedScriptWitnesses 16 !> To x @@ -305,13 +297,13 @@ instance 4 -> SumD ScriptWitnessNotValidatingUTXOW SumD MissingTxBodyMetadataHash SumD MissingTxMetadata SumD ConflictingMetadataHash SumD ConflictingMetadataHash SumD InvalidMetadata 9 -> SumD ExtraneousScriptWitnessesUTXOW SumD MissingRedeemers SumD MissingRequiredDatums SumD NotAllowedSupplementalDatums SumD PPViewHashesDontMatch SumD PPViewHashesDontMatch SumD UnspendableUTxONoDatumHash SumD ExtraRedeemers SumD MalformedScriptWitnesses MissingRedeemers rs Alonzo.MissingRequiredDatums mds rds -> MissingRequiredDatums mds rds Alonzo.NotAllowedSupplementalDatums uds ads -> NotAllowedSupplementalDatums uds ads - Alonzo.PPViewHashesDontMatch a b -> PPViewHashesDontMatch a b + Alonzo.PPViewHashesDontMatch a b -> + PPViewHashesDontMatch + Mismatch + { mismatchSupplied = a + , mismatchExpected = b + } Alonzo.MissingRequiredSigners _xs -> error "Impossible case. It will be removed once we are in Conway. See #3972" Alonzo.UnspendableUTxONoDatumHash ins -> UnspendableUTxONoDatumHash ins @@ -357,7 +354,6 @@ shelleyToConwayUtxowPredFailure = \case error "Impossible: MIR has been removed in Conway" Shelley.MissingTxBodyMetadataHash x -> MissingTxBodyMetadataHash x Shelley.MissingTxMetadata x -> MissingTxMetadata x - Shelley.ConflictingMetadataHash (Mismatch supplied expected) -> - ConflictingMetadataHash supplied expected + Shelley.ConflictingMetadataHash mm -> ConflictingMetadataHash mm Shelley.InvalidMetadata -> InvalidMetadata Shelley.ExtraneousScriptWitnessesUTXOW xs -> ExtraneousScriptWitnessesUTXOW xs diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/UTxO.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/UTxO.hs index 5f9a14ef8d0..fbc492adb87 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/UTxO.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/UTxO.hs @@ -1,12 +1,9 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs index 9305bf3c739..8872e927567 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/BbodySpec.hs @@ -13,7 +13,7 @@ module Test.Cardano.Ledger.Conway.Imp.BbodySpec ( import Cardano.Ledger.BHeaderView (BHeaderView (..)) import Cardano.Ledger.Babbage.Core -import Cardano.Ledger.BaseTypes (BlocksMade (..), ProtVer (..)) +import Cardano.Ledger.BaseTypes (BlocksMade (..), Mismatch (..), ProtVer (..)) import Cardano.Ledger.Block import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Conway.Rules ( @@ -97,9 +97,11 @@ spec = describe "BBODY" $ do predFailures `shouldBe` NE.fromList [ injectFailure - ( BodyRefScriptsSizeTooBig - expectedTotalRefScriptSize - maxRefScriptSizePerBlock + ( BodyRefScriptsSizeTooBig $ + Mismatch + { mismatchSupplied = expectedTotalRefScriptSize + , mismatchExpected = maxRefScriptSizePerBlock + } ) ] where diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovCertSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovCertSpec.hs index 25a9a18b2c9..90a0232d35d 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovCertSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovCertSpec.hs @@ -2,19 +2,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} module Test.Cardano.Ledger.Conway.Imp.GovCertSpec ( spec, relevantDuringBootstrapSpec, ) where -import Cardano.Ledger.BaseTypes (EpochInterval (..)) +import Cardano.Ledger.BaseTypes (EpochInterval (..), Mismatch (..)) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Governance (GovPurposeId (..), Voter (..)) @@ -162,7 +159,11 @@ relevantDuringBootstrapSpec = do (RegDRepTxCert (KeyHashObj khDRep) providedDRepDeposit SNothing) ) ( pure . injectFailure $ - ConwayDRepIncorrectDeposit providedDRepDeposit expectedDRepDeposit + ConwayDRepIncorrectDeposit $ + Mismatch + { mismatchSupplied = providedDRepDeposit + , mismatchExpected = expectedDRepDeposit + } ) it "invalid refund provided with DRep deregistration cert" $ do modifyPParams $ ppDRepDepositL .~ Coin 100 @@ -181,7 +182,11 @@ relevantDuringBootstrapSpec = do (UnRegDRepTxCert drepCred refund) ) ( pure . injectFailure $ - ConwayDRepIncorrectRefund refund drepDeposit + ConwayDRepIncorrectRefund $ + Mismatch + { mismatchSupplied = refund + , mismatchExpected = drepDeposit + } ) it "DRep already registered" $ do modifyPParams $ ppDRepDepositL .~ Coin 100 diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs index 45f651d54bd..7855cf14220 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs @@ -139,7 +139,13 @@ predicateFailuresSpec = , pProcAnchor = anchor } ) - [injectFailure $ ProposalDepositIncorrect (actionDeposit <-> Coin 1) actionDeposit] + [ injectFailure $ + ProposalDepositIncorrect $ + Mismatch + { mismatchSupplied = actionDeposit <-> Coin 1 + , mismatchExpected = actionDeposit + } + ] it "ConflictingCommitteeUpdate" $ do committeeC <- KeyHashObj <$> freshKeyHash curEpochNo <- getsNES nesELL @@ -1296,7 +1302,13 @@ firstHardForkCantFollow = do , pProcAnchor = def } ) - [injectFailure $ ProposalCantFollow SNothing protver2 protver0] + [ injectFailure $ + ProposalCantFollow SNothing $ + Mismatch + { mismatchSupplied = protver2 + , mismatchExpected = protver0 + } + ] -- | Tests a second hardfork in the Conway era where the PrevGovActionID is SJust secondHardForkFollows :: @@ -1341,7 +1353,13 @@ secondHardForkCantFollow = do , pProcAnchor = def } ) - [injectFailure $ ProposalCantFollow (SJust (GovPurposeId gaid1)) protver2 protver1] + [ injectFailure $ + ProposalCantFollow (SJust (GovPurposeId gaid1)) $ + Mismatch + { mismatchSupplied = protver2 + , mismatchExpected = protver1 + } + ] ccVoteOnConstitutionFailsWithMultipleVotes :: forall era. diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs index 4bc88d0a3a7..1ceda4123a9 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs @@ -67,7 +67,12 @@ spec = do tx = mkBasicTx (mkBasicTxBody & referenceInputsTxBodyL .~ Set.fromList txIns) submitFailingTx tx - [ injectFailure $ ConwayTxRefScriptsSizeTooBig (size * n) maxRefScriptSizePerTx + [ injectFailure $ + ConwayTxRefScriptsSizeTooBig $ + Mismatch + { mismatchSupplied = size * n + , mismatchExpected = maxRefScriptSizePerTx + } ] it "Withdraw from delegated and non-delegated staking key" $ do diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs index a53ccd5aeff..5dd9220d994 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs @@ -1301,19 +1301,28 @@ ppConwayUtxoPredFailure = \case [ ("provided interval", ppValidityInterval vi) , ("current slot", pcSlotNo slot) ] - ConwayRules.MaxTxSizeUTxO actual maxs -> - ppRecord "MaxTxSizeUTxO" [("Actual", ppInteger actual), ("max transaction size", ppInteger maxs)] + ConwayRules.MaxTxSizeUTxO mm@(Mismatch _ _) -> + let Mismatch {..} = mm + in ppRecord + "MaxTxSizeUTxO" + [ ("Actual", ppInteger mismatchSupplied) + , ("max transaction size", ppInteger mismatchExpected) + ] ConwayRules.InputSetEmptyUTxO -> ppString "InputSetEmptyUTxO" - ConwayRules.FeeTooSmallUTxO computed supplied -> - ppRecord - "FeeTooSmallUTxO" - [ ("min fee for this transaction", pcCoin computed) - , ("fee supplied by this transaction", pcCoin supplied) - ] - ConwayRules.ValueNotConservedUTxO consumed produced -> - ppRecord - "ValueNotConservedUTxO" - [("coin consumed", pcVal @era reify consumed), ("coin produced", pcVal @era reify produced)] + ConwayRules.FeeTooSmallUTxO mm@(Mismatch _ _) -> + let Mismatch {..} = mm + in ppRecord + "FeeTooSmallUTxO" + [ ("fee supplied by this transaction", pcCoin mismatchSupplied) + , ("min fee for this transaction", pcCoin mismatchExpected) + ] + ConwayRules.ValueNotConservedUTxO mm@(Mismatch _ _) -> + let Mismatch {mismatchSupplied = consumed, mismatchExpected = produced} = mm + in ppRecord + "ValueNotConservedUTxO" + [ ("coin consumed", pcVal @era reify consumed) + , ("coin produced", pcVal @era reify produced) + ] ConwayRules.WrongNetwork n add -> ppRecord "WrongNetwork" @@ -1352,26 +1361,29 @@ ppConwayUtxoPredFailure = \case , ("the required collateral for the given fee", pcCoin c2) ] ConwayRules.ScriptsNotPaidUTxO u -> ppSexp "ScriptsNotPaidUTxO" [pcUTxO reify u] - ConwayRules.ExUnitsTooBigUTxO e1 e2 -> - ppRecord - "ExUnitsTooBigUTxO" - [ ("Max EXUnits from the protocol parameters", pcExUnits e1) - , ("EXUnits supplied", pcExUnits e2) - ] + ConwayRules.ExUnitsTooBigUTxO mm@(Mismatch _ _) -> + let Mismatch {..} = mm + in ppRecord + "ExUnitsTooBigUTxO" + [ ("EXUnits supplied", pcExUnits mismatchSupplied) + , ("Max EXUnits from the protocol parameters", pcExUnits mismatchExpected) + ] ConwayRules.CollateralContainsNonADA v -> ppSexp "CollateralContainsNonADA" [pcVal (reify @era) v] - ConwayRules.WrongNetworkInTxBody n1 n2 -> - ppRecord - "WrongNetworkInTxBody" - [ ("Actual Network ID", ppNetwork n1) - , ("Network ID in transaction body", ppNetwork n2) - ] + ConwayRules.WrongNetworkInTxBody mm@(Mismatch _ _) -> + let Mismatch {..} = mm + in ppRecord + "WrongNetworkInTxBody" + [ ("Network ID in transaction body", ppNetwork mismatchSupplied) + , ("Actual Network ID", ppNetwork mismatchExpected) + ] ConwayRules.OutsideForecast slot -> ppRecord "OutsideForecast" [("slot number outside consensus forecast range", pcSlotNo slot)] - ConwayRules.TooManyCollateralInputs n1 n2 -> - ppRecord - "TooManyCollateralInputs" - [ ("Max allowed collateral inputs", ppNatural n1) - , ("Number of collateral inputs", ppNatural n2) - ] + ConwayRules.TooManyCollateralInputs mm@(Mismatch _ _) -> + let Mismatch {..} = mm + in ppRecord + "TooManyCollateralInputs" + [ ("Number of collateral inputs", ppNatural mismatchSupplied) + , ("Max allowed collateral inputs", ppNatural mismatchExpected) + ] ConwayRules.NoCollateralInputs -> ppSexp " NoCollateralInputs" [] ConwayRules.IncorrectTotalCollateralField c1 c2 -> ppRecord @@ -1411,7 +1423,8 @@ instance Reflect era => PrettyA (ShelleyLedgersPredFailure era) where ppConwayLedgerPredFailure :: Reflect era => Proof era -> ConwayLedgerPredFailure era -> PDoc ppConwayLedgerPredFailure proof x = case x of ConwayWdrlNotDelegatedToDRep s -> ppSexp "ConwayWdrlNotDelegatedToDRep" [prettyA s] - ConwayTreasuryValueMismatch c1 c2 -> ppSexp "ConwayTreasuryValueMismatch" [pcCoin c1, pcCoin c2] + ConwayTreasuryValueMismatch (Mismatch {mismatchSupplied = c1, mismatchExpected = c2}) -> + ppSexp "ConwayTreasuryValueMismatch" [pcCoin c1, pcCoin c2] ConwayGovFailure y -> case proof of Conway -> ppSexp "ConwayGovFailure" [ppConwayGovPredFailure y] _ -> @@ -1423,7 +1436,7 @@ ppConwayLedgerPredFailure proof x = case x of _ -> error ("Only the ConwayEra has a (PredicateFailure (EraRule \"CERTS\" era)). This Era is " ++ show proof) - ConwayTxRefScriptsSizeTooBig s1 s2 -> + ConwayTxRefScriptsSizeTooBig (Mismatch {mismatchSupplied = s1, mismatchExpected = s2}) -> ppRecord "ConwayTxRefScriptsSizeTooBig" [ ("Computed sum of reference script size", ppInt s1) @@ -1452,9 +1465,11 @@ ppConwayGovCertPredFailure :: ConwayGovCertPredFailure era -> PDoc ppConwayGovCertPredFailure z = case z of ConwayDRepAlreadyRegistered x -> ppSexp "ConwayDRepAlreadyRegistered" [pcCredential x] ConwayDRepNotRegistered x -> ppSexp "ConwayDRepNotRegistered" [pcCredential x] - ConwayDRepIncorrectDeposit c1 c2 -> ppSexp "ConwayDRepIncorrectDeposit" [pcCoin c1, pcCoin c2] + ConwayDRepIncorrectDeposit (Mismatch {mismatchSupplied = c1, mismatchExpected = c2}) -> + ppSexp "ConwayDRepIncorrectDeposit" [pcCoin c1, pcCoin c2] ConwayCommitteeHasPreviouslyResigned x -> ppSexp "ConwayCommitteeHasPreviouslyResigned" [pcCredential x] - ConwayDRepIncorrectRefund c1 c2 -> ppSexp "ConwayDRepIncorrectRefund" [pcCoin c1, pcCoin c2] + ConwayDRepIncorrectRefund (Mismatch {mismatchSupplied = c1, mismatchExpected = c2}) -> + ppSexp "ConwayDRepIncorrectRefund" [pcCoin c1, pcCoin c2] ConwayCommitteeIsUnknown c -> ppSexp "ConwayCommitteeIsUnknown" [pcCredential c] instance PrettyA (ConwayGovCertPredFailure era) where @@ -1480,7 +1495,7 @@ ppConwayGovPredFailure x = case x of ppSexp "ProposalProcedureNetworkIdMismatch" [pcRewardAccount racnt, pcNetwork nw] TreasuryWithdrawalsNetworkIdMismatch sr nw -> ppSexp "TreasuryWithdrawalsNetworkIdMismatch" [ppSet pcRewardAccount sr, pcNetwork nw] - ProposalDepositIncorrect c1 c2 -> ppSexp "ProposalDepositIncorrect" [pcCoin c1, pcCoin c2] + ProposalDepositIncorrect (Mismatch supplied expected) -> ppSexp "ProposalDepositIncorrect" [pcCoin supplied, pcCoin expected] DisallowedVoters m -> ppSexp "DisallowedVoters" [prettyA m] ConflictingCommitteeUpdate s -> ppSexp "ConflictingCommitteeUpdate" [ppSet pcCredential s] @@ -1488,7 +1503,7 @@ ppConwayGovPredFailure x = case x of InvalidPrevGovActionId p -> ppSexp "InvalidPrevGovActionId" [pcProposalProcedure p] VotingOnExpiredGovAction m -> ppSexp "VotingOnExpiredGovAction" [prettyA m] - ProposalCantFollow s1 p1 p2 -> + ProposalCantFollow s1 Mismatch {mismatchSupplied = p1, mismatchExpected = p2} -> ppSexp "ProposalCantFollow" [ppStrictMaybe pcGovPurposeId s1, ppProtVer p1, ppProtVer p2] InvalidPolicyHash a b -> ppSexp "InvalidPolicyHash" [ppStrictMaybe prettyA a, ppStrictMaybe prettyA b] @@ -1530,21 +1545,24 @@ ppConwayUtxowPredFailure proof = \case ppSexp " MissingTxMetadata" [ppAuxiliaryDataHash m] ConwayRules.MissingTxMetadata m -> ppSexp " MissingTxMetadata" [ppAuxiliaryDataHash m] - ConwayRules.ConflictingMetadataHash h1 h2 -> - ppRecord - "ConflictingMetadataHash" - [("Hash in the body", ppAuxiliaryDataHash h1), ("Hash of full metadata", ppAuxiliaryDataHash h2)] + ConwayRules.ConflictingMetadataHash mm@(Mismatch _ _) -> + let Mismatch {..} = mm + in ppRecord + "ConflictingMetadataHash" + [ ("Hash in the body", ppAuxiliaryDataHash mismatchSupplied) + , ("Hash of full metadata", ppAuxiliaryDataHash mismatchExpected) + ] ConwayRules.InvalidMetadata -> ppSexp "InvalidMetadata" [] ConwayRules.ExtraneousScriptWitnessesUTXOW m -> ppSexp "ExtraneousScriptWitnessesUTXOW" [ppSet pcScriptHash m] ConwayRules.MissingRedeemers xs -> ppSexp "MissingRedeemers" [ppList (ppPair ppPlutusPurposeAsItem prettyA) xs] - ConwayRules.MissingRequiredDatums s1 s2 -> + ConwayRules.MissingRequiredDatums h1 h2 -> ppRecord "MissingRequiredDatums" - [ ("missing data hashes", ppSet ppSafeHash s1) - , ("received data hashes", ppSet ppSafeHash s2) + [ ("received data hashes", ppSet ppSafeHash h1) + , ("missing data hashes", ppSet ppSafeHash h2) ] ConwayRules.NotAllowedSupplementalDatums s1 s2 -> ppRecord @@ -1552,12 +1570,13 @@ ppConwayUtxowPredFailure proof = \case [ ("unallowed data hashes", ppSet ppSafeHash s1) , ("acceptable data hashes", ppSet ppSafeHash s2) ] - ConwayRules.PPViewHashesDontMatch h1 h2 -> - ppRecord - "PPViewHashesDontMatch" - [ ("PPHash in the TxBody", ppStrictMaybe ppSafeHash h1) - , ("PPHash Computed from the current Protocol Parameters", ppStrictMaybe ppSafeHash h2) - ] + ConwayRules.PPViewHashesDontMatch mm@(Mismatch _ _) -> + let Mismatch {..} = mm + in ppRecord + "PPViewHashesDontMatch" + [ ("PPHash in the TxBody", ppStrictMaybe ppSafeHash mismatchSupplied) + , ("PPHash Computed from the current Protocol Parameters", ppStrictMaybe ppSafeHash mismatchExpected) + ] ConwayRules.UnspendableUTxONoDatumHash x -> ppSexp "UnspendableUTxONoDatumHash" [ppSet pcTxIn x] ConwayRules.ExtraRedeemers x -> @@ -1609,32 +1628,35 @@ ppBbodyPredicateFailure (LedgersFailure x) = instance Reflect era => PrettyA (ShelleyBbodyPredFailure era) where prettyA = ppBbodyPredicateFailure --- ================ ppConwayBbodyPredFail :: forall era. Reflect era => ConwayBbodyPredFailure era -> PDoc -ppConwayBbodyPredFail (ConwayRules.BodyRefScriptsSizeTooBig s1 s2) = - ppRecord - "BodyRefScriptsSizeTooBig" - [ ("Computed sum of reference script size", ppInt s1) - , ("Maximum allowed total reference script size", ppInt s2) - ] -ppConwayBbodyPredFail (ConwayRules.TooManyExUnits e1 e2) = - ppRecord - "TooManyExUnits" - [ ("Computed Sum of ExUnits for all plutus scripts", pcExUnits e1) - , ("Maximum allowed by protocal parameters", pcExUnits e2) - ] -ppConwayBbodyPredFail (ConwayRules.WrongBlockBodySizeBBODY x y) = - ppRecord - "WrongBlockBodySizeBBODY" - [ ("actual computed BBody size", ppInt x) - , ("claimed BBody Size in Header", ppInt y) - ] -ppConwayBbodyPredFail (ConwayRules.InvalidBodyHashBBODY h1 h2) = - ppRecord - "(InvalidBodyHashBBODY" - [ ("actual hash", ppHash h1) - , ("claimed hash", ppHash h2) - ] +ppConwayBbodyPredFail (ConwayRules.BodyRefScriptsSizeTooBig mm@(Mismatch _ _)) = + let Mismatch {..} = mm + in ppRecord + "BodyRefScriptsSizeTooBig" + [ ("Computed sum of reference script size", ppInt mismatchSupplied) + , ("Maximum allowed total reference script size", ppInt mismatchExpected) + ] +ppConwayBbodyPredFail (ConwayRules.TooManyExUnits mm@(Mismatch _ _)) = + let Mismatch {..} = mm + in ppRecord + "TooManyExUnits" + [ ("Computed Sum of ExUnits for all plutus scripts", pcExUnits mismatchSupplied) + , ("Maximum allowed by protocal parameters", pcExUnits mismatchExpected) + ] +ppConwayBbodyPredFail (ConwayRules.WrongBlockBodySizeBBODY mm@(Mismatch _ _)) = + let Mismatch {..} = mm + in ppRecord + "WrongBlockBodySizeBBODY" + [ ("actual computed BBody size", ppInt mismatchSupplied) + , ("claimed BBody Size in Header", ppInt mismatchExpected) + ] +ppConwayBbodyPredFail (ConwayRules.InvalidBodyHashBBODY mm@(Mismatch _ _)) = + let Mismatch {..} = mm + in ppRecord + "(InvalidBodyHashBBODY" + [ ("actual hash", ppHash mismatchSupplied) + , ("claimed hash", ppHash mismatchExpected) + ] ppConwayBbodyPredFail (ConwayRules.LedgersFailure x) = ppSexp "LedgersFailure" [ppLEDGERS @era reify x] From 7ab118dcf5e24e16b4f6a96c7cbf6886c0a974ab Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Fri, 18 Oct 2024 17:50:54 +0530 Subject: [PATCH 3/3] Bump versions and add changelog --- eras/alonzo/impl/cardano-ledger-alonzo.cabal | 2 +- eras/conway/impl/cardano-ledger-conway.cabal | 4 ++-- .../test-suite/cardano-ledger-shelley-ma-test.cabal | 2 +- eras/shelley/impl/cardano-ledger-shelley.cabal | 2 +- eras/shelley/test-suite/cardano-ledger-shelley-test.cabal | 2 +- libs/cardano-ledger-binary/CHANGELOG.md | 7 +++++-- libs/cardano-ledger-binary/cardano-ledger-binary.cabal | 2 +- libs/cardano-ledger-core/CHANGELOG.md | 2 ++ libs/cardano-ledger-core/cardano-ledger-core.cabal | 4 ++-- 9 files changed, 16 insertions(+), 11 deletions(-) diff --git a/eras/alonzo/impl/cardano-ledger-alonzo.cabal b/eras/alonzo/impl/cardano-ledger-alonzo.cabal index 9585cc13397..5ebe391ad7d 100644 --- a/eras/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/eras/alonzo/impl/cardano-ledger-alonzo.cabal @@ -81,7 +81,7 @@ library cardano-data ^>=1.2.1, cardano-ledger-allegra ^>=1.6, cardano-crypto-class, - cardano-ledger-binary ^>=1.4, + cardano-ledger-binary ^>=1.5, cardano-ledger-core ^>=1.15, cardano-ledger-mary ^>=1.7, cardano-ledger-shelley ^>=1.15, diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 1e6bd28f455..2ee4e1b0eab 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -88,7 +88,7 @@ library data-default-class, cardano-crypto-class, cardano-data >=1.2.3, - cardano-ledger-binary ^>=1.4, + cardano-ledger-binary ^>=1.5, cardano-ledger-allegra ^>=1.6, cardano-ledger-alonzo ^>=1.12, cardano-ledger-babbage ^>=1.10, @@ -187,7 +187,7 @@ executable huddle-cddl build-depends: base, testlib, - cardano-ledger-binary:testlib >=1.4 + cardano-ledger-binary:testlib >=1.5 executable gen-golden main-is: GenerateGoldenFileMain.hs diff --git a/eras/shelley-ma/test-suite/cardano-ledger-shelley-ma-test.cabal b/eras/shelley-ma/test-suite/cardano-ledger-shelley-ma-test.cabal index 4b38ec8ee9f..744f13405fe 100644 --- a/eras/shelley-ma/test-suite/cardano-ledger-shelley-ma-test.cabal +++ b/eras/shelley-ma/test-suite/cardano-ledger-shelley-ma-test.cabal @@ -41,7 +41,7 @@ library build-depends: base >=4.14 && <5, bytestring, - cardano-ledger-binary:{cardano-ledger-binary, testlib} ^>=1.4, + cardano-ledger-binary:{cardano-ledger-binary, testlib} ^>=1.5, cardano-ledger-core:{cardano-ledger-core, testlib} >=1.14, cardano-ledger-allegra:{cardano-ledger-allegra, testlib} >=1.6 && <1.7, cardano-ledger-mary:{cardano-ledger-mary, testlib} >=1.7 && <1.8, diff --git a/eras/shelley/impl/cardano-ledger-shelley.cabal b/eras/shelley/impl/cardano-ledger-shelley.cabal index f535b559456..c186530576f 100644 --- a/eras/shelley/impl/cardano-ledger-shelley.cabal +++ b/eras/shelley/impl/cardano-ledger-shelley.cabal @@ -103,7 +103,7 @@ library cardano-crypto-class, cardano-crypto-wrapper, cardano-data ^>=1.2.2, - cardano-ledger-binary ^>=1.4, + cardano-ledger-binary ^>=1.5, cardano-ledger-byron, cardano-ledger-core ^>=1.15, cardano-slotting, diff --git a/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal b/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal index ff7322b2041..4741af3333b 100644 --- a/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal +++ b/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal @@ -76,7 +76,7 @@ library cardano-crypto-class, cardano-crypto-wrapper, cardano-data >=1.2, - cardano-ledger-binary:{cardano-ledger-binary, testlib} ^>=1.4, + cardano-ledger-binary:{cardano-ledger-binary, testlib} ^>=1.5, cardano-ledger-byron, cardano-ledger-core:{cardano-ledger-core, testlib} >=1.15, cardano-ledger-shelley:{cardano-ledger-shelley, testlib} >=1.14, diff --git a/libs/cardano-ledger-binary/CHANGELOG.md b/libs/cardano-ledger-binary/CHANGELOG.md index e5b6f70e640..de11f2552c5 100644 --- a/libs/cardano-ledger-binary/CHANGELOG.md +++ b/libs/cardano-ledger-binary/CHANGELOG.md @@ -1,8 +1,11 @@ # Version history for `cardano-ledger-binary` -## 1.4.0.1 +## 1.5.0.0 -* +* Extend `Coders` to accommodate `{Enc|Dec}CBORGroup`. #4666 + * Add `ToGroup` to `Encode` + * Add `FromGroup` to `Decode` +* Add `{Enc|Dec}CBORGroup` instance for `(a, a)`. #4666 ## 1.4.0.0 diff --git a/libs/cardano-ledger-binary/cardano-ledger-binary.cabal b/libs/cardano-ledger-binary/cardano-ledger-binary.cabal index 93f9fcc18a2..47035d997eb 100644 --- a/libs/cardano-ledger-binary/cardano-ledger-binary.cabal +++ b/libs/cardano-ledger-binary/cardano-ledger-binary.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cardano-ledger-binary -version: 1.4.0.0 +version: 1.5.0.0 license: Apache-2.0 maintainer: operations@iohk.io author: IOHK diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 7c8dd441e46..48f831ba247 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -2,6 +2,8 @@ ## 1.15.1.0 +* Add `{Enc|Dec}CBORGroup` instances for `Mismatch`. #4666 + * Add `(un)swapMismatch` to swap `Mismatch` values to preserve serialisation when necessary. * Add `drepDelegsL` ### `testlib` diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index 33e297fe21b..63627f28d5d 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -95,7 +95,7 @@ library base-deriving-via, binary, bytestring, - cardano-ledger-binary ^>=1.4, + cardano-ledger-binary ^>=1.5, cardano-crypto, cardano-crypto-class, cardano-crypto-praos, @@ -180,7 +180,7 @@ library testlib cardano-crypto-test, cardano-crypto-wrapper, cardano-ledger-core, - cardano-ledger-binary:{cardano-ledger-binary, testlib} >=1.4, + cardano-ledger-binary:{cardano-ledger-binary, testlib} >=1.5, cardano-ledger-byron, cardano-ledger-byron-test, containers,