From a32a05816c2c43a2a899650f40afee0b1714ba07 Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Tue, 22 Oct 2024 18:56:00 +0530 Subject: [PATCH] Use Mismatch for Shelley,Mary,Allegra,Alonzo,Babbage --- eras/allegra/impl/CHANGELOG.md | 4 +- .../allegra/impl/cardano-ledger-allegra.cabal | 2 +- .../src/Cardano/Ledger/Allegra/Rules/Utxo.hs | 167 +++++------------- eras/alonzo/impl/CHANGELOG.md | 2 +- eras/alonzo/impl/cardano-ledger-alonzo.cabal | 2 +- .../src/Cardano/Ledger/Alonzo/Rules/Bbody.hs | 14 +- .../src/Cardano/Ledger/Alonzo/Rules/Utxo.hs | 98 +++++----- .../src/Cardano/Ledger/Alonzo/Rules/Utxow.hs | 18 +- .../Test/Cardano/Ledger/Alonzo/Arbitrary.hs | 2 +- .../Cardano/Ledger/Alonzo/Imp/UtxoSpec.hs | 12 +- .../Ledger/Alonzo/Imp/UtxowSpec/Invalid.hs | 7 +- eras/babbage/impl/CHANGELOG.md | 4 +- .../babbage/impl/cardano-ledger-babbage.cabal | 6 +- .../src/Cardano/Ledger/Babbage/Rules/Utxo.hs | 6 +- .../cardano-ledger-babbage-test.cabal | 4 +- eras/conway/impl/CHANGELOG.md | 2 +- eras/conway/impl/cardano-ledger-conway.cabal | 4 +- .../src/Cardano/Ledger/Conway/Rules/Bbody.hs | 7 +- .../src/Cardano/Ledger/Conway/Rules/Utxo.hs | 58 +----- .../src/Cardano/Ledger/Conway/Rules/Utxow.hs | 7 +- .../cardano-ledger-conway-test.cabal | 4 +- eras/mary/impl/cardano-ledger-mary.cabal | 2 +- .../Test/Cardano/Ledger/Mary/Imp/UtxoSpec.hs | 9 +- eras/shelley/impl/CHANGELOG.md | 7 + .../src/Cardano/Ledger/Shelley/Rules/Bbody.hs | 8 +- .../src/Cardano/Ledger/Shelley/Rules/Deleg.hs | 55 +++--- .../src/Cardano/Ledger/Shelley/Rules/Ppup.hs | 41 ++--- .../src/Cardano/Ledger/Shelley/Rules/Utxo.hs | 133 ++++---------- .../Cardano/Ledger/Shelley/Imp/UtxoSpec.hs | 8 +- .../Cardano/Ledger/Shelley/Examples/Mir.hs | 6 +- .../Ledger/Shelley/Examples/MirTransfer.hs | 14 +- .../Test/Cardano/Ledger/Shelley/UnitTests.hs | 6 +- .../cardano-ledger-api.cabal | 6 +- .../Test/Cardano/Ledger/Generic/PrettyCore.hs | 90 +++++----- 34 files changed, 313 insertions(+), 502 deletions(-) diff --git a/eras/allegra/impl/CHANGELOG.md b/eras/allegra/impl/CHANGELOG.md index d72a1ee5e61..e65fbd3b195 100644 --- a/eras/allegra/impl/CHANGELOG.md +++ b/eras/allegra/impl/CHANGELOG.md @@ -1,8 +1,8 @@ # Version history for `cardano-ledger-allegra` -## 1.6.0.2 +## 1.6.1.0 -* +* Use `Mismatch` to clarify predicate failures. #4711 ## 1.6.0.1 diff --git a/eras/allegra/impl/cardano-ledger-allegra.cabal b/eras/allegra/impl/cardano-ledger-allegra.cabal index 445ae1cf08f..a7df4426bc9 100644 --- a/eras/allegra/impl/cardano-ledger-allegra.cabal +++ b/eras/allegra/impl/cardano-ledger-allegra.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cardano-ledger-allegra -version: 1.6.0.1 +version: 1.6.1.0 license: Apache-2.0 maintainer: operations@iohk.io author: IOHK diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs index 106843b55b3..683c2cf7449 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs @@ -32,18 +32,13 @@ import Cardano.Ledger.BaseTypes ( Mismatch (..), Network, ProtVer (pvMajor), + Relation (..), ShelleyBase, StrictMaybe (..), networkId, ) -import Cardano.Ledger.Binary ( - DecCBOR (..), - EncCBOR (..), - decodeRecordSum, - encodeListLen, - invalidKey, - serialize, - ) +import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), serialize) +import Cardano.Ledger.Binary.Coders import Cardano.Ledger.CertState (certDState, dsGenDelegs) import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Crypto (Crypto) @@ -58,11 +53,7 @@ import Cardano.Ledger.Shelley.Rules ( ) import qualified Cardano.Ledger.Shelley.Rules as Shelley import Cardano.Ledger.TxIn (TxIn) -import Cardano.Ledger.UTxO ( - EraUTxO (..), - UTxO (..), - txouts, - ) +import Cardano.Ledger.UTxO (EraUTxO (..), UTxO (..), txouts) import qualified Cardano.Ledger.Val as Val import Cardano.Slotting.Slot (SlotNo) import Control.DeepSeq (NFData) @@ -73,7 +64,6 @@ import Data.Foldable (toList) import Data.Int (Int64) import qualified Data.Map.Strict as Map import Data.Set (Set) -import Data.Word (Word8) import GHC.Generics (Generic) import Lens.Micro import NoThunks.Class (NoThunks) @@ -87,16 +77,10 @@ data AllegraUtxoPredFailure era | OutsideValidityIntervalUTxO !ValidityInterval -- transaction's validity interval !SlotNo -- current slot - | MaxTxSizeUTxO - !Integer -- the actual transaction size - !Integer -- the max transaction size + | MaxTxSizeUTxO !(Mismatch 'RelLTEQ Integer) | InputSetEmptyUTxO - | FeeTooSmallUTxO - !Coin -- the minimum fee for this transaction - !Coin -- the fee supplied in this transaction - | ValueNotConservedUTxO - !(Value era) -- the Coin consumed by this transaction - !(Value era) -- the Coin produced by this transaction + | FeeTooSmallUTxO !(Mismatch 'RelGTEQ Coin) + | ValueNotConservedUTxO !(Mismatch 'RelEQ (Value era)) -- Consumed, then produced | WrongNetwork !Network -- the expected network id !(Set (Addr (EraCrypto era))) -- the set of addresses with incorrect network IDs @@ -160,7 +144,7 @@ data AllegraUtxoEvent era TxUTxODiff -- | UTxO consumed (UTxO era) - -- | UTxO created + -- | UTxO created (produced) (UTxO era) deriving (Generic) @@ -363,57 +347,22 @@ instance ) => EncCBOR (AllegraUtxoPredFailure era) where - encCBOR = \case - BadInputsUTxO ins -> - encodeListLen 2 <> encCBOR (0 :: Word8) <> encCBOR ins - (OutsideValidityIntervalUTxO a b) -> - encodeListLen 3 - <> encCBOR (1 :: Word8) - <> encCBOR a - <> encCBOR b - (MaxTxSizeUTxO a b) -> - encodeListLen 3 - <> encCBOR (2 :: Word8) - <> encCBOR a - <> encCBOR b - InputSetEmptyUTxO -> encodeListLen 1 <> encCBOR (3 :: Word8) - (FeeTooSmallUTxO a b) -> - encodeListLen 3 - <> encCBOR (4 :: Word8) - <> encCBOR a - <> encCBOR b - (ValueNotConservedUTxO a b) -> - encodeListLen 3 - <> encCBOR (5 :: Word8) - <> encCBOR a - <> encCBOR b - OutputTooSmallUTxO outs -> - encodeListLen 2 - <> encCBOR (6 :: Word8) - <> encCBOR outs - (UpdateFailure a) -> - encodeListLen 2 - <> encCBOR (7 :: Word8) - <> encCBOR a - (WrongNetwork right wrongs) -> - encodeListLen 3 - <> encCBOR (8 :: Word8) - <> encCBOR right - <> encCBOR wrongs - (WrongNetworkWithdrawal right wrongs) -> - encodeListLen 3 - <> encCBOR (9 :: Word8) - <> encCBOR right - <> encCBOR wrongs - OutputBootAddrAttrsTooBig outs -> - encodeListLen 2 - <> encCBOR (10 :: Word8) - <> encCBOR outs - TriesToForgeADA -> encodeListLen 1 <> encCBOR (11 :: Word8) - OutputTooBigUTxO outs -> - encodeListLen 2 - <> encCBOR (12 :: Word8) - <> encCBOR outs + encCBOR = + encode . \case + BadInputsUTxO ins -> Sum BadInputsUTxO 0 !> To ins + OutsideValidityIntervalUTxO validityInterval slot -> + Sum OutsideValidityIntervalUTxO 1 !> To validityInterval !> To slot + MaxTxSizeUTxO m -> Sum MaxTxSizeUTxO 2 !> To m + InputSetEmptyUTxO -> Sum InputSetEmptyUTxO 3 + FeeTooSmallUTxO m -> Sum FeeTooSmallUTxO 4 !> To m + ValueNotConservedUTxO m -> Sum ValueNotConservedUTxO 5 !> To m + OutputTooSmallUTxO outs -> Sum OutputTooSmallUTxO 6 !> To outs + UpdateFailure fails -> Sum UpdateFailure 7 !> To fails + WrongNetwork right wrongs -> Sum WrongNetwork 8 !> To right !> To wrongs + WrongNetworkWithdrawal right wrongs -> Sum WrongNetworkWithdrawal 9 !> To right !> To wrongs + OutputBootAddrAttrsTooBig outs -> Sum OutputBootAddrAttrsTooBig 10 !> To outs + TriesToForgeADA -> Sum TriesToForgeADA 11 + OutputTooBigUTxO outs -> Sum OutputTooBigUTxO 12 !> To outs instance ( EraTxOut era @@ -421,61 +370,31 @@ instance ) => DecCBOR (AllegraUtxoPredFailure era) where - decCBOR = - decodeRecordSum "PredicateFailureUTXO" $ - \case - 0 -> do - ins <- decCBOR - pure (2, BadInputsUTxO ins) -- The (2,..) indicates the number of things decoded, INCLUDING the tags, which are decoded by decodeRecordSumNamed - 1 -> do - a <- decCBOR - b <- decCBOR - pure (3, OutsideValidityIntervalUTxO a b) - 2 -> do - a <- decCBOR - b <- decCBOR - pure (3, MaxTxSizeUTxO a b) - 3 -> pure (1, InputSetEmptyUTxO) - 4 -> do - a <- decCBOR - b <- decCBOR - pure (3, FeeTooSmallUTxO a b) - 5 -> do - a <- decCBOR - b <- decCBOR - pure (3, ValueNotConservedUTxO a b) - 6 -> do - outs <- decCBOR - pure (2, OutputTooSmallUTxO outs) - 7 -> do - a <- decCBOR - pure (2, UpdateFailure a) - 8 -> do - right <- decCBOR - wrongs <- decCBOR - pure (3, WrongNetwork right wrongs) - 9 -> do - right <- decCBOR - wrongs <- decCBOR - pure (3, WrongNetworkWithdrawal right wrongs) - 10 -> do - outs <- decCBOR - pure (2, OutputBootAddrAttrsTooBig outs) - 11 -> pure (1, TriesToForgeADA) - 12 -> do - outs <- decCBOR - pure (2, OutputTooBigUTxO outs) - k -> invalidKey k + decCBOR = decode . Summands "AllegraUtxoPredFailure" $ \case + 0 -> SumD BadInputsUTxO SumD OutsideValidityIntervalUTxO SumD MaxTxSizeUTxO SumD InputSetEmptyUTxO + 4 -> SumD FeeTooSmallUTxO SumD ValueNotConservedUTxO SumD OutputTooSmallUTxO SumD UpdateFailure SumD WrongNetwork SumD WrongNetworkWithdrawal SumD OutputBootAddrAttrsTooBig SumD TriesToForgeADA + 12 -> SumD OutputTooBigUTxO Invalid k shelleyToAllegraUtxoPredFailure :: Shelley.ShelleyUtxoPredFailure era -> AllegraUtxoPredFailure era shelleyToAllegraUtxoPredFailure = \case Shelley.BadInputsUTxO ins -> BadInputsUTxO ins - Shelley.ExpiredUTxO ttl current -> + Shelley.ExpiredUTxO Mismatch {mismatchSupplied = ttl, mismatchExpected = current} -> OutsideValidityIntervalUTxO (ValidityInterval SNothing (SJust ttl)) current - Shelley.MaxTxSizeUTxO (Mismatch a m) -> MaxTxSizeUTxO a m + Shelley.MaxTxSizeUTxO m -> MaxTxSizeUTxO m Shelley.InputSetEmptyUTxO -> InputSetEmptyUTxO - Shelley.FeeTooSmallUTxO (Mismatch sf ef) -> FeeTooSmallUTxO ef sf - Shelley.ValueNotConservedUTxO vc vp -> ValueNotConservedUTxO vc vp + Shelley.FeeTooSmallUTxO m -> FeeTooSmallUTxO m + Shelley.ValueNotConservedUTxO m -> ValueNotConservedUTxO m Shelley.WrongNetwork n as -> WrongNetwork n as Shelley.WrongNetworkWithdrawal n as -> WrongNetworkWithdrawal n as Shelley.OutputTooSmallUTxO x -> OutputTooSmallUTxO x diff --git a/eras/alonzo/impl/CHANGELOG.md b/eras/alonzo/impl/CHANGELOG.md index b4d81834563..30cbf126962 100644 --- a/eras/alonzo/impl/CHANGELOG.md +++ b/eras/alonzo/impl/CHANGELOG.md @@ -2,7 +2,7 @@ ## 1.12.0.0 -* +* Use `Mismatch` to clarify predicate failures. #4711 ### `testlib` diff --git a/eras/alonzo/impl/cardano-ledger-alonzo.cabal b/eras/alonzo/impl/cardano-ledger-alonzo.cabal index 5ebe391ad7d..a3f9290c77c 100644 --- a/eras/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/eras/alonzo/impl/cardano-ledger-alonzo.cabal @@ -79,7 +79,7 @@ library base64-bytestring, bytestring, cardano-data ^>=1.2.1, - cardano-ledger-allegra ^>=1.6, + cardano-ledger-allegra ^>=1.6.1, cardano-crypto-class, cardano-ledger-binary ^>=1.5, cardano-ledger-core ^>=1.15, diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs index fc7ba64ed53..7461ee44bf1 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs @@ -33,7 +33,7 @@ import Cardano.Ledger.Alonzo.Tx (AlonzoTx, totExUnits) import Cardano.Ledger.Alonzo.TxSeq (AlonzoTxSeq, txSeqTxns) import Cardano.Ledger.Alonzo.TxWits (AlonzoEraTxWits (..)) import Cardano.Ledger.BHeaderView (BHeaderView (..), isOverlaySlot) -import Cardano.Ledger.BaseTypes (Mismatch (..), ShelleyBase, epochInfoPure) +import Cardano.Ledger.BaseTypes (Mismatch (..), Relation (..), ShelleyBase, epochInfoPure) import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) import Cardano.Ledger.Binary.Coders import Cardano.Ledger.Block (Block (..)) @@ -82,11 +82,7 @@ import NoThunks.Class (NoThunks (..)) data AlonzoBbodyPredFailure era = ShelleyInAlonzoBbodyPredFailure (ShelleyBbodyPredFailure era) - | TooManyExUnits - -- | Computed Sum of ExUnits for all plutus scripts - !ExUnits - -- | Maximum allowed by protocal parameters - !ExUnits + | TooManyExUnits !(Mismatch 'RelLTEQ ExUnits) deriving (Generic) newtype AlonzoBbodyEvent era @@ -157,7 +153,7 @@ instance EncCBOR (AlonzoBbodyPredFailure era) where encCBOR (ShelleyInAlonzoBbodyPredFailure x) = encode (Sum ShelleyInAlonzoBbodyPredFailure 0 !> To x) - encCBOR (TooManyExUnits x y) = encode (Sum TooManyExUnits 1 !> To x !> To y) + encCBOR (TooManyExUnits m) = encode (Sum TooManyExUnits 1 !> To m) instance ( Typeable era @@ -168,7 +164,7 @@ instance decCBOR = decode (Summands "AlonzoBbodyPredFail" dec) where dec 0 = SumD ShelleyInAlonzoBbodyPredFailure pure () - SJust bid -> failureUnless (netId == bid) $ WrongNetworkInTxBody netId bid + SJust bid -> + failureUnless (netId == bid) $ + WrongNetworkInTxBody Mismatch {mismatchSupplied = bid, mismatchExpected = netId} -- | Ensure that execution units to not exceed the maximum allowed @maxTxExUnits@ parameter. -- @@ -461,7 +443,7 @@ validateExUnitsTooBigUTxO :: Test (AlonzoUtxoPredFailure era) validateExUnitsTooBigUTxO pp tx = failureUnless (pointWiseExUnits (<=) totalExUnits maxTxExUnits) $ - ExUnitsTooBigUTxO maxTxExUnits totalExUnits + ExUnitsTooBigUTxO Mismatch {mismatchSupplied = totalExUnits, mismatchExpected = maxTxExUnits} where maxTxExUnits = pp ^. ppMaxTxExUnitsL -- This sums up the ExUnits for all embedded Plutus Scripts anywhere in the transaction: @@ -476,7 +458,8 @@ validateTooManyCollateralInputs :: TxBody era -> Test (AlonzoUtxoPredFailure era) validateTooManyCollateralInputs pp txBody = - failureUnless (numColl <= maxColl) $ TooManyCollateralInputs maxColl numColl + failureUnless (numColl <= maxColl) $ + TooManyCollateralInputs Mismatch {mismatchSupplied = numColl, mismatchExpected = maxColl} where maxColl, numColl :: Natural maxColl = pp ^. ppMaxCollateralInputsL @@ -636,14 +619,14 @@ encFail (BadInputsUTxO ins) = Sum (BadInputsUTxO @era) 0 !> To ins encFail (OutsideValidityIntervalUTxO a b) = Sum OutsideValidityIntervalUTxO 1 !> To a !> To b -encFail (MaxTxSizeUTxO a b) = - Sum MaxTxSizeUTxO 2 !> To a !> To b +encFail (MaxTxSizeUTxO m) = + Sum MaxTxSizeUTxO 2 !> To m encFail InputSetEmptyUTxO = Sum InputSetEmptyUTxO 3 -encFail (FeeTooSmallUTxO a b) = - Sum FeeTooSmallUTxO 4 !> To a !> To b -encFail (ValueNotConservedUTxO a b) = - Sum (ValueNotConservedUTxO @era) 5 !> To a !> To b +encFail (FeeTooSmallUTxO m) = + Sum FeeTooSmallUTxO 4 !> To m +encFail (ValueNotConservedUTxO m) = + Sum (ValueNotConservedUTxO @era) 5 !> To m encFail (OutputTooSmallUTxO outs) = Sum (OutputTooSmallUTxO @era) 6 !> To outs encFail (UtxosFailure a) = @@ -662,16 +645,16 @@ encFail (InsufficientCollateral a b) = Sum InsufficientCollateral 13 !> To a !> To b encFail (ScriptsNotPaidUTxO a) = Sum ScriptsNotPaidUTxO 14 !> To a -encFail (ExUnitsTooBigUTxO a b) = - Sum ExUnitsTooBigUTxO 15 !> To a !> To b +encFail (ExUnitsTooBigUTxO m) = + Sum ExUnitsTooBigUTxO 15 !> To m encFail (CollateralContainsNonADA a) = Sum CollateralContainsNonADA 16 !> To a -encFail (WrongNetworkInTxBody a b) = - Sum WrongNetworkInTxBody 17 !> To a !> To b +encFail (WrongNetworkInTxBody m) = + Sum WrongNetworkInTxBody 17 !> To m encFail (OutsideForecast a) = Sum OutsideForecast 18 !> To a -encFail (TooManyCollateralInputs a b) = - Sum TooManyCollateralInputs 19 !> To a !> To b +encFail (TooManyCollateralInputs m) = + Sum TooManyCollateralInputs 19 !> To m encFail NoCollateralInputs = Sum NoCollateralInputs 20 @@ -685,10 +668,10 @@ decFail :: Decode 'Open (AlonzoUtxoPredFailure era) decFail 0 = SumD BadInputsUTxO decCBOR) decFail 13 = SumD InsufficientCollateral decCBOR) -decFail 15 = SumD ExUnitsTooBigUTxO decCBOR) +decFail 15 = SumD ExUnitsTooBigUTxO DecCBOR (AlonzoUtxoPredFailure era) @@ -734,10 +716,10 @@ allegraToAlonzoUtxoPredFailure :: allegraToAlonzoUtxoPredFailure = \case Allegra.BadInputsUTxO x -> BadInputsUTxO x Allegra.OutsideValidityIntervalUTxO vi slotNo -> OutsideValidityIntervalUTxO vi slotNo - Allegra.MaxTxSizeUTxO x y -> MaxTxSizeUTxO x y + Allegra.MaxTxSizeUTxO m -> MaxTxSizeUTxO m Allegra.InputSetEmptyUTxO -> InputSetEmptyUTxO - Allegra.FeeTooSmallUTxO c1 c2 -> FeeTooSmallUTxO c1 c2 - Allegra.ValueNotConservedUTxO vc vp -> ValueNotConservedUTxO vc vp + Allegra.FeeTooSmallUTxO m -> FeeTooSmallUTxO m + Allegra.ValueNotConservedUTxO m -> ValueNotConservedUTxO m Allegra.WrongNetwork x y -> WrongNetwork x y Allegra.WrongNetworkWithdrawal x y -> WrongNetworkWithdrawal x y Allegra.OutputTooSmallUTxO x -> OutputTooSmallUTxO x diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs index f687212aef9..71cff09005d 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs @@ -51,6 +51,8 @@ import Cardano.Ledger.Alonzo.UTxO ( getInputDataHashesTxBody, ) import Cardano.Ledger.BaseTypes ( + Mismatch (..), + Relation (..), ShelleyBase, StrictMaybe (..), quorum, @@ -100,25 +102,27 @@ data AlonzoUtxowPredFailure era MissingRedeemers ![(PlutusPurpose AsItem era, ScriptHash (EraCrypto era))] | MissingRequiredDatums + -- TODO: Make this NonEmpty #4066 + -- | Set of missing data hashes !(Set (DataHash (EraCrypto era))) -- | Set of received data hashes !(Set (DataHash (EraCrypto era))) | NotAllowedSupplementalDatums + -- TODO: Make this NonEmpty #4066 + -- | Set of unallowed data hashes !(Set (DataHash (EraCrypto era))) -- | Set of acceptable supplemental data hashes !(Set (DataHash (EraCrypto era))) | PPViewHashesDontMatch - -- | The PPHash in the TxBody - !(StrictMaybe (ScriptIntegrityHash (EraCrypto era))) - -- | Computed from the current Protocol Parameters - !(StrictMaybe (ScriptIntegrityHash (EraCrypto era))) + !(Mismatch 'RelEQ (StrictMaybe (ScriptIntegrityHash (EraCrypto era)))) | -- | Set of witnesses which were needed and not supplied MissingRequiredSigners -- TODO: remove once in Conway. It is now redundant. See #3972 (Set (KeyHash 'Witness (EraCrypto era))) | -- | Set of transaction inputs that are TwoPhase scripts, and should have a DataHash but don't UnspendableUTxONoDatumHash + -- TODO: Make this NonEmpty #4066 (Set (TxIn (EraCrypto era))) | -- | List of redeemers not needed ExtraRedeemers @@ -190,7 +194,7 @@ instance MissingRedeemers x -> Sum MissingRedeemers 1 !> To x MissingRequiredDatums x y -> Sum MissingRequiredDatums 2 !> To x !> To y NotAllowedSupplementalDatums x y -> Sum NotAllowedSupplementalDatums 3 !> To x !> To y - PPViewHashesDontMatch x y -> Sum PPViewHashesDontMatch 4 !> To x !> To y + PPViewHashesDontMatch m -> Sum PPViewHashesDontMatch 4 !> To m MissingRequiredSigners x -> Sum MissingRequiredSigners 5 !> To x UnspendableUTxONoDatumHash x -> Sum UnspendableUTxONoDatumHash 6 !> To x ExtraRedeemers x -> Sum ExtraRedeemers 7 !> To x @@ -217,7 +221,7 @@ instance 1 -> SumD MissingRedeemers SumD MissingRequiredDatums SumD NotAllowedSupplementalDatums SumD PPViewHashesDontMatch SumD PPViewHashesDontMatch SumD MissingRequiredSigners SumD UnspendableUTxONoDatumHash SumD ExtraRedeemers arbitrary -- see #4110 MissingRequiredDatums <$> arbitrary <*> arbitrary , NotAllowedSupplementalDatums <$> arbitrary <*> arbitrary - , PPViewHashesDontMatch <$> arbitrary <*> arbitrary + , PPViewHashesDontMatch <$> arbitrary , MissingRequiredSigners <$> arbitrary , UnspendableUTxONoDatumHash <$> arbitrary -- , ExtraRedeemers <$> arbitrary -- see #4110 diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxoSpec.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxoSpec.hs index 28f7785e940..9c2b69f4ec9 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxoSpec.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxoSpec.hs @@ -12,7 +12,7 @@ import Cardano.Ledger.Alonzo.Rules (AlonzoUtxoPredFailure (..)) import Cardano.Ledger.Alonzo.Scripts (eraLanguages) import Cardano.Ledger.Alonzo.TxAuxData (mkAlonzoTxAuxData) import Cardano.Ledger.Alonzo.TxWits (Redeemers (..)) -import Cardano.Ledger.BaseTypes (Network (..), StrictMaybe (..)) +import Cardano.Ledger.BaseTypes (Mismatch (..), Network (..), StrictMaybe (..)) import Cardano.Ledger.Coin (Coin (..), toDeltaCoin) import qualified Cardano.Ledger.Metadata as M import Cardano.Ledger.Plutus (Data (..), ExUnits (..), hashPlutusScript, withSLanguage) @@ -36,7 +36,9 @@ spec = describe "UTXO" $ do it "Wrong network ID" $ do submitFailingTx (mkBasicTx mkBasicTxBody & bodyTxL . networkIdTxBodyL .~ SJust Mainnet) - [injectFailure $ WrongNetworkInTxBody Testnet Mainnet] + [ injectFailure $ + WrongNetworkInTxBody Mismatch {mismatchSupplied = Mainnet, mismatchExpected = Testnet} + ] forM_ (eraLanguages @era) $ \lang -> withSLanguage lang $ \slang -> @@ -52,7 +54,11 @@ spec = describe "UTXO" $ do mkBasicTx mkBasicTxBody & bodyTxL . inputsTxBodyL .~ [txIn] & witsTxL . rdmrsTxWitsL <>~ Redeemers (Map.singleton prp (dat, txExUnits)) - submitFailingTx tx [injectFailure $ ExUnitsTooBigUTxO maxExUnits txExUnits] + submitFailingTx + tx + [ injectFailure $ + ExUnitsTooBigUTxO Mismatch {mismatchSupplied = txExUnits, mismatchExpected = maxExUnits} + ] it "Insufficient collateral" $ do scriptInput <- produceScript $ hashPlutusScript $ alwaysSucceedsWithDatum slang diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Invalid.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Invalid.hs index 8bdd50b34fb..af9f5f28455 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Invalid.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxowSpec/Invalid.hs @@ -5,7 +5,6 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} module Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec.Invalid (spec) where @@ -21,7 +20,7 @@ import Cardano.Ledger.Alonzo.Rules ( ) import Cardano.Ledger.Alonzo.Scripts (eraLanguages) import Cardano.Ledger.Alonzo.TxWits (Redeemers (..), TxDats (..), unRedeemers) -import Cardano.Ledger.BaseTypes (Network (..), StrictMaybe (..), natVersion) +import Cardano.Ledger.BaseTypes (Mismatch (..), Network (..), StrictMaybe (..), natVersion) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Credential (Credential (..), StakeReference (..)) import Cardano.Ledger.Keys (asWitness, witVKeyHash) @@ -130,7 +129,9 @@ spec = describe "Invalid transactions" $ do withNoFixup $ submitFailingTx badHashTx - [injectFailure $ PPViewHashesDontMatch badHash goodHash] + [ injectFailure $ + PPViewHashesDontMatch Mismatch {mismatchSupplied = badHash, mismatchExpected = goodHash} + ] it "Mismatched" $ testHashMismatch . SJust =<< arbitrary diff --git a/eras/babbage/impl/CHANGELOG.md b/eras/babbage/impl/CHANGELOG.md index e7dc0d22e98..91e6c69fb97 100644 --- a/eras/babbage/impl/CHANGELOG.md +++ b/eras/babbage/impl/CHANGELOG.md @@ -1,8 +1,8 @@ # Version history for `cardano-ledger-babbage` -## 1.10.0.1 +## 1.10.1.0 -* +* Use `Mismatch` to clarify predicate failures. #4711 ## 1.10.0.0 diff --git a/eras/babbage/impl/cardano-ledger-babbage.cabal b/eras/babbage/impl/cardano-ledger-babbage.cabal index 87e89805bb6..a54b7981d4d 100644 --- a/eras/babbage/impl/cardano-ledger-babbage.cabal +++ b/eras/babbage/impl/cardano-ledger-babbage.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cardano-ledger-babbage -version: 1.10.0.0 +version: 1.10.1.0 license: Apache-2.0 maintainer: operations@iohk.io author: IOHK @@ -74,8 +74,8 @@ library bytestring, cardano-crypto-class, cardano-data >=1.2, - cardano-ledger-allegra ^>=1.6, - cardano-ledger-alonzo >=1.11, + cardano-ledger-allegra ^>=1.6.1, + cardano-ledger-alonzo >=1.12, cardano-ledger-binary >=1.4, cardano-ledger-core ^>=1.15, cardano-ledger-mary ^>=1.7, diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxo.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxo.hs index e2b755e6c08..6ff15713632 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxo.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxo.hs @@ -53,6 +53,7 @@ import Cardano.Ledger.Babbage.Era (BabbageEra, BabbageUTXO) import Cardano.Ledger.Babbage.Rules.Ppup () import Cardano.Ledger.Babbage.Rules.Utxos (BabbageUTXOS) import Cardano.Ledger.BaseTypes ( + Mismatch (..), ProtVer (..), ShelleyBase, epochInfo, @@ -212,7 +213,9 @@ feesOK pp tx u@(UTxO utxo) = minFee = getMinFeeTxUtxo pp tx u in sequenceA_ [ -- Part 1: minfee pp tx ≤ txfee txBody - failureUnless (minFee <= theFee) (injectFailure $ FeeTooSmallUTxO minFee theFee) + failureUnless + (minFee <= theFee) + (injectFailure $ FeeTooSmallUTxO Mismatch {mismatchSupplied = theFee, mismatchExpected = minFee}) , -- Part 2: (txrdmrs tx ≠ ∅ ⇒ validateCollateral) unless (nullRedeemers $ tx ^. witsTxL . rdmrsTxWitsL) $ validateTotalCollateral pp txBody utxoCollateral @@ -508,6 +511,7 @@ instance instance ( Era era , DecCBOR (TxOut era) + , EncCBOR (Value era) , DecCBOR (Value era) , DecCBOR (PredicateFailure (EraRule "UTXOS" era)) , DecCBOR (PredicateFailure (EraRule "UTXO" era)) diff --git a/eras/babbage/test-suite/cardano-ledger-babbage-test.cabal b/eras/babbage/test-suite/cardano-ledger-babbage-test.cabal index 80f13a62c58..26074c14eae 100644 --- a/eras/babbage/test-suite/cardano-ledger-babbage-test.cabal +++ b/eras/babbage/test-suite/cardano-ledger-babbage-test.cabal @@ -31,9 +31,9 @@ library build-depends: base >=4.14 && <5, cardano-ledger-binary:{cardano-ledger-binary, testlib} >=1.0, - cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib} >=1.9, + cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib} >=1.12, cardano-ledger-alonzo-test >=1.1, - cardano-ledger-babbage >=1.10 && <1.11, + cardano-ledger-babbage >=1.10.1 && <1.11, cardano-ledger-core:{cardano-ledger-core, testlib} >=1.11, cardano-ledger-shelley-ma-test >=1.1, cardano-ledger-mary >=1.4, diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index 981edf83813..87d5ce28d56 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -2,7 +2,7 @@ ## 1.18.0.0 -* Add new event `GovRemovedVotes` for invalidated votes +* Add new event `GovRemovedVotes` for invalidated votes. ### `testlib` diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 2ee4e1b0eab..57ba90d517e 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -89,9 +89,9 @@ library cardano-crypto-class, cardano-data >=1.2.3, cardano-ledger-binary ^>=1.5, - cardano-ledger-allegra ^>=1.6, + cardano-ledger-allegra ^>=1.6.1, cardano-ledger-alonzo ^>=1.12, - cardano-ledger-babbage ^>=1.10, + cardano-ledger-babbage ^>=1.10.1, cardano-ledger-core ^>=1.15.1, cardano-ledger-mary ^>=1.7, cardano-ledger-shelley ^>=1.15, 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 79b94652a0c..e2637741964 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Bbody.hs @@ -227,12 +227,7 @@ alonzoToConwayBbodyPredFailure :: AlonzoBbodyPredFailure era -> ConwayBbodyPredFailure era alonzoToConwayBbodyPredFailure (ShelleyInAlonzoBbodyPredFailure x) = shelleyToConwayBbodyPredFailure x -alonzoToConwayBbodyPredFailure (Alonzo.TooManyExUnits x y) = - TooManyExUnits $ - Mismatch - { mismatchSupplied = x - , mismatchExpected = y - } +alonzoToConwayBbodyPredFailure (Alonzo.TooManyExUnits m) = TooManyExUnits m instance ( DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody) 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 0606f007318..db1fe030c40 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxo.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxo.hs @@ -357,20 +357,10 @@ alonzoToConwayUtxoPredFailure :: alonzoToConwayUtxoPredFailure = \case Alonzo.BadInputsUTxO x -> BadInputsUTxO x Alonzo.OutsideValidityIntervalUTxO vi slotNo -> OutsideValidityIntervalUTxO vi slotNo - Alonzo.MaxTxSizeUTxO x y -> MaxTxSizeUTxO Mismatch {mismatchSupplied = x, mismatchExpected = y} + Alonzo.MaxTxSizeUTxO m -> MaxTxSizeUTxO m Alonzo.InputSetEmptyUTxO -> InputSetEmptyUTxO - Alonzo.FeeTooSmallUTxO ppMinFee supplied -> - FeeTooSmallUTxO - Mismatch - { mismatchSupplied = supplied - , mismatchExpected = ppMinFee - } - Alonzo.ValueNotConservedUTxO consumed produced -> - ValueNotConservedUTxO - Mismatch - { mismatchSupplied = consumed - , mismatchExpected = produced - } + Alonzo.FeeTooSmallUTxO m -> FeeTooSmallUTxO m + Alonzo.ValueNotConservedUTxO m -> ValueNotConservedUTxO m Alonzo.WrongNetwork x y -> WrongNetwork x y Alonzo.WrongNetworkWithdrawal x y -> WrongNetworkWithdrawal x y Alonzo.OutputTooSmallUTxO x -> OutputTooSmallUTxO x @@ -390,26 +380,11 @@ alonzoToConwayUtxoPredFailure = \case OutputTooBigUTxO $ map toRestricted xs Alonzo.InsufficientCollateral c1 c2 -> InsufficientCollateral c1 c2 Alonzo.ScriptsNotPaidUTxO u -> ScriptsNotPaidUTxO u - Alonzo.ExUnitsTooBigUTxO e1 e2 -> - ExUnitsTooBigUTxO - Mismatch - { mismatchSupplied = e2 - , mismatchExpected = e1 - } + Alonzo.ExUnitsTooBigUTxO m -> ExUnitsTooBigUTxO m Alonzo.CollateralContainsNonADA v -> CollateralContainsNonADA v - Alonzo.WrongNetworkInTxBody nid nidInTx -> - WrongNetworkInTxBody - Mismatch - { mismatchSupplied = nidInTx - , mismatchExpected = nid - } + Alonzo.WrongNetworkInTxBody m -> WrongNetworkInTxBody m Alonzo.OutsideForecast sno -> OutsideForecast sno - Alonzo.TooManyCollateralInputs maxI suppliedI -> - TooManyCollateralInputs - Mismatch - { mismatchSupplied = suppliedI - , mismatchExpected = maxI - } + Alonzo.TooManyCollateralInputs m -> TooManyCollateralInputs m Alonzo.NoCollateralInputs -> NoCollateralInputs allegraToConwayUtxoPredFailure :: @@ -420,25 +395,10 @@ allegraToConwayUtxoPredFailure :: allegraToConwayUtxoPredFailure = \case Allegra.BadInputsUTxO x -> BadInputsUTxO x Allegra.OutsideValidityIntervalUTxO vi slotNo -> OutsideValidityIntervalUTxO vi slotNo - Allegra.MaxTxSizeUTxO supplied expected -> - MaxTxSizeUTxO - Mismatch - { mismatchSupplied = supplied - , mismatchExpected = expected - } + Allegra.MaxTxSizeUTxO m -> MaxTxSizeUTxO m Allegra.InputSetEmptyUTxO -> InputSetEmptyUTxO - Allegra.FeeTooSmallUTxO minFee suppliedFee -> - FeeTooSmallUTxO - Mismatch - { mismatchSupplied = suppliedFee - , mismatchExpected = minFee - } - Allegra.ValueNotConservedUTxO consumed produced -> - ValueNotConservedUTxO - Mismatch - { mismatchSupplied = consumed - , mismatchExpected = produced - } + Allegra.FeeTooSmallUTxO m -> FeeTooSmallUTxO m + Allegra.ValueNotConservedUTxO m -> ValueNotConservedUTxO m 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 84a84e51c9b..0fa7f6e54ee 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxow.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxow.hs @@ -332,12 +332,7 @@ alonzoToConwayUtxowPredFailure = \case Alonzo.MissingRedeemers rs -> MissingRedeemers rs Alonzo.MissingRequiredDatums mds rds -> MissingRequiredDatums mds rds Alonzo.NotAllowedSupplementalDatums uds ads -> NotAllowedSupplementalDatums uds ads - Alonzo.PPViewHashesDontMatch a b -> - PPViewHashesDontMatch - Mismatch - { mismatchSupplied = a - , mismatchExpected = b - } + Alonzo.PPViewHashesDontMatch m -> PPViewHashesDontMatch m Alonzo.MissingRequiredSigners _xs -> error "Impossible case. It will be removed once we are in Conway. See #3972" Alonzo.UnspendableUTxONoDatumHash ins -> UnspendableUTxONoDatumHash ins diff --git a/eras/conway/test-suite/cardano-ledger-conway-test.cabal b/eras/conway/test-suite/cardano-ledger-conway-test.cabal index 13bac93379d..05136dc1287 100644 --- a/eras/conway/test-suite/cardano-ledger-conway-test.cabal +++ b/eras/conway/test-suite/cardano-ledger-conway-test.cabal @@ -27,8 +27,8 @@ library build-depends: base >=4.14 && <5, cardano-data >=1.2.2, - cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib} >=1.11, - cardano-ledger-babbage >=1.10, + cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib} >=1.12, + cardano-ledger-babbage >=1.10.1, cardano-ledger-binary >=1.0, cardano-ledger-conway:{cardano-ledger-conway, testlib} >=1.16.1 && <1.19, cardano-ledger-core:{cardano-ledger-core, testlib} >=1.11, diff --git a/eras/mary/impl/cardano-ledger-mary.cabal b/eras/mary/impl/cardano-ledger-mary.cabal index d0671681e9c..f92b4740618 100644 --- a/eras/mary/impl/cardano-ledger-mary.cabal +++ b/eras/mary/impl/cardano-ledger-mary.cabal @@ -75,7 +75,7 @@ library aeson >=2.2, cardano-crypto-class, cardano-data ^>=1.2, - cardano-ledger-allegra ^>=1.6, + cardano-ledger-allegra ^>=1.6.1, cardano-ledger-binary >=1.4, cardano-ledger-core ^>=1.15, cardano-ledger-shelley ^>=1.15, diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp/UtxoSpec.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp/UtxoSpec.hs index 304f6dac2d9..309c63ee38a 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp/UtxoSpec.hs +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp/UtxoSpec.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -10,6 +9,7 @@ module Test.Cardano.Ledger.Mary.Imp.UtxoSpec (spec) where import Cardano.Ledger.Allegra.Scripts +import Cardano.Ledger.BaseTypes (Mismatch (..)) import Cardano.Ledger.Mary.Core import Cardano.Ledger.Mary.Value import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure (..)) @@ -70,7 +70,8 @@ spec = describe "UTXO" $ do submitFailingTx (mkBasicTx txBody) [ injectFailure $ - ValueNotConservedUTxO - (rootTxOutValue <> MaryValue c (MultiAsset mintedMultiAsset)) - (rootTxOutValue <> MaryValue c burnTooMuchProducedMultiAsset) + ValueNotConservedUTxO $ + Mismatch + (rootTxOutValue <> MaryValue c (MultiAsset mintedMultiAsset)) + (rootTxOutValue <> MaryValue c burnTooMuchProducedMultiAsset) ] diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index d9e62eb0f88..1e6d703de26 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -3,6 +3,13 @@ ## 1.15.0.0 * Added `EncCBOR` instance for `LedgerEnv` +* Use `Mismatch` to clarify _some more_ predicate failures. #4711 + * `Shelley/InsufficientForInstantaneousRewardsDELEG` + * `Shelley/MIRCertificateTooLateinEpochDELEG` + * `Shelley/InsufficientForTransferDELEG` + * `Shelley/ExpiredUTxO` + * `Shelley/ValueNotConservedUTxO` + ### `testlib` diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs index d36569c754e..0f9c06b4003 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs @@ -77,8 +77,12 @@ data BbodyEnv era = BbodyEnv } data ShelleyBbodyPredFailure era - = WrongBlockBodySizeBBODY (Mismatch 'RelEQ Int) - | InvalidBodyHashBBODY (Mismatch 'RelEQ (Hash (EraCrypto era) EraIndependentBlockBody)) + = -- | `mismatchSupplied` ~ Actual body size. + -- `mismatchExpected` ~ Claimed body size in the header. + WrongBlockBodySizeBBODY (Mismatch 'RelEQ Int) + | -- | `mismatchSupplied` ~ Actual hash. + -- `mismatchExpected` ~ Claimed hash in the header. + InvalidBodyHashBBODY (Mismatch 'RelEQ (Hash (EraCrypto era) EraIndependentBlockBody)) | LedgersFailure (PredicateFailure (EraRule "LEDGERS" era)) -- Subtransition Failures deriving (Generic) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs index 770e7c563de..2e61731f2e8 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Deleg.hs @@ -21,6 +21,8 @@ where import Cardano.Ledger.BaseTypes ( Globals (..), + Mismatch (..), + Relation (..), ShelleyBase, StrictMaybe (..), epochInfoPure, @@ -119,19 +121,16 @@ data ShelleyDelegPredFailure era !(KeyHash 'GenesisDelegate (EraCrypto era)) -- Keyhash which is already delegated to | InsufficientForInstantaneousRewardsDELEG !MIRPot -- which pot the rewards are to be drawn from, treasury or reserves - !Coin -- amount of rewards to be given out - !Coin -- size of the pot from which the lovelace is drawn + !(Mismatch 'RelLTEQ Coin) | MIRCertificateTooLateinEpochDELEG - !SlotNo -- current slot - !SlotNo -- EraRule "MIR" must be submitted before this slot + !(Mismatch 'RelLT SlotNo) | DuplicateGenesisVRFDELEG !(Hash (EraCrypto era) (VerKeyVRF (EraCrypto era))) -- VRF KeyHash which is already delegated to | MIRTransferNotCurrentlyAllowed | MIRNegativesNotCurrentlyAllowed | InsufficientForTransferDELEG !MIRPot -- which pot the rewards are to be drawn from, treasury or reserves - !Coin -- amount attempted to transfer - !Coin -- amount available + !(Mismatch 'RelLTEQ Coin) | MIRProducesNegativeUpdate | MIRNegativeTransfer !MIRPot -- which pot the rewards are to be drawn from, treasury or reserves @@ -180,14 +179,13 @@ instance encodeListLen 2 <> encCBOR (5 :: Word8) <> encCBOR gkh DuplicateGenesisDelegateDELEG kh -> encodeListLen 2 <> encCBOR (6 :: Word8) <> encCBOR kh - InsufficientForInstantaneousRewardsDELEG pot needed potAmount -> - encodeListLen 4 + InsufficientForInstantaneousRewardsDELEG pot m -> + encodeListLen 3 <> encCBOR (7 :: Word8) <> encCBOR pot - <> encCBOR needed - <> encCBOR potAmount - MIRCertificateTooLateinEpochDELEG sNow sTooLate -> - encodeListLen 3 <> encCBOR (8 :: Word8) <> encCBOR sNow <> encCBOR sTooLate + <> encCBOR m + MIRCertificateTooLateinEpochDELEG m -> + encodeListLen 2 <> encCBOR (8 :: Word8) <> encCBOR m DuplicateGenesisVRFDELEG vrf -> encodeListLen 2 <> encCBOR (9 :: Word8) <> encCBOR vrf StakeKeyInRewardsDELEG cred -> @@ -196,12 +194,11 @@ instance encodeListLen 1 <> encCBOR (11 :: Word8) MIRNegativesNotCurrentlyAllowed -> encodeListLen 1 <> encCBOR (12 :: Word8) - InsufficientForTransferDELEG pot needed available -> - encodeListLen 4 + InsufficientForTransferDELEG pot m -> + encodeListLen 3 <> encCBOR (13 :: Word8) <> encCBOR pot - <> encCBOR needed - <> encCBOR available + <> encCBOR m MIRProducesNegativeUpdate -> encodeListLen 1 <> encCBOR (14 :: Word8) MIRNegativeTransfer pot amt -> @@ -238,13 +235,11 @@ instance pure (2, DuplicateGenesisDelegateDELEG kh) 7 -> do pot <- decCBOR - needed <- decCBOR - potAmount <- decCBOR - pure (4, InsufficientForInstantaneousRewardsDELEG pot needed potAmount) + m <- decCBOR + pure (3, InsufficientForInstantaneousRewardsDELEG pot m) 8 -> do - sNow <- decCBOR - sTooLate <- decCBOR - pure (3, MIRCertificateTooLateinEpochDELEG sNow sTooLate) + m <- decCBOR + pure (2, MIRCertificateTooLateinEpochDELEG m) 9 -> do vrf <- decCBOR pure (2, DuplicateGenesisVRFDELEG vrf) @@ -257,9 +252,8 @@ instance pure (1, MIRNegativesNotCurrentlyAllowed) 13 -> do pot <- decCBOR - needed <- decCBOR - available <- decCBOR - pure (4, InsufficientForTransferDELEG pot needed available) + m <- decCBOR + pure (3, InsufficientForTransferDELEG pot m) 14 -> do pure (1, MIRProducesNegativeUpdate) 15 -> do @@ -356,7 +350,7 @@ delegationTransition = do then do let available = availableAfterMIR targetPot acnt (dsIRewards ds) coin >= mempty ?! MIRNegativeTransfer targetPot coin - coin <= available ?! InsufficientForTransferDELEG targetPot coin available + coin <= available ?! InsufficientForTransferDELEG targetPot (Mismatch coin available) let ir = dsIRewards ds dr = deltaReserves ir @@ -400,7 +394,7 @@ checkSlotNotTooLate slot = do tellEvent (DelegNewEpoch newEpoch) firstSlot <- liftSTS $ epochInfoFirst ei newEpoch let tooLate = firstSlot *- Duration sp - slot < tooLate ?! MIRCertificateTooLateinEpochDELEG slot tooLate + slot < tooLate ?! MIRCertificateTooLateinEpochDELEG (Mismatch slot tooLate) updateReservesAndTreasury :: MIRPot -> @@ -412,7 +406,12 @@ updateReservesAndTreasury targetPot combinedMap available ds = do let requiredForRewards = fold combinedMap requiredForRewards <= available - ?! InsufficientForInstantaneousRewardsDELEG targetPot requiredForRewards available + ?! InsufficientForInstantaneousRewardsDELEG + targetPot + Mismatch + { mismatchSupplied = requiredForRewards + , mismatchExpected = available + } pure $ case targetPot of ReservesMIR -> ds {dsIRewards = (dsIRewards ds) {iRReserves = combinedMap}} diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ppup.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ppup.hs index 2eb08732e70..88ff5ad90c5 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ppup.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ppup.hs @@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -31,15 +32,13 @@ import Cardano.Ledger.BaseTypes ( Relation (..), ShelleyBase, StrictMaybe (..), - invalidKey, ) import Cardano.Ledger.Binary ( DecCBOR (..), EncCBOR (..), - decodeRecordSum, decodeWord, - encodeListLen, ) +import Cardano.Ledger.Binary.Coders import Cardano.Ledger.Core import Cardano.Ledger.Keys (GenDelegs (GenDelegs), KeyHash, KeyRole (Genesis)) import Cardano.Ledger.Shelley.Era (ShelleyEra, ShelleyPPUP) @@ -90,8 +89,8 @@ instance DecCBOR VotingPeriod where data ShelleyPpupPredFailure era = -- | An update was proposed by a key hash that is not one of the genesis keys. - -- The first set contains the key hashes which were a part of the update. - -- The second set contains the key hashes of the genesis keys. + -- `mismatchSupplied` ~ key hashes which were a part of the update. + -- `mismatchExpected` ~ key hashes of the genesis keys. NonGenesisUpdatePPUP !(Mismatch 'RelSubset (Set (KeyHash 'Genesis (EraCrypto era)))) | -- | An update was proposed for the wrong epoch. @@ -138,30 +137,18 @@ instance (EraPParams era, ProtVerAtMost era 8) => STS (ShelleyPPUP era) where transitionRules = [ppupTransitionNonEmpty] instance Era era => EncCBOR (ShelleyPpupPredFailure era) where - encCBOR = \case - NonGenesisUpdatePPUP mm -> - encodeListLen 2 - <> encCBOR (0 :: Word8) - <> encCBOR mm - PPUpdateWrongEpoch ce e vp -> - encodeListLen 4 <> encCBOR (1 :: Word8) <> encCBOR ce <> encCBOR e <> encCBOR vp - PVCannotFollowPPUP p -> encodeListLen 2 <> encCBOR (2 :: Word8) <> encCBOR p + encCBOR = + encode @_ @(ShelleyPpupPredFailure era) . \case + NonGenesisUpdatePPUP mm -> Sum NonGenesisUpdatePPUP 0 !> To mm + PPUpdateWrongEpoch ce e vp -> Sum PPUpdateWrongEpoch 1 !> To ce !> To e !> To vp + PVCannotFollowPPUP p -> Sum PVCannotFollowPPUP 2 !> To p instance Era era => DecCBOR (ShelleyPpupPredFailure era) where - decCBOR = decodeRecordSum "ShelleyPpupPredFailure" $ - \case - 0 -> do - mm <- decCBOR - pure (2, NonGenesisUpdatePPUP mm) - 1 -> do - a <- decCBOR - b <- decCBOR - c <- decCBOR - pure (4, PPUpdateWrongEpoch a b c) - 2 -> do - p <- decCBOR - pure (2, PVCannotFollowPPUP p) - k -> invalidKey k + decCBOR = decode . Summands "ShelleyPpupPredFailure" $ \case + 0 -> SumD NonGenesisUpdatePPUP SumD PPUpdateWrongEpoch SumD PVCannotFollowPPUP Invalid k ppupTransitionNonEmpty :: (EraPParams era, ProtVerAtMost era 8) => TransitionRule (ShelleyPPUP era) ppupTransitionNonEmpty = do diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs index e28972ff641..890fef4b189 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs @@ -52,16 +52,10 @@ import Cardano.Ledger.BaseTypes ( Relation (..), ShelleyBase, StrictMaybe, - invalidKey, networkId, ) -import Cardano.Ledger.Binary ( - DecCBOR (..), - EncCBOR (..), - decodeRecordSum, - encodeListLen, - ) -import Cardano.Ledger.Binary.Coders (Encode (..), encode, (!>)) +import Cardano.Ledger.Binary +import Cardano.Ledger.Binary.Coders import Cardano.Ledger.CertState ( certsTotalDepositsTxBody, certsTotalRefundsTxBody, @@ -111,7 +105,6 @@ import qualified Data.Map.Strict as Map import Data.MapExtras (extractKeys) import Data.Set (Set) import qualified Data.Set as Set -import Data.Word (Word8) import GHC.Generics (Generic) import Lens.Micro import Lens.Micro.Extras (view) @@ -172,16 +165,14 @@ data ShelleyUtxoPredFailure era = BadInputsUTxO !(Set (TxIn (EraCrypto era))) -- The bad transaction inputs | ExpiredUTxO - !SlotNo -- transaction's time to live - !SlotNo -- current slot + !(Mismatch 'RelLTEQ SlotNo) | MaxTxSizeUTxO !(Mismatch 'RelLTEQ Integer) | InputSetEmptyUTxO | FeeTooSmallUTxO !(Mismatch 'RelGTEQ Coin) | ValueNotConservedUTxO - !(Value era) -- the Coin consumed by this transaction - !(Value era) -- the Coin produced by this transaction + !(Mismatch 'RelEQ (Value era)) | WrongNetwork !Network -- the expected network id !(Set (Addr (EraCrypto era))) -- the set of addresses with incorrect network IDs @@ -239,50 +230,19 @@ instance ) => EncCBOR (ShelleyUtxoPredFailure era) where - encCBOR = \case - BadInputsUTxO ins -> - encodeListLen 2 <> encCBOR (0 :: Word8) <> encCBOR ins - ExpiredUTxO a b -> - encodeListLen 3 - <> encCBOR (1 :: Word8) - <> encCBOR a - <> encCBOR b - MaxTxSizeUTxO mm -> - encodeListLen 2 - <> encCBOR (2 :: Word8) - <> encCBOR mm - InputSetEmptyUTxO -> encodeListLen 1 <> encCBOR (3 :: Word8) - FeeTooSmallUTxO mm -> - encodeListLen 2 - <> encCBOR (4 :: Word8) - <> encCBOR mm - ValueNotConservedUTxO a b -> - encodeListLen 3 - <> encCBOR (5 :: Word8) - <> encCBOR a - <> encCBOR b - OutputTooSmallUTxO outs -> - encodeListLen 2 - <> encCBOR (6 :: Word8) - <> encCBOR outs - UpdateFailure a -> - encodeListLen 2 - <> encCBOR (7 :: Word8) - <> encCBOR a - WrongNetwork right wrongs -> - encodeListLen 3 - <> encCBOR (8 :: Word8) - <> encCBOR right - <> encCBOR wrongs - WrongNetworkWithdrawal right wrongs -> - encodeListLen 3 - <> encCBOR (9 :: Word8) - <> encCBOR right - <> encCBOR wrongs - OutputBootAddrAttrsTooBig outs -> - encodeListLen 2 - <> encCBOR (10 :: Word8) - <> encCBOR outs + encCBOR = + encode . \case + BadInputsUTxO ins -> Sum BadInputsUTxO 0 !> To ins + ExpiredUTxO m -> Sum ExpiredUTxO 1 !> To m + MaxTxSizeUTxO m -> Sum MaxTxSizeUTxO 2 !> To m + InputSetEmptyUTxO -> Sum InputSetEmptyUTxO 3 + FeeTooSmallUTxO m -> Sum FeeTooSmallUTxO 4 !> To m + ValueNotConservedUTxO m -> Sum ValueNotConservedUTxO 5 !> To m + OutputTooSmallUTxO outs -> Sum OutputTooSmallUTxO 6 !> To outs + UpdateFailure a -> Sum UpdateFailure 7 !> To a + WrongNetwork right wrongs -> Sum WrongNetwork 8 !> To right !> To wrongs + WrongNetworkWithdrawal right wrongs -> Sum WrongNetworkWithdrawal 9 !> To right !> To wrongs + OutputBootAddrAttrsTooBig outs -> Sum OutputBootAddrAttrsTooBig 10 !> To outs instance ( EraTxOut era @@ -290,45 +250,19 @@ instance ) => DecCBOR (ShelleyUtxoPredFailure era) where - decCBOR = - decodeRecordSum "PredicateFailureUTXO" $ - \case - 0 -> do - ins <- decCBOR - pure (2, BadInputsUTxO ins) - 1 -> do - a <- decCBOR - b <- decCBOR - pure (3, ExpiredUTxO a b) - 2 -> do - mm <- decCBOR - pure (2, MaxTxSizeUTxO mm) - 3 -> pure (1, InputSetEmptyUTxO) - 4 -> do - mm <- decCBOR - pure (2, FeeTooSmallUTxO mm) - 5 -> do - a <- decCBOR - b <- decCBOR - pure (3, ValueNotConservedUTxO a b) - 6 -> do - outs <- decCBOR - pure (2, OutputTooSmallUTxO outs) - 7 -> do - a <- decCBOR - pure (2, UpdateFailure a) - 8 -> do - right <- decCBOR - wrongs <- decCBOR - pure (3, WrongNetwork right wrongs) - 9 -> do - right <- decCBOR - wrongs <- decCBOR - pure (3, WrongNetworkWithdrawal right wrongs) - 10 -> do - outs <- decCBOR - pure (2, OutputBootAddrAttrsTooBig outs) - k -> invalidKey k + decCBOR = decode . Summands "PredicateFailureUTXO" $ \case + 0 -> SumD BadInputsUTxO SumD ExpiredUTxO SumD MaxTxSizeUTxO SumD InputSetEmptyUTxO + 4 -> SumD FeeTooSmallUTxO SumD ValueNotConservedUTxO SumD OutputTooSmallUTxO SumD UpdateFailure SumD WrongNetwork SumD WrongNetworkWithdrawal SumD OutputBootAddrAttrsTooBig Invalid k instance ( EraTx era @@ -478,7 +412,9 @@ validateTimeToLive :: TxBody era -> SlotNo -> Test (ShelleyUtxoPredFailure era) -validateTimeToLive txb slot = failureUnless (ttl >= slot) $ ExpiredUTxO ttl slot +validateTimeToLive txb slot = + failureUnless (ttl >= slot) $ + ExpiredUTxO Mismatch {mismatchSupplied = ttl, mismatchExpected = slot} where ttl = txb ^. ttlTxBodyL @@ -572,7 +508,8 @@ validateValueNotConservedUTxO :: TxBody era -> Test (ShelleyUtxoPredFailure era) validateValueNotConservedUTxO pp utxo certState txBody = - failureUnless (consumedValue == producedValue) $ ValueNotConservedUTxO consumedValue producedValue + failureUnless (consumedValue == producedValue) $ + ValueNotConservedUTxO Mismatch {mismatchSupplied = consumedValue, mismatchExpected = producedValue} where consumedValue = consumed pp certState utxo txBody producedValue = produced pp certState txBody diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/UtxoSpec.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/UtxoSpec.hs index ca7af7dc79d..11d7b074c25 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/UtxoSpec.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/UtxoSpec.hs @@ -6,6 +6,7 @@ module Test.Cardano.Ledger.Shelley.Imp.UtxoSpec (spec) where +import Cardano.Ledger.BaseTypes (Mismatch (..)) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Core import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure (..)) @@ -45,7 +46,8 @@ spec = describe "UTXO" $ do submitFailingTx (mkBasicTx txBody) [ injectFailure $ - ValueNotConservedUTxO - (rootTxOutValue <> inject txAmount) - (rootTxOutValue <> inject (txAmount <> extra)) + ValueNotConservedUTxO $ + Mismatch + (rootTxOutValue <> inject txAmount) + (rootTxOutValue <> inject (txAmount <> extra)) ] diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Mir.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Mir.hs index 8dd95029987..a60f1f1d6d3 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Mir.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Mir.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -16,7 +15,7 @@ module Test.Cardano.Ledger.Shelley.Examples.Mir ( ) where -import Cardano.Ledger.BaseTypes (Nonce, StrictMaybe (..), mkCertIxPartial) +import Cardano.Ledger.BaseTypes (Mismatch (..), Nonce, StrictMaybe (..), mkCertIxPartial) import Cardano.Ledger.Block (Block, bheader) import Cardano.Ledger.Coin (Coin (..), toDeltaCoin) import Cardano.Ledger.Credential (Ptr (..)) @@ -264,7 +263,8 @@ mirFailFunds pot treasury llNeeded llReceived = . pure . BbodyFailure . injectFailure - $ InsufficientForInstantaneousRewardsDELEG pot llNeeded llReceived + $ InsufficientForInstantaneousRewardsDELEG pot + $ Mismatch llNeeded llReceived ) -- diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/MirTransfer.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/MirTransfer.hs index ff927ec0fa0..cc93da86e6d 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/MirTransfer.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/MirTransfer.hs @@ -6,7 +6,7 @@ module Test.Cardano.Ledger.Shelley.Examples.MirTransfer ( ) where -import Cardano.Ledger.BaseTypes (ProtVer (..), natVersion) +import Cardano.Ledger.BaseTypes (Mismatch (..), ProtVer (..), natVersion) import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..)) import Cardano.Ledger.Keys ( GenDelegs (..), @@ -153,7 +153,7 @@ testMIRTransfer = (StakeAddressesMIR $ aliceOnlyDelta 1) (InstantaneousRewards (aliceOnlyReward 1) mempty mempty mempty) (AccountState {asReserves = Coin 1, asTreasury = Coin 0}) - (Left . pure $ InsufficientForInstantaneousRewardsDELEG ReservesMIR (Coin 2) (Coin 1)) + (Left . pure $ InsufficientForInstantaneousRewardsDELEG ReservesMIR $ Mismatch (Coin 2) (Coin 1)) , testCase "increment treasury too much" $ testMirTransfer alonzoPV @@ -161,7 +161,7 @@ testMIRTransfer = (StakeAddressesMIR $ aliceOnlyDelta 1) (InstantaneousRewards mempty (aliceOnlyReward 1) mempty mempty) (AccountState {asReserves = Coin 0, asTreasury = Coin 1}) - (Left . pure $ InsufficientForInstantaneousRewardsDELEG TreasuryMIR (Coin 2) (Coin 1)) + (Left . pure $ InsufficientForInstantaneousRewardsDELEG TreasuryMIR $ Mismatch (Coin 2) (Coin 1)) , testCase "increment reserves too much with delta" $ testMirTransfer alonzoPV @@ -169,7 +169,7 @@ testMIRTransfer = (StakeAddressesMIR $ aliceOnlyDelta 1) (InstantaneousRewards (aliceOnlyReward 1) mempty (DeltaCoin (-1)) (DeltaCoin 1)) (AccountState {asReserves = Coin 2, asTreasury = Coin 0}) - (Left . pure $ InsufficientForInstantaneousRewardsDELEG ReservesMIR (Coin 2) (Coin 1)) + (Left . pure $ InsufficientForInstantaneousRewardsDELEG ReservesMIR $ Mismatch (Coin 2) (Coin 1)) , testCase "increment treasury too much with delta" $ testMirTransfer alonzoPV @@ -177,7 +177,7 @@ testMIRTransfer = (StakeAddressesMIR $ aliceOnlyDelta 1) (InstantaneousRewards mempty (aliceOnlyReward 1) (DeltaCoin 1) (DeltaCoin (-1))) (AccountState {asReserves = Coin 0, asTreasury = Coin 2}) - (Left . pure $ InsufficientForInstantaneousRewardsDELEG TreasuryMIR (Coin 2) (Coin 1)) + (Left . pure $ InsufficientForInstantaneousRewardsDELEG TreasuryMIR $ Mismatch (Coin 2) (Coin 1)) , testCase "negative balance in reserves mapping" $ testMirTransfer alonzoPV @@ -217,7 +217,7 @@ testMIRTransfer = (SendToOppositePotMIR (Coin 1)) (InstantaneousRewards (aliceOnlyReward 1) mempty (DeltaCoin (-1)) (DeltaCoin 1)) (AccountState {asReserves = Coin 2, asTreasury = Coin 0}) - (Left . pure $ InsufficientForTransferDELEG ReservesMIR (Coin 1) (Coin 0)) + (Left . pure $ InsufficientForTransferDELEG ReservesMIR $ Mismatch (Coin 1) (Coin 0)) , testCase "insufficient transfer treasury to reserves" $ testMirTransfer alonzoPV @@ -225,7 +225,7 @@ testMIRTransfer = (SendToOppositePotMIR (Coin 1)) (InstantaneousRewards mempty (aliceOnlyReward 1) (DeltaCoin 1) (DeltaCoin (-1))) (AccountState {asReserves = Coin 0, asTreasury = Coin 2}) - (Left . pure $ InsufficientForTransferDELEG TreasuryMIR (Coin 1) (Coin 0)) + (Left . pure $ InsufficientForTransferDELEG TreasuryMIR $ Mismatch (Coin 1) (Coin 0)) , testCase "increment reserves mapping" $ testMirTransfer alonzoPV diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/UnitTests.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/UnitTests.hs index 481e027c15a..39a62227f8d 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/UnitTests.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/UnitTests.hs @@ -357,7 +357,7 @@ testInvalidTx errs tx = testSpendNonexistentInput :: Assertion testSpendNonexistentInput = testInvalidTx - [ UtxowFailure (UtxoFailure (ValueNotConservedUTxO (Coin 0) (Coin 10000))) + [ UtxowFailure (UtxoFailure (ValueNotConservedUTxO $ Mismatch (Coin 0) (Coin 10000))) , UtxowFailure (UtxoFailure $ BadInputsUTxO (Set.singleton $ mkGenesisTxIn 42)) ] $ aliceGivesBobLovelace @@ -491,7 +491,9 @@ testFeeTooSmall = testExpiredTx :: Assertion testExpiredTx = - let errs = [UtxowFailure (UtxoFailure (ExpiredUTxO (SlotNo {unSlotNo = 0}) (SlotNo {unSlotNo = 1})))] + let errs = + [ UtxowFailure (UtxoFailure (ExpiredUTxO $ Mismatch (SlotNo {unSlotNo = 0}) (SlotNo {unSlotNo = 1}))) + ] tx = aliceGivesBobLovelace $ AliceToBob diff --git a/libs/cardano-ledger-api/cardano-ledger-api.cabal b/libs/cardano-ledger-api/cardano-ledger-api.cabal index c59c9d96d4d..95affb8edce 100644 --- a/libs/cardano-ledger-api/cardano-ledger-api.cabal +++ b/libs/cardano-ledger-api/cardano-ledger-api.cabal @@ -54,9 +54,9 @@ library base >=4.14 && <5, aeson >=2.2, bytestring, - cardano-ledger-allegra ^>=1.6, - cardano-ledger-alonzo >=1.9, - cardano-ledger-babbage >=1.10 && <=1.11, + cardano-ledger-allegra ^>=1.6.1, + cardano-ledger-alonzo >=1.12, + cardano-ledger-babbage >=1.10.1 && <=1.11, cardano-ledger-binary >=1.4, cardano-ledger-conway >=1.13 && <1.19, cardano-ledger-core ^>=1.15, 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 5dd9220d994..8b821e4c409 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 @@ -1666,11 +1666,11 @@ instance Reflect era => PrettyA (ConwayBbodyPredFailure era) where ppAlonzoBbodyPredFail :: Reflect era => AlonzoBbodyPredFailure era -> PDoc ppAlonzoBbodyPredFail (ShelleyInAlonzoBbodyPredFailure x) = ppSexp "ShelleyInAlonzoPredFail" [ppBbodyPredicateFailure x] -ppAlonzoBbodyPredFail (TooManyExUnits e1 e2) = +ppAlonzoBbodyPredFail (TooManyExUnits Mismatch {..}) = ppRecord "TooManyExUnits" - [ ("Computed Sum of ExUnits for all plutus scripts", pcExUnits e1) - , ("Maximum allowed by protocal parameters", pcExUnits e2) + [ ("Computed Sum of ExUnits for all plutus scripts", pcExUnits mismatchSupplied) + , ("Maximum allowed by protocal parameters", pcExUnits mismatchExpected) ] instance Reflect era => PrettyA (AlonzoBbodyPredFailure era) where @@ -1750,11 +1750,11 @@ ppAlonzoUtxowPredFailure (NotAllowedSupplementalDatums s1 s2) = [ ("unallowed data hashes", ppSet ppSafeHash s1) , ("acceptable data hashes", ppSet ppSafeHash s2) ] -ppAlonzoUtxowPredFailure (PPViewHashesDontMatch h1 h2) = +ppAlonzoUtxowPredFailure (PPViewHashesDontMatch Mismatch {..}) = ppRecord "PPViewHashesDontMatch" - [ ("PPHash in the TxBody", ppStrictMaybe ppSafeHash h1) - , ("PPHash Computed from the current Protocol Parameters", ppStrictMaybe ppSafeHash h2) + [ ("PPHash in the TxBody", ppStrictMaybe ppSafeHash mismatchSupplied) + , ("PPHash Computed from the current Protocol Parameters", ppStrictMaybe ppSafeHash mismatchExpected) ] ppAlonzoUtxowPredFailure (MissingRequiredSigners x) = ppSexp "MissingRequiredSigners" [ppSet pcKeyHash x] @@ -1814,19 +1814,23 @@ ppAlonzoUtxoPredFailure x = case x of [ ("provided interval", ppValidityInterval vi) , ("current slot", pcSlotNo slot) ] - Alonzo.MaxTxSizeUTxO actual maxs -> - ppRecord "MaxTxSizeUTxO" [("Actual", ppInteger actual), ("max transaction size", ppInteger maxs)] + Alonzo.MaxTxSizeUTxO Mismatch {..} -> + ppRecord + "MaxTxSizeUTxO" + [("Actual", ppInteger mismatchSupplied), ("max transaction size", ppInteger mismatchExpected)] Alonzo.InputSetEmptyUTxO -> ppString "InputSetEmptyUTxO" - Alonzo.FeeTooSmallUTxO computed supplied -> + Alonzo.FeeTooSmallUTxO Mismatch {..} -> ppRecord "FeeTooSmallUTxO" - [ ("min fee for this transaction", pcCoin computed) - , ("fee supplied by this transaction", pcCoin supplied) + [ ("min fee for this transaction", pcCoin mismatchExpected) + , ("fee supplied by this transaction", pcCoin mismatchSupplied) ] - Alonzo.ValueNotConservedUTxO consumed produced -> + Alonzo.ValueNotConservedUTxO Mismatch {..} -> ppRecord "ValueNotConservedUTxO" - [("coin consumed", pcVal @era reify consumed), ("coin produced", pcVal @era reify produced)] + [ ("coin consumed", pcVal @era reify mismatchSupplied) + , ("coin produced", pcVal @era reify mismatchExpected) + ] Alonzo.WrongNetwork n add -> ppRecord "WrongNetwork" @@ -1867,25 +1871,25 @@ ppAlonzoUtxoPredFailure x = case x of , ("the required collateral for the given fee", pcCoin c2) ] ScriptsNotPaidUTxO u -> ppSexp "ScriptsNotPaidUTxO" [pcUTxO reify u] - ExUnitsTooBigUTxO e1 e2 -> + ExUnitsTooBigUTxO Mismatch {..} -> ppRecord "ExUnitsTooBigUTxO" - [ ("Max EXUnits from the protocol parameters", pcExUnits e1) - , ("EXUnits supplied", pcExUnits e2) + [ ("Max EXUnits from the protocol parameters", pcExUnits mismatchExpected) + , ("EXUnits supplied", pcExUnits mismatchSupplied) ] CollateralContainsNonADA v -> ppSexp "CollateralContainsNonADA" [pcVal (reify @era) v] - WrongNetworkInTxBody n1 n2 -> + WrongNetworkInTxBody Mismatch {..} -> ppRecord "WrongNetworkInTxBody" - [ ("Actual Network ID", ppNetwork n1) - , ("Network ID in transaction body", ppNetwork n2) + [ ("Actual Network ID", ppNetwork mismatchExpected) + , ("Network ID in transaction body", ppNetwork mismatchSupplied) ] OutsideForecast slot -> ppRecord "OutsideForecast" [("slot number outside consensus forecast range", pcSlotNo slot)] - TooManyCollateralInputs n1 n2 -> + TooManyCollateralInputs Mismatch {..} -> ppRecord "TooManyCollateralInputs" - [ ("Max allowed collateral inputs", ppNatural n1) - , ("Number of collateral inputs", ppNatural n2) + [ ("Max allowed collateral inputs", ppNatural mismatchExpected) + , ("Number of collateral inputs", ppNatural mismatchSupplied) ] NoCollateralInputs -> ppSexp " NoCollateralInputs" [] @@ -1904,17 +1908,19 @@ ppShelleyDelegPredFailure x = case x of WrongCertificateTypeDELEG -> ppSexp "WrongCertificateTypeDELEG" [] GenesisKeyNotInMappingDELEG kh -> ppSexp "GenesisKeyNotInMappingDELEG" [pcKeyHash kh] DuplicateGenesisDelegateDELEG kh -> ppSexp "DuplicateGenesisDelegateDELEG" [pcKeyHash kh] - InsufficientForInstantaneousRewardsDELEG pot c1 c2 -> + InsufficientForInstantaneousRewardsDELEG pot Mismatch {..} -> ppSexp "InsufficientForInstantaneousRewardsDELEG" - [ppString (show pot), pcCoin c1, pcCoin c2] - MIRCertificateTooLateinEpochDELEG s1 s2 -> - ppSexp "MIRCertificateTooLateinEpochDELEG" [pcSlotNo s1, pcSlotNo s2] + [ppString (show pot), pcCoin mismatchSupplied, pcCoin mismatchExpected] + MIRCertificateTooLateinEpochDELEG Mismatch {..} -> + ppSexp "MIRCertificateTooLateinEpochDELEG" [pcSlotNo mismatchSupplied, pcSlotNo mismatchExpected] DuplicateGenesisVRFDELEG hash -> ppSexp "DuplicateGenesisVRFDELEG" [ppHash hash] MIRTransferNotCurrentlyAllowed -> ppString "MIRTransferNotCurrentlyAllowed" MIRNegativesNotCurrentlyAllowed -> ppString " MIRNegativesNotCurrentlyAllowed" - InsufficientForTransferDELEG pot c1 c2 -> - ppSexp "InsufficientForTransferDELEG" [ppString (show pot), pcCoin c1, pcCoin c2] + InsufficientForTransferDELEG pot Mismatch {..} -> + ppSexp + "InsufficientForTransferDELEG" + [ppString (show pot), pcCoin mismatchSupplied, pcCoin mismatchExpected] MIRProducesNegativeUpdate -> ppString "MIRProducesNegativeUpdate" MIRNegativeTransfer pot c1 -> ppSexp " MIRNegativeTransfer" [ppString (show pot), pcCoin c1] @@ -2103,8 +2109,12 @@ instance PrettyA FailureDescription where ppShelleyUtxoPredFailure :: forall era. Reflect era => ShelleyUtxoPredFailure era -> PDoc ppShelleyUtxoPredFailure (Shelley.BadInputsUTxO x) = ppSexp "BadInputsUTxO" [ppSet pcTxIn x] -ppShelleyUtxoPredFailure (Shelley.ExpiredUTxO ttl slot) = - ppRecord "ExpiredUTxO" [("transaction time to live", pcSlotNo ttl), ("current slot", pcSlotNo slot)] +ppShelleyUtxoPredFailure (Shelley.ExpiredUTxO Mismatch {..}) = + ppRecord + "ExpiredUTxO" + [ ("transaction time to live", pcSlotNo mismatchSupplied) + , ("current slot", pcSlotNo mismatchExpected) + ] ppShelleyUtxoPredFailure (Shelley.MaxTxSizeUTxO (Mismatch {mismatchSupplied = actual, mismatchExpected = maxs})) = ppRecord "MaxTxSizeUTxO" @@ -2119,7 +2129,7 @@ ppShelleyUtxoPredFailure (Shelley.FeeTooSmallUTxO (Mismatch {mismatchSupplied = [ ("min fee for this transaction", pcCoin computed) , ("fee supplied by this transaction", pcCoin supplied) ] -ppShelleyUtxoPredFailure (Shelley.ValueNotConservedUTxO consumed produced) = +ppShelleyUtxoPredFailure (Shelley.ValueNotConservedUTxO Mismatch {mismatchSupplied = consumed, mismatchExpected = produced}) = ppRecord "ValueNotConservedUTxO" [ ("coin consumed", pcVal @era reify consumed) @@ -2193,24 +2203,24 @@ ppAllegraUtxoPredFailure (Allegra.OutsideValidityIntervalUTxO vi slot) = [ ("provided interval", ppValidityInterval vi) , ("current slot", pcSlotNo slot) ] -ppAllegraUtxoPredFailure (Allegra.MaxTxSizeUTxO actual maxs) = +ppAllegraUtxoPredFailure (Allegra.MaxTxSizeUTxO Mismatch {..}) = ppRecord "MaxTxSizeUTxO" - [ ("Actual", ppInteger actual) - , ("max transaction size", ppInteger maxs) + [ ("Actual", ppInteger mismatchSupplied) + , ("max transaction size", ppInteger mismatchExpected) ] ppAllegraUtxoPredFailure (Allegra.InputSetEmptyUTxO) = ppSexp "InputSetEmptyUTxO" [] -ppAllegraUtxoPredFailure (Allegra.FeeTooSmallUTxO computed supplied) = +ppAllegraUtxoPredFailure (Allegra.FeeTooSmallUTxO Mismatch {..}) = ppRecord "FeeTooSmallUTxO" - [ ("min fee for this transaction", pcCoin computed) - , ("fee supplied by this transaction", pcCoin supplied) + [ ("min fee for this transaction", pcCoin mismatchExpected) + , ("fee supplied by this transaction", pcCoin mismatchSupplied) ] -ppAllegraUtxoPredFailure (Allegra.ValueNotConservedUTxO consumed produced) = +ppAllegraUtxoPredFailure (Allegra.ValueNotConservedUTxO Mismatch {..}) = ppRecord "ValueNotConservedUTxO" - [ ("coin consumed", pcVal @era reify consumed) - , ("coin produced", pcVal @era reify produced) + [ ("coin consumed", pcVal @era reify mismatchSupplied) + , ("coin produced", pcVal @era reify mismatchExpected) ] ppAllegraUtxoPredFailure (Allegra.WrongNetwork n add) = ppRecord