diff --git a/eras/allegra/impl/CHANGELOG.md b/eras/allegra/impl/CHANGELOG.md index 586f3ef931b..93ee6fcd74d 100644 --- a/eras/allegra/impl/CHANGELOG.md +++ b/eras/allegra/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.9.0.0 +* Add `AllegraApplyTxError` constructor for `ApplyTxError era` * Add `cddl` sub-library, and `generate-cddl` executable. * Remove deprecated type `Allegra` * Remove deprecated type `TimelockConstr` diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs index bda4a0bc88f..e7790429623 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs @@ -1,13 +1,17 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Ledger.Allegra ( AllegraEra, Tx (..), + ApplyTxError (..), ) where import Cardano.Ledger.Allegra.BlockBody () @@ -20,13 +24,22 @@ import Cardano.Ledger.Allegra.Transition () import Cardano.Ledger.Allegra.Translation () import Cardano.Ledger.Allegra.Tx (Tx (..)) import Cardano.Ledger.Allegra.UTxO () +import Cardano.Ledger.Binary (DecCBOR, EncCBOR) import Cardano.Ledger.Shelley.API +import Cardano.Ledger.Shelley.Rules (ShelleyLedgerPredFailure) +import Data.Bifunctor (Bifunctor (first)) +import Data.List.NonEmpty (NonEmpty) -------------------------------------------------------------------------------- -- Mempool instances -------------------------------------------------------------------------------- instance ApplyTx AllegraEra where - applyTxValidation = ruleApplyTxValidation @"LEDGER" + newtype ApplyTxError AllegraEra = AllegraApplyTxError (NonEmpty (ShelleyLedgerPredFailure AllegraEra)) + deriving (Eq, Show) + deriving newtype (EncCBOR, DecCBOR) + applyTxValidation validationPolicy globals env state tx = + first AllegraApplyTxError $ + ruleApplyTxValidation @"LEDGER" validationPolicy globals env state tx instance ApplyBlock AllegraEra diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Arbitrary.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Arbitrary.hs index a65de14b582..7d0ac877454 100644 --- a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Arbitrary.hs +++ b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Arbitrary.hs @@ -19,7 +19,7 @@ module Test.Cardano.Ledger.Allegra.Arbitrary ( maxTimelockDepth, ) where -import Cardano.Ledger.Allegra (AllegraEra, Tx (..)) +import Cardano.Ledger.Allegra (AllegraEra, ApplyTxError (..), Tx (..)) import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure) import Cardano.Ledger.Allegra.Scripts ( AllegraEraScript (..), @@ -132,3 +132,5 @@ instance Arbitrary ValidityInterval where deriving newtype instance Arbitrary (TransitionConfig AllegraEra) deriving newtype instance Arbitrary (Tx TopTx AllegraEra) + +deriving newtype instance Arbitrary (ApplyTxError AllegraEra) diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Examples.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Examples.hs index c88dce8c217..f55c530cc9b 100644 --- a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Examples.hs +++ b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Examples.hs @@ -41,7 +41,7 @@ import Test.Cardano.Ledger.Shelley.Examples ( mkWitnessesPreAlonzo, ) -ledgerExamples :: LedgerExamples AllegraEra +ledgerExamples :: LedgerExamples "LEDGER" AllegraEra ledgerExamples = mkLedgerExamples (mkWitnessesPreAlonzo (Proxy @AllegraEra)) diff --git a/eras/alonzo/impl/CHANGELOG.md b/eras/alonzo/impl/CHANGELOG.md index f50ef7b70b7..64d791409a7 100644 --- a/eras/alonzo/impl/CHANGELOG.md +++ b/eras/alonzo/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.15.0.0 +* Add `AlonzoApplyTxError` constructor for `ApplyTxError era` * Changed the type of `dappMinUTxOValue` to `CompactForm Coin` in `DowngradeAlonzoPParams` * Changed the type of the following fields to `CompactForm Coin` in `AlonzoPParams`: - `appMinFeeA` diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs index b144d6849b8..8a721264431 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs @@ -1,9 +1,12 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -15,6 +18,7 @@ module Cardano.Ledger.Alonzo ( AlonzoScript, AlonzoTxAuxData, Tx (..), + ApplyTxError (..), ) where import Cardano.Ledger.Alonzo.BlockBody () @@ -31,13 +35,22 @@ import Cardano.Ledger.Alonzo.TxAuxData (AlonzoTxAuxData) import Cardano.Ledger.Alonzo.TxBody (AlonzoTxOut, TxBody (AlonzoTxBody)) import Cardano.Ledger.Alonzo.TxWits () import Cardano.Ledger.Alonzo.UTxO () +import Cardano.Ledger.Binary (DecCBOR, EncCBOR) import Cardano.Ledger.Mary.Value (MaryValue) import Cardano.Ledger.Plutus.Data () import Cardano.Ledger.Shelley.API +import Cardano.Ledger.Shelley.Rules (ShelleyLedgerPredFailure) +import Data.Bifunctor (Bifunctor (first)) +import Data.List.NonEmpty (NonEmpty) -- ===================================================== instance ApplyTx AlonzoEra where - applyTxValidation = ruleApplyTxValidation @"LEDGER" + newtype ApplyTxError AlonzoEra = AlonzoApplyTxError (NonEmpty (ShelleyLedgerPredFailure AlonzoEra)) + deriving (Eq, Show) + deriving newtype (EncCBOR, DecCBOR) + applyTxValidation validationPolicy globals env state tx = + first AlonzoApplyTxError $ + ruleApplyTxValidation @"LEDGER" validationPolicy globals env state tx instance ApplyBlock AlonzoEra diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs index abae6874f64..01dc1a8d6f1 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs @@ -32,7 +32,7 @@ module Test.Cardano.Ledger.Alonzo.Arbitrary ( genAlonzoPlutusPurposePointer, ) where -import Cardano.Ledger.Alonzo (AlonzoEra, Tx (..)) +import Cardano.Ledger.Alonzo (AlonzoEra, ApplyTxError (..), Tx (..)) import Cardano.Ledger.Alonzo.Core import Cardano.Ledger.Alonzo.Genesis (AlonzoExtraConfig (..), AlonzoGenesis (..)) import Cardano.Ledger.Alonzo.PParams ( @@ -468,6 +468,8 @@ instance Arbitrary (TransitionConfig AlonzoEra) where deriving newtype instance Arbitrary (Tx TopTx AlonzoEra) +deriving newtype instance Arbitrary (ApplyTxError AlonzoEra) + instance ( EraBlockBody era , AlonzoEraTx era diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Examples.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Examples.hs index d878bfd368d..1566401d813 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Examples.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Examples.hs @@ -33,7 +33,6 @@ import Cardano.Ledger.Mary.Value (MaryValue (..)) import Cardano.Ledger.Plutus.Data (Data (..), hashData) import Cardano.Ledger.Plutus.Language (Language (..)) import Cardano.Ledger.Shelley.API ( - ApplyTxError (..), Credential (..), Network (..), NewEpochState (..), @@ -42,11 +41,16 @@ import Cardano.Ledger.Shelley.API ( TxId (..), Update (..), ) -import Cardano.Ledger.Shelley.Rules (ShelleyDelegsPredFailure (..), ShelleyLedgerPredFailure (..)) +import Cardano.Ledger.Shelley.Rules ( + PredicateFailure, + ShelleyDelegsPredFailure (..), + ShelleyLedgerPredFailure (..), + ) import Cardano.Ledger.Shelley.Scripts import Cardano.Ledger.TxIn (mkTxInPartial) import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..)) import Data.Default (def) +import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as Map import qualified Data.Sequence.Strict as StrictSeq import qualified Data.Set as Set @@ -72,13 +76,12 @@ import Test.Cardano.Ledger.Shelley.Examples ( testShelleyGenesis, ) -ledgerExamples :: LedgerExamples AlonzoEra +ledgerExamples :: LedgerExamples "LEDGER" AlonzoEra ledgerExamples = mkLedgerExamples - ( ApplyTxError $ - pure $ - DelegsFailure $ - DelegateeNotRegisteredDELEG @AlonzoEra (mkKeyHash 1) + ( pure $ + DelegsFailure $ + DelegateeNotRegisteredDELEG @AlonzoEra (mkKeyHash 1) ) exampleAlonzoNewEpochState exampleTxAlonzo @@ -87,11 +90,11 @@ ledgerExamples = mkLedgerExamples :: forall era. AlonzoEraPParams era => - ApplyTxError era -> + NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> NewEpochState era -> Tx TopTx era -> TranslationContext era -> - LedgerExamples era + LedgerExamples "LEDGER" era mkLedgerExamples applyTxError newEpochState diff --git a/eras/babbage/impl/CHANGELOG.md b/eras/babbage/impl/CHANGELOG.md index 739bbcd94c1..64697f78310 100644 --- a/eras/babbage/impl/CHANGELOG.md +++ b/eras/babbage/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.13.0.0 +* Add `BabbageApplyTxError` constructor for `ApplyTxError era` * Add `babbageUtxoValidation` * Add `babbageUtxoTests` * Changed the type of the following fields to `CompactForm Coin` in `BabbagePParams`: diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs index ed618626097..f24c520f5df 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs @@ -1,7 +1,10 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -10,6 +13,7 @@ module Cardano.Ledger.Babbage ( BabbageTxOut, TxBody (BabbageTxBody), Tx (..), + ApplyTxError (..), AlonzoScript, AlonzoTxAuxData, ) where @@ -26,11 +30,20 @@ import Cardano.Ledger.Babbage.Tx (Tx (..)) import Cardano.Ledger.Babbage.TxBody (BabbageTxOut, TxBody (BabbageTxBody)) import Cardano.Ledger.Babbage.TxInfo () import Cardano.Ledger.Babbage.UTxO () +import Cardano.Ledger.Binary (DecCBOR, EncCBOR) import Cardano.Ledger.Shelley.API +import Cardano.Ledger.Shelley.Rules (ShelleyLedgerPredFailure) +import Data.Bifunctor (Bifunctor (first)) +import Data.List.NonEmpty (NonEmpty) -- ===================================================== instance ApplyTx BabbageEra where - applyTxValidation = ruleApplyTxValidation @"LEDGER" + newtype ApplyTxError BabbageEra = BabbageApplyTxError (NonEmpty (ShelleyLedgerPredFailure BabbageEra)) + deriving (Eq, Show) + deriving newtype (EncCBOR, DecCBOR) + applyTxValidation validationPolicy globals env state tx = + first BabbageApplyTxError $ + ruleApplyTxValidation @"LEDGER" validationPolicy globals env state tx instance ApplyBlock BabbageEra diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Arbitrary.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Arbitrary.hs index fb27a98fa05..09310d88965 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Arbitrary.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Arbitrary.hs @@ -150,3 +150,5 @@ instance Arbitrary (TxBody TopTx BabbageEra) where deriving newtype instance Arbitrary (TransitionConfig BabbageEra) deriving newtype instance Arbitrary (Tx TopTx BabbageEra) + +deriving newtype instance Arbitrary (ApplyTxError BabbageEra) diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Examples.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Examples.hs index 2005bf3fcd4..97a1e4c47ef 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Examples.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Examples.hs @@ -27,7 +27,6 @@ import Cardano.Ledger.Plutus.Data ( ) import Cardano.Ledger.Plutus.Language (Language (..)) import Cardano.Ledger.Shelley.API ( - ApplyTxError (..), Network (..), NewEpochState (..), ProposedPPUpdates (..), @@ -59,13 +58,12 @@ import Test.Cardano.Ledger.Shelley.Examples ( mkKeyHash, ) -ledgerExamples :: LedgerExamples BabbageEra +ledgerExamples :: LedgerExamples "LEDGER" BabbageEra ledgerExamples = mkLedgerExamples - ( ApplyTxError $ - pure $ - DelegsFailure $ - DelegateeNotRegisteredDELEG @BabbageEra (mkKeyHash 1) + ( pure $ + DelegsFailure $ + DelegateeNotRegisteredDELEG @BabbageEra (mkKeyHash 1) ) exampleBabbageNewEpochState exampleTxBabbage diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index 0831a8fecad..3743c227fb9 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.21.0.0 +* Add `ConwayApplyTxError` constructor for `ApplyTxError era` * Re-export `UtxoEnv` from `Cardano.Ledger.Conway.Rules.Utxo` * Changed the type of the following fields to `CompactForm Coin` in `ConwayPParams`: - `cppMinFeeA` diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 48106cf73c0..7de1d225ee9 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -149,6 +149,7 @@ library testlib Test.Cardano.Ledger.Conway.Imp.GovSpec Test.Cardano.Ledger.Conway.Imp.HardForkSpec Test.Cardano.Ledger.Conway.Imp.LedgerSpec + Test.Cardano.Ledger.Conway.Imp.MempoolSpec Test.Cardano.Ledger.Conway.Imp.RatifySpec Test.Cardano.Ledger.Conway.Imp.UtxoSpec Test.Cardano.Ledger.Conway.Imp.UtxosSpec diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway.hs b/eras/conway/impl/src/Cardano/Ledger/Conway.hs index a55588003a2..96d671dfc43 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -12,9 +14,11 @@ module Cardano.Ledger.Conway ( hardforkConwayDELEGIncorrectDepositsAndRefunds, hardforkConwayMoveWithdrawalsAndDRepChecksToLedgerRule, Tx (..), + ApplyTxError (..), ) where import Cardano.Ledger.Babbage.TxBody () +import Cardano.Ledger.BaseTypes (Inject (..)) import Cardano.Ledger.Conway.BlockBody () import Cardano.Ledger.Conway.Era ( ConwayEra, @@ -24,7 +28,7 @@ import Cardano.Ledger.Conway.Era ( hardforkConwayMoveWithdrawalsAndDRepChecksToLedgerRule, ) import Cardano.Ledger.Conway.Governance (RunConwayRatify (..)) -import Cardano.Ledger.Conway.Rules () +import Cardano.Ledger.Conway.Rules (ConwayLedgerPredFailure) import Cardano.Ledger.Conway.State () import Cardano.Ledger.Conway.Transition () import Cardano.Ledger.Conway.Translation () @@ -33,12 +37,21 @@ import Cardano.Ledger.Conway.TxInfo () import Cardano.Ledger.Conway.TxOut () import Cardano.Ledger.Conway.UTxO () import Cardano.Ledger.Shelley.API +import Data.Bifunctor (Bifunctor (first)) +import Data.List.NonEmpty (NonEmpty) -- ===================================================== instance ApplyTx ConwayEra where - applyTxValidation = ruleApplyTxValidation @"MEMPOOL" + newtype ApplyTxError ConwayEra = ConwayApplyTxError (NonEmpty (ConwayLedgerPredFailure ConwayEra)) + deriving (Eq, Show) + applyTxValidation validationPolicy globals env state tx = + first ConwayApplyTxError $ + ruleApplyTxValidation @"MEMPOOL" validationPolicy globals env state tx instance ApplyBlock ConwayEra instance RunConwayRatify ConwayEra + +instance Inject (NonEmpty (ConwayLedgerPredFailure ConwayEra)) (ApplyTxError ConwayEra) where + inject = ConwayApplyTxError diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Examples.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Examples.hs index 0116b6f30ad..eb3dfc803e4 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Examples.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Examples.hs @@ -28,7 +28,6 @@ import Cardano.Ledger.Plutus.Data ( ) import Cardano.Ledger.Plutus.Language (Language (..)) import Cardano.Ledger.Shelley.API ( - ApplyTxError (..), RewardAccount (..), TxId (..), ) @@ -60,13 +59,12 @@ import Test.Cardano.Ledger.Shelley.Examples ( mkKeyHash, ) -ledgerExamples :: LedgerExamples ConwayEra +ledgerExamples :: LedgerExamples "LEDGER" ConwayEra ledgerExamples = mkLedgerExamples - ( ApplyTxError $ - pure $ - wrapFailed @(ConwayDELEG ConwayEra) @(ConwayLEDGER ConwayEra) $ - DelegateeStakePoolNotRegisteredDELEG @ConwayEra (mkKeyHash 1) + ( pure $ + wrapFailed @(ConwayDELEG ConwayEra) @(ConwayLEDGER ConwayEra) $ + DelegateeStakePoolNotRegisteredDELEG @ConwayEra (mkKeyHash 1) ) exampleBabbageNewEpochState exampleTxConway diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs index ba49713b141..893a7895d76 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs @@ -28,6 +28,7 @@ import qualified Test.Cardano.Ledger.Conway.Imp.GovCertSpec as GovCert import qualified Test.Cardano.Ledger.Conway.Imp.GovSpec as Gov import qualified Test.Cardano.Ledger.Conway.Imp.HardForkSpec as HardFork import qualified Test.Cardano.Ledger.Conway.Imp.LedgerSpec as Ledger +import qualified Test.Cardano.Ledger.Conway.Imp.MempoolSpec as Mempool import qualified Test.Cardano.Ledger.Conway.Imp.RatifySpec as Ratify import qualified Test.Cardano.Ledger.Conway.Imp.UtxoSpec as Utxo import qualified Test.Cardano.Ledger.Conway.Imp.UtxosSpec as Utxos @@ -75,6 +76,7 @@ conwayEraSpecificSpec :: SpecWith (ImpInit (LedgerSpec ConwayEra)) conwayEraSpecificSpec = do describe "Conway era specific Imp spec" $ do describe "UTXO" Utxo.conwayEraSpecificSpec + describe "MEMPOOL" Mempool.conwayEraSpecificSpec instance EraSpecificSpec ConwayEra where eraSpecificSpec = 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 a069f9879bb..58e710f6933 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 @@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Test.Cardano.Ledger.Conway.Imp.LedgerSpec (spec) where @@ -13,31 +14,20 @@ import Cardano.Ledger.BaseTypes import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Conway ( hardforkConwayBootstrapPhase, - hardforkConwayDisallowUnelectedCommitteeFromVoting, ) import Cardano.Ledger.Conway.Core -import Cardano.Ledger.Conway.Governance import Cardano.Ledger.Conway.PParams (ConwayEraPParams (..)) import Cardano.Ledger.Conway.Rules ( - ConwayGovPredFailure (UnelectedCommitteeVoters), ConwayLedgerPredFailure (..), - ConwayUtxoPredFailure (BadInputsUTxO), ) import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.DRep import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript) -import Cardano.Ledger.Shelley.API.Mempool (ApplyTxError (..), applyTx, mkMempoolEnv) import Cardano.Ledger.Shelley.LedgerState -import Control.Monad.Reader (asks) -import qualified Data.Map.Strict as Map import qualified Data.Set as Set -import qualified Data.Text as T import Data.Word (Word32) -import GHC.Exts (fromList) -import Lens.Micro ((&), (.~), (<>~), (^.)) -import Lens.Micro.Mtl (use) +import Lens.Micro ((&), (.~), (^.)) import Test.Cardano.Ledger.Conway.ImpTest -import Test.Cardano.Ledger.Core.Rational (IsRatio (..)) import Test.Cardano.Ledger.Imp.Common import Test.Cardano.Ledger.Plutus.Examples ( alwaysSucceedsNoDatum, @@ -209,90 +199,3 @@ spec = do submitTx_ $ mkBasicTx $ mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(ra, mempty)] - - describe "Mempool" $ do - let - submitFailingMempoolTx cause tx expectedFailures = do - globals <- use impGlobalsL - nes <- use impNESL - slotNo <- use impCurSlotNoG - let - mempoolEnv = mkMempoolEnv nes slotNo - ls = nes ^. nesEsL . esLStateL - txFixed <- (tx &) =<< asks iteFixup - logToExpr txFixed - case applyTx globals mempoolEnv ls txFixed of - Left err -> do - err `shouldBe` ApplyTxError @era expectedFailures - Right _ -> - assertFailure $ "Expected failure due to " <> cause <> ": " <> show txFixed - pure txFixed - submitFailingMempoolTx_ c t = void . submitFailingMempoolTx c t - - it "Duplicate transactions" $ do - let - newInput = do - addr <- freshKeyAddr_ - amount <- Coin <$> choose (2_000_000, 8_000_000) - sendCoinTo addr amount - - inputsCommon <- replicateM 5 newInput - inputs1 <- replicateM 2 newInput - inputs2 <- replicateM 3 newInput - - txFinal <- - submitTx $ - mkBasicTx $ - mkBasicTxBody & inputsTxBodyL <>~ fromList (inputsCommon <> inputs1) - - impAnn "Identical transaction" $ do - withNoFixup $ - submitFailingMempoolTx_ "duplicate transaction" txFinal $ - pure . injectFailure . ConwayMempoolFailure $ - "All inputs are spent. Transaction has probably already been included" - - impAnn "Overlapping transaction" $ do - let txOverlap = mkBasicTx $ mkBasicTxBody & inputsTxBodyL <>~ fromList (inputsCommon <> inputs2) - submitFailingMempoolTx_ - "overlapping transaction" - txOverlap - [injectFailure $ BadInputsUTxO $ fromList inputsCommon] - - it "Unelected Committee voting" $ whenPostBootstrap $ do - _ <- registerInitialCommittee - ccCold <- KeyHashObj <$> freshKeyHash - curEpochNo <- getsNES nesELL - let action = - UpdateCommittee - SNothing - mempty - (Map.singleton ccCold (addEpochInterval curEpochNo (EpochInterval 7))) - (1 %! 1) - proposal <- mkProposal action - submitTx_ $ - mkBasicTx (mkBasicTxBody & proposalProceduresTxBodyL .~ [proposal]) - ccHot <- registerCommitteeHotKey ccCold - govActionId <- do - rewardAccount <- registerRewardAccount - submitTreasuryWithdrawals [(rewardAccount, Coin 1)] - - let - tx = - mkBasicTx $ - mkBasicTxBody - & votingProceduresTxBodyL - .~ VotingProcedures - ( Map.singleton - (CommitteeVoter ccHot) - (Map.singleton govActionId (VotingProcedure VoteYes SNothing)) - ) - pv <- getProtVer - if hardforkConwayDisallowUnelectedCommitteeFromVoting pv - then - submitFailingTx tx [injectFailure $ UnelectedCommitteeVoters [ccHot]] - else do - txFixed <- - submitFailingMempoolTx "unallowed votes" tx $ - pure . injectFailure . ConwayMempoolFailure $ - "Unelected committee members are not allowed to cast votes: " <> T.pack (show (pure @[] ccHot)) - withNoFixup $ submitTx_ txFixed diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/MempoolSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/MempoolSpec.hs new file mode 100644 index 00000000000..d5c14fb341b --- /dev/null +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/MempoolSpec.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Cardano.Ledger.Conway.Imp.MempoolSpec (conwayEraSpecificSpec) where + +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Conway ( + hardforkConwayDisallowUnelectedCommitteeFromVoting, + ) +import Cardano.Ledger.Conway.Core +import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Conway.Rules ( + ConwayGovPredFailure (UnelectedCommitteeVoters), + ConwayLedgerPredFailure (..), + ConwayUtxoPredFailure (BadInputsUTxO), + PredicateFailure, + ) +import Cardano.Ledger.Credential (Credential (..)) +import Cardano.Ledger.Shelley.API.Mempool (applyTx, mkMempoolEnv) +import Cardano.Ledger.Shelley.LedgerState +import Control.Monad.Reader (asks) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import GHC.Exts (fromList) +import Lens.Micro ((&), (.~), (<>~), (^.)) +import Lens.Micro.Mtl (use) +import Test.Cardano.Ledger.Conway.ImpTest +import Test.Cardano.Ledger.Core.Rational (IsRatio (..)) +import Test.Cardano.Ledger.Imp.Common + +conwayEraSpecificSpec :: + forall era. + ConwayEraImp era => + SpecWith (ImpInit (LedgerSpec era)) +conwayEraSpecificSpec = + describe "Mempool" $ do + let + submitFailingMempoolTx :: + String -> + Tx TopTx era -> + NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> + ImpM (LedgerSpec era) (Tx TopTx era) + submitFailingMempoolTx cause tx expectedFailures = do + globals <- use impGlobalsL + nes <- use impNESL + slotNo <- use impCurSlotNoG + let + mempoolEnv = mkMempoolEnv nes slotNo + ls = nes ^. nesEsL . esLStateL + txFixed <- (tx &) =<< asks iteFixup + logToExpr txFixed + case applyTx globals mempoolEnv ls txFixed of + Left err -> do + err `shouldBe` inject expectedFailures + Right _ -> + assertFailure $ "Expected failure due to " <> cause <> ": " <> show txFixed + pure txFixed + + submitFailingMempoolTx_ :: + String -> + Tx TopTx era -> + NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> + ImpM (LedgerSpec era) () + submitFailingMempoolTx_ c t = void . submitFailingMempoolTx c t + + it "Duplicate transactions" $ do + let + newInput = do + addr <- freshKeyAddr_ + amount <- Coin <$> choose (2_000_000, 8_000_000) + sendCoinTo addr amount + + inputsCommon <- replicateM 5 newInput + inputs1 <- replicateM 2 newInput + inputs2 <- replicateM 3 newInput + + txFinal <- + submitTx $ + mkBasicTx $ + mkBasicTxBody & inputsTxBodyL <>~ fromList (inputsCommon <> inputs1) + + impAnn "Identical transaction" $ do + withNoFixup $ + submitFailingMempoolTx_ "duplicate transaction" txFinal $ + NonEmpty.singleton . injectFailure . ConwayMempoolFailure $ + "All inputs are spent. Transaction has probably already been included" + + impAnn "Overlapping transaction" $ do + let txOverlap = mkBasicTx $ mkBasicTxBody & inputsTxBodyL <>~ fromList (inputsCommon <> inputs2) + submitFailingMempoolTx_ + "overlapping transaction" + txOverlap + [injectFailure $ BadInputsUTxO $ fromList inputsCommon] + + it "Unelected Committee voting" $ whenPostBootstrap $ do + _ <- registerInitialCommittee + ccCold <- KeyHashObj <$> freshKeyHash + curEpochNo <- getsNES nesELL + let action = + UpdateCommittee + SNothing + mempty + (Map.singleton ccCold (addEpochInterval curEpochNo (EpochInterval 7))) + (1 %! 1) + proposal <- mkProposal action + submitTx_ $ + mkBasicTx (mkBasicTxBody & proposalProceduresTxBodyL .~ [proposal]) + ccHot <- registerCommitteeHotKey ccCold + govActionId <- do + rewardAccount <- registerRewardAccount + submitTreasuryWithdrawals [(rewardAccount, Coin 1)] + + let + tx = + mkBasicTx $ + mkBasicTxBody + & votingProceduresTxBodyL + .~ VotingProcedures + ( Map.singleton + (CommitteeVoter ccHot) + (Map.singleton govActionId (VotingProcedure VoteYes SNothing)) + ) + pv <- getProtVer + if hardforkConwayDisallowUnelectedCommitteeFromVoting pv + then + submitFailingTx tx [injectFailure $ UnelectedCommitteeVoters [ccHot]] + else do + txFixed <- + submitFailingMempoolTx "unallowed votes" tx $ + pure . injectFailure . ConwayMempoolFailure $ + "Unelected committee members are not allowed to cast votes: " <> T.pack (show (pure @[] ccHot)) + withNoFixup $ submitTx_ txFixed diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs index b250cec1df9..fab0ecf955a 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs @@ -140,6 +140,7 @@ import Cardano.Ledger.Address (RewardAccount (..)) import Cardano.Ledger.BaseTypes ( EpochInterval (..), EpochNo (..), + Inject, ProtVer (..), ShelleyBase, StrictMaybe (..), @@ -186,6 +187,7 @@ import Cardano.Ledger.Conway.TxCert (Delegatee (..)) import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.DRep import Cardano.Ledger.Plutus.Language (Language (..), SLanguage (..), hashPlutusScript) +import Cardano.Ledger.Shelley.API (ApplyTxError) import Cardano.Ledger.Shelley.LedgerState ( curPParamsEpochStateL, epochStateGovStateL, @@ -367,6 +369,7 @@ class , InjectRuleFailure "BBODY" ConwayBbodyPredFailure era , InjectRuleEvent "TICK" ConwayHardForkEvent era , InjectRuleEvent "TICK" ConwayEpochEvent era + , Inject (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) (ApplyTxError era) ) => ConwayEraImp era diff --git a/eras/dijkstra/impl/CHANGELOG.md b/eras/dijkstra/impl/CHANGELOG.md index 02f838fdffd..0752a4e0e88 100644 --- a/eras/dijkstra/impl/CHANGELOG.md +++ b/eras/dijkstra/impl/CHANGELOG.md @@ -2,6 +2,9 @@ ## 0.2.0.0 +* Move the `DijkstraMempoolFailure` constructor from `DijkstraLedgerPredFailure` to `DijkstraMempoolPredFailure` +* Add the `DijkstraMempoolPredFailure` predicate failure for the MEMPOOL rule +* Add `DijkstraApplyTxError` constructor for `ApplyTxError era` * Add `DijkstraBlockBody` type and pattern * Add `mkBasicBlockBodyDijkstra` * Add `DijkstraEraBlockBody` class and instance for `DijkstraEraBlockBody` diff --git a/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal b/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal index bc36921fc24..208aa1ef7bf 100644 --- a/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal +++ b/eras/dijkstra/impl/cardano-ledger-dijkstra.cabal @@ -103,7 +103,6 @@ library nothunks, plutus-ledger-api, small-steps >=1.1.2, - text, if flag(asserts) ghc-options: -fno-ignore-asserts @@ -121,6 +120,7 @@ library testlib Test.Cardano.Ledger.Dijkstra.Era Test.Cardano.Ledger.Dijkstra.Examples Test.Cardano.Ledger.Dijkstra.Imp + Test.Cardano.Ledger.Dijkstra.Imp.MempoolSpec Test.Cardano.Ledger.Dijkstra.Imp.UtxoSpec Test.Cardano.Ledger.Dijkstra.Imp.UtxowSpec Test.Cardano.Ledger.Dijkstra.ImpTest @@ -154,9 +154,12 @@ library testlib cardano-strict-containers, containers, cuddle >=0.4, + data-default, generic-random, heredoc, microlens, + microlens-mtl, + mtl, small-steps, tree-diff, diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra.hs index 3c68093d6f1..6ea18b0bf08 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra.hs @@ -1,15 +1,23 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Ledger.Dijkstra (DijkstraEra) where +import Cardano.Ledger.BaseTypes (Inject (inject)) import Cardano.Ledger.Conway.Governance (RunConwayRatify) import Cardano.Ledger.Dijkstra.BlockBody () import Cardano.Ledger.Dijkstra.Era import Cardano.Ledger.Dijkstra.Genesis () import Cardano.Ledger.Dijkstra.Governance () -import Cardano.Ledger.Dijkstra.Rules () +import Cardano.Ledger.Dijkstra.Rules ( + DijkstraLedgerPredFailure, + DijkstraMempoolPredFailure (LedgerFailure), + ) import Cardano.Ledger.Dijkstra.Scripts () import Cardano.Ledger.Dijkstra.State.CertState () import Cardano.Ledger.Dijkstra.State.Stake () @@ -21,10 +29,22 @@ import Cardano.Ledger.Dijkstra.TxInfo () import Cardano.Ledger.Dijkstra.TxWits () import Cardano.Ledger.Dijkstra.UTxO () import Cardano.Ledger.Shelley.API (ApplyBlock, ApplyTx (..), ruleApplyTxValidation) +import Data.Bifunctor (Bifunctor (first)) +import Data.List.NonEmpty (NonEmpty) instance ApplyTx DijkstraEra where - applyTxValidation = ruleApplyTxValidation @"MEMPOOL" + newtype ApplyTxError DijkstraEra = DijkstraApplyTxError (NonEmpty (DijkstraMempoolPredFailure DijkstraEra)) + deriving (Eq, Show) + applyTxValidation validationPolicy globals env state tx = + first DijkstraApplyTxError $ + ruleApplyTxValidation @"MEMPOOL" validationPolicy globals env state tx instance ApplyBlock DijkstraEra instance RunConwayRatify DijkstraEra + +instance Inject (NonEmpty (DijkstraMempoolPredFailure DijkstraEra)) (ApplyTxError DijkstraEra) where + inject = DijkstraApplyTxError + +instance Inject (NonEmpty (DijkstraLedgerPredFailure DijkstraEra)) (ApplyTxError DijkstraEra) where + inject = DijkstraApplyTxError . fmap LedgerFailure diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules.hs index 83f0ff789d0..f65f0e532e7 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules.hs @@ -12,6 +12,7 @@ module Cardano.Ledger.Dijkstra.Rules ( module Cardano.Ledger.Dijkstra.Rules.Mempool, module Cardano.Ledger.Dijkstra.Rules.Utxo, module Cardano.Ledger.Dijkstra.Rules.Utxow, + module Control.State.Transition.Extended, ) where import Cardano.Ledger.Conway.Rules ( @@ -35,6 +36,7 @@ import Cardano.Ledger.Dijkstra.Rules.Utxo import Cardano.Ledger.Dijkstra.Rules.Utxos () import Cardano.Ledger.Dijkstra.Rules.Utxow import Cardano.Ledger.Shelley.Rules (ShelleyTickEvent (..)) +import Control.State.Transition.Extended (STS (PredicateFailure)) type instance EraRuleEvent "TICK" DijkstraEra = ShelleyTickEvent DijkstraEra diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Ledger.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Ledger.hs index d43e7051882..9c3a81e41d4 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Ledger.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Ledger.hs @@ -17,6 +17,7 @@ module Cardano.Ledger.Dijkstra.Rules.Ledger ( DijkstraLEDGER, DijkstraLedgerPredFailure (..), + shelleyToDijkstraLedgerPredFailure, conwayToDijkstraLedgerPredFailure, ) where @@ -70,7 +71,6 @@ import Cardano.Ledger.Conway.Rules ( GovEnv (..), GovSignal (..), conwayLedgerTransition, - shelleyToConwayLedgerPredFailure, ) import qualified Cardano.Ledger.Conway.Rules as Conway import Cardano.Ledger.Conway.State @@ -105,7 +105,6 @@ import Control.State.Transition.Extended ( import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as Map import Data.Sequence (Seq) -import Data.Text (Text) import GHC.Generics (Generic (..)) import NoThunks.Class (NoThunks (..)) @@ -116,7 +115,6 @@ data DijkstraLedgerPredFailure era | DijkstraWdrlNotDelegatedToDRep (NonEmpty (KeyHash Staking)) | DijkstraTreasuryValueMismatch (Mismatch RelEQ Coin) | DijkstraTxRefScriptsSizeTooBig (Mismatch RelLTEQ Int) - | DijkstraMempoolFailure Text | DijkstraWithdrawalsMissingAccounts Withdrawals | DijkstraIncompleteWithdrawals (Map.Map RewardAccount (Mismatch RelEQ Coin)) deriving (Generic) @@ -131,7 +129,7 @@ instance InjectRuleFailure "LEDGER" ConwayLedgerPredFailure DijkstraEra where injectFailure = conwayToDijkstraLedgerPredFailure instance InjectRuleFailure "LEDGER" ShelleyLedgerPredFailure DijkstraEra where - injectFailure = conwayToDijkstraLedgerPredFailure . shelleyToConwayLedgerPredFailure + injectFailure = shelleyToDijkstraLedgerPredFailure instance InjectRuleFailure "LEDGER" DijkstraUtxowPredFailure DijkstraEra where injectFailure = DijkstraUtxowFailure @@ -244,9 +242,8 @@ instance DijkstraWdrlNotDelegatedToDRep x -> Sum (DijkstraWdrlNotDelegatedToDRep @era) 4 !> To x DijkstraTreasuryValueMismatch mm -> Sum (DijkstraTreasuryValueMismatch @era) 5 !> To mm DijkstraTxRefScriptsSizeTooBig mm -> Sum DijkstraTxRefScriptsSizeTooBig 6 !> To mm - DijkstraMempoolFailure t -> Sum DijkstraMempoolFailure 7 !> To t - DijkstraWithdrawalsMissingAccounts w -> Sum DijkstraWithdrawalsMissingAccounts 8 !> To w - DijkstraIncompleteWithdrawals w -> Sum DijkstraIncompleteWithdrawals 9 !> To w + DijkstraWithdrawalsMissingAccounts w -> Sum DijkstraWithdrawalsMissingAccounts 7 !> To w + DijkstraIncompleteWithdrawals w -> Sum DijkstraIncompleteWithdrawals 8 !> To w instance ( Era era @@ -263,9 +260,8 @@ instance 4 -> SumD DijkstraWdrlNotDelegatedToDRep SumD DijkstraTreasuryValueMismatch SumD DijkstraTxRefScriptsSizeTooBig SumD DijkstraMempoolFailure SumD DijkstraWithdrawalsMissingAccounts SumD DijkstraIncompleteWithdrawals SumD DijkstraWithdrawalsMissingAccounts SumD DijkstraIncompleteWithdrawals Invalid n instance @@ -390,10 +386,18 @@ conwayToDijkstraLedgerPredFailure = \case Conway.ConwayWdrlNotDelegatedToDRep kh -> DijkstraWdrlNotDelegatedToDRep kh Conway.ConwayTreasuryValueMismatch mm -> DijkstraTreasuryValueMismatch mm Conway.ConwayTxRefScriptsSizeTooBig mm -> DijkstraTxRefScriptsSizeTooBig mm - Conway.ConwayMempoolFailure f -> DijkstraMempoolFailure f + Conway.ConwayMempoolFailure _ -> error "Impossible: MempoolFailure has ben removed in Dijkstra" Conway.ConwayWithdrawalsMissingAccounts ws -> DijkstraWithdrawalsMissingAccounts ws Conway.ConwayIncompleteWithdrawals ws -> DijkstraIncompleteWithdrawals ws +shelleyToDijkstraLedgerPredFailure :: + forall era. ShelleyLedgerPredFailure era -> DijkstraLedgerPredFailure era +shelleyToDijkstraLedgerPredFailure = \case + UtxowFailure x -> DijkstraUtxowFailure x + DelegsFailure _ -> error "Impossible: DELEGS has ben removed in Dijkstra" + ShelleyWithdrawalsMissingAccounts x -> DijkstraWithdrawalsMissingAccounts x + ShelleyIncompleteWithdrawals x -> DijkstraIncompleteWithdrawals x + instance ( EraTx era , ConwayEraTxBody era diff --git a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Mempool.hs b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Mempool.hs index 316a9233618..15ba8c0f917 100644 --- a/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Mempool.hs +++ b/eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/Rules/Mempool.hs @@ -1,11 +1,14 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE EmptyDataDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -14,9 +17,20 @@ module Cardano.Ledger.Dijkstra.Rules.Mempool ( DijkstraMEMPOOL, + DijkstraMempoolPredFailure (..), + DijkstraMempoolEvent (..), ) where import Cardano.Ledger.BaseTypes (ShelleyBase) +import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) +import Cardano.Ledger.Binary.Coders ( + Decode (..), + Encode (..), + decode, + encode, + (!>), + ( + Eq (DijkstraMempoolPredFailure era) + +deriving instance + Show (PredicateFailure (EraRule "LEDGER" era)) => + Show (DijkstraMempoolPredFailure era) + +instance + ( Era era + , EncCBOR (PredicateFailure (EraRule "LEDGER" era)) + ) => + EncCBOR (DijkstraMempoolPredFailure era) + where + encCBOR = + encode . \case + LedgerFailure x -> Sum (LedgerFailure @era) 1 !> To x + AllInputsAreSpent -> Sum AllInputsAreSpent 2 + +instance + ( Era era + , DecCBOR (PredicateFailure (EraRule "LEDGER" era)) + ) => + DecCBOR (DijkstraMempoolPredFailure era) + where + decCBOR = decode . Summands "DijkstraMempoolPredFailure" $ \case + 1 -> SumD (LedgerFailure @era) SumD AllInputsAreSpent + n -> Invalid n + +data DijkstraMempoolEvent era + = LedgerEvent (Event (EraRule "LEDGER" era)) + deriving (Generic) + +deriving instance + Eq (Event (EraRule "LEDGER" era)) => + Eq (DijkstraMempoolEvent era) + +instance + NFData (Event (EraRule "LEDGER" era)) => + NFData (DijkstraMempoolEvent era) + instance ( EraTx era , ConwayEraTxBody era @@ -82,8 +151,8 @@ instance type Signal (DijkstraMEMPOOL era) = Tx TopTx era type Environment (DijkstraMEMPOOL era) = LedgerEnv era type BaseM (DijkstraMEMPOOL era) = ShelleyBase - type PredicateFailure (DijkstraMEMPOOL era) = DijkstraLedgerPredFailure era - type Event (DijkstraMEMPOOL era) = ConwayLedgerEvent era + type PredicateFailure (DijkstraMEMPOOL era) = DijkstraMempoolPredFailure era + type Event (DijkstraMEMPOOL era) = DijkstraMempoolEvent era transitionRules = [mempoolTransition @era] @@ -109,8 +178,7 @@ mempoolTransition = do UTxO utxo = ledgerState ^. utxoG notAllSpent = any (`Map.member` utxo) inputs notAllSpent - ?! DijkstraMempoolFailure - "All inputs are spent. Transaction has probably already been included" + ?! AllInputsAreSpent -- Continue with LEDGER rules if the transaction is not a duplicate, whenFailureFreeDefault ledgerState $ do @@ -148,5 +216,5 @@ instance ) => Embed (DijkstraLEDGER era) (DijkstraMEMPOOL era) where - wrapFailed = id - wrapEvent = id + wrapFailed = LedgerFailure + wrapEvent = LedgerEvent diff --git a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Arbitrary.hs b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Arbitrary.hs index cbac79ea7ce..faae0f9dfcf 100644 --- a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Arbitrary.hs +++ b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Arbitrary.hs @@ -35,9 +35,6 @@ import Cardano.Ledger.Dijkstra.TxInfo (DijkstraContextError) import Cardano.Ledger.Shelley.Scripts ( pattern RequireSignature, ) -import Control.State.Transition ( - STS (..), - ) import Data.Functor.Identity (Identity) import qualified Data.OMap.Strict as OMap import Data.Typeable (Typeable) diff --git a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Examples.hs b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Examples.hs index 73e922afa62..60dc8d9b83b 100644 --- a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Examples.hs +++ b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Examples.hs @@ -4,6 +4,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} module Test.Cardano.Ledger.Dijkstra.Examples ( ledgerExamples, @@ -17,7 +18,7 @@ import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Governance (VotingProcedures (..)) import Cardano.Ledger.Conway.Rules (ConwayDELEG, ConwayDelegPredFailure (..)) import Cardano.Ledger.Dijkstra (DijkstraEra) -import Cardano.Ledger.Dijkstra.Rules (DijkstraLEDGER) +import Cardano.Ledger.Dijkstra.Rules (DijkstraLEDGER, DijkstraMEMPOOL) import Cardano.Ledger.Dijkstra.Scripts (DijkstraPlutusPurpose (..)) import Cardano.Ledger.Dijkstra.TxBody (TxBody (..)) import Cardano.Ledger.Dijkstra.TxCert @@ -28,23 +29,29 @@ import Cardano.Ledger.Plutus.Data ( ) import Cardano.Ledger.Plutus.Language (Language (..)) import Cardano.Ledger.Shelley.API ( - ApplyTxError (..), Credential (..), + NewEpochState, + ProposedPPUpdates (ProposedPPUpdates), RewardAccount (..), TxId (..), ) import Cardano.Ledger.Shelley.Scripts import Cardano.Ledger.TxIn (mkTxInPartial) -import Control.State.Transition.Extended (Embed (..)) +import Control.State.Transition.Extended ( + Embed (..), + STS (..), + ) +import Data.Default (def) +import Data.List.NonEmpty (NonEmpty) import qualified Data.Map.Strict as Map import qualified Data.OSet.Strict as OSet import qualified Data.Sequence.Strict as StrictSeq import qualified Data.Set as Set +import Lens.Micro import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysSucceeds) import Test.Cardano.Ledger.Alonzo.Examples ( exampleDatum, exampleTx, - mkLedgerExamples, ) import Test.Cardano.Ledger.Babbage.Examples (exampleBabbageNewEpochState, exampleCollateralOutput) import Test.Cardano.Ledger.Core.KeyPair (mkAddr) @@ -54,19 +61,22 @@ import Test.Cardano.Ledger.Dijkstra.ImpTest (exampleDijkstraGenesis) import Test.Cardano.Ledger.Mary.Examples (exampleMultiAssetValue) import Test.Cardano.Ledger.Shelley.Examples ( LedgerExamples (..), + exampleNonMyopicRewards, examplePayKey, + examplePoolDistr, exampleStakeKey, exampleStakePoolParams, keyToCredential, mkKeyHash, mkScriptHash, + testShelleyGenesis, ) -ledgerExamples :: LedgerExamples DijkstraEra +ledgerExamples :: LedgerExamples "MEMPOOL" DijkstraEra ledgerExamples = mkLedgerExamples - ( ApplyTxError $ - pure $ + ( pure $ + wrapFailed @(DijkstraLEDGER DijkstraEra) @(DijkstraMEMPOOL DijkstraEra) $ wrapFailed @(ConwayDELEG DijkstraEra) @(DijkstraLEDGER DijkstraEra) $ DelegateeStakePoolNotRegisteredDELEG @DijkstraEra (mkKeyHash 1) ) @@ -74,6 +84,41 @@ ledgerExamples = exampleTxDijkstra exampleDijkstraGenesis +mkLedgerExamples :: + forall era. + AlonzoEraPParams era => + NonEmpty (PredicateFailure (EraRule "MEMPOOL" era)) -> + NewEpochState era -> + Tx TopTx era -> + TranslationContext era -> + LedgerExamples "MEMPOOL" era +mkLedgerExamples + applyTxError + newEpochState + tx + translationContext = + LedgerExamples + { leTx = tx + , leApplyTxError = applyTxError + , lePParams = def + , leProposedPPUpdates = + ProposedPPUpdates $ + Map.singleton + (mkKeyHash 0) + (emptyPParamsUpdate & ppuCollateralPercentageL .~ SJust 150) + , leNewEpochState = newEpochState + , lePoolDistr = examplePoolDistr + , leRewardsCredentials = + Set.fromList + [ Left (Coin 100) + , Right (ScriptHashObj (mkScriptHash 1)) + , Right (KeyHashObj (mkKeyHash 2)) + ] + , leNonMyopicRewards = exampleNonMyopicRewards + , leTranslationContext = translationContext + , leShelleyGenesis = testShelleyGenesis + } + exampleTxDijkstra :: Tx TopTx DijkstraEra exampleTxDijkstra = exampleTx diff --git a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Imp.hs b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Imp.hs index 63dda29fdf1..31b0395a09a 100644 --- a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Imp.hs +++ b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Imp.hs @@ -8,13 +8,17 @@ module Test.Cardano.Ledger.Dijkstra.Imp where +import Cardano.Ledger.BaseTypes (Inject (..)) import Cardano.Ledger.Conway.Rules import Cardano.Ledger.Dijkstra (DijkstraEra) import Cardano.Ledger.Dijkstra.Core -import Cardano.Ledger.Dijkstra.Rules (DijkstraUtxoPredFailure) +import Cardano.Ledger.Dijkstra.Rules (DijkstraMempoolPredFailure, DijkstraUtxoPredFailure) +import Cardano.Ledger.Shelley.API.Mempool (ApplyTxError) import Cardano.Ledger.Shelley.Rules +import Data.List.NonEmpty (NonEmpty) import Test.Cardano.Ledger.Common import qualified Test.Cardano.Ledger.Conway.Imp as ConwayImp +import qualified Test.Cardano.Ledger.Dijkstra.Imp.MempoolSpec as Mempool import qualified Test.Cardano.Ledger.Dijkstra.Imp.UtxoSpec as Utxo import qualified Test.Cardano.Ledger.Dijkstra.Imp.UtxowSpec as Utxow import Test.Cardano.Ledger.Dijkstra.ImpTest @@ -27,6 +31,8 @@ spec :: , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era , InjectRuleFailure "LEDGER" DijkstraUtxoPredFailure era + , Inject (NonEmpty (DijkstraMempoolPredFailure era)) (ApplyTxError era) + , PredicateFailure (EraRule "MEMPOOL" era) ~ DijkstraMempoolPredFailure era ) => Spec spec = do @@ -37,10 +43,13 @@ dijkstraEraGenericSpec :: forall era. ( DijkstraEraImp era , InjectRuleFailure "LEDGER" DijkstraUtxoPredFailure era + , PredicateFailure (EraRule "MEMPOOL" era) ~ DijkstraMempoolPredFailure era + , Inject (NonEmpty (DijkstraMempoolPredFailure era)) (ApplyTxError era) ) => SpecWith (ImpInit (LedgerSpec era)) dijkstraEraGenericSpec = do describe "UTXOW" Utxow.spec describe "UTXO" Utxo.spec + describe "MEMPOOL" Mempool.spec instance EraSpecificSpec DijkstraEra diff --git a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Imp/MempoolSpec.hs b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Imp/MempoolSpec.hs new file mode 100644 index 00000000000..19f29a6b3c0 --- /dev/null +++ b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Imp/MempoolSpec.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Cardano.Ledger.Dijkstra.Imp.MempoolSpec (spec) where + +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Dijkstra () +import Cardano.Ledger.Dijkstra.Core +import Cardano.Ledger.Dijkstra.Rules ( + DijkstraMempoolPredFailure (AllInputsAreSpent, LedgerFailure), + DijkstraUtxoPredFailure (BadInputsUTxO), + PredicateFailure, + ) +import Cardano.Ledger.Shelley.API.Mempool (ApplyTx (ApplyTxError), applyTx, mkMempoolEnv) +import Cardano.Ledger.Shelley.LedgerState +import Control.Monad.Reader (asks) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import GHC.Exts (fromList) +import Lens.Micro ((&), (<>~), (^.)) +import Lens.Micro.Mtl (use) +import Test.Cardano.Ledger.Dijkstra.ImpTest +import Test.Cardano.Ledger.Imp.Common + +spec :: + forall era. + ( DijkstraEraImp era + , PredicateFailure (EraRule "MEMPOOL" era) ~ DijkstraMempoolPredFailure era + , InjectRuleFailure "LEDGER" DijkstraUtxoPredFailure era + , Inject (NonEmpty (DijkstraMempoolPredFailure era)) (ApplyTxError era) + ) => + SpecWith (ImpInit (LedgerSpec era)) +spec = + describe "Mempool" $ do + let + submitFailingMempoolTx :: + String -> + Tx TopTx era -> + NonEmpty (PredicateFailure (EraRule "MEMPOOL" era)) -> + ImpM (LedgerSpec era) (Tx TopTx era) + submitFailingMempoolTx cause tx expectedFailures = do + globals <- use impGlobalsL + nes <- use impNESL + slotNo <- use impCurSlotNoG + let + mempoolEnv = mkMempoolEnv nes slotNo + ls = nes ^. nesEsL . esLStateL + txFixed <- (tx &) =<< asks iteFixup + logToExpr txFixed + case applyTx globals mempoolEnv ls txFixed of + Left err -> do + err `shouldBe` inject expectedFailures + Right _ -> + assertFailure $ "Expected failure due to " <> cause <> ": " <> show txFixed + pure txFixed + + submitFailingMempoolTx_ :: + String -> + Tx TopTx era -> + NonEmpty (PredicateFailure (EraRule "MEMPOOL" era)) -> + ImpM (LedgerSpec era) () + submitFailingMempoolTx_ c t = void . submitFailingMempoolTx c t + + it "Duplicate transactions" $ do + let + newInput = do + addr <- freshKeyAddr_ + amount <- Coin <$> choose (2_000_000, 8_000_000) + sendCoinTo addr amount + + inputsCommon <- replicateM 5 newInput + inputs1 <- replicateM 2 newInput + inputs2 <- replicateM 3 newInput + + txFinal <- + submitTx $ + mkBasicTx $ + mkBasicTxBody & inputsTxBodyL <>~ fromList (inputsCommon <> inputs1) + + impAnn "Identical transaction" $ do + withNoFixup $ + submitFailingMempoolTx_ "duplicate transaction" txFinal $ + NonEmpty.singleton $ + AllInputsAreSpent + + impAnn "Overlapping transaction" $ do + let txOverlap = mkBasicTx $ mkBasicTxBody & inputsTxBodyL <>~ fromList (inputsCommon <> inputs2) + submitFailingMempoolTx_ + "overlapping transaction" + txOverlap + [LedgerFailure $ injectFailure $ BadInputsUTxO $ fromList inputsCommon] diff --git a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/TreeDiff.hs b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/TreeDiff.hs index 05613707948..bc6416e100b 100644 --- a/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/TreeDiff.hs +++ b/eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/TreeDiff.hs @@ -37,6 +37,8 @@ import Cardano.Ledger.Dijkstra.Rules ( DijkstraGovCertPredFailure, DijkstraGovPredFailure, DijkstraLedgerPredFailure, + DijkstraMempoolEvent, + DijkstraMempoolPredFailure, DijkstraUtxoPredFailure, DijkstraUtxowPredFailure, ) @@ -186,3 +188,11 @@ instance ToExpr (DijkstraGovPredFailure era) instance ToExpr (DijkstraGovCertPredFailure era) + +instance + ToExpr (PredicateFailure (EraRule "LEDGER" era)) => + ToExpr (DijkstraMempoolPredFailure era) + +instance + ToExpr (Event (EraRule "LEDGER" era)) => + ToExpr (DijkstraMempoolEvent era) diff --git a/eras/mary/impl/CHANGELOG.md b/eras/mary/impl/CHANGELOG.md index 0d6a31ae037..404940a56e5 100644 --- a/eras/mary/impl/CHANGELOG.md +++ b/eras/mary/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.10.0.0 +* Add `MaryApplyTxError` constructor for `ApplyTxError era` * Add `cddl` sub-library, and `generate-cddl` executable. * Remove deprecated functions `insert`, `lookup`, `prune` * Remove deprecated type `Mary` diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary.hs b/eras/mary/impl/src/Cardano/Ledger/Mary.hs index 81b4cc14451..a9ca257aa8a 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary.hs @@ -1,7 +1,10 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -12,8 +15,10 @@ module Cardano.Ledger.Mary ( MaryValue, TxBody (..), Tx (..), + ApplyTxError (..), ) where +import Cardano.Ledger.Binary (DecCBOR, EncCBOR) import Cardano.Ledger.Mary.BlockBody () import Cardano.Ledger.Mary.Era (MaryEra) import Cardano.Ledger.Mary.PParams () @@ -28,8 +33,16 @@ import Cardano.Ledger.Mary.TxBody (TxBody (..)) import Cardano.Ledger.Mary.UTxO () import Cardano.Ledger.Mary.Value (MaryValue) import Cardano.Ledger.Shelley.API +import Cardano.Ledger.Shelley.Rules (ShelleyLedgerPredFailure) +import Data.Bifunctor (Bifunctor (first)) +import Data.List.NonEmpty (NonEmpty) instance ApplyTx MaryEra where - applyTxValidation = ruleApplyTxValidation @"LEDGER" + newtype ApplyTxError MaryEra = MaryApplyTxError (NonEmpty (ShelleyLedgerPredFailure MaryEra)) + deriving (Eq, Show) + deriving newtype (EncCBOR, DecCBOR) + applyTxValidation validationPolicy globals env state tx = + first MaryApplyTxError $ + ruleApplyTxValidation @"LEDGER" validationPolicy globals env state tx instance ApplyBlock MaryEra diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Arbitrary.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Arbitrary.hs index 127d0f14a01..e05dbccedbf 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Arbitrary.hs +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Arbitrary.hs @@ -26,7 +26,7 @@ import Cardano.Crypto.Hash.Class (castHash, hashWith) import Cardano.Ledger.Coin import Cardano.Ledger.Compactible import Cardano.Ledger.Core -import Cardano.Ledger.Mary (MaryEra, Tx (..), TxBody (MaryTxBody)) +import Cardano.Ledger.Mary (ApplyTxError (..), MaryEra, Tx (..), TxBody (MaryTxBody)) import Cardano.Ledger.Mary.Transition import Cardano.Ledger.Mary.Value ( AssetName (..), @@ -245,3 +245,5 @@ hashOfDigitByteStrings = castHash . hashWith id <$> digitByteStrings deriving newtype instance Arbitrary (TransitionConfig MaryEra) deriving newtype instance Arbitrary (Tx TopTx MaryEra) + +deriving newtype instance Arbitrary (ApplyTxError MaryEra) diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Examples.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Examples.hs index 425cea7b533..da7822881d8 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Examples.hs +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Examples.hs @@ -26,7 +26,7 @@ import Test.Cardano.Ledger.Shelley.Examples ( mkWitnessesPreAlonzo, ) -ledgerExamples :: LedgerExamples MaryEra +ledgerExamples :: LedgerExamples "LEDGER" MaryEra ledgerExamples = mkLedgerExamples (mkWitnessesPreAlonzo (Proxy @MaryEra)) 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 5f9b6ce42e7..290bb4cc4a2 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 @@ -56,7 +56,6 @@ library hashable, microlens, mtl, - small-steps >=1.1, text, test-suite cardano-ledger-shelley-ma-test diff --git a/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Roundtrip.hs b/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Roundtrip.hs index facaea81647..014a0b85441 100644 --- a/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Roundtrip.hs +++ b/eras/shelley-ma/test-suite/src/Test/Cardano/Ledger/ShelleyMA/Serialisation/Roundtrip.hs @@ -9,11 +9,9 @@ module Test.Cardano.Ledger.ShelleyMA.Serialisation.Roundtrip where import Cardano.Ledger.Allegra (AllegraEra) import Cardano.Ledger.Binary (DecCBOR, EncCBOR) -import Cardano.Ledger.Core import Cardano.Ledger.Mary (MaryEra) import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Shelley.API (ApplyTx, ApplyTxError) -import Control.State.Transition.Extended (PredicateFailure) import Data.Proxy (Proxy (Proxy)) import Data.Typeable (typeRep) import Test.Cardano.Ledger.Binary.RoundTrip ( @@ -31,8 +29,8 @@ eraRoundTripProps :: forall e. ( ApplyTx e , Arbitrary (ApplyTxError e) - , EncCBOR (PredicateFailure (EraRule "LEDGER" e)) - , DecCBOR (PredicateFailure (EraRule "LEDGER" e)) + , EncCBOR (ApplyTxError e) + , DecCBOR (ApplyTxError e) ) => TestTree eraRoundTripProps = diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 2026cce3d3e..97b1e69742f 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.18.0.0 +* Change the type `ApplyTxError era` to be a data family of the `ApplyTx era` class, with its constructor renamed to `ShelleyApplyTxError` for the Shelley era * Changed the type of the following fields to `CompactForm Coin` in `ShelleyPParams`: - `sppMinFeeA` - `sppMinFeeB` diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Mempool.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Mempool.hs index f542661fd07..1687ab91f8e 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Mempool.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Mempool.hs @@ -38,12 +38,7 @@ module Cardano.Ledger.Shelley.API.Mempool ( ) where import Cardano.Ledger.BaseTypes (Globals, ShelleyBase) -import Cardano.Ledger.Binary ( - DecCBOR (..), - EncCBOR (..), - FromCBOR (..), - ToCBOR (..), - ) +import Cardano.Ledger.Binary (DecCBOR, EncCBOR) import Cardano.Ledger.Core import Cardano.Ledger.Rules.ValidationMode (lblStatic) import Cardano.Ledger.Shelley (ShelleyEra) @@ -51,7 +46,7 @@ import Cardano.Ledger.Shelley.Core (EraGov) import Cardano.Ledger.Shelley.LedgerState (NewEpochState, curPParamsEpochStateL) import qualified Cardano.Ledger.Shelley.LedgerState as LedgerState import Cardano.Ledger.Shelley.Rules () -import Cardano.Ledger.Shelley.Rules.Ledger (LedgerEnv) +import Cardano.Ledger.Shelley.Rules.Ledger (LedgerEnv, ShelleyLedgerPredFailure) import qualified Cardano.Ledger.Shelley.Rules.Ledger as Ledger import Cardano.Ledger.Shelley.State () import Cardano.Ledger.Slot (SlotNo) @@ -59,7 +54,7 @@ import Control.DeepSeq (NFData) import Control.Monad.Except (Except) import Control.Monad.Trans.Reader (runReader) import Control.State.Transition.Extended -import Data.Bifunctor (bimap) +import Data.Bifunctor (Bifunctor (first)) import Data.Coerce (Coercible, coerce) import Data.Functor ((<&>)) import Data.List.NonEmpty (NonEmpty) @@ -103,6 +98,8 @@ class ) => ApplyTx era where + data ApplyTxError era + -- | Validate a transaction against a mempool state and for given STS options, -- and return the new mempool state, a "validated" 'TxInBlock' and, -- depending on the passed options, the emitted events. @@ -121,14 +118,13 @@ ruleApplyTxValidation :: , Environment (EraRule rule era) ~ LedgerEnv era , State (EraRule rule era) ~ MempoolState era , Signal (EraRule rule era) ~ Tx TopTx era - , PredicateFailure (EraRule rule era) ~ PredicateFailure (EraRule "LEDGER" era) ) => ValidationPolicy -> Globals -> MempoolEnv era -> MempoolState era -> Tx TopTx era -> - Either (ApplyTxError era) (MempoolState era, Validated (Tx TopTx era)) + Either (NonEmpty (PredicateFailure (EraRule rule era))) (MempoolState era, Validated (Tx TopTx era)) ruleApplyTxValidation validationPolicy globals env state tx = let opts = ApplySTSOpts @@ -140,10 +136,15 @@ ruleApplyTxValidation validationPolicy globals env state tx = flip runReader globals . applySTSOptsEither @(EraRule rule era) opts $ TRC (env, state, tx) - in bimap ApplyTxError (,Validated tx) result + in fmap (,Validated tx) result instance ApplyTx ShelleyEra where - applyTxValidation = ruleApplyTxValidation @"LEDGER" + newtype ApplyTxError ShelleyEra = ShelleyApplyTxError (NonEmpty (ShelleyLedgerPredFailure ShelleyEra)) + deriving (Eq, Show) + deriving newtype (EncCBOR, DecCBOR) + applyTxValidation validationPolicy globals env state tx = + first ShelleyApplyTxError $ + ruleApplyTxValidation @"LEDGER" validationPolicy globals env state tx type MempoolEnv era = Ledger.LedgerEnv era @@ -188,44 +189,6 @@ mkMempoolEnv mkMempoolState :: NewEpochState era -> MempoolState era mkMempoolState LedgerState.NewEpochState {LedgerState.nesEs} = LedgerState.esLState nesEs -newtype ApplyTxError era = ApplyTxError (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) - -deriving stock instance - Eq (PredicateFailure (EraRule "LEDGER" era)) => - Eq (ApplyTxError era) - -deriving stock instance - Show (PredicateFailure (EraRule "LEDGER" era)) => - Show (ApplyTxError era) - -deriving newtype instance - ( Era era - , EncCBOR (PredicateFailure (EraRule "LEDGER" era)) - ) => - EncCBOR (ApplyTxError era) - -deriving newtype instance - ( Era era - , DecCBOR (PredicateFailure (EraRule "LEDGER" era)) - ) => - DecCBOR (ApplyTxError era) - -instance - ( Era era - , EncCBOR (PredicateFailure (EraRule "LEDGER" era)) - ) => - ToCBOR (ApplyTxError era) - where - toCBOR = toEraCBOR @era - -instance - ( Era era - , DecCBOR (PredicateFailure (EraRule "LEDGER" era)) - ) => - FromCBOR (ApplyTxError era) - where - fromCBOR = fromEraCBOR @era - -- | Transform a function over mempool states to one over the full -- 'NewEpochState'. overNewEpochState :: diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Arbitrary.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Arbitrary.hs index c4c47dd301a..4f92b772330 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Arbitrary.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Arbitrary.hs @@ -32,7 +32,8 @@ import Cardano.Ledger.BaseTypes import Cardano.Ledger.Binary (EncCBOR (..)) import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Shelley.API ( - ApplyTxError (ApplyTxError), + ApplyTx (..), + ApplyTxError (..), MultiSig, ShelleyDelegCert, ShelleyTx (ShelleyTx), @@ -711,14 +712,7 @@ instance deriving newtype instance Arbitrary (Tx TopTx ShelleyEra) -instance - ( Era era - , Arbitrary (PredicateFailure (EraRule "LEDGER" era)) - ) => - Arbitrary (ApplyTxError era) - where - arbitrary = ApplyTxError <$> arbitrary - shrink (ApplyTxError xs) = [ApplyTxError xs' | xs' <- shrink xs] +deriving newtype instance Arbitrary (ApplyTxError ShelleyEra) instance ( Era era diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Examples.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Examples.hs index 092ea008546..e860886e89d 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Examples.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Examples.hs @@ -61,6 +61,7 @@ import Cardano.Slotting.EpochInfo import qualified Data.ByteString as Strict import Data.Coerce (coerce) import Data.Default +import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) @@ -77,10 +78,10 @@ import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkAddr, mkWitnessesVKey) import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash, testGlobals, unsafeBoundRational) import Test.Cardano.Ledger.Shelley.Arbitrary (RawSeed (..)) -data LedgerExamples era = LedgerExamples +data LedgerExamples rule era = LedgerExamples { -- tx leTx :: Tx TopTx era - , leApplyTxError :: ApplyTxError era + , leApplyTxError :: NonEmpty (PredicateFailure (EraRule rule era)) , -- protocol parameters lePParams :: PParams era , leProposedPPUpdates :: ProposedPPUpdates era @@ -103,15 +104,15 @@ deriving instance , Eq (PParamsUpdate era) , EraGov era , Eq (Tx TopTx era) - , Eq (PredicateFailure (EraRule "LEDGER" era)) + , Eq (PredicateFailure (EraRule rule era)) , Eq (StashedAVVMAddresses era) , Eq (TranslationContext era) , Eq (CertState era) , Eq (InstantStake era) ) => - Eq (LedgerExamples era) + Eq (LedgerExamples rule era) -ledgerExamples :: LedgerExamples ShelleyEra +ledgerExamples :: LedgerExamples "LEDGER" ShelleyEra ledgerExamples = mkLedgerExamples (mkWitnessesPreAlonzo (Proxy @ShelleyEra)) @@ -136,7 +137,7 @@ mkLedgerExamples :: TxBody TopTx era -> TxAuxData era -> TranslationContext era -> - LedgerExamples era + LedgerExamples "LEDGER" era mkLedgerExamples mkWitnesses value @@ -146,7 +147,7 @@ mkLedgerExamples LedgerExamples { leTx = tx , leApplyTxError = - ApplyTxError . pure . DelegsFailure $ + pure . DelegsFailure $ DelegateeNotRegisteredDELEG @era (mkKeyHash 1) , lePParams = def , leProposedPPUpdates = diff --git a/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Examples.hs b/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Examples.hs index c32da3b8c84..0dbdcdc40af 100644 --- a/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Examples.hs +++ b/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Examples.hs @@ -72,7 +72,7 @@ data ProtocolLedgerExamples bh era = ProtocolLedgerExamples { pleHashHeader :: HashHeader , pleBlockHeader :: bh , pleChainDepState :: ChainDepState - , pleLedgerExamples :: LedgerExamples era + , pleLedgerExamples :: LedgerExamples "LEDGER" era , pleBlock :: Block bh era } @@ -106,7 +106,7 @@ ledgerExamplesAlonzo = ledgerExamplesTPraos Alonzo.ledgerExamples ledgerExamplesTPraos :: forall era. EraBlockBody era => - LedgerExamples era -> + LedgerExamples "LEDGER" era -> ProtocolLedgerExamples (BHeader StandardCrypto) era ledgerExamplesTPraos = mkProtocolLedgerExamples @@ -178,7 +178,7 @@ mkProtocolLedgerExamples :: HashHeader -> (Hash HASH EraIndependentBlockBody -> bh) -> ChainDepState -> - LedgerExamples era -> + LedgerExamples "LEDGER" era -> ProtocolLedgerExamples bh era mkProtocolLedgerExamples pleHashHeader toBlockHeader pleChainDepState pleLedgerExamples = ProtocolLedgerExamples {..} diff --git a/libs/ledger-state/bench/Performance.hs b/libs/ledger-state/bench/Performance.hs index 4cb2d6ab1c4..324bee39018 100644 --- a/libs/ledger-state/bench/Performance.hs +++ b/libs/ledger-state/bench/Performance.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} module Main where @@ -11,6 +12,7 @@ import Cardano.Ledger.Address import Cardano.Ledger.Api.Era import Cardano.Ledger.BaseTypes import Cardano.Ledger.Binary +import Cardano.Ledger.Conway import Cardano.Ledger.Conway.Rules ( ConwayLedgerPredFailure (ConwayUtxowFailure), ConwayUtxowPredFailure (InvalidWitnessesUTXOW), @@ -78,8 +80,9 @@ main = do toMempoolState NewEpochState {nesEs = EpochState {esLState}} = esLState !globals = mkGlobals genesis !slotNo = SlotNo 55733343 + -- restrictError :: forall era. Era era => NonEmpty (ConwayLedgerPredFailure era) -> () restrictError = \case - ApplyTxError (ConwayUtxowFailure (InvalidWitnessesUTXOW [_]) :| []) -> () + ConwayApplyTxError (ConwayUtxowFailure (InvalidWitnessesUTXOW [_]) :| []) -> () otherErr -> error . show $ otherErr applyTx' mempoolEnv mempoolState = -- TODO: revert this to `either (error . show) seqTuple` after tx's are fixed