From f4a20f90eda380c04a8676baf7d23293f51d87a2 Mon Sep 17 00:00:00 2001 From: Will Gould Date: Tue, 25 Jun 2024 19:24:35 +0100 Subject: [PATCH 01/19] Babel era initial commit --- cabal.project | 18 + .../src/Cardano/Ledger/Allegra/Rules/Utxo.hs | 2 +- .../src/Cardano/Ledger/Allegra/Translation.hs | 1 + .../impl/src/Cardano/Ledger/Allegra/TxSeq.hs | 10 +- eras/alonzo/impl/cardano-ledger-alonzo.cabal | 2 +- .../impl/src/Cardano/Ledger/Alonzo/PParams.hs | 2 + .../Cardano/Ledger/Alonzo/Plutus/Context.hs | 5 + .../src/Cardano/Ledger/Alonzo/Rules/Bbody.hs | 6 +- .../src/Cardano/Ledger/Alonzo/Rules/Utxos.hs | 4 +- .../impl/src/Cardano/Ledger/Alonzo/Scripts.hs | 2 + .../src/Cardano/Ledger/Alonzo/Translation.hs | 3 +- .../impl/src/Cardano/Ledger/Alonzo/Tx.hs | 52 +- .../impl/src/Cardano/Ledger/Alonzo/TxSeq.hs | 13 +- .../Test/Cardano/Ledger/Alonzo/Arbitrary.hs | 3 + .../Ledger/Alonzo/Binary/TxWitsSpec.hs | 1 + .../Test/Cardano/Ledger/Alonzo/TreeDiff.hs | 15 +- .../cardano-ledger-alonzo-test.cabal | 2 +- .../Cardano/Ledger/Alonzo/AlonzoEraGen.hs | 2 +- .../Ledger/Alonzo/Examples/Consensus.hs | 2 +- .../Alonzo/Translation/TranslatableGen.hs | 1 + .../Alonzo/Translation/TranslationInstance.hs | 22 + .../test/Test/Cardano/Ledger/Alonzo/Golden.hs | 20 +- .../test/Test/Cardano/Ledger/Alonzo/TxInfo.hs | 2 +- .../babbage/impl/cardano-ledger-babbage.cabal | 2 +- .../src/Cardano/Ledger/Babbage/Rules/Utxos.hs | 4 +- .../src/Cardano/Ledger/Babbage/Transition.hs | 2 +- .../src/Cardano/Ledger/Babbage/Translation.hs | 3 +- .../impl/src/Cardano/Ledger/Babbage/Tx.hs | 103 +- .../Test/Cardano/Ledger/Babbage/Arbitrary.hs | 13 + .../Test/Cardano/Ledger/Babbage/TreeDiff.hs | 14 + .../Ledger/Babbage/Examples/Consensus.hs | 2 +- .../Babbage/Translation/TranslatableGen.hs | 2 + .../src/Test/Cardano/Ledger/Babbage/TxInfo.hs | 22 +- eras/babel/impl/.ghcid | 1 + eras/babel/impl/CHANGELOG.md | 776 +++++++++ eras/babel/impl/Setup.hs | 3 + eras/babel/impl/cardano-ledger-babel.cabal | 203 +++ eras/babel/impl/cddl-files/babel.cddl | 608 +++++++ eras/babel/impl/cddl-files/crypto.cddl | 13 + eras/babel/impl/cddl-files/extra.cddl | 59 + eras/babel/impl/src/Cardano/Ledger/Babel.hs | 72 + .../src/Cardano/Ledger/Babel/API/Genesis.hs | 125 ++ .../src/Cardano/Ledger/Babel/API/Mempool.hs | 321 ++++ .../Cardano/Ledger/Babel/API/Validation.hs | 276 +++ .../impl/src/Cardano/Ledger/Babel/Core.hs | 67 + .../impl/src/Cardano/Ledger/Babel/Era.hs | 149 ++ .../impl/src/Cardano/Ledger/Babel/FRxO.hs | 65 + .../impl/src/Cardano/Ledger/Babel/Genesis.hs | 99 ++ .../src/Cardano/Ledger/Babel/Governance.hs | 23 + .../Cardano/Ledger/Babel/LedgerState/Types.hs | 98 ++ .../impl/src/Cardano/Ledger/Babel/PParams.hs | 265 +++ .../Cardano/Ledger/Babel/Plutus/Context.hs | 32 + .../impl/src/Cardano/Ledger/Babel/Rules.hs | 34 + .../src/Cardano/Ledger/Babel/Rules/Bbody.hs | 211 +++ .../src/Cardano/Ledger/Babel/Rules/Cert.hs | 16 + .../src/Cardano/Ledger/Babel/Rules/Certs.hs | 16 + .../src/Cardano/Ledger/Babel/Rules/Deleg.hs | 16 + .../src/Cardano/Ledger/Babel/Rules/Gov.hs | 16 + .../src/Cardano/Ledger/Babel/Rules/GovCert.hs | 16 + .../src/Cardano/Ledger/Babel/Rules/Ledger.hs | 431 +++++ .../src/Cardano/Ledger/Babel/Rules/Ledgers.hs | 125 ++ .../src/Cardano/Ledger/Babel/Rules/Pool.hs | 14 + .../src/Cardano/Ledger/Babel/Rules/Utxo.hs | 577 +++++++ .../src/Cardano/Ledger/Babel/Rules/Utxos.hs | 376 ++++ .../src/Cardano/Ledger/Babel/Rules/Utxow.hs | 532 ++++++ .../src/Cardano/Ledger/Babel/Rules/Zone.hs | 491 ++++++ .../src/Cardano/Ledger/Babel/Rules/Zones.hs | 205 +++ .../impl/src/Cardano/Ledger/Babel/Scripts.hs | 287 ++++ .../src/Cardano/Ledger/Babel/Transition.hs | 170 ++ .../src/Cardano/Ledger/Babel/Translation.hs | 211 +++ .../babel/impl/src/Cardano/Ledger/Babel/Tx.hs | 358 ++++ .../src/Cardano/Ledger/Babel/TxAuxData.hs | 37 + .../impl/src/Cardano/Ledger/Babel/TxBody.hs | 769 +++++++++ .../impl/src/Cardano/Ledger/Babel/TxCert.hs | 695 ++++++++ .../impl/src/Cardano/Ledger/Babel/TxInfo.hs | 916 ++++++++++ .../impl/src/Cardano/Ledger/Babel/TxOut.hs | 72 + .../impl/src/Cardano/Ledger/Babel/TxWits.hs | 60 + .../impl/src/Cardano/Ledger/Babel/UTxO.hs | 178 ++ eras/babel/impl/test/Main.hs | 45 + .../Cardano/Ledger/Conway/Binary/CddlSpec.hs | 42 + .../Test/Cardano/Ledger/Conway/BinarySpec.hs | 32 + .../Ledger/Conway/CommitteeRatifySpec.hs | 394 +++++ .../Cardano/Ledger/Conway/DRepRatifySpec.hs | 328 ++++ .../Test/Cardano/Ledger/Conway/GenesisSpec.hs | 56 + .../Ledger/Conway/GovActionReorderSpec.hs | 37 + .../Ledger/Conway/Plutus/PlutusSpec.hs | 23 + eras/babel/impl/test/data/conway-genesis.json | 77 + .../Test/Cardano/Ledger/Babel/Arbitrary.hs | 410 +++++ .../Test/Cardano/Ledger/Babel/Binary/Cddl.hs | 18 + .../Cardano/Ledger/Babel/Binary/Regression.hs | 160 ++ .../Cardano/Ledger/Babel/Binary/RoundTrip.hs | 106 ++ .../Test/Cardano/Ledger/Babel/Genesis.hs | 142 ++ .../testlib/Test/Cardano/Ledger/Babel/Imp.hs | 81 + .../Cardano/Ledger/Babel/Imp/EnactSpec.hs | 499 ++++++ .../Cardano/Ledger/Babel/Imp/EpochSpec.hs | 433 +++++ .../Cardano/Ledger/Babel/Imp/GovCertSpec.hs | 247 +++ .../Test/Cardano/Ledger/Babel/Imp/GovSpec.hs | 1408 +++++++++++++++ .../Cardano/Ledger/Babel/Imp/RatifySpec.hs | 994 +++++++++++ .../Test/Cardano/Ledger/Babel/Imp/UtxoSpec.hs | 168 ++ .../Cardano/Ledger/Babel/Imp/UtxosSpec.hs | 827 +++++++++ .../Test/Cardano/Ledger/Babel/ImpTest.hs | 1512 +++++++++++++++++ .../Test/Cardano/Ledger/Babel/Proposals.hs | 96 ++ .../Test/Cardano/Ledger/Babel/TreeDiff.hs | 104 ++ eras/babel/test-suite/.ghcid | 1 + eras/babel/test-suite/CHANGELOG.md | 46 + .../cardano-ledger-babel-test.cabal | 108 ++ .../babel/test-suite/golden/translations.cbor | Bin 0 -> 68526 bytes .../src/Test/Cardano/Ledger/Babel/Examples.hs | 59 + .../Ledger/Babel/Examples/Combinators.hs | 834 +++++++++ .../Ledger/Babel/Examples/Consensus.hs | 208 +++ .../Ledger/Babel/Examples/Prototype.hs | 463 +++++ .../Test/Cardano/Ledger/Babel/Rules/Chain.hs | 470 +++++ .../Test/Cardano/Ledger/Babel/RulesTests.hs | 99 ++ .../Babel/Translation/TranslatableGen.hs | 90 + .../src/Test/Cardano/Ledger/Babel/Utils.hs | 264 +++ .../test-suite/test/GenerateGoldenFileMain.hs | 12 + .../test/Test/Cardano/Ledger/Conway/TxInfo.hs | 15 + eras/babel/test-suite/test/Tests.hs | 24 + eras/conway/impl/cardano-ledger-conway.cabal | 3 +- .../impl/src/Cardano/Ledger/Conway/PParams.hs | 4 + .../Cardano/Ledger/Conway/Plutus/Context.hs | 2 +- .../src/Cardano/Ledger/Conway/Rules/Ledger.hs | 5 +- .../src/Cardano/Ledger/Conway/Rules/Ratify.hs | 10 +- .../src/Cardano/Ledger/Conway/Rules/Utxos.hs | 2 +- .../impl/src/Cardano/Ledger/Conway/Scripts.hs | 1 + .../src/Cardano/Ledger/Conway/Transition.hs | 7 +- .../src/Cardano/Ledger/Conway/Translation.hs | 25 +- .../impl/src/Cardano/Ledger/Conway/Tx.hs | 11 +- .../impl/src/Cardano/Ledger/Conway/TxInfo.hs | 24 +- .../Conway/Translation/TranslatableGen.hs | 2 + .../src/Cardano/Ledger/Mary/Translation.hs | 1 + eras/mary/impl/src/Cardano/Ledger/Mary/Tx.hs | 17 +- .../impl/src/Cardano/Ledger/Mary/TxSeq.hs | 10 +- .../test/Test/Cardano/Ledger/Mary/Examples.hs | 2 +- .../Ledger/Shelley/API/ByronTranslation.hs | 7 +- .../Cardano/Ledger/Shelley/API/Validation.hs | 6 +- .../src/Cardano/Ledger/Shelley/AdaPots.hs | 2 +- .../src/Cardano/Ledger/Shelley/BlockChain.hs | 12 +- .../Shelley/LedgerState/IncrementalStake.hs | 9 +- .../Shelley/LedgerState/NewEpochState.hs | 7 +- .../Ledger/Shelley/LedgerState/Types.hs | 12 +- .../src/Cardano/Ledger/Shelley/Rules/Bbody.hs | 11 +- .../src/Cardano/Ledger/Shelley/Rules/Snap.hs | 2 +- .../src/Cardano/Ledger/Shelley/Rules/Utxo.hs | 3 +- .../impl/src/Cardano/Ledger/Shelley/Tx.hs | 83 + .../Test/Cardano/Ledger/Shelley/Arbitrary.hs | 34 +- .../Test/Cardano/Ledger/Shelley/TreeDiff.hs | 16 + eras/shelley/test-suite/bench/Main.hs | 2 +- .../Ledger/Shelley/BenchmarkFunctions.hs | 37 +- .../Ledger/Shelley/Examples/Consensus.hs | 50 +- .../Ledger/Shelley/Examples/Federation.hs | 21 +- .../Cardano/Ledger/Shelley/Generator/Block.hs | 32 +- .../Cardano/Ledger/Shelley/Generator/Utxo.hs | 2 +- .../Test/Cardano/Ledger/Shelley/LaxBlock.hs | 8 +- .../Ledger/Shelley/Rules/AdaPreservation.hs | 15 +- .../Cardano/Ledger/Shelley/Rules/Chain.hs | 10 +- .../Ledger/Shelley/Rules/ClassifyTraces.hs | 2 +- .../Ledger/Shelley/Rules/CollisionFreeness.hs | 2 +- .../Ledger/Shelley/Rules/IncrementalStake.hs | 2 +- .../Cardano/Ledger/Shelley/Rules/TestChain.hs | 2 +- .../Test/Cardano/Ledger/Shelley/RulesTests.hs | 17 +- .../Test/Cardano/Ledger/Shelley/UnitTests.hs | 1 + eras/shelley/test-suite/test/Tests.hs | 32 +- flake.nix | 4 +- hie.yaml | 21 + .../cardano-ledger-binary.cabal | 2 +- .../cardano-ledger-core.cabal | 1 + .../src/Cardano/Ledger/Block.hs | 20 +- .../src/Cardano/Ledger/Core.hs | 87 +- .../src/Cardano/Ledger/FRxO.hs | 91 + .../src/Cardano/Ledger/Hashes.hs | 3 + .../src/Cardano/Ledger/Keys/Bootstrap.hs | 17 +- .../src/Cardano/Ledger/Plutus/CostModels.hs | 13 +- .../src/Cardano/Ledger/Plutus/Evaluate.hs | 2 + .../src/Cardano/Ledger/Plutus/Language.hs | 26 +- .../src/Cardano/Ledger/TxIn.hs | 4 + .../src/Cardano/Ledger/UTxO.hs | 13 + .../Test/Cardano/Ledger/Core/Arbitrary.hs | 10 +- .../testlib/Test/Cardano/Ledger/Plutus.hs | 15 +- .../Test/Cardano/Ledger/Plutus/Examples.hs | 209 +++ .../testlib/Test/Cardano/Ledger/TreeDiff.hs | 3 + .../cardano-ledger-test.cabal | 2 +- .../src/Test/Cardano/Ledger/Alonzo/Tools.hs | 1 + .../Ledger/Constrained/Conway/Instances.hs | 14 + .../Cardano/Ledger/Constrained/Conway/Utxo.hs | 2 + .../Cardano/Ledger/Examples/AlonzoBBODY.hs | 4 +- .../Cardano/Ledger/Examples/STSTestUtils.hs | 3 +- .../Cardano/Ledger/Generic/AggPropTests.hs | 5 +- .../src/Test/Cardano/Ledger/Generic/Fields.hs | 10 +- .../Test/Cardano/Ledger/Generic/Functions.hs | 3 +- .../Test/Cardano/Ledger/Generic/MockChain.hs | 53 +- .../Test/Cardano/Ledger/Generic/PrettyCore.hs | 10 +- .../Test/Cardano/Ledger/Generic/Properties.hs | 2 +- .../src/Test/Cardano/Ledger/Generic/Same.hs | 6 +- .../src/Test/Cardano/Ledger/Generic/Trace.hs | 14 +- .../src/Test/Cardano/Ledger/TestableEra.hs | 2 +- .../Test/Cardano/Protocol/TPraos/Arbitrary.hs | 5 +- .../Test/Cardano/Protocol/TPraos/Create.hs | 8 +- .../plutus-preprocessor.cabal | 2 +- 199 files changed, 22355 insertions(+), 270 deletions(-) create mode 100644 eras/babel/impl/.ghcid create mode 100644 eras/babel/impl/CHANGELOG.md create mode 100644 eras/babel/impl/Setup.hs create mode 100644 eras/babel/impl/cardano-ledger-babel.cabal create mode 100644 eras/babel/impl/cddl-files/babel.cddl create mode 100644 eras/babel/impl/cddl-files/crypto.cddl create mode 100644 eras/babel/impl/cddl-files/extra.cddl create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/API/Genesis.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/API/Mempool.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/API/Validation.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Core.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Era.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/FRxO.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Genesis.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Governance.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/PParams.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Plutus/Context.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Rules.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Cert.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Certs.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Deleg.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Gov.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Rules/GovCert.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledger.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledgers.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Pool.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxo.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zones.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Scripts.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Transition.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Translation.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/Tx.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/TxAuxData.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/TxBody.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/TxCert.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/TxInfo.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/TxOut.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/TxWits.hs create mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/UTxO.hs create mode 100644 eras/babel/impl/test/Main.hs create mode 100644 eras/babel/impl/test/Test/Cardano/Ledger/Conway/Binary/CddlSpec.hs create mode 100644 eras/babel/impl/test/Test/Cardano/Ledger/Conway/BinarySpec.hs create mode 100644 eras/babel/impl/test/Test/Cardano/Ledger/Conway/CommitteeRatifySpec.hs create mode 100644 eras/babel/impl/test/Test/Cardano/Ledger/Conway/DRepRatifySpec.hs create mode 100644 eras/babel/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs create mode 100644 eras/babel/impl/test/Test/Cardano/Ledger/Conway/GovActionReorderSpec.hs create mode 100644 eras/babel/impl/test/Test/Cardano/Ledger/Conway/Plutus/PlutusSpec.hs create mode 100644 eras/babel/impl/test/data/conway-genesis.json create mode 100644 eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Arbitrary.hs create mode 100644 eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Binary/Cddl.hs create mode 100644 eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Binary/Regression.hs create mode 100644 eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Binary/RoundTrip.hs create mode 100644 eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Genesis.hs create mode 100644 eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp.hs create mode 100644 eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EnactSpec.hs create mode 100644 eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EpochSpec.hs create mode 100644 eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovCertSpec.hs create mode 100644 eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovSpec.hs create mode 100644 eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/RatifySpec.hs create mode 100644 eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxoSpec.hs create mode 100644 eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxosSpec.hs create mode 100644 eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/ImpTest.hs create mode 100644 eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Proposals.hs create mode 100644 eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/TreeDiff.hs create mode 100644 eras/babel/test-suite/.ghcid create mode 100644 eras/babel/test-suite/CHANGELOG.md create mode 100644 eras/babel/test-suite/cardano-ledger-babel-test.cabal create mode 100644 eras/babel/test-suite/golden/translations.cbor create mode 100644 eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples.hs create mode 100644 eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Combinators.hs create mode 100644 eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Consensus.hs create mode 100644 eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Prototype.hs create mode 100644 eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Rules/Chain.hs create mode 100644 eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/RulesTests.hs create mode 100644 eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Translation/TranslatableGen.hs create mode 100644 eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Utils.hs create mode 100644 eras/babel/test-suite/test/GenerateGoldenFileMain.hs create mode 100644 eras/babel/test-suite/test/Test/Cardano/Ledger/Conway/TxInfo.hs create mode 100644 eras/babel/test-suite/test/Tests.hs create mode 100644 libs/cardano-ledger-core/src/Cardano/Ledger/FRxO.hs diff --git a/cabal.project b/cabal.project index 4955fcf580d..3ad94545848 100644 --- a/cabal.project +++ b/cabal.project @@ -28,6 +28,8 @@ packages: eras/alonzo/test-suite eras/babbage/impl eras/babbage/test-suite + eras/babel/impl + eras/babel/test-suite eras/conway/impl eras/conway/test-suite eras/mary/impl @@ -85,6 +87,9 @@ package cardano-ledger-mary package cardano-ledger-conway flags: +asserts +package cardano-ledger-babel + flags: +asserts + -- Always write GHC env files, because they are needed for repl and by the doctests. write-ghc-environment-files: always @@ -94,3 +99,16 @@ benchmarks: true -- The only sensible test display option test-show-details: streaming + + +source-repository-package + type: git + location: https://github.com/willjgould/plutus + tag: cb3dcbde537635fccd46ec40e71750ecf7cb9530 + --sha256: 10kimcrsh7fibbnq96i7fc7xv0r3vsyngqbmpnfmijaa2j4k2zha + subdir: + plutus-ledger-api + plutus-tx + plutus-tx-plugin + plutus-core + prettyprinter-configurable \ No newline at end of file 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 c136df23b4b..513620dd9ef 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs @@ -197,7 +197,7 @@ utxoTransition :: TransitionRule (EraRule "UTXO" era) utxoTransition = do TRC (Shelley.UtxoEnv slot pp certState, utxos, tx) <- judgmentContext - let Shelley.UTxOState utxo _ _ ppup _ _ = utxos + let Shelley.UTxOState utxo _ _ _ ppup _ _ = utxos txBody = tx ^. bodyTxL genDelegs = dsGenDelegs (certDState certState) diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Translation.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Translation.hs index cb571e32a71..f0d86ab7ba5 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Translation.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Translation.hs @@ -114,6 +114,7 @@ instance Crypto c => TranslateEra (AllegraEra c) UTxOState where return UTxOState { utxosUtxo = translateEra' ctxt $ utxosUtxo us + , utxosFrxo = mempty , utxosDeposited = utxosDeposited us , utxosFees = utxosFees us , utxosGovState = translateEra' ctxt $ utxosGovState us diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxSeq.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxSeq.hs index 7618fcb75e0..14255df196f 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxSeq.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxSeq.hs @@ -15,11 +15,13 @@ import Cardano.Ledger.Allegra.Tx () import Cardano.Ledger.Core (EraSegWits (..)) import Cardano.Ledger.Crypto (Crypto, StandardCrypto) import Cardano.Ledger.Shelley.BlockChain (ShelleyTxSeq (..), bbHash, txSeqTxns) +import Control.Monad ((<=<)) +import qualified Data.Sequence.Strict as StrictSeq instance Crypto c => EraSegWits (AllegraEra c) where {-# SPECIALIZE instance EraSegWits (AllegraEra StandardCrypto) #-} - type TxSeq (AllegraEra c) = ShelleyTxSeq (AllegraEra c) - fromTxSeq = txSeqTxns - toTxSeq = ShelleyTxSeq - hashTxSeq = bbHash + type TxZones (AllegraEra c) = ShelleyTxSeq (AllegraEra c) + fromTxZones = fmap StrictSeq.singleton . txSeqTxns + toTxZones = ShelleyTxSeq . StrictSeq.forceToStrict . (StrictSeq.fromStrict <=< StrictSeq.fromStrict) + hashTxZones = bbHash numSegComponents = 3 diff --git a/eras/alonzo/impl/cardano-ledger-alonzo.cabal b/eras/alonzo/impl/cardano-ledger-alonzo.cabal index ae915dd47a1..cb157423a5a 100644 --- a/eras/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/eras/alonzo/impl/cardano-ledger-alonzo.cabal @@ -90,7 +90,7 @@ library mtl, microlens, nothunks, - plutus-ledger-api ^>=1.26.0, + plutus-ledger-api ^>=1.30.0.0, set-algebra >=1.0, small-steps >=1.1, text, diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs index bce3a166436..455754a47ac 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs @@ -773,6 +773,7 @@ encodeCostModel cm = -- we use the 'canonical' serialization with definite list length. PlutusV2 -> encodeFoldableAsDefLenList encCBOR $ getCostModelParams cm PlutusV3 -> encodeFoldableAsDefLenList encCBOR $ getCostModelParams cm + PlutusV4 -> encodeFoldableAsDefLenList encCBOR $ getCostModelParams cm getLanguageView :: AlonzoEraPParams era => @@ -787,6 +788,7 @@ getLanguageView pp lang = (serialize' version costModelEncoding) PlutusV2 -> latestLangDepView PlutusV3 -> latestLangDepView + PlutusV4 -> latestLangDepView where -- LangDepView for PlutusV1 differs from the rest latestLangDepView = LangDepView (serialize' version lang) costModelEncoding diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Context.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Context.hs index 82d04880502..529382a616d 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Context.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Plutus/Context.hs @@ -44,6 +44,7 @@ import qualified PlutusLedgerApi.V1 as P (ToData, toData) import qualified PlutusLedgerApi.V1 as PV1 import qualified PlutusLedgerApi.V2 as PV2 import qualified PlutusLedgerApi.V3 as PV3 +import qualified PlutusLedgerApi.V4 as PV4 class (PlutusLanguage l, EraPlutusContext era) => EraPlutusTxInfo (l :: Language) era where toPlutusTxCert :: proxy l -> TxCert era -> Either (ContextError era) (PlutusTxCert l) @@ -114,18 +115,22 @@ type family PlutusTxCert (l :: Language) where PlutusTxCert 'PlutusV1 = PV1.DCert PlutusTxCert 'PlutusV2 = PV2.DCert PlutusTxCert 'PlutusV3 = PV3.TxCert + PlutusTxCert 'PlutusV4 = PV4.TxCert type family PlutusScriptPurpose (l :: Language) where PlutusScriptPurpose 'PlutusV1 = PV1.ScriptPurpose PlutusScriptPurpose 'PlutusV2 = PV2.ScriptPurpose PlutusScriptPurpose 'PlutusV3 = PV3.ScriptPurpose + PlutusScriptPurpose 'PlutusV4 = PV4.ScriptPurpose type family PlutusScriptContext (l :: Language) where PlutusScriptContext 'PlutusV1 = PV1.ScriptContext PlutusScriptContext 'PlutusV2 = PV2.ScriptContext PlutusScriptContext 'PlutusV3 = PV3.ScriptContext + PlutusScriptContext 'PlutusV4 = PV4.ScriptContext type family PlutusTxInfo (l :: Language) where PlutusTxInfo 'PlutusV1 = PV1.TxInfo PlutusTxInfo 'PlutusV2 = PV2.TxInfo PlutusTxInfo 'PlutusV3 = PV3.TxInfo + PlutusTxInfo 'PlutusV4 = PV4.TxInfo 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 79c9ca61000..6ee9dd2da22 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs @@ -189,7 +189,7 @@ bbodyTransition :: , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) , EraSegWits era , AlonzoEraTxWits era - , Era.TxSeq era ~ AlonzoTxSeq era + , Era.TxZones era ~ AlonzoTxSeq era , Tx era ~ AlonzoTx era , AlonzoEraPParams era ) => @@ -204,7 +204,7 @@ bbodyTransition = ) -> do let txs = txSeqTxns txsSeq actualBodySize = bBodySize (pp ^. ppProtocolVersionL) txsSeq - actualBodyHash = hashTxSeq @era txsSeq + actualBodyHash = hashTxZones @era txsSeq actualBodySize == fromIntegral (bhviewBSize bh) @@ -260,7 +260,7 @@ instance , Signal (EraRule "LEDGERS" era) ~ Seq (AlonzoTx era) , AlonzoEraTxWits era , Tx era ~ AlonzoTx era - , Era.TxSeq era ~ AlonzoTxSeq era + , Era.TxZones era ~ AlonzoTxSeq era , Tx era ~ AlonzoTx era , EraSegWits era , AlonzoEraPParams era diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs index c33311923d7..eb18fcbea4b 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs @@ -254,7 +254,7 @@ alonzoEvalScriptsTxValid :: ) => TransitionRule (AlonzoUTXOS era) alonzoEvalScriptsTxValid = do - TRC (UtxoEnv slot pp certState, utxos@(UTxOState utxo _ _ pup _ _), tx) <- + TRC (UtxoEnv slot pp certState, utxos@(UTxOState utxo _ _ _ pup _ _), tx) <- judgmentContext let txBody = tx ^. bodyTxL genDelegs = dsGenDelegs (certDState certState) @@ -294,7 +294,7 @@ alonzoEvalScriptsTxInvalid :: ) => TransitionRule (AlonzoUTXOS era) alonzoEvalScriptsTxInvalid = do - TRC (UtxoEnv slot pp _, us@(UTxOState utxo _ fees _ _ _), tx) <- judgmentContext + TRC (UtxoEnv slot pp _, us@(UTxOState utxo _ _ fees _ _ _), tx) <- judgmentContext let txBody = tx ^. bodyTxL () <- pure $! traceEvent invalidBegin () diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs index 4edf67f2734..6cc9f46da5b 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs @@ -539,6 +539,7 @@ encodeScript = \case SPlutusV1 -> Sum (PlutusScript . fromJust . mkPlutusScript . Plutus @'PlutusV1) 1 !> To pb SPlutusV2 -> Sum (PlutusScript . fromJust . mkPlutusScript . Plutus @'PlutusV2) 2 !> To pb SPlutusV3 -> Sum (PlutusScript . fromJust . mkPlutusScript . Plutus @'PlutusV3) 3 !> To pb + SPlutusV4 -> Sum (PlutusScript . fromJust . mkPlutusScript . Plutus @'PlutusV4) 4 !> To pb instance AlonzoEraScript era => DecCBOR (Annotator (AlonzoScript era)) where decCBOR = decode (Summands "AlonzoScript" decodeScript) @@ -552,6 +553,7 @@ instance AlonzoEraScript era => DecCBOR (Annotator (AlonzoScript era)) where 1 -> decodeAnnPlutus SPlutusV1 2 -> decodeAnnPlutus SPlutusV2 3 -> decodeAnnPlutus SPlutusV3 + 4 -> decodeAnnPlutus SPlutusV4 n -> Invalid n {-# INLINE decodeScript #-} {-# INLINE decCBOR #-} diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs index 58ba3bc90c9..dfeecc1b028 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs @@ -81,7 +81,7 @@ instance Crypto c => TranslateEra (AlonzoEra c) Tx where txAuxData <- mapM (translateEraThroughCBOR "TxAuxData") (tx ^. auxDataTxL) -- transactions from Mary era always pass script ("phase 2") validation let validating = IsValid True - pure $ Tx $ AlonzoTx txBody txWits validating txAuxData + pure $ Tx $ AlonzoTx txBody txWits validating txAuxData -- mempty -------------------------------------------------------------------------------- -- Auxiliary instances and functions @@ -133,6 +133,7 @@ instance Crypto c => TranslateEra (AlonzoEra c) UTxOState where return UTxOState { utxosUtxo = translateEra' ctxt $ utxosUtxo us + , utxosFrxo = mempty , utxosDeposited = utxosDeposited us , utxosFees = utxosFees us , utxosGovState = translateEra' ctxt $ utxosGovState us diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs index 213f848caa6..df0f8ffa4f9 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs @@ -7,6 +7,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} @@ -15,6 +16,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} @@ -128,7 +130,11 @@ import Cardano.Ledger.MemoBytes (EqRaw (..)) import Cardano.Ledger.Plutus.Data (Data, hashData) import Cardano.Ledger.Plutus.Language (nonNativeLanguages) import Cardano.Ledger.SafeHash (HashAnnotated, SafeToHash (..), hashAnnotated) -import Cardano.Ledger.Shelley.Tx (ShelleyTx (ShelleyTx), shelleyEqTxRaw) +import Cardano.Ledger.Shelley.Tx ( + -- ShelleyRequiredTx, + ShelleyTx (ShelleyTx), + shelleyEqTxRaw, + ) import qualified Cardano.Ledger.UTxO as Shelley import Cardano.Ledger.Val (Val ((<+>), (<×>))) import Control.Arrow (left) @@ -161,12 +167,16 @@ data AlonzoTx era = AlonzoTx , wits :: !(TxWits era) , isValid :: !IsValid , auxiliaryData :: !(StrictMaybe (TxAuxData era)) + -- , requiredTxs :: !(RequiredTxs era) } deriving (Generic) newtype AlonzoTxUpgradeError = ATUEBodyUpgradeError AlonzoTxBodyUpgradeError deriving (Show) +-- instance Crypto c => EraRequiredTxsData (AlonzoEra c) where +-- type RequiredTxs (AlonzoEra c) = ShelleyRequiredTx (AlonzoEra c) + instance Crypto c => EraTx (AlonzoEra c) where {-# SPECIALIZE instance EraTx (AlonzoEra StandardCrypto) #-} @@ -184,6 +194,9 @@ instance Crypto c => EraTx (AlonzoEra c) where auxDataTxL = auxDataAlonzoTxL {-# INLINE auxDataTxL #-} + -- requiredTxsTxL = lens (const mempty) const + -- {-# INLINE requiredTxsTxL #-} + sizeTxF = sizeAlonzoTxF {-# INLINE sizeTxF #-} @@ -200,6 +213,8 @@ instance Crypto c => EraTx (AlonzoEra c) where <*> pure (IsValid True) <*> pure (fmap upgradeTxAuxData aux) +-- <*> pure mempty -- TODO WG: Do I need to change this? I'm thinking not for the prototype + instance (Tx era ~ AlonzoTx era, AlonzoEraTx era) => EqRaw (AlonzoTx era) where eqRaw = alonzoEqTxRaw @@ -215,8 +230,11 @@ instance Crypto c => AlonzoEraTx (AlonzoEra c) where isValidTxL = isValidAlonzoTxL {-# INLINE isValidTxL #-} -mkBasicAlonzoTx :: Monoid (TxWits era) => TxBody era -> AlonzoTx era -mkBasicAlonzoTx txBody = AlonzoTx txBody mempty (IsValid True) SNothing +mkBasicAlonzoTx :: + Monoid (TxWits era) => + TxBody era -> + AlonzoTx era +mkBasicAlonzoTx txBody = AlonzoTx txBody mempty (IsValid True) SNothing -- mempty -- | `TxBody` setter and getter for `AlonzoTx`. bodyAlonzoTxL :: Lens' (AlonzoTx era) (TxBody era) @@ -248,10 +266,21 @@ isValidAlonzoTxL = lens isValid (\tx valid -> tx {isValid = valid}) {-# INLINEABLE isValidAlonzoTxL #-} deriving instance - (Era era, Eq (TxBody era), Eq (TxWits era), Eq (TxAuxData era)) => Eq (AlonzoTx era) + ( Era era + , Eq (TxBody era) + , Eq (TxWits era) + , Eq (TxAuxData era) -- Eq (RequiredTxs era) + ) => + Eq (AlonzoTx era) deriving instance - (Era era, Show (TxBody era), Show (TxAuxData era), Show (Script era), Show (TxWits era)) => + ( Era era + , Show (TxBody era) + , Show (TxAuxData era) + , Show (Script era) + , Show (TxWits era) + -- , Show (RequiredTxs era) + ) => Show (AlonzoTx era) instance @@ -259,6 +288,7 @@ instance , NoThunks (TxWits era) , NoThunks (TxAuxData era) , NoThunks (TxBody era) + -- , NoThunks (RequiredTxs era) ) => NoThunks (AlonzoTx era) @@ -267,6 +297,7 @@ instance , NFData (TxWits era) , NFData (TxAuxData era) , NFData (TxBody era) + -- , NFData (RequiredTxs era) ) => NFData (AlonzoTx era) @@ -405,9 +436,12 @@ alonzoSegwitTx txBodyAnn txWitsAnn isValid auxDataAnn = Annotator $ \bytes -> txWits = runAnnotator txWitsAnn bytes txAuxData = maybeToStrictMaybe (flip runAnnotator bytes <$> auxDataAnn) in mkBasicTx txBody - & witsTxL .~ txWits - & auxDataTxL .~ txAuxData - & isValidTxL .~ isValid + & witsTxL + .~ txWits + & auxDataTxL + .~ txAuxData + & isValidTxL + .~ isValid -------------------------------------------------------------------------------- -- Mempool Serialisation @@ -469,6 +503,7 @@ instance , DecCBOR (Annotator (TxBody era)) , DecCBOR (Annotator (TxWits era)) , DecCBOR (Annotator (TxAuxData era)) + -- , DecCBOR (Annotator (RequiredTxs era)) ) => DecCBOR (Annotator (AlonzoTx era)) where @@ -482,6 +517,7 @@ instance ( sequence . maybeToStrictMaybe <$> decodeNullMaybe decCBOR ) + -- <*! From {-# INLINE decCBOR #-} -- ======================================================================= diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs index d0ab86e57df..b31cfce2afc 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs @@ -38,13 +38,12 @@ import Cardano.Ledger.Binary ( serialize, withSlice, ) -import Cardano.Ledger.Core hiding (TxSeq, hashTxSeq) -import qualified Cardano.Ledger.Core as Core +import Cardano.Ledger.Core import Cardano.Ledger.Crypto import Cardano.Ledger.Keys (Hash) import Cardano.Ledger.SafeHash (SafeToHash, originalBytes) import Cardano.Ledger.Shelley.BlockChain (constructMetadata) -import Control.Monad (unless) +import Control.Monad (unless, (<=<)) import Data.ByteString (ByteString) import Data.ByteString.Builder (shortByteString, toLazyByteString) import qualified Data.ByteString.Lazy as BSL @@ -86,10 +85,10 @@ data AlonzoTxSeq era = AlonzoTxSeqRaw deriving (Generic) instance Crypto c => EraSegWits (AlonzoEra c) where - type TxSeq (AlonzoEra c) = AlonzoTxSeq (AlonzoEra c) - fromTxSeq = txSeqTxns - toTxSeq = AlonzoTxSeq - hashTxSeq = hashAlonzoTxSeq + type TxZones (AlonzoEra c) = AlonzoTxSeq (AlonzoEra c) + fromTxZones = fmap StrictSeq.singleton . txSeqTxns + toTxZones = AlonzoTxSeq . StrictSeq.forceToStrict . (StrictSeq.fromStrict <=< StrictSeq.fromStrict) + hashTxZones = hashAlonzoTxSeq numSegComponents = 4 pattern AlonzoTxSeq :: 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 59d54eef179..9837e16f753 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs @@ -206,6 +206,7 @@ instance ( Arbitrary (TxBody era) , Arbitrary (TxWits era) , Arbitrary (TxAuxData era) + -- , Arbitrary (RequiredTxs era) ) => Arbitrary (AlonzoTx era) where @@ -216,6 +217,8 @@ instance <*> arbitrary <*> arbitrary +-- <*> arbitrary + instance (AlonzoEraScript era, Script era ~ AlonzoScript era) => Arbitrary (AlonzoScript era) where arbitrary = do lang <- elements [minBound .. eraMaxLanguage @era] diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/TxWitsSpec.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/TxWitsSpec.hs index 38da8f678ae..d0e927796da 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/TxWitsSpec.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/TxWitsSpec.hs @@ -95,6 +95,7 @@ plutusScriptsProp = do keys PlutusV1 = 3 :: Int keys PlutusV2 = 6 keys PlutusV3 = 7 + keys PlutusV4 = 7 nativeScriptsProp :: forall era. diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs index 1a9d735ae5f..7830516688c 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs @@ -98,15 +98,24 @@ instance ToExpr (AlonzoTxBodyRaw era) instance - (Era era, ToExpr (TxOut era), ToExpr (TxCert era), ToExpr (PParamsUpdate era)) => + ( Era era + , ToExpr (TxOut era) + , ToExpr (TxCert era) + , ToExpr (PParamsUpdate era) + -- , ToExpr (RequiredTxs era) + ) => ToExpr (AlonzoTxBody era) -- Tx instance ToExpr IsValid instance - (ToExpr (TxBody era), ToExpr (TxWits era), ToExpr (TxAuxData era)) => - ToExpr (AlonzoTx era) + ( ToExpr (TxBody era) + , ToExpr (TxWits era) + , ToExpr (TxAuxData era) -- ToExpr (RequiredTxs era)) => + ) => + ToExpr + (AlonzoTx era) -- Plutus/TxInfo instance ToExpr (AlonzoContextError era) diff --git a/eras/alonzo/test-suite/cardano-ledger-alonzo-test.cabal b/eras/alonzo/test-suite/cardano-ledger-alonzo-test.cabal index f2f028cb882..5a6b0582da0 100644 --- a/eras/alonzo/test-suite/cardano-ledger-alonzo-test.cabal +++ b/eras/alonzo/test-suite/cardano-ledger-alonzo-test.cabal @@ -59,7 +59,7 @@ library containers, data-default-class, microlens, - plutus-ledger-api ^>=1.26.0, + plutus-ledger-api ^>=1.30.0.0, QuickCheck, random, serialise, diff --git a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs index 4195d910d93..0373340c947 100644 --- a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs +++ b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs @@ -405,7 +405,7 @@ instance Mock c => EraGen (AlonzoEra c) where Just info -> addRedeemMap (getRedeemer2 info) purpose ans -- Add it to the redeemer map Nothing -> ans - constructTx bod wit auxdata = AlonzoTx bod wit (IsValid v) auxdata + constructTx bod wit auxdata = AlonzoTx bod wit (IsValid v) auxdata -- mempty where v = all twoPhaseValidates (txscripts' wit) twoPhaseValidates script = diff --git a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Examples/Consensus.hs b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Examples/Consensus.hs index cefa5adcd55..e73008904f7 100644 --- a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Examples/Consensus.hs +++ b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Examples/Consensus.hs @@ -161,7 +161,7 @@ exampleTx = ) exampleTransactionInBlock :: AlonzoTx Alonzo -exampleTransactionInBlock = AlonzoTx b w (IsValid True) a +exampleTransactionInBlock = AlonzoTx b w (IsValid True) a -- mempty where ShelleyTx b w a = exampleTx diff --git a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Translation/TranslatableGen.hs b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Translation/TranslatableGen.hs index 73c5441e4f3..2bad7557be1 100644 --- a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Translation/TranslatableGen.hs +++ b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Translation/TranslatableGen.hs @@ -92,6 +92,7 @@ toVersionedTxInfo slang txInfo = SPlutusV1 -> TxInfoPV1 txInfo SPlutusV2 -> TxInfoPV2 txInfo SPlutusV3 -> TxInfoPV3 txInfo + SPlutusV4 -> TxInfoPV4 txInfo genTranslationInstance :: forall era. diff --git a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs index e9955890832..f4ab8002140 100644 --- a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs +++ b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Translation/TranslationInstance.hs @@ -48,11 +48,13 @@ import GHC.Generics (Generic) import qualified PlutusLedgerApi.V1 as PV1 import qualified PlutusLedgerApi.V2 as PV2 import qualified PlutusLedgerApi.V3 as PV3 +import qualified PlutusLedgerApi.V4 as PV4 data VersionedTxInfo = TxInfoPV1 PV1.TxInfo | TxInfoPV2 PV2.TxInfo | TxInfoPV3 PV3.TxInfo + | TxInfoPV4 PV4.TxInfo deriving (Show, Eq, Generic) -- | Represents arguments passed to `alonzoTxInfo` along with the produced result. @@ -119,6 +121,26 @@ instance Cborg.Serialise a => Cborg.Serialise (PV3.Interval a) instance Cborg.Serialise a => Cborg.Serialise (PV3.LowerBound a) instance Cborg.Serialise a => Cborg.Serialise (PV3.UpperBound a) instance Cborg.Serialise PV3.Rational +instance Cborg.Serialise PV4.ChangedParameters +instance Cborg.Serialise PV4.ColdCommitteeCredential +instance Cborg.Serialise PV4.Committee +instance Cborg.Serialise PV4.Constitution +instance Cborg.Serialise PV4.DRep +instance Cborg.Serialise PV4.DRepCredential +instance Cborg.Serialise PV4.Delegatee +instance Cborg.Serialise PV4.GovernanceAction +instance Cborg.Serialise PV4.GovernanceActionId +instance Cborg.Serialise PV4.HotCommitteeCredential +instance Cborg.Serialise PV4.ProposalProcedure +instance Cborg.Serialise PV4.ProtocolVersion +instance Cborg.Serialise PV4.ScriptPurpose +instance Cborg.Serialise PV4.TxCert +instance Cborg.Serialise PV4.TxId +instance Cborg.Serialise PV4.TxInInfo +instance Cborg.Serialise PV4.TxInfo +instance Cborg.Serialise PV4.TxOutRef +instance Cborg.Serialise PV4.Vote +instance Cborg.Serialise PV4.Voter instance Cborg.Serialise VersionedTxInfo diff --git a/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Golden.hs b/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Golden.hs index 317fdfe6380..eec7d7873da 100644 --- a/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Golden.hs +++ b/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Golden.hs @@ -45,10 +45,10 @@ import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Base16.Lazy as B16L import qualified Data.ByteString.Lazy as BSL import Data.Either (fromRight) +import Data.Foldable (toList) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) -import Data.Sequence.Strict import GHC.Stack (HasCallStack) import Lens.Micro import Paths_cardano_ledger_alonzo_test @@ -301,9 +301,9 @@ goldenMinFee = Left err -> error (show err) Right (Block _h txs :: Block (BHeader StandardCrypto) Alonzo) -> txs firstTx = - case fromTxSeq @Alonzo txsSeq of - tx :<| _ -> tx - Empty -> error "Block doesn't have any transactions" + case concatMap toList $ fromTxZones @Alonzo txsSeq of + tx : _ -> tx + [] -> error "Block doesn't have any transactions" -- Below are the relevant protocol parameters that were active -- at the time this block was rejected. @@ -312,9 +312,12 @@ goldenMinFee = pricesParam = Prices priceMem priceSteps pp = emptyPParams - & ppMinFeeAL .~ Coin 44 - & ppMinFeeBL .~ Coin 155381 - & ppPricesL .~ pricesParam + & ppMinFeeAL + .~ Coin 44 + & ppMinFeeBL + .~ Coin 155381 + & ppPricesL + .~ pricesParam Coin 1006053 @?= alonzoMinFeeTx pp firstTx ] @@ -326,7 +329,8 @@ fromRightError errorMsg = exPP :: PParams Alonzo exPP = emptyPParams - & ppCostModelsL .~ zeroTestingCostModels [PlutusV1, PlutusV2] + & ppCostModelsL + .~ zeroTestingCostModels [PlutusV1, PlutusV2] exampleLangDepViewPV1 :: LangDepView exampleLangDepViewPV1 = LangDepView b1 b2 diff --git a/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/TxInfo.hs b/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/TxInfo.hs index c650875edf5..8f5334804d1 100644 --- a/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/TxInfo.hs +++ b/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/TxInfo.hs @@ -87,7 +87,7 @@ txb i o = SNothing -- network ID txEx :: TxIn StandardCrypto -> TxOut Alonzo -> Tx Alonzo -txEx i o = AlonzoTx (txb i o) mempty (IsValid True) SNothing +txEx i o = AlonzoTx (txb i o) mempty (IsValid True) SNothing -- mempty silentlyIgnore :: Tx Alonzo -> Assertion silentlyIgnore tx = diff --git a/eras/babbage/impl/cardano-ledger-babbage.cabal b/eras/babbage/impl/cardano-ledger-babbage.cabal index d6fb7bf9554..a5f238e7524 100644 --- a/eras/babbage/impl/cardano-ledger-babbage.cabal +++ b/eras/babbage/impl/cardano-ledger-babbage.cabal @@ -83,7 +83,7 @@ library deepseq, microlens, nothunks, - plutus-ledger-api ^>=1.26.0, + plutus-ledger-api ^>=1.30.0.0, set-algebra, small-steps >=1.1, text, diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs index e5a1f212c69..67798709bc4 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs @@ -218,7 +218,7 @@ babbageEvalScriptsTxValid :: ) => TransitionRule (BabbageUTXOS era) babbageEvalScriptsTxValid = do - TRC (UtxoEnv slot pp certState, utxos@(UTxOState utxo _ _ pup _ _), tx) <- + TRC (UtxoEnv slot pp certState, utxos@(UTxOState utxo _ _ _ pup _ _), tx) <- judgmentContext let txBody = tx ^. bodyTxL genDelegs = dsGenDelegs (certDState certState) @@ -260,7 +260,7 @@ babbageEvalScriptsTxInvalid :: ) => TransitionRule (EraRule "UTXOS" era) babbageEvalScriptsTxInvalid = do - TRC (UtxoEnv _ pp _, us@(UTxOState utxo _ fees _ _ _), tx) <- judgmentContext + TRC (UtxoEnv _ pp _, us@(UTxOState utxo _ _ fees _ _ _), tx) <- judgmentContext {- txb := txbody tx -} let txBody = tx ^. bodyTxL sysSt <- liftSTS $ asks systemStart diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Transition.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Transition.hs index 834e367c2f1..ea9ae6c328c 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Transition.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Transition.hs @@ -28,4 +28,4 @@ instance Crypto c => EraTransition (BabbageEra c) where tcPreviousEraConfigL = lens btcAlonzoTransitionConfig (\btc pc -> btc {btcAlonzoTransitionConfig = pc}) - tcTranslationContextL = lens (const ()) (const . id) + tcTranslationContextL = lens (const ()) (const . id) \ No newline at end of file diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs index 4973530a053..5f085a6f8f0 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs @@ -84,7 +84,7 @@ instance Crypto c => TranslateEra (BabbageEra c) Tx where SNothing -> pure SNothing SJust auxData -> SJust <$> translateEraThroughCBOR "AuxData" auxData let validating = tx ^. Alonzo.isValidTxL - pure $ Tx $ AlonzoTx txBody txWits validating auxData + pure $ Tx $ AlonzoTx txBody txWits validating auxData -- mempty -------------------------------------------------------------------------------- -- Auxiliary instances and functions @@ -139,6 +139,7 @@ instance Crypto c => TranslateEra (BabbageEra c) UTxOState where pure UTxOState { utxosUtxo = translateEra' ctxt $ utxosUtxo us + , utxosFrxo = mempty , utxosDeposited = utxosDeposited us , utxosFees = utxosFees us , utxosGovState = translateEra' ctxt $ utxosGovState us diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs index 03180d62eeb..34907abd7f4 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs @@ -1,11 +1,27 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Ledger.Babbage.Tx ( AlonzoTx (..), BabbageTxBody (..), module X, + -- Babel Fees + -- pattern BabbageRequiredTx, + -- requiredTxs, + -- BabbageRequiredTx (..), + -- BabbageRequiredTxRaw (..), ) where @@ -25,6 +41,8 @@ import Cardano.Ledger.Babbage.TxWits () import Cardano.Ledger.Core import Cardano.Ledger.Crypto import Control.Arrow (left) +import Control.Monad ((<=<)) +import qualified Data.Sequence.Strict as StrictSeq newtype BabbageTxUpgradeError = BTUEBodyUpgradeError BabbageTxBodyUpgradeError @@ -47,6 +65,9 @@ instance Crypto c => EraTx (BabbageEra c) where auxDataTxL = auxDataAlonzoTxL {-# INLINE auxDataTxL #-} + -- requiredTxsTxL = lens (const mempty) const + -- {-# INLINE requiredTxsTxL #-} + sizeTxF = sizeAlonzoTxF {-# INLINE sizeTxF #-} @@ -68,9 +89,81 @@ instance Crypto c => AlonzoEraTx (BabbageEra c) where isValidTxL = isValidAlonzoTxL {-# INLINE isValidTxL #-} +-- newtype BabbageRequiredTxRaw era = BabbageRequiredTxRaw (Set (TxId (EraCrypto era))) +-- deriving (Eq, Show, Generic) + +-- instance EraScript era => NoThunks (BabbageRequiredTxRaw era) + +-- deriving newtype instance Era era => EncCBOR (BabbageRequiredTxRaw era) + +-- deriving newtype instance Era era => DecCBOR (BabbageRequiredTxRaw era) + +-- instance Era era => DecCBOR (Annotator (BabbageRequiredTxRaw era)) where +-- decCBOR = pure <$> decCBOR + +-- deriving via +-- (Mem BabbageRequiredTxRaw era) +-- instance +-- Era era => DecCBOR (Annotator (BabbageRequiredTx era)) + +-- newtype BabbageRequiredTx era +-- = RequiredTxBodyConstr (MemoBytes BabbageRequiredTxRaw era) +-- deriving (Eq, Generic) +-- deriving newtype (Plain.ToCBOR, SafeToHash) + +-- deriving newtype instance EraScript era => Show (BabbageRequiredTx era) + +-- instance EraScript era => NoThunks (BabbageRequiredTx era) + +-- instance Memoized BabbageRequiredTx where +-- type RawType BabbageRequiredTx = BabbageRequiredTxRaw + +-- deriving newtype instance EraRequiredTxsData era => NFData (BabbageRequiredTxRaw era) +-- deriving newtype instance EraRequiredTxsData era => NFData (BabbageRequiredTx era) + +-- pattern BabbageRequiredTx :: +-- forall era. +-- EraScript era => +-- Set (TxId (EraCrypto era)) -> +-- BabbageRequiredTx era +-- pattern BabbageRequiredTx {requiredTxs} <- +-- (getMemoRawType -> BabbageRequiredTxRaw requiredTxs) +-- where +-- BabbageRequiredTx requiredTxs' = +-- mkMemoized $ BabbageRequiredTxRaw requiredTxs' + +-- {-# COMPLETE BabbageRequiredTx #-} + +-- instance EraScript era => Semigroup (BabbageRequiredTx era) where +-- (BabbageRequiredTx a) <> y | Set.null a = y +-- y <> (BabbageRequiredTx a) | Set.null a = y +-- (BabbageRequiredTx a) <> (BabbageRequiredTx a') = BabbageRequiredTx (a <> a') + +-- instance EraScript era => Monoid (BabbageRequiredTx era) where +-- mempty = BabbageRequiredTx mempty + +-- instance +-- (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => +-- EqRaw (BabbageRequiredTx era) + +-- -- | Encodes memoized bytes created upon construction. +-- instance Era era => EncCBOR (BabbageRequiredTx era) + +-- type instance MemoHashIndex BabbageRequiredTxRaw = EraIndependentRequiredTxs + +-- -- deriving instance +-- -- HashAlgorithm (HASH (EraCrypto era)) => +-- -- Show (BabbageRequiredTx era) + +-- instance c ~ EraCrypto era => HashAnnotated (BabbageRequiredTx era) EraIndependentRequiredTxs c where +-- hashAnnotated = getMemoSafeHash + +-- instance Crypto c => EraRequiredTxsData (BabbageEra c) where +-- type RequiredTxs (BabbageEra c) = BabbageRequiredTx (BabbageEra c) + instance Crypto c => EraSegWits (BabbageEra c) where - type TxSeq (BabbageEra c) = AlonzoTxSeq (BabbageEra c) - fromTxSeq = txSeqTxns - toTxSeq = AlonzoTxSeq - hashTxSeq = hashAlonzoTxSeq - numSegComponents = 4 + type TxZones (BabbageEra c) = AlonzoTxSeq (BabbageEra c) + fromTxZones = fmap StrictSeq.singleton . txSeqTxns + toTxZones = AlonzoTxSeq . StrictSeq.forceToStrict . (StrictSeq.fromStrict <=< StrictSeq.fromStrict) + hashTxZones = hashAlonzoTxSeq + numSegComponents = 4 \ No newline at end of file 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 ddb71613a82..b8ab1494a1e 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Arbitrary.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Arbitrary.hs @@ -165,3 +165,16 @@ instance <*> arbitrary <*> arbitrary <*> arbitrary + +-- Babel fees + +-- instance +-- ( EraScript era +-- , EraTxOut era +-- , EncCBOR (TxCert era) +-- ) => +-- Arbitrary (BabbageRequiredTx era) +-- where +-- arbitrary = +-- BabbageRequiredTx +-- <$> pure mempty -- arbitrary \ No newline at end of file diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TreeDiff.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TreeDiff.hs index 8a8bb66e6b7..dc0f0df9cbd 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TreeDiff.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TreeDiff.hs @@ -56,6 +56,20 @@ instance (Era era, ToExpr (TxOut era), ToExpr (TxCert era), ToExpr (PParamsUpdate era)) => ToExpr (BabbageTxBody era) +-- Babel Fees + +-- instance +-- ( ToExpr (TxOut era) +-- , ToExpr (TxCert era) +-- ) => +-- ToExpr (BabbageRequiredTxRaw era) + +-- instance +-- ( ToExpr (TxOut era) +-- , ToExpr (TxCert era) +-- ) => +-- ToExpr (BabbageRequiredTx era) + -- Rules/Utxo instance ( ToExpr (AlonzoUtxoPredFailure era) diff --git a/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Examples/Consensus.hs b/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Examples/Consensus.hs index b1f9422aa21..520f848a031 100644 --- a/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Examples/Consensus.hs +++ b/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Examples/Consensus.hs @@ -175,7 +175,7 @@ exampleTx = ) exampleTransactionInBlock :: AlonzoTx Babbage -exampleTransactionInBlock = AlonzoTx b w (IsValid True) a +exampleTransactionInBlock = AlonzoTx b w (IsValid True) a -- mempty where ShelleyTx b w a = exampleTx diff --git a/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Translation/TranslatableGen.hs b/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Translation/TranslatableGen.hs index 69bb4896bf7..a2dd0dc6ea6 100644 --- a/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Translation/TranslatableGen.hs +++ b/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Translation/TranslatableGen.hs @@ -92,6 +92,8 @@ genTx txbGen = <*> arbitrary <*> arbitrary +-- <*> pure mempty + genTxOut :: forall era. ( EraTxOut era diff --git a/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/TxInfo.hs b/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/TxInfo.hs index 9ac3f87db4a..bc6d72fbc56 100644 --- a/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/TxInfo.hs +++ b/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/TxInfo.hs @@ -40,6 +40,7 @@ import Lens.Micro import qualified PlutusLedgerApi.V1 as PV1 import qualified PlutusLedgerApi.V2 as PV2 import qualified PlutusLedgerApi.V3 as PV3 +import qualified PlutusLedgerApi.V4 as PV4 import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysSucceeds) import Test.Cardano.Ledger.Shelley.Address.Bootstrap (aliceByronAddr) import Test.Cardano.Ledger.Shelley.Examples.Cast (alicePHK) @@ -86,12 +87,14 @@ inlineDatumOutput :: TxOut era inlineDatumOutput = mkBasicTxOut (shelleyAddr) (inject $ Coin 3) - & datumTxOutL .~ datumEx + & datumTxOutL + .~ datumEx refScriptOutput :: BabbageEraTxOut era => TxOut era refScriptOutput = mkBasicTxOut (shelleyAddr) (inject $ Coin 3) - & referenceScriptTxOutL .~ (SJust $ alwaysSucceeds @'PlutusV2 3) + & referenceScriptTxOutL + .~ (SJust $ alwaysSucceeds @'PlutusV2 3) -- This input is only a "Shelley input" in the sense -- that we attach it to a Shelley output in the UTxO created below. @@ -127,10 +130,14 @@ txb :: TxBody era txb i mRefInp o = mkBasicTxBody - & inputsTxBodyL .~ Set.singleton i - & referenceInputsTxBodyL .~ maybe mempty Set.singleton mRefInp - & outputsTxBodyL .~ StrictSeq.singleton o - & feeTxBodyL .~ Coin 2 + & inputsTxBodyL + .~ Set.singleton i + & referenceInputsTxBodyL + .~ maybe mempty Set.singleton mRefInp + & outputsTxBodyL + .~ StrictSeq.singleton o + & feeTxBodyL + .~ Coin 2 txBare :: forall era. @@ -149,6 +156,7 @@ hasReferenceInput slang txInfo = SPlutusV1 -> False SPlutusV2 -> PV2.txInfoReferenceInputs txInfo /= mempty SPlutusV3 -> PV3.txInfoReferenceInputs txInfo /= mempty + SPlutusV4 -> PV4.txInfoReferenceInputs txInfo /= mempty expectOneInput :: PV2.TxInInfo -> SLanguage l -> PlutusTxInfo l -> Bool expectOneInput i slang txInfo = @@ -156,6 +164,7 @@ expectOneInput i slang txInfo = SPlutusV1 -> False SPlutusV2 -> PV2.txInfoInputs txInfo == [i] SPlutusV3 -> False + SPlutusV4 -> False expectOneOutput :: PV2.TxOut -> SLanguage l -> PlutusTxInfo l -> Bool expectOneOutput o slang txInfo = @@ -163,6 +172,7 @@ expectOneOutput o slang txInfo = SPlutusV1 -> False SPlutusV2 -> PV2.txInfoOutputs txInfo == [o] SPlutusV3 -> PV3.txInfoOutputs txInfo == [o] + SPlutusV4 -> PV4.txInfoOutputs txInfo == [o] successfulTranslation :: ( BabbageEraTxOut era diff --git a/eras/babel/impl/.ghcid b/eras/babel/impl/.ghcid new file mode 100644 index 00000000000..0dd2ff39096 --- /dev/null +++ b/eras/babel/impl/.ghcid @@ -0,0 +1 @@ +--command="cabal repl --repl-options='-isrc -fwarn-unused-binds -fwarn-unused-imports -fno-code -fobject-code -g2 -fno-break-on-exception -fno-break-on-error -ferror-spans -j -Wno-unused-packages'" --clear --no-height-limit --reverse-errors --reload=../../../ --outputfile=/tmp/cardano-ledger-babel-ghcid.txt \ No newline at end of file diff --git a/eras/babel/impl/CHANGELOG.md b/eras/babel/impl/CHANGELOG.md new file mode 100644 index 00000000000..25dbbe4246d --- /dev/null +++ b/eras/babel/impl/CHANGELOG.md @@ -0,0 +1,776 @@ +# Version history for `cardano-ledger-conway` + +## 1.14.0 0 + +* Add lenses: + * `dvtHardForkInitiationL` + * `dvtMotionNoConfidenceL` + * `dvtTreasuryWithdrawalL` +* Add`DisallowedProposalDuringBootstrap` and `DisallowedVotesDuringBootstrap` to `ConwayGovPredFailure` +* Make `DRepDistr` calculation include rewards when no UTxO stake is delegated. #4273 + * Rename `computeDrepPulser` to `computeDRepPulser`. +* Implement `NoThunks` instance for: + * `ConwayUtxoPredFailure` + * `ConwayUtxowPredFailure` +* Add `ConwayUtxowPredFailure` era rule failure: + * Implement its `InjectRuleFailure` instances for: + * `BBODY` + * `LEDGER` + * `LEDGERS` + * `UTXOW` + * Implement instances: + * `Generic` + * `Show` + * `Eq` + * `EncCBOR` + * `DecCBOR` + * `NFData` + * Add mappings: + * `babbageToConwayUtxowPredFailure` + * `alonzoToConwayUtxowPredFailure` + * `shelleyToConwayUtxowPredFailure` + * Update `Embed (ConwayUTXO era) (ConwayUTXOW era)` instance +* Add `ConwayUtxoPredFailure` era rule failure: + * Implement its `InjectRuleFailure` instances for: + * `BBODY` + * `LEDGER` + * `LEDGERS` + * `UTXO` + * `UTXOW` + * Implement instances: + * `Generic` + * `Show` + * `Eq` + * `EncCBOR` + * `DecCBOR` + * `NFData` + * Add mappings: + * `babbageToConwayUtxoPredFailure` + * `alonzoToConwayUtxoPredFailure` + * Update `allegraToConwayUtxoPredFailure` mapping +* Add `ConwayUTXO` era rule: + * Implement instances: + * `STS` + * `Embed (ConwayUTXOS era) (ConwayUTXO era)` + * `Embed (ConwayUTXO era) (ConwayUTXOW era)` +* Add `ucppPlutusV3CostModel` to `UpgradeConwayPParams`. #4252 + * Remove the `Default` instance for `ConwayGenesis`. +* Add `foldrVotingProcedures`. + +### `testlib` + +* Add `withPostBootstrap` to Conway ImpTest +* Add `withImpStateWithProtVer` to Conway ImpTest +* Add the following utilities. #4273 + * to `Conway.ImpTest` + * `setupDRepWithoutStake` + * `setupPoolWithoutStake` + * `submitAndExpireProposalToMakeReward` + * to `Shelley.ImpTest` + * `getRewardAccountFor` + * `registerAndRetirePoolToMakeReward` +* Add `getConstitution` to Conway ImpTest +* Change return type of `setupSingleDRep` to Credential instead of KeyHash +* Add `registerInitialCommittee` and `getCommitteeMembers` to Conway ImpTest +* Implement `ConwayUtxowPredFailure` instances: + * `Arbitrary` + * `ToExpr` +* Implement `ConwayUtxoPredFailure` instances: + * `Arbitrary` + * `ToExpr` +* Updated `exampleConwayGenesis` to `conway-genesis.json`. #4252 + +## 1.13.1.0 + +* Fix typo in `ToJSON` instance of `ConwayGovState` + +### `testlib` + +* Add `ToExpr` instance for `GovProcedures` + +## 1.13.0.0 + +* Add `geCommitteeState` +* Remove `ConwayDelegEvent`, `ConwayGovCertEvent` +* Add `GovInfoEvent` +* Add `ConwayUtxosEvent` +* Add `Generic`, `Eq` and `NFData` instances for `ConwayEpochEvent` +* Add `Eq` and `NFData` instances for: + * `ConwayGovEvent` + * `ConwayCertEvent` + * `ConwayCertsEvent` + * `ConwayLedgerEvent` + * `ConwayNewEpochEvent` +* Add type `EraRuleEvent` instances for the event type of: + * `UPEC` + * `NEWPP` + * `PPUP` + * `MIR` + * `DELEGS` + * `TICK` + * `ENACT` + * `LEDGER` + * `UTXOS` +* Add `ConwayDRepIncorrectRefund` +* Stop exporting `utxosGovStateL` from `Cardano.Ledger.Conway.Governance` +* Remove deprecated `curPParamsConwayGovStateL` and `prevPParamsConwayGovStateL` +* Add `EraRuleFailure "POOL"` type instance for `ConwayEra` +* Add `ConwayUtxosPredFailure` +* Support for intra-era hard fork with `ProtVerHigh` set to `10` +* Guard Conway-specific features in transactions that use Plutus v1 or v2. #4112 + * Add `PlutusContextError` variants: + * `CurrentTreasuryValueFieldNotSupported` + * `VotingProceduresFieldNotSupported` + * `ProposalProceduresFieldNotSupported` + * `TreasuryDonationFieldNotSupported` + * Allow `RegDepositTxCert` and `UnRegDepositTxCert` to pass by ignoring the deposit or refund values, respectively. +* Switch `EPOCH` rule environment back to `()`. Start using the latest stake pool + distribution: #4115 +* Add: + * `transTxInInfoV1` + * `transTxOutV1` +* Add instances for `InjectRuleFailure` and switch to using `injectFailure` +* Remove `ConwayPOOL` rule, in favor of `ShelleyPOOL` +* Add `NFData` instance for `BabbageUtxoPredFailure` +* Rename `MinFeeRefScriptCoinsPerByte` to `MinFeeRefScriptCostPerByte` and change its type from `CoinsPerByte` to `NonNegativeInterval` #4055 +* Rename `committeeQuorum` to `committeeThreshold` #4053 +* Changed `GovActionState` to have 1 field (`gasProposalProcedure`) rather than 3 (`gasDeposit`, `gasAction`, `gasReturnAddr`) + * the old field names (`gasDeposit`, `gasAction`, `gasReturnAddr`) become functions, and the lenses + * (`gasDepositL`, `gasActionL`, `gasReturnAddrL`) have the same type, but behave differently. + * Added the lenses: `pProcDepositL`, `pProcGovActionL`, `pProcReturnAddrL`, `pProcAnchorL`, `gasProposalProcedureL`. +* Add `getDRepDistr`, `getConstitution` and `getCommitteeMembers` from `ConwayEraGov` #4033 + * Move `Constitution` to `Conway.Governance.Procedures` +* Add implementation for `getMinFeeTxUtxo` +* Add `cppMinFeeRefScriptCoinsPerByte` to `ConwayPParams` and `ppMinFeeRefScriptCoinsPerByteL` +* Add `ucppMinFeeRefScriptCoinsPerByte` to `UpgradeConwayPParams` and `ppuMinFeeRefScriptCoinsPerByteL` +* Fix `ConwayTxBody` pattern synonym, by changing its certificates arguments to `OSet` + from a `StrictSeq`. +* Add `VotingPurpose` and `ProposingPurpose` pattern synonyms +* Add `ConwayEraScript` with `toVotingPurpose`, `toProposingPurpose`, `fromVotingPurpose`, + `fromProposingPurpose`. +* Add upgrade failure: `CTBUEContainsDuplicateCerts` +* Rename `proposalsRemoveDescendentIds` to `proposalsRemoveWithDescendants` (fixed spelling too) +* Rename: + * `pfPParamUpdateL` to `grPParamUpdateL` + * `pfHardForkL` to `grHardForkL` + * `pfCommitteeL` to `grCommitteeL` + * `pfConstitutionL` to `grConstitutionL` +* Rename: + * `cgProposalsL` to `cgsProposalsL` + * `cgEnactStateL` to `cgsEnactStateL` + * `cgDRepPulsingStateL` to `cgsDRepPulsingStateL` +* Add: + * `cgsPrevPParamsL` + * `cgsCommitteeL` + * `cgsConstitutionL` + * `govStatePrevGovActionIds` + * `mkEnactState` +* Deprecated `curPParamsConwayGovStateL` and `curPParamsConwayGovStateL` +* Rename `PForest` to `GovRelation` +* Add `hoistGovRelation` and `withGovActionParent` +* Add `TreeMaybe`, `toGovRelationTree` and `toGovRelationTreeEither` +* Remove `proposalsAreConsistent` +* Remove `registerDelegs` and `registerInitialDReps` +* Modify `PParams` JSON instances to match `cardano-api` + +### `testlib` + +* Add `ToExpr` instances for: + * `ConwayNewEpochEvent` + * `ConwayEpochEvent` + * `ConwayLedgerEvent` + * `ConwayCertsEvent` + * `ConwayCertEvent` + * `ConwayGovEvent` +* Change the types of some functions in `Test.Cardano.Ledger.Conway.ImpTest` + to use `NonEmpty (PredicateFailure _)` instead of `[PredicateFailure _]` + - `submitFailingVote` + - `trySubmitVote` + - `trySubmitProposal` + - `trySubmitProposals` + - `submitFailingProposal` + - `trySubmitGovAction` + - `trySubmitGovActions` +* Add `Test.Cardano.Ledger.Conway.Imp.GovCertSpec` +* Add `RuleListEra` instance for Conway +* Rename `canGovActionBeDRepAccepted` to `isDRepAccepted` and refactor #4097 + * Add `isSPOAccepted` + * Change `setupSingleDRep` to return relevant keyhashes + * Change `setupPoolWithStake` to return relevant keyhashes + * Add `getLastEnactedCommittee` + * Add `getRatifyEnvAndState` +* Add `Test.Cardano.Ledger.Conway.Imp.UtxosSpec` +* Add `getGovPolicy` +* Add `submitGovActions` and `trySubmitGovActions` +* Add `submitProposals` and `trySubmitProposal` + +## 1.12.0.0 + +* Changed the types in `GovernanceActionsDoNotExist`, `DisallowedVoters` + and `VotingOnExpiredGovAction` to `NonEmpty` +* Add `cgDelegsL` +* Add `FromJSON`, `EncCBOR` and `DecCBOR` instances for `Delegatee` +* Add `pvtPPSecurityGroup` +* Add lenses: + * `pvtCommitteeNormalL` + * `pvtCommitteeNoConfidenceL` + * `pvtPPSecurityGroupL` + * `dvtCommitteeNoConfidenceL` +* Add `PPGroups` and `StakePoolGroup` +* Add `ToStakePoolGroup` typeclass +* Add `DRepGroup` and `ToDRepGroup` typeclass +* Modify `THKD` replacing `PPGroup` with `PPGroups` +* Add `ConwayPlutusPurpose` +* Add `unGovActionIx` +* Add `foldlVotingProcedures` +* Add a policy field to `ParameterChange` and `TreasuryWithdrawals` constructors + of `GovAction` +* Add `InvalidPolicyHash` to `ConwayGovPredFailure` +* Add `ToJSON` instance for `ConwayContextError`, `ConwayTxCert`, `ConwayDelegCert`, + `Delegatee` and `ConwayGovCert` +* Add `forceDRepPulsingState` +* Add `registerInitialDReps` and `registerDelegs` +* Add `cgDelegs`, `cgInitialDReps` to `ConwayGenesis` +* Changed the type of lenses ppCommitteeMaxTermLengthL, ppuCommitteeMaxTermLengthL +* Change 'getScriptWitnessConwayTxCert' so that DRepRegistration certificate requires a witness +* Implement `ToJSON` and `FromJSON` instances for `PoolVotingThresholds` and + `DRepVotingThreshold`, instead of deriving that doesn't handle field names + correctly. +* Hide `Cardano.Ledger.Conway.TxOut` module +* Export `ConwayEraPParams` and `ConwayEraTxBody` from `Cardano.Ledger.Conway.Core` +* Stop exporting `BabbagePParams` from `Cardano.Ledger.Conway.PParams` +* Add `transTxBodyWithdrawals`, `transTxCert`, `transDRepCred`, `transColdCommitteeCred`, + `transHotCommitteeCred`, `transDelegatee`, `transDRep`, `transScriptPurpose` +* Remove `conwayTxInfo` and `babbageScriptPrefixTag` +* Remove deprcated `translateScript` +* Add `getVoteDelegatee` +* Track and prune unreachable proposals #3855 #3919 #3978 #3981 + * Consolidate the entire proposals-tree under the `Proposals` module and expose all its operations in a convenient manner + * Move `PrevGovActionIds` from `Governance` to `Governance.Proposals` + * Add `rsEnacted` field to `RatifyState` to track enacted proposals separately from removed ones and rename `rsRemoved` to `rsExpired` in order to better represent its role + * Add `ProposalsSerializable` as an accompanying type used to correctly serialize `Proposals` in a space-efficient way + * Add the following operations to `Governance.Proposals` + * `mkProposals` as the only way to reconstruct the `Proposals` tree from, for instance, a deserialized one + * `proposalsAddAction` as the only way to add new proposals to the system + * `proposalsApplyEnactment` as the only way to replay from `ENACT` operations upon `Proposals` in the ledger state, outside of the pulser. + * Rename `PrevGovActionId purpose (EraCrypto era)` to `GovPurposeId purpose era` + * Add the following accessors and lenses, among others: + * `PForest` + * `PRoot` + * `PEdges` + * `PHierarchy` + * `pRootsL` + * `prRootL` + * `prChildrenL` + * `pnChildrenL` + * `pHierarchyL` + * `pHierarchyNodesL` + * `pfPParamUpdateL` + * `pfHardForkL` + * `pfCommitteeL` + * `pfConstitutionL` + * Add the pruning functionality and the deposit refunds in the `EPOCH` rule + * In the `Gov` rule + * Modify the rule transition implementation to accept new proposals into the `Proposals` forests based on proposal purpose + * In the `Ratify` rule + * Account for the tracking of enacted and expired proposals +* Moved `ToExpr` instances out of the main library and into the testlib. +* Changed the type of ConwayPParam's fields cppEMax, cppGovActionLifetime, cppDRepActivity +* Changed types of lenses: `ppGovActionLifetimeL`, `ppDRepActivityL`, `ppCommitteeMaxTermLengthL` and `ppuGovActionLifetimeL`, `ppuDRepActivityL`, `ppuCommitteeMaxTermLengthL` +* Implement `getNextEpochCommitteeMembers` in Conway `EraGov` +* Change argument of `validCommitteeTerm` function from `StrictMaybe Committee` to `GovAction` + +### `testlib` + +* Add the previous governance action ID to the outputs of `electBasicCommittee` +* Add `setupPoolWithStake` +* Add: + * `registerPool` + * `sendCoinTo` and `sendValueTo` +* Add `submitProposal_` +* Add `submitTreasuryWithdrawals` +* Track and prune unreachable proposals #3855 #3919 #3978 #3981 + * Add invariant-respecting `Arbitrary` generators for `Proposals` + * Add property tests for all `Proposals` operations + * Add procedural unit tests for all `Proposals` operations +* Remove `Test.Cardano.Ledger.Conway.PParamsSpec` and replace the unit test it contained + with a new property test in `Test.Cardano.Ledger.Alonzo.Binary.CostModelsSpec` + +## 1.11.0.0 + +* Switch `ppCommitteeMaxTermLength` to `EpochNo`, rather than `Natural` +* Add `conwayTotalDepositsTxBody` and `conwayProposalsDeposits` +* Add `conwayDRepDepositsTxCerts`, `conwayDRepRefundsTxCerts`, + `conwayTotalDepositsTxCerts` and `conwayTotalRefundsTxCerts` +* Rename data-type `ProposalsSnapshot` to `Proposals`. #3859 + * Rename module `Governance.Snapshots` to `Governance.Proposals`. + * Rename all the functions related to the data-type. +* Switch to using `OMap` for `ProposalsSnapshot` #3791 +* Add `VotingOnExpiredGovAction` predicate failure in `GOV` #3825 +* Rename `modifiedGroups` -> `modifiedPPGroups` and move into `ConwayEraPParams` +* Expose `pparamsUpdateThreshold` +* Fix [#3835](https://github.com/intersectmbo/cardano-ledger/issues/3835) +* Rename `PParamGroup` to `PPGroup` and `GovernanceGroup` to `GovGroup` +* Introduce `THKD` and use it for `ConwayPParams` +* Add `data ConwayGovEvent era` with constructor `GovNewProposals !(TxId (EraCrypto era)) !(ProposalsSnapshot era)`. #3856 +* Add `EpochBoundaryRatifyState (RatifyState era)` inhabitant to the `ConwayEpochEvent era` data type. + +### `testlib` + +* Provide CDDL spec files with `readConwayCddlFileNames` and `readConwayCddlFiles` from + `Test.Cardano.Ledger.Conway.Binary.Cddl` + +## 1.10.0.0 + +* Add `ToJSON` instance for `ProposalProcedure` +* Fix `NewEpochState` translation: #3801 +* Change order of arguments for `committeeAccepted` adn `spoAccepted` for consistency #3801 +* Add `spoAcceptedRatio` #3801 +* Export `snapshotGovActionStates` #3801 +* Change type for `snapshotRemoveIds` to also return the removed actions. #3801 +* Add `reDRepDistrL` #3759 +* Remove `GovSnapshots` #3759 +* Move `DRepPulser` from `cardano-ledger-core`. #3759 +* Add `DRepPulsingState` #3759: `pulseDRepPulsingState`, `completeDRepPulsingState`, + `extractDRepPulsingState`, `finishDRepPulser`, `computeDrepDistr`, `getRatifyState`, + `getPulsingStateDRepDistr`, `dormantEpoch`, `setFreshDRepPulsingState`, + `setCompleteDRepPulsingState` +* Add `PulsingSnapshot` and `psProposalsL`, `psDRepDistrL`, `psDRepStateL` #3759 +* Add `RunConwayRatify` class #3759 +* Enforce no duplicates from `certsTxBodyL` and `proposalProceduresTxBodyL` #3779 +* Remove `WrongCertificateTypeDELEG` predicate failure. +* Add `getDelegateeTxCert` and `getStakePoolDelegatee` +* Add `enactStateGovStateL` to `ConwayEraGov` +* Add `psDRepDistrG`. +* Rename `ensPParams` to `ensCurPParams`. +* Add `ToJSON` instance for `RatifyState` +* Change `ToJSON` instance for `ConwayGovState`: + * Add `"nextRatifyState"` field + * Rename `"ratify"` to `"enactState"` + * Rename `"gov"` to `"proposals"` +* Fix `ToJSON` instance for `EnactState`: + * Current PParams were wrongfully used for `"prevPParams"`. + * Remove `"treasury"` and `"withdrawals"` as those are temporary bindings needed only + for `ENACT` rule +* Add an anchor argument to `ResignCommitteeColdTxCert` +* Prevent invalid previous gov-action ids in proposals #3768 + * Also, add lenses + * `govProceduresProposalsL` + * `pProcGovActionL` + * `gasActionL` +* Add `ToExpr` instance for: + * `Voter` + * `ConwayCertPredFailure` + * `ConwayCertsPredFailure` + * `ConwayDelegPredFailure` + * `ConwayGovPredFailure` + * `ConwayGovCertPredFailure` + * `ConwayLedgerPredFailure` + * `ConwayTxBody` +* Add `Generic` and `NFData` instance for: + * `ConwayNewEpochPredFailure` +* Add `totalObligation` +* Add `utxosDepositedL` +* Add `conwayWitsVKeyNeeded` +* Add `ConwayEraPParams era` constraint to `isCommitteeVotingAllowed` and `votingCommitteeThreshold` +* Switch to using `AlonzoEraUTxO` in rules +* Change `cppProtocolVersion` to a `HKDNoUpdate` field + +### `testlib` + +* Addition of `ImpTest` interface + +## 1.9.0.0 + +* Add `ConwayEraPParams era` constraint to `isCommitteeVotingAllowed` and `votingCommitteeThreshold` +* Add `ToExpr` instance for: + * `Voter` + * `VotingProcedures` + * `VotingProcedure` + * `ProposalProcedure` + * `ConwayTxBody` +* Add `ConwayTxBodyUpgradeError`, `ConwayTxCertUpgradeError` +* Add to `Ratify`: + * `committeeAccepted` + * `committeeAcceptedRatio` +* Add `reCommitteeState` to `RatifyEnv` +* Add PredicateFailure for current treasury value mismatch in tx body in LEDGER #3749 +* Change `To/FromJSON` format for `ConwayGenesis` +* Add `EraTransition` instance and `toConwayTransitionConfigPairs`. +* Expose `toConwayGenesisPairs` and `toUpgradeConwayPParamsUpdatePairs` +* Rename `ConwayPParams` to be consistent with the Agda specification. #3739 + * `govActionExpiration` to `govActionLifetime` + * `committeeTermLimit` to `committeeMaxTermLength` + * `minCommitteeSize` to `committeeMinSize` +* Prevent `DRep` expiry when there are no active governance proposals to vote on (in + ConwayCERTS). #3729 + * Add `updateNumDormantEpochs` function in `ConwayEPOCH` to update the dormant-epochs counter + * Refactor access to `ConwayGovState` by making its lens part of `ConwayEraGov`. + * Export `gasExpiresAfterL` for use in tests +* Add `ExpirationEpochTooSmall` data constructor to `ConwayGovPredFailure` +* Add `ConflictingCommitteeUpdate` data constructor to `ConwayGovPredFailure` +* Rename `NewCommitte` to `UpdateCommittee` +* Remove `NewCommitteeSizeTooSmall` data constructor from `ConwayGovPredFailure` +* Fix invalid order in `fromGovActionStateSeq`, thus also `DecCBOR` for `ProposalsSnapshot` +* Remove `DecCBOR`/`EncCBOR` and `FromCBOR`/`ToCBOR` for `RatifyState`, since that state + is ephemeral and is never serialized. +* Add `PredicateFailure` for `Voter` - `GovAction` mismatches, with `checkVotesAreValid`. #3718 + * Add `DisallowedVoters (Map (GovActionId (EraCrypto era)) (Voter (EraCrypto era)))` + inhabitant to the `ConwayGovPredFailure` data type. + * Fix naming for `toPrevGovActionIdsParis` to `toPrevGovActionIdsPairs` +* Rename: + * `thresholdSPO` -> `votingStakePoolThreshold` + * `thresholdDRep` -> `votingDRepThreshold` + * `thresholdCC` -> `votingCommitteeThreshold` +* Add: + * `isStakePoolVotingAllowed` + * `isDRepVotingAllowed` + * `isCommitteeVotingAllowed` +* Fix `ConwayTxBodyRaw` decoder to disallow empty `Field`s #3712 + * `certsTxBodyL` + * `withdrawalsTxBodyL` + * `mintTxBodyL` + * `collateralInputsTxBodyL` + * `reqSignerHashesTxBodyL` + * `referenceInputsTxBodyL` + * `votingProceduresTxBodyL` + * `proposalProceduresTxBodyL` +* Add `reorderActions`, `actionPriority` +* Remove `ensProtVer` field from `EnactState`: #3705 +* Move `ConwayEraTxBody` to `Cardano.Ledger.Conway.TxBody` +* Move `ConwayEraPParams` to `Cardano.Ledger.Conway.PParams` +* Rename: + * `GovActionsState` to `GovSnapshots` + * `cgGovActionsStateL` to `cgGovSnapshotsL` + * `curGovActionsStateL` to `curGovSnapshotsL` + * `prevGovActionsStateL` to `prevGovSnapshotsL` +* Add: + * `ProposalsSnapshot` + * `snapshotIds` + * `snapshotAddVote` + * `snapshotInsertGovAction` + * `snapshotActions` + * `snapshotRemoveIds` + * `fromGovActionStateSeq` +* Add lenses: + * `gasCommitteeVotesL` + * `gasDRepVotesL` + * `gasStakePoolVotesL` +* Add `FromJSON` instance for `Committee` +* Add `constitution` and `committee` fields to `ConwayGenesis` + +### testlib + +* Add `Test.Cardano.Ledger.Conway.ImpTest` +* Rename `genNewCommittee` to `genUpdateCommitteee` +* Add `genNewCommittee` +* Add `genNoConfidence` +* Add `genTreasuryWithdrawals` +* Add `genHardForkInitiation` +* Add `genParameterChange` +* Add `genNewConstitution` +* Add `genGovActionStateFromAction` +* Add `govActionGenerators` + +## 1.8.1.0 + +* Apply enacted `TreasuryWithdrawals` in `ConwayEPOCH` #3748 + * Add lenses `ensWithdrawalsL` and `ensTreasuryL` + +## 1.8.0.0 + +* Add all Conway `TxCert` to consumed/produced calculations in the `UTXO` rule. #3700 +* Change `ToJSONKey` implementation of `Voter` to flat text +* Add DRep refund calculation #3688 + * Add `conwayConsumedValue` as `getConsumedValue` for Conway +* Change `PredicateFailure (ConwayENACT era)` to `Void` +* Remove `EnactPredFailure` +* Change `PredicateFailure (ConwayEPOCH era)` to `Void` +* Remove `ConwayEpochPredFailure` +* Remove `EpochFailure` and `RatifyFailure` from `ConwayNewEpochPredFailure` +* Change `PredicateFailure (ConwayRATIFY era)` to `Void` +* Add: + * `rsDelayed` + * `PParamGroup` + * `ParamGrouper` + * `pGroup` + * `pUngrouped` + * `modifiedGroups` + * `dvtPPNetworkGroupL` + * `dvtPPGovGroupL` + * `dvtPPTechnicalGroupL` + * `dvtPPEconomicGroupL` + * `threshold` + * `ensCommitteeL` +* Add `pparamsGroups` to `ConwayEraPParams` +* Add `PrevGovActionIds` +* Change `EnactState` to add `ensPrevGovActionIds` +* Add `ensPrevGovActionIdsL`, `ensPrevPParamUpdateL`, `ensPrevHardForkL` `ensPrevCommitteeL`, `ensPrevConstitutionL` +* Add `EnactSignal` and the signal of `Enact` to it +* Remove `rsFuture` from `RatifyState` +* Add to `GovActionsState`: + * `curGovActionsState` + * `prevGovActionsState` + * `prevDRepState` + * `prevCommitteeState` +* Add `ToExpr` instances to: + * `PoolVotingThresholds` + * `DRepVotingThresholds` + * `GovActionState` + * `GovActionsState` + * `EnactState` + * `RatifyState` + * `ConwayGovState` + * `GovActionIx` + * `GovActionId` + * `Vote` + * `Committee` + * `PrevGovActionId` + * `GovAction` + * `ConwayPParams` with `Identity` and `StrictMaybe` +* Add lenses: + * `cgEnactStateL` + * `curGovActionsStateL` + * `prevGovActionsStateL` + * `prevDRepStateL` + * `prevCommitteeStateL` +* Replace `cgRatifyState` with `cgEnactState` +* Deprecate `cgRatifyStateL` +* Add `ProposalDepositIncorrect` predicate failure, that is produced when `ProposalProcedure` deposit does not match `"govActionDeposit"` from `PParams` #3669 +* Add "minCommitteeSize" `PParam` validation for `NewCommittee` `GovAction` #3668 + * Add `committeeMembersL` and `committeeQuorumL` lenses for `Committee` + * Add `NewCommitteeSizeTooSmall` `PredicateFailure` in `GOV` +* Add `EqRaw` instance for `ConwayTxBody` +* Add `ToExpr` instance for `Delegatee`, `ConwayDelegCert`, `ConwayGovCert` and + `ConwayTxCert` +* Implement expiry for governance proposals #3664 + * Update `ppGovActionExpiration` to be an `EpochNo` + * Add `gasExpiresAfter :: !EpochNo` to `GovActionState` + * Add `gePParams` to `GovEnv` + * Rename `teTxId` to `geTxId` and `teEpoch` to `geEpoch` +* Add `reDRepState` to `RatifyEnv` +* Add field `gasId` to `GovActionState` +* Add `insertGovActionsState` +* Change type of `rsRemoved` in `RatifyState` to use `GovActionState` instead of a tuple +* Change `RatifySignal` to use `GovActionsState` instead of a tuple + +## 1.7.1.0 + +* Fix DRep distribution computation. + +## 1.7.0.0 + +* Add `Network` validation for `ProposalProcedure` and `TreasuryWithdrawals` in GOV #3659 +* Make `DELEG`, `POOL` and `GOVCERT` conform to spec-v0.8 #3628 + * Add `CertEnv` and `CertsEnv` to pass `EpochNo` down from `LEDGER` to sub-rules + * Add `drepDeposit` to `DRepState` to track deposits paid by `DRep`s + * Update `DRep` expiry in `LEDGER` for all `DRep`s who are voting in current `Tx` +* Add `ConwayGovCertEnv` +* Change the environment of `GOVCERT` to `ConwayGovCertEnv` +* Add `ConwayEraGov` with `constitutionGovStateL` +* Add `PrevGovActionId` and `GovActionPurpose` +* Add optional `PrevGovActionId` to `ParameterChange`, `HardForkInitiation`, + `NoConfidence`, `NewCommittee` and `NewConstitution` governance actions. +* Rename `*governance*` to `*gov*` #3607 + * `GovernanceAction` to `GovAction` + * `GovernanceActionId` to `GovActionId` + * `GovernanceActionIx` to `GovActionIx` + * `GovernanceActionState` to `GovActionState` + * `ConwayGovState` to `GovActionsState` + * `ConwayGovernance` to `ConwayGovState` +* Add `MalformedProposal` to `ConwayGovPredFailure` +* Add `ppuWellFormed` to `ConwayEraPParams` +* Filter out zero valued `TxOut`'s on Byron/Shelley boundary instead of on Babbage/Conway. +* Deprecate `translateTxOut` in favor of `upgradeTxOut` +* Deprecate `translateScript` in favor of `upgradeScript` +* Switch GovernanceActionIx to `Word32` fro `Word64` and remove `Num` and `Enum` + instances, which are dangerous due to potential overflows. +* Add `currentTreasuryValue :: !(StrictMaybe Coin)` as a new field to Conway TxBody #3586 +* Add an optional Anchor to the Conway DRep registration certificate #3576 +* Change `ConwayCommitteeCert` to allow: + * committee cold keys to be script-hashes #3581 + * committee hot keys to be script-hashes #3552 +* Change EnactState.ensConstitution #3556 + * from `SafeHash (EraCrypto era) ByteString` + * to `Constitution era` + * Use this datatype for GovernanceAction.NewConstitution +* Add `ConwayPParams` #3498 + * Add `UpgradeConwayPParams` + * Add `ConwayEraPParams` + * Add `PoolVotingThresholds` + * Add `DRepVotingThresholds` +* Rename: + * `cgTally` -> `cgGovActionsState` + * `cgTallyL` -> `cgGovActionsStateL` + * `VDelFailure` -> `GovCertFailure` + * `VDelEvent` -> `GovCertEvent` + * `certVState` -> `certGState` + * `ConwayVDelPredFailure` -> `ConwayGovCertPredFailure` + * `ConwayTallyPredFailure` -> `ConwayGovPredFailure` + * `TallyEnv` -> `GovEnv` + * `ConwayTallyState` -> `ConwayGovState` + * `TALLY` -> `GOV` + * `VDEL` -> `GOVCERT` +* Make `Anchor` required in `ProposalProcedure`. +* Add `ConwayUTXO` +* Add `indexedGovProps` +* Add `rsRemoved` to `RatifyState` +* Add `conwayProducedValue` +* Changed the superclasses of `STS (ConwayUTXOS era)` +* Add `VotingProcedures` type +* Remove `vProcGovActionId` and `vProcVoter` from `VotingProcedure` +* Change the type of `votingProceduresL` to return `VotingProcedures`, which is a nested Map + instead of a sequence, as before. +* Change `GovernanceActionDoesNotExist` to `GovernanceActionsDoNotExist`, which now + reports all actions as a set, rather than one action per each individual failure. +* Type of `gpVotingProcedures` in `GovernanceProcedures` was aslo changed to `GovernanceProcedures` +* Rename: + * `ConwayCommitteeCert` -> `ConwayGovCert` + * `ConwayTxCertCommittee` -> `ConwayTxCertGov` +* Remove `DelegStakeTxCert` from the `COMPLETE` pragma for `TxCert` +* Add `Committee` and adjust `NewCommittee` governance action +* Add `treasuryDonationTxBodyL` to `ConwayEraTxBody` +* Add `ConwayUpdateDRep` constructor to `ConwayGovCert` type and corresponding pattern `UnRegDRepTxCert` +* Update `ProposalProcedure` return address to be a `RewardAcnt` +* Add `ensPrevPParams` field to `EnactState` +* Add lenses: + * `ensPrevPParamsL` + * `ensCurPParamsL` + +## 1.6.3.0 + +* Implement stake distribution handling in the `TICKF` rule. + +## 1.6.2.0 + +* Add implementation for `spendableInputsTxBodyL` + +## 1.6.1.0 + +* Removal of TxOuts with zero `Coin` from UTxO on translation + +## 1.6.0.0 + +* Removal of `GovernanceProcedure` in favor of `GovernanceProcedures` + +## 1.5.0.0 + +* Add `ensConstitutionL` and `rsEnactStateL` to `Governance` #3506 + * Override `getConsitutionHash` for Conway to return just the hash of the constitution +* Added `ConwayWdrlNotDelegatedToDRep` to `ConwayLedgerPredFailure` +* Changed the type of voting delegatee from `Credential` to `DRep` +* Removal of `VoterRole` in favor of `Voter` +* Removal of `vProcRole` and `vProcRoleKeyHash` in favor of `vProcVoter` in `VotingProcedure` +* Removal of `cgVoterRolesL` and `cgVoterRoles` for `ConwayGovernance` as no longer needed. +* Removal of `gasVotes` in favor of `gasCommitteeVotes`, `gasDRepVotes` and + `gasStakePoolVotes` in `GovernanceActionState` +* Removal of `reRoles` from `RatifyEnv` as no longer needed +* Addition of `reStakePoolDistr` to `RatifyEnv` +* Remove `VoterDoesNotHaveRole` as no longer needed from `ConwayTallyPredFailure` +* Added `ConwayEpochPredFailure` +* Added instance for `Embed (ConwayRATIFY era) (ConwayEPOCH era)` +* Removed instance for `Embed (ConwayRATIFY era) (ConwayNEWEPOCH era)` +* Changed superclasses of `STS (ConwayEPOCH era)` and `STS (ConwayNEWEPOCH era)` + +## 1.4.0.0 + +* Added `ConwayUTXOW` rule + +### `testlib` + +* Add `Arbitrary` instances for `ConwayCertPredFailure`, `ConwayVDelPredFailure`, and `ConwayDelegPredFailure` + +## 1.3.0.0 + +* Add `VDEL` rules to Conway #3467 +* Add `EncCBOR`/`DecCBOR` for `ConwayCertPredFailure` +* Add `EncCBOR`/`DecCBOR` for `ConwayVDelPredFailure` +* Add `POOL` rules to Conway #3464 + * Make `ShelleyPOOL` rules reusable in Conway +* Add `CERT` and `DELEG` rules to Conway #3412 + * Add `domDeleteAll` to `UMap`. +* Introduction of `TxCert` and `EraTxCert` +* Add `ConwayEraTxCert` +* Add `EraTxCert`, `ShelleyEraTxCert` and `ConwayEraTxCert` instances for `ConwayEra` +* Add `EraPlutusContext 'PlutusV1` instance to `ConwayEra` +* Add `EraPlutusContext 'PlutusV2` instance to `ConwayEra` +* Add `EraPlutusContext 'PlutusV3` instance to `ConwayEra` +* Added `toShelleyDelegCert` and `fromShelleyDelegCert` +* Changed `ConwayDelegCert` structure #3408 +* Addition of `getScriptWitnessConwayTxCert` and `getVKeyWitnessConwayTxCert` +* Add `ConwayCommitteeCert` + +## 1.2.0.0 + +* Added `ConwayDelegCert` and `Delegatee` #3372 +* Removed `toShelleyDCert` and `fromShelleyDCertMaybe` #3372 +* Replace `DPState c` with `CertState era` +* Add `TranslateEra` instances for: + * `DState` + * `PState` + * `VState` +* Add `ConwayDelegsPredFailure` +* Renamed `DELPL` to `CERT` +* Added `ConwayDELEGS` rule +* Added `ConwayCERT` rule +* Added `ConwayDelegsPredFailure` rule +* Added `ConwayDelegsEvent` rule +* Change the Conway txInfo to allow Plutus V3 + NOTE - unlike V1 and V2, the ledger will no longer place the "zero ada" value + in the script context for the transaction minting field. +* Added instances for ConwayDelegsPredFailure: + `NoThunks`, `EncCBOR`, `DecCBOR`, and `Arbitrary` +* Added `GovernanceActionMetadata` +* Added `RatifyEnv` and `RatifySignal` + +## 1.1.0.0 + +* Added `RATIFY` rule +* Added `ConwayGovernance` +* Added lenses: + * `cgTallyL` + * `cgRatifyL` + * `cgVoterRolesL` +* Removed `GovernanceActionInfo` +* Replaced `ctbrVotes` and `ctbrGovActions` with `ctbrGovProcedure` +* Renamed `ENACTMENT` to `ENACT` +* Add `ToJSON` instance for: #3323 + * `ConwayGovernance` + * `ConwayTallyState` + * `GovernanceAction` + * `GovernanceActionState` + * `GovernanceActionIx` + * `GovernanceActionId` +* Add `ToJSONKey` instance for `GovernanceActionId` #3323 +* Fix `EncCBOR`/`DecCBOR` and `ToCBOR`/`FromCBOR` for `ConwayTallyState` #3323 +* Add `Anchor` and `AnchorDataHash` types. #3323 +* Rename `transDCert` to `toShelleyDCert` +* Add `fromShelleyDCertMaybe` +* Renamed `Vote` type to `VotingProcedure` +* Add `ProposalProcedure` +* Use `VotingProcedure` and `ProposalProcedure` in `GovernanceProcedure` +* Rename `VoteDecision` to `Vote`. Rename `No`/`Yes` -> `VoteNo`/`VoteYes`. +* Export `govActionIdToText` +* Export constructors for `ConwayTallyPredFailure` +* Add `ensTreasury` and `ensWithdrawals` to `EnactState` #3339 +* Add `EnactPredFailure` as the failure for `ENACT` and `RATIFY` #3339 +* Add `RatifyFailure` to `ConwayNewEpochPredFailure` #3339 +* Add `EncCBOR`/`DecCBOR` and `ToCBOR`/`FromCBOR` for `ConwayTallyPredFailure` +* Add `ToCBOR`/`FromCBOR` for `ConwayGovernance` +* Remove `cgAlonzoGenesis` from `ConwayGenesis`. +* Set `ConwayGenesis` as `TranslationContext` + +### `testlib` + +* Fix `Arbitrary` for `ConwayTallyState`. #3323 +* Consolidate all `Arbitrary` instances from the test package to under a new `testlib`. #3285 +* Add `Arbitrary` instances for: + * `ConwayTallyPredFailure` + * `EnactState` + * `RatifyState` + * `ConwayGovernance` +* Fix `Arbitrary` for `ConwayTxBody`. + +## 1.0.0.0 + +* First properly versioned release. diff --git a/eras/babel/impl/Setup.hs b/eras/babel/impl/Setup.hs new file mode 100644 index 00000000000..e8ef27dbba9 --- /dev/null +++ b/eras/babel/impl/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/eras/babel/impl/cardano-ledger-babel.cabal b/eras/babel/impl/cardano-ledger-babel.cabal new file mode 100644 index 00000000000..20247becb75 --- /dev/null +++ b/eras/babel/impl/cardano-ledger-babel.cabal @@ -0,0 +1,203 @@ +cabal-version: 3.0 +name: cardano-ledger-babel +version: 1.14.0.0 +license: Apache-2.0 +maintainer: operations@iohk.io +author: IOHK +bug-reports: https://github.com/intersectmbo/cardano-ledger/issues +synopsis: Cardano ledger with Babel Fees. +description: + This package builds upon the Conway ledger with Babel Fees + +category: Network +build-type: Simple +data-files: + test/data/*.json + cddl-files/babel.cddl + cddl-files/crypto.cddl + cddl-files/extra.cddl + +extra-source-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/intersectmbo/cardano-ledger + subdir: eras/babel/impl + +flag asserts + description: Enable assertions + default: False + +library + exposed-modules: + Cardano.Ledger.Babel.Era + Cardano.Ledger.Babel.Genesis + Cardano.Ledger.Babel.LedgerState.Types + Cardano.Ledger.Babel.PParams + Cardano.Ledger.Babel.Tx + Cardano.Ledger.Babel.TxBody + Cardano.Ledger.Babel.TxInfo + Cardano.Ledger.Babel.TxWits + Cardano.Ledger.Babel.Transition + Cardano.Ledger.Babel.Translation + Cardano.Ledger.Babel.Scripts + Cardano.Ledger.Babel + Cardano.Ledger.Babel.Governance + Cardano.Ledger.Babel.Rules + Cardano.Ledger.Babel.Rules.Bbody + Cardano.Ledger.Babel.Core + Cardano.Ledger.Babel.TxCert + Cardano.Ledger.Babel.FRxO + Cardano.Ledger.Babel.UTxO + Cardano.Ledger.Babel.Plutus.Context + Cardano.Ledger.Babel.API.Validation + + hs-source-dirs: src + other-modules: + Cardano.Ledger.Babel.API.Genesis + Cardano.Ledger.Babel.API.Mempool + Cardano.Ledger.Babel.Rules.Gov + Cardano.Ledger.Babel.Rules.Ledger + Cardano.Ledger.Babel.Rules.Ledgers + Cardano.Ledger.Babel.Rules.Pool + Cardano.Ledger.Babel.Rules.Utxo + Cardano.Ledger.Babel.Rules.Utxos + Cardano.Ledger.Babel.Rules.Utxow + Cardano.Ledger.Babel.Rules.Zone + Cardano.Ledger.Babel.Rules.Zones + Cardano.Ledger.Babel.Rules.Cert + Cardano.Ledger.Babel.Rules.Certs + Cardano.Ledger.Babel.Rules.Deleg + Cardano.Ledger.Babel.Rules.GovCert + Cardano.Ledger.Babel.TxAuxData + Cardano.Ledger.Babel.TxOut + + default-language: Haskell2010 + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -Wunused-packages + + build-depends: + base >=4.14 && <5, + aeson >=2.2, + bytestring, + data-default-class, + cardano-crypto-class, + cardano-data >=1.2.1, + cardano-ledger-binary >=1.3.2, + cardano-ledger-allegra >=1.4, + cardano-ledger-alonzo >=1.8, + cardano-ledger-babbage >=1.8, + cardano-ledger-conway >=1.14.0.0, + cardano-ledger-core >=1.12, + cardano-ledger-mary >=1.6, + cardano-ledger-shelley >=1.11, + cardano-strict-containers, + containers, + deepseq, + microlens, + mtl, + nothunks, + plutus-ledger-api ^>=1.30.0.0, + small-steps >=1.1, + transformers, + validation-selective, + plutus-tx, + + if flag(asserts) + ghc-options: -fno-ignore-asserts + +library testlib + exposed-modules: + Test.Cardano.Ledger.Babel.Arbitrary + Test.Cardano.Ledger.Babel.Binary.Cddl + Test.Cardano.Ledger.Babel.Binary.RoundTrip + Test.Cardano.Ledger.Babel.Binary.Regression + Test.Cardano.Ledger.Babel.ImpTest + Test.Cardano.Ledger.Babel.Imp + Test.Cardano.Ledger.Babel.Imp.EpochSpec + Test.Cardano.Ledger.Babel.Imp.EnactSpec + Test.Cardano.Ledger.Babel.Imp.GovSpec + Test.Cardano.Ledger.Babel.Imp.GovCertSpec + Test.Cardano.Ledger.Babel.Imp.UtxoSpec + Test.Cardano.Ledger.Babel.Imp.UtxosSpec + Test.Cardano.Ledger.Babel.Imp.RatifySpec + Test.Cardano.Ledger.Babel.Proposals + Test.Cardano.Ledger.Babel.TreeDiff + Test.Cardano.Ledger.Babel.Genesis + + visibility: public + hs-source-dirs: testlib + other-modules: Paths_cardano_ledger_babel + default-language: Haskell2010 + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -Wunused-packages + + build-depends: + base, + bytestring, + cardano-data:{cardano-data, testlib}, + containers, + plutus-ledger-api, + deepseq, + microlens, + cardano-crypto-class, + cardano-ledger-allegra, + cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib}, + cardano-ledger-binary, + cardano-ledger-babbage:{cardano-ledger-babbage, testlib}, + cardano-ledger-babel, + cardano-ledger-core:{cardano-ledger-core, testlib}, + cardano-ledger-conway:{cardano-ledger-conway, testlib}, + cardano-ledger-mary, + cardano-ledger-shelley, + cardano-strict-containers, + data-default-class, + generic-random, + microlens-mtl, + mtl, + text, + small-steps >=1.1 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + other-modules: + Test.Cardano.Ledger.Babel.BinarySpec + Test.Cardano.Ledger.Babel.Binary.CddlSpec + Test.Cardano.Ledger.Babel.DRepRatifySpec + Test.Cardano.Ledger.Babel.CommitteeRatifySpec + Test.Cardano.Ledger.Babel.GenesisSpec + Test.Cardano.Ledger.Babel.GovActionReorderSpec + Test.Cardano.Ledger.Babel.Plutus.PlutusSpec + Paths_cardano_ledger_babel + + default-language: Haskell2010 + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints -Wpartial-fields + -Wunused-packages -threaded -rtsopts -with-rtsopts=-N + + build-depends: + aeson, + base, + cardano-ledger-core:testlib, + cardano-ledger-allegra, + cardano-ledger-alonzo:testlib, + cardano-ledger-alonzo, + cardano-ledger-babbage, + cardano-ledger-babel, + cardano-ledger-shelley:testlib, + cardano-ledger-conway:{cardano-ledger-conway, testlib}, + cardano-ledger-core, + cardano-ledger-binary:testlib, + cardano-slotting:testlib, + cardano-strict-containers, + containers, + data-default-class, + microlens, + testlib diff --git a/eras/babel/impl/cddl-files/babel.cddl b/eras/babel/impl/cddl-files/babel.cddl new file mode 100644 index 00000000000..73a831726e3 --- /dev/null +++ b/eras/babel/impl/cddl-files/babel.cddl @@ -0,0 +1,608 @@ +block = + [ header + , transaction_bodies : [* transaction_body] + , transaction_witness_sets : [* transaction_witness_set] + , auxiliary_data_set : {* transaction_index => auxiliary_data } + , invalid_transactions : [* transaction_index ] + ]; Valid blocks must also satisfy the following two constraints: + ; 1) the length of transaction_bodies and transaction_witness_sets + ; must be the same + ; 2) every transaction_index must be strictly smaller than the + ; length of transaction_bodies + +transaction = + [ transaction_body + , transaction_witness_set + , bool + , auxiliary_data / null + ] + +transaction_index = uint .size 2 + +header = + [ header_body + , body_signature : $kes_signature + ] + +header_body = + [ block_number : uint + , slot : uint + , prev_hash : $hash32 / null + , issuer_vkey : $vkey + , vrf_vkey : $vrf_vkey + , vrf_result : $vrf_cert ; replaces nonce_vrf and leader_vrf + , block_body_size : uint + , block_body_hash : $hash32 ; merkle triple root + , operational_cert + , protocol_version + ] + +operational_cert = + [ hot_vkey : $kes_vkey + , sequence_number : uint + , kes_period : uint + , sigma : $signature + ] + +next_major_protocol_version = 10 + +major_protocol_version = 1..next_major_protocol_version + +protocol_version = [(major_protocol_version, uint)] + +transaction_body = + { 0 : set ; inputs + , 1 : [* transaction_output] + , 2 : coin ; fee + , ? 3 : uint ; time to live + , ? 4 : certificates + , ? 5 : withdrawals + , ? 7 : auxiliary_data_hash + , ? 8 : uint ; validity interval start + , ? 9 : mint + , ? 11 : script_data_hash + , ? 13 : nonempty_set ; collateral inputs + , ? 14 : required_signers + , ? 15 : network_id + , ? 16 : transaction_output ; collateral return + , ? 17 : coin ; total collateral + , ? 18 : nonempty_set ; reference inputs + , ? 19 : voting_procedures ; New; Voting procedures + , ? 20 : proposal_procedures ; New; Proposal procedures + , ? 21 : coin ; New; current treasury value + , ? 22 : positive_coin ; New; donation + } + +voting_procedures = { + voter => { + gov_action_id => voting_procedure } } + +voting_procedure = + [ vote + , anchor / null + ] + +proposal_procedure = + [ deposit : coin + , reward_account + , gov_action + , anchor + ] + +proposal_procedures = nonempty_oset + +certificates = nonempty_oset + +gov_action = + [ parameter_change_action + // hard_fork_initiation_action + // treasury_withdrawals_action + // no_confidence + // update_committee + // new_constitution + // info_action + ] + +policy_hash = scripthash + +parameter_change_action = (0, gov_action_id / null, protocol_param_update, policy_hash / null) + +hard_fork_initiation_action = (1, gov_action_id / null, protocol_version) + +treasury_withdrawals_action = (2, { reward_account => coin }, policy_hash / null) + +no_confidence = (3, gov_action_id / null) + +update_committee = (4, gov_action_id / null, set, { committee_cold_credential => epoch }, unit_interval) + +new_constitution = (5, gov_action_id / null, constitution) + +constitution = + [ anchor + , scripthash / null + ] + +info_action = 6 + +; Constitutional Committee Hot KeyHash: 0 +; Constitutional Committee Hot ScriptHash: 1 +; DRep KeyHash: 2 +; DRep ScriptHash: 3 +; StakingPool KeyHash: 4 +voter = + [ 0, addr_keyhash + // 1, scripthash + // 2, addr_keyhash + // 3, scripthash + // 4, addr_keyhash + ] + +anchor = + [ anchor_url : url + , anchor_data_hash : $hash32 + ] + +; no - 0 +; yes - 1 +; abstain - 2 +vote = 0 .. 2 + +gov_action_id = + [ transaction_id : $hash32 + , gov_action_index : uint + ] + +required_signers = nonempty_set + +transaction_input = [ transaction_id : $hash32 + , index : uint + ] + +; Both of the Alonzo and Babbage style TxOut formats are equally valid +; and can be used interchangeably +transaction_output = pre_babbage_transaction_output / post_alonzo_transaction_output + +pre_babbage_transaction_output = + [ address + , amount : value + , ? datum_hash : $hash32 + ] + +post_alonzo_transaction_output = + { 0 : address + , 1 : value + , ? 2 : datum_option ; datum option + , ? 3 : script_ref ; script reference + } + +script_data_hash = $hash32 +; This is a hash of data which may affect evaluation of a script. +; This data consists of: +; - The redeemers from the transaction_witness_set (the value of field 5). +; - The datums from the transaction_witness_set (the value of field 4). +; - The value in the costmdls map corresponding to the script's language +; (in field 18 of protocol_param_update.) +; (In the future it may contain additional protocol parameters.) +; +; Since this data does not exist in contiguous form inside a transaction, it needs +; to be independently constructed by each recipient. +; +; The bytestring which is hashed is the concatenation of three things: +; redeemers || datums || language views +; The redeemers are exactly the data present in the transaction witness set. +; Similarly for the datums, if present. If no datums are provided, the middle +; field is omitted (i.e. it is the empty/null bytestring). +; +; language views CDDL: +; { * language => script_integrity_data } +; +; This must be encoded canonically, using the same scheme as in +; RFC7049 section 3.9: +; - Maps, strings, and bytestrings must use a definite-length encoding +; - Integers must be as small as possible. +; - The expressions for map length, string length, and bytestring length +; must be as short as possible. +; - The keys in the map must be sorted as follows: +; - If two keys have different lengths, the shorter one sorts earlier. +; - If two keys have the same length, the one with the lower value +; in (byte-wise) lexical order sorts earlier. +; +; For PlutusV1 (language id 0), the language view is the following: +; - the value of costmdls map at key 0 (in other words, the script_integrity_data) +; is encoded as an indefinite length list and the result is encoded as a bytestring. +; (our apologies) +; For example, the script_integrity_data corresponding to the all zero costmodel for V1 +; would be encoded as (in hex): +; 58a89f00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000ff +; - the language ID tag is also encoded twice. first as a uint then as +; a bytestring. (our apologies) +; Concretely, this means that the language version for V1 is encoded as +; 4100 in hex. +; For PlutusV2 (language id 1), the language view is the following: +; - the value of costmdls map at key 1 is encoded as an definite length list. +; For example, the script_integrity_data corresponding to the all zero costmodel for V2 +; would be encoded as (in hex): +; 98af0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 +; - the language ID tag is encoded as expected. +; Concretely, this means that the language version for V2 is encoded as +; 01 in hex. +; For PlutusV3 (language id 2), the language view is the following: +; - the value of costmdls map at key 2 is encoded as a definite length list. +; +; Note that each Plutus language represented inside a transaction must have +; a cost model in the costmdls protocol parameter in order to execute, +; regardless of what the script integrity data is. +; +; Finally, note that in the case that a transaction includes datums but does not +; include the redeemers field, the script data format becomes (in hex): +; [ 80 | datums | A0 ] +; corresponding to a CBOR empty list and an empty map. +; Note that a transaction might include the redeemers field and it to the +; empty map, in which case the user supplied encoding of the empty map is used. + +; address = bytes +; reward_account = bytes + +; address format: +; [ 8 bit header | payload ]; +; +; shelley payment addresses: +; bit 7: 0 +; bit 6: base/other +; bit 5: pointer/enterprise [for base: stake cred is keyhash/scripthash] +; bit 4: payment cred is keyhash/scripthash +; bits 3-0: network id +; +; reward addresses: +; bits 7-5: 111 +; bit 4: credential is keyhash/scripthash +; bits 3-0: network id +; +; byron addresses: +; bits 7-4: 1000 + +; 0000: base address: keyhash28,keyhash28 +; 0001: base address: scripthash28,keyhash28 +; 0010: base address: keyhash28,scripthash28 +; 0011: base address: scripthash28,scripthash28 +; 0100: pointer address: keyhash28, 3 variable length uint +; 0101: pointer address: scripthash28, 3 variable length uint +; 0110: enterprise address: keyhash28 +; 0111: enterprise address: scripthash28 +; 1000: byron address +; 1110: reward account: keyhash28 +; 1111: reward account: scripthash28 +; 1001 - 1101: future formats + +certificate = + [ stake_registration + // stake_deregistration + // stake_delegation + // pool_registration + // pool_retirement + // reg_cert + // unreg_cert + // vote_deleg_cert + // stake_vote_deleg_cert + // stake_reg_deleg_cert + // vote_reg_deleg_cert + // stake_vote_reg_deleg_cert + // auth_committee_hot_cert + // resign_committee_cold_cert + // reg_drep_cert + // unreg_drep_cert + // update_drep_cert + ] + +stake_registration = (0, stake_credential) ; to be deprecated in era after Conway +stake_deregistration = (1, stake_credential) ; to be deprecated in era after Conway +stake_delegation = (2, stake_credential, pool_keyhash) + +; POOL +pool_registration = (3, pool_params) +pool_retirement = (4, pool_keyhash, epoch) + +; numbers 5 and 6 used to be the Genesis and MIR certificates respectively, +; which were deprecated in Conway + +; DELEG +reg_cert = (7, stake_credential, coin) +unreg_cert = (8, stake_credential, coin) +vote_deleg_cert = (9, stake_credential, drep) +stake_vote_deleg_cert = (10, stake_credential, pool_keyhash, drep) +stake_reg_deleg_cert = (11, stake_credential, pool_keyhash, coin) +vote_reg_deleg_cert = (12, stake_credential, drep, coin) +stake_vote_reg_deleg_cert = (13, stake_credential, pool_keyhash, drep, coin) + +; GOVCERT +auth_committee_hot_cert = (14, committee_cold_credential, committee_hot_credential) +resign_committee_cold_cert = (15, committee_cold_credential, anchor / null) +reg_drep_cert = (16, drep_credential, coin, anchor / null) +unreg_drep_cert = (17, drep_credential, coin) +update_drep_cert = (18, drep_credential, anchor / null) + + +delta_coin = int + +credential = + [ 0, addr_keyhash + // 1, scripthash + ] + +drep = + [ 0, addr_keyhash + // 1, scripthash + // 2 ; always abstain + // 3 ; always no confidence + ] + +stake_credential = credential +drep_credential = credential +committee_cold_credential = credential +committee_hot_credential = credential + +pool_params = ( operator: pool_keyhash + , vrf_keyhash: vrf_keyhash + , pledge: coin + , cost: coin + , margin: unit_interval + , reward_account: reward_account + , pool_owners: set + , relays: [* relay] + , pool_metadata: pool_metadata / null + ) + +port = uint .le 65535 +ipv4 = bytes .size 4 +ipv6 = bytes .size 16 +dns_name = tstr .size (0..128) + +single_host_addr = ( 0 + , port / null + , ipv4 / null + , ipv6 / null + ) +single_host_name = ( 1 + , port / null + , dns_name ; An A or AAAA DNS record + ) +multi_host_name = ( 2 + , dns_name ; A SRV DNS record + ) +relay = + [ single_host_addr + // single_host_name + // multi_host_name + ] + +pool_metadata = [url, pool_metadata_hash] +url = tstr .size (0..128) + +withdrawals = { + reward_account => coin } + +protocol_param_update = + { ? 0: coin ; minfee A + , ? 1: coin ; minfee B + , ? 2: uint ; max block body size + , ? 3: uint ; max transaction size + , ? 4: uint ; max block header size + , ? 5: coin ; key deposit + , ? 6: coin ; pool deposit + , ? 7: epoch ; maximum epoch + , ? 8: uint ; n_opt: desired number of stake pools + , ? 9: nonnegative_interval ; pool pledge influence + , ? 10: unit_interval ; expansion rate + , ? 11: unit_interval ; treasury growth rate + , ? 16: coin ; min pool cost + , ? 17: coin ; ada per utxo byte + , ? 18: costmdls ; cost models for script languages + , ? 19: ex_unit_prices ; execution costs + , ? 20: ex_units ; max tx ex units + , ? 21: ex_units ; max block ex units + , ? 22: uint ; max value size + , ? 23: uint ; collateral percentage + , ? 24: uint ; max collateral inputs + , ? 25: pool_voting_thresholds ; pool voting thresholds + , ? 26: drep_voting_thresholds ; DRep voting thresholds + , ? 27: uint ; min committee size + , ? 28: epoch ; committee term limit + , ? 29: epoch ; governance action validity period + , ? 30: coin ; governance action deposit + , ? 31: coin ; DRep deposit + , ? 32: epoch ; DRep inactivity period + , ? 33: nonnegative_interval ; MinFee RefScriptCostPerByte + } + +pool_voting_thresholds = + [ unit_interval ; motion no confidence + , unit_interval ; committee normal + , unit_interval ; committee no confidence + , unit_interval ; hard fork initiation + , unit_interval ; security relevant parameter voting threshold + ] + +drep_voting_thresholds = + [ unit_interval ; motion no confidence + , unit_interval ; committee normal + , unit_interval ; committee no confidence + , unit_interval ; update constitution + , unit_interval ; hard fork initiation + , unit_interval ; PP network group + , unit_interval ; PP economic group + , unit_interval ; PP technical group + , unit_interval ; PP governance group + , unit_interval ; treasury withdrawal + ] + +transaction_witness_set = + { ? 0: nonempty_set + , ? 1: nonempty_set + , ? 2: nonempty_set + , ? 3: nonempty_set + , ? 4: nonempty_set + , ? 5: redeemers + , ? 6: nonempty_set + , ? 7: nonempty_set + } + +; The real type of plutus_v1_script, plutus_v2_script and plutus_v3_script is bytes. +; However, because we enforce uniqueness when many scripts are supplied, +; we need to hack around for tests in order to avoid generating duplicates, +; since the cddl tool we use for roundtrip testing doesn't generate distinct collections. +plutus_v1_script = distinct +plutus_v2_script = distinct +plutus_v3_script = distinct + +plutus_data = + constr + / { * plutus_data => plutus_data } + / [ * plutus_data ] + / big_int + / bounded_bytes + +big_int = int / big_uint / big_nint +big_uint = #6.2(bounded_bytes) +big_nint = #6.3(bounded_bytes) + +constr = + #6.121([* a]) + / #6.122([* a]) + / #6.123([* a]) + / #6.124([* a]) + / #6.125([* a]) + / #6.126([* a]) + / #6.127([* a]) + ; similarly for tag range: 6.1280 .. 6.1400 inclusive + / #6.102([uint, [* a]]) + +; Flat Array support is included for backwards compatibility and will be removed in the next era. +; It is recommended for tools to adopt using a Map instead of Array going forward. +redeemers = + [ + [ tag: redeemer_tag, index: uint, data: plutus_data, ex_units: ex_units ] ] + / { + [ tag: redeemer_tag, index: uint ] => [ data: plutus_data, ex_units: ex_units ] } + +redeemer_tag = + 0 ; Spending + / 1 ; Minting + / 2 ; Certifying + / 3 ; Rewarding + / 4 ; Voting + / 5 ; Proposing + +ex_units = [mem: uint, steps: uint] + +ex_unit_prices = + [ mem_price: nonnegative_interval, step_price: nonnegative_interval ] + +language = 0 ; Plutus v1 + / 1 ; Plutus v2 + / 2 ; Plutus v3 + +potential_languages = 0 .. 255 + +; The format for costmdls is flexible enough to allow adding Plutus built-ins and language +; versions in the future. +; +costmdls = + { ? 0 : [ 166* int ] ; Plutus v1, only 166 integers are used, but more are accepted (and ignored) + , ? 1 : [ 175* int ] ; Plutus v2, only 175 integers are used, but more are accepted (and ignored) + , ? 2 : [ 233* int ] ; Plutus v3, only 233 integers are used, but more are accepted (and ignored) + , ? 3 : [ int ] ; Any 8-bit unsigned number can be used as a key. + } + +transaction_metadatum = + { * transaction_metadatum => transaction_metadatum } + / [ * transaction_metadatum ] + / int + / bytes .size (0..64) + / text .size (0..64) + +transaction_metadatum_label = uint +metadata = { * transaction_metadatum_label => transaction_metadatum } + +auxiliary_data = + metadata ; Shelley + / [ transaction_metadata: metadata ; Shelley-ma + , auxiliary_scripts: [ * native_script ] + ] + / #6.259({ ? 0 => metadata ; Alonzo and beyond + , ? 1 => [ * native_script ] + , ? 2 => [ * plutus_v1_script ] + , ? 3 => [ * plutus_v2_script ] + , ? 4 => [ * plutus_v3_script ] + }) + +vkeywitness = [ $vkey, $signature ] + +bootstrap_witness = + [ public_key : $vkey + , signature : $signature + , chain_code : bytes .size 32 + , attributes : bytes + ] + +native_script = + [ script_pubkey + // script_all + // script_any + // script_n_of_k + // invalid_before + ; Timelock validity intervals are half-open intervals [a, b). + ; This field specifies the left (included) endpoint a. + // invalid_hereafter + ; Timelock validity intervals are half-open intervals [a, b). + ; This field specifies the right (excluded) endpoint b. + ] + +script_pubkey = (0, addr_keyhash) +script_all = (1, [ * native_script ]) +script_any = (2, [ * native_script ]) +script_n_of_k = (3, n: uint, [ * native_script ]) +invalid_before = (4, uint) +invalid_hereafter = (5, uint) + +coin = uint + +multiasset = { + policy_id => { + asset_name => a } } +policy_id = scripthash +asset_name = bytes .size (0..32) + +negInt64 = -9223372036854775808 .. -1 +posInt64 = 1 .. 9223372036854775807 +nonZeroInt64 = negInt64 / posInt64 ; this is the same as the current int64 definition but without zero + +positive_coin = 1 .. 18446744073709551615 + +value = coin / [coin, multiasset] + +mint = multiasset + +int64 = -9223372036854775808 .. 9223372036854775807 + +network_id = 0 / 1 + +epoch = uint + +addr_keyhash = $hash28 +pool_keyhash = $hash28 + +vrf_keyhash = $hash32 +auxiliary_data_hash = $hash32 +pool_metadata_hash = $hash32 + +; To compute a script hash, note that you must prepend +; a tag to the bytes of the script before hashing. +; The tag is determined by the language. +; The tags in the Conway era are: +; "\x00" for multisig scripts +; "\x01" for Plutus V1 scripts +; "\x02" for Plutus V2 scripts +; "\x03" for Plutus V3 scripts +scripthash = $hash28 + +datum_hash = $hash32 +data = #6.24(bytes .cbor plutus_data) + +datum_option = [ 0, $hash32 // 1, data ] + +script_ref = #6.24(bytes .cbor script) + +script = [ 0, native_script // 1, plutus_v1_script // 2, plutus_v2_script // 3, plutus_v3_script ] diff --git a/eras/babel/impl/cddl-files/crypto.cddl b/eras/babel/impl/cddl-files/crypto.cddl new file mode 100644 index 00000000000..339444964d2 --- /dev/null +++ b/eras/babel/impl/cddl-files/crypto.cddl @@ -0,0 +1,13 @@ +$hash28 /= bytes .size 28 +$hash32 /= bytes .size 32 + +$vkey /= bytes .size 32 + +$vrf_vkey /= bytes .size 32 +$vrf_cert /= [bytes, bytes .size 80] + +$kes_vkey /= bytes .size 32 +$kes_signature /= bytes .size 448 +signkeyKES = bytes .size 64 + +$signature /= bytes .size 64 diff --git a/eras/babel/impl/cddl-files/extra.cddl b/eras/babel/impl/cddl-files/extra.cddl new file mode 100644 index 00000000000..f4fa6e31ad7 --- /dev/null +++ b/eras/babel/impl/cddl-files/extra.cddl @@ -0,0 +1,59 @@ +; Conway era introduces an optional 258 tag for sets, which will become mandatory in the +; second era after Conway. We recommend all the tooling to account for this future breaking +; change sooner rather than later, in order to provide a smooth transition for their users. + +set = #6.258([* a]) / [* a] + +nonempty_set = #6.258([+ a]) / [+ a] + +nonempty_oset = #6.258([+ a]) / [+ a] + +positive_int = 1 .. 18446744073709551615 + +unit_interval = #6.30([1, 2]) + ; unit_interval = #6.30([uint, uint]) + ; + ; Comment above depicts the actual definition for `unit_interval`. + ; + ; Unit interval is a number in the range between 0 and 1, which + ; means there are two extra constraints: + ; * numerator <= denominator + ; * denominator > 0 + ; + ; Relation between numerator and denominator cannot be expressed in CDDL, which + ; poses a problem for testing. We need to be able to generate random valid data + ; for testing implementation of our encoders/decoders. Which means we cannot use + ; the actual definition here and we hard code the value to 1/2 + + +nonnegative_interval = #6.30([uint, positive_int]) + + +address = + h'001000000000000000000000000000000000000000000000000000000011000000000000000000000000000000000000000000000000000000' / + h'102000000000000000000000000000000000000000000000000000000022000000000000000000000000000000000000000000000000000000' / + h'203000000000000000000000000000000000000000000000000000000033000000000000000000000000000000000000000000000000000000' / + h'304000000000000000000000000000000000000000000000000000000044000000000000000000000000000000000000000000000000000000' / + h'405000000000000000000000000000000000000000000000000000000087680203' / + h'506000000000000000000000000000000000000000000000000000000087680203' / + h'6070000000000000000000000000000000000000000000000000000000' / + h'7080000000000000000000000000000000000000000000000000000000' + +reward_account = + h'E090000000000000000000000000000000000000000000000000000000' / + h'F0A0000000000000000000000000000000000000000000000000000000' + +bounded_bytes = bytes .size (0..64) + ; the real bounded_bytes does not have this limit. it instead has a different + ; limit which cannot be expressed in CDDL. + ; The limit is as follows: + ; - bytes with a definite-length encoding are limited to size 0..64 + ; - for bytes with an indefinite-length CBOR encoding, each chunk is + ; limited to size 0..64 + ; ( reminder: in CBOR, the indefinite-length encoding of bytestrings + ; consists of a token #2.31 followed by a sequence of definite-length + ; encoded bytestrings and a stop code ) + +; a type for distinct values. +; The type parameter must support .size, for example: bytes or uint +distinct = a .size 8 / a .size 16 / a .size 20 / a .size 24 / a .size 30 / a .size 32 diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel.hs b/eras/babel/impl/src/Cardano/Ledger/Babel.hs new file mode 100644 index 00000000000..084fc637487 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +-- CanStartFromGenesis +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel ( + Babel, + BabelEra, +) +where + +import Cardano.Ledger.Babbage.TxBody () +import Cardano.Ledger.Babel.API.Genesis (CanStartFromGenesis (..)) +import Cardano.Ledger.Babel.API.Mempool ( + ApplyTx (reapplyTx), + ApplyTxError (ApplyTxError), + extractTx, + ) +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Babel.Genesis (BabelGenesis (..)) +import Cardano.Ledger.Babel.Governance () +import Cardano.Ledger.Babel.Rules () +import Cardano.Ledger.Babel.Rules.Gov () +import Cardano.Ledger.Babel.Transition () +import Cardano.Ledger.Babel.Translation () +import Cardano.Ledger.Babel.Tx () +import Cardano.Ledger.Babel.TxInfo () +import Cardano.Ledger.Babel.TxOut () +import Cardano.Ledger.Babel.UTxO () +import Cardano.Ledger.Conway.Governance (RunConwayRatify (..)) +import Cardano.Ledger.Crypto (Crypto, StandardCrypto) +import Cardano.Ledger.Keys (DSignable, Hash) +import Cardano.Ledger.Rules.ValidationMode (applySTSNonStatic) +import Control.Arrow (left) +import Control.Monad.Error.Class (liftEither) +import Control.Monad.Reader (runReader) +import Control.State.Transition (TRC (TRC)) + +type Babel = BabelEra StandardCrypto + +-- ===================================================== + +instance + ( Crypto c + , DSignable c (Hash c EraIndependentTxBody) + , DSignable c (Hash c EraIndependentRequiredTxs) + ) => + ApplyTx (BabelEra c) + where + reapplyTx globals env state vtx = + let res = + flip runReader globals + . applySTSNonStatic + @(EraRule "LEDGER" (BabelEra c)) + $ TRC (env, state, extractTx vtx) + in liftEither . left ApplyTxError $ res + +instance Crypto c => CanStartFromGenesis (BabelEra c) where + type AdditionalGenesisConfig (BabelEra c) = BabelGenesis c + fromShelleyPParams = + error "Unimplemented: Current interface is too limited and needs replacement for Babel to work" + +instance Crypto c => RunConwayRatify (BabelEra c) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/API/Genesis.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/API/Genesis.hs new file mode 100644 index 00000000000..cd3141140af --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/API/Genesis.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Cardano.Ledger.Babel.API.Genesis where + +import Cardano.Ledger.BaseTypes (BlocksMade (..), EpochNo (EpochNo)) +import Cardano.Ledger.Crypto (Crypto) +import Cardano.Ledger.EpochBoundary (emptySnapShots) +import Cardano.Ledger.Shelley (ShelleyEra) +import Cardano.Ledger.Shelley.API.Types ( + AccountState (AccountState), + CertState (CertState), + Coin (Coin), + DState (..), + EpochState (EpochState), + GenDelegs (GenDelegs), + LedgerState (LedgerState), + NewEpochState (NewEpochState), + PoolDistr (PoolDistr), + ShelleyGenesis (sgGenDelegs, sgMaxLovelaceSupply, sgProtocolParams), + StrictMaybe (SNothing), + genesisUTxO, + word64ToCoin, + ) +import Cardano.Ledger.Shelley.Core +import Cardano.Ledger.Shelley.LedgerState ( + StashedAVVMAddresses, + smartUTxOState, + ) +import qualified Cardano.Ledger.UMap as UM +import Cardano.Ledger.UTxO (coinBalance) +import Cardano.Ledger.Val (Val (..)) +import Data.Default.Class (Default, def) +import Data.Kind (Type) +import qualified Data.Map.Strict as Map +import Lens.Micro ((&), (.~)) + +-- | Indicates that this era may be bootstrapped from 'ShelleyGenesis'. +class + ( EraTxOut era + , Default (StashedAVVMAddresses era) + , EraGov era + ) => + CanStartFromGenesis era + where + -- | Additional genesis configuration necessary for this era. + type AdditionalGenesisConfig era :: Type + + type AdditionalGenesisConfig era = () + + -- | Upgrade `PParams` from `ShelleyEra` all the way to the current one. + fromShelleyPParams :: + AdditionalGenesisConfig era -> + PParams (ShelleyEra (EraCrypto era)) -> + PParams era + + -- | Construct an initial state given a 'ShelleyGenesis' and any appropriate + -- 'AdditionalGenesisConfig' for the era. + initialState :: + ShelleyGenesis (EraCrypto era) -> + AdditionalGenesisConfig era -> + NewEpochState era + initialState = initialStateFromGenesis + +{-# DEPRECATED CanStartFromGenesis "Use `Cardano.Ledger.Shelley.Transition.EraTransition` instead" #-} +{-# DEPRECATED fromShelleyPParams "Use `Cardano.Ledger.Shelley.Transition.tcInitialPParamsG` instead" #-} +{-# DEPRECATED initialState "Use `Cardano.Ledger.Shelley.Transition.createInitialState` instead" #-} + +instance + Crypto c => + CanStartFromGenesis (ShelleyEra c) + where + fromShelleyPParams _ = id + +-- | Helper function for constructing the initial state for any era +initialStateFromGenesis :: + forall era. + CanStartFromGenesis era => + -- | Genesis type + ShelleyGenesis (EraCrypto era) -> + AdditionalGenesisConfig era -> + NewEpochState era +initialStateFromGenesis sg ag = + NewEpochState + initialEpochNo + (BlocksMade Map.empty) + (BlocksMade Map.empty) + ( EpochState + (AccountState (Coin 0) reserves) + ( LedgerState + (smartUTxOState (fromShelleyPParams ag pp) initialUtxo (Coin 0) (Coin 0) govSt zero) + (CertState def def dState) + ) + emptySnapShots + def + ) + SNothing + (PoolDistr Map.empty) + def + where + initialEpochNo = EpochNo 0 + initialUtxo = genesisUTxO sg + reserves = word64ToCoin (sgMaxLovelaceSupply sg) <-> coinBalance initialUtxo + genDelegs = sgGenDelegs sg + pp = sgProtocolParams sg + govSt = + def + & curPParamsGovStateL + .~ fromShelleyPParams ag pp + & prevPParamsGovStateL + .~ fromShelleyPParams ag pp + + dState :: DState era + dState = + DState + { dsUnified = UM.empty + , dsFutureGenDelegs = Map.empty + , dsGenDelegs = GenDelegs genDelegs + , dsIRewards = def + } diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/API/Mempool.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/API/Mempool.hs new file mode 100644 index 00000000000..4f717521b8b --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/API/Mempool.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +-- | Interface to the Conway ledger for the purposes of managing a Conway +-- mempool. +module Cardano.Ledger.Babel.API.Mempool ( + ApplyTx (..), + ApplyTxError (..), + Validated, + extractTx, + coerceValidated, + translateValidated, + + -- * Exports for testing + MempoolEnv, + MempoolState, + applyTxsTransition, + unsafeMakeValidated, + + -- * Exports for compatibility + applyTxs, + mkMempoolEnv, + mkMempoolState, + overNewEpochState, +) +where + +import Cardano.Ledger.BaseTypes (Globals, ShelleyBase) +import Cardano.Ledger.Binary ( + DecCBOR (..), + EncCBOR (..), + FromCBOR (..), + ToCBOR (..), + encodeFoldableAsIndefLenList, + ifEncodingVersionAtLeast, + natVersion, + ) +import Cardano.Ledger.Core +import Cardano.Ledger.Keys +import Cardano.Ledger.Shelley (ShelleyEra) +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 (LedgerEnv) +import qualified Cardano.Ledger.Shelley.Rules as Ledger +import Cardano.Ledger.Slot (SlotNo) +import Control.Arrow (ArrowChoice (right), left) +import Control.DeepSeq (NFData) +import Control.Monad (foldM) +import Control.Monad.Except (Except, MonadError, liftEither) +import Control.Monad.Trans.Reader (runReader) +import Control.State.Transition.Extended ( + BaseM, + Environment, + PredicateFailure, + STS, + Signal, + State, + TRC (..), + applySTS, + ) +import Data.Coerce (Coercible, coerce) +import Data.Functor ((<&>)) +import Data.List.NonEmpty (NonEmpty) +import Data.Sequence (Seq) +import Data.Typeable (Typeable) +import Lens.Micro ((^.)) +import NoThunks.Class (NoThunks) + +-- | A newtype which indicates that a transaction has been validated against +-- some chain state. +newtype Validated tx = Validated tx + deriving (Eq, NoThunks, Show, NFData) + +-- | Extract the underlying unvalidated Tx. +extractTx :: Validated tx -> tx +extractTx (Validated tx) = tx + +coerceValidated :: Coercible a b => Validated a -> Validated b +coerceValidated (Validated a) = Validated $ coerce a + +-- Don't use this except in Testing to make Arbitrary instances, etc. +unsafeMakeValidated :: tx -> Validated tx +unsafeMakeValidated = Validated + +-- | Translate a validated transaction across eras. +-- +-- This is not a `TranslateEra` instance since `Validated` is not itself +-- era-parametrised. +translateValidated :: + forall era f. + TranslateEra era f => + TranslationContext era -> + Validated (f (PreviousEra era)) -> + Except (TranslationError era f) (Validated (f era)) +translateValidated ctx (Validated tx) = Validated <$> translateEra @era ctx tx + +class + ( EraTx era + , Eq (ApplyTxError era) + , Show (ApplyTxError era) + , Typeable (ApplyTxError era) + , STS (EraRule "LEDGER" era) + , BaseM (EraRule "LEDGER" era) ~ ShelleyBase + , Environment (EraRule "LEDGER" era) ~ LedgerEnv era + , State (EraRule "LEDGER" era) ~ MempoolState era + , Signal (EraRule "LEDGER" era) ~ Tx era + ) => + ApplyTx era + where + -- | Validate a transaction against a mempool state, and return both the new + -- mempool state and a "validated" 'TxInBlock'. + -- + -- The meaning of being "validated" depends on the era. In general, a + -- 'TxInBlock' has had all checks run, and can now only fail due to checks + -- which depend on the state; most notably, that UTxO inputs disappear. + applyTx :: + MonadError (ApplyTxError era) m => + Globals -> + MempoolEnv era -> + MempoolState era -> + Tx era -> + m (MempoolState era, Validated (Tx era)) + applyTx globals env state tx = + let res = + flip runReader globals + . applySTS @(EraRule "LEDGER" era) + $ TRC (env, state, tx) + in liftEither + . left ApplyTxError + . right (,Validated tx) + $ res + + -- | Reapply a previously validated 'Tx'. + -- + -- This applies the (validated) transaction to a new mempool state. It may + -- fail due to the mempool state changing (for example, a needed output + -- having already been spent). It should not fail due to any static check + -- (such as cryptographic checks). + -- + -- Implementations of this function may optionally skip the performance of + -- any static checks. This is not required, but strongly encouraged since + -- this function will be called each time the mempool revalidates + -- transactions against a new mempool state. + reapplyTx :: + MonadError (ApplyTxError era) m => + Globals -> + MempoolEnv era -> + MempoolState era -> + Validated (Tx era) -> + m (MempoolState era) + reapplyTx globals env state (Validated tx) = + let res = + flip runReader globals + . applySTS @(EraRule "LEDGER" era) + $ TRC (env, state, tx) + in liftEither + . left ApplyTxError + $ res + +instance + ( EraPParams (ShelleyEra c) + , DSignable c (Hash c EraIndependentTxBody) + ) => + ApplyTx (ShelleyEra c) + +type MempoolEnv era = Ledger.LedgerEnv era + +type MempoolState era = LedgerState.LedgerState era + +-- | Construct the environment used to validate transactions from the full +-- ledger state. +-- +-- Note that this function also takes a slot. During slot validation, the slot +-- given here is the slot of the block containing the transactions. This slot is +-- used for quite a number of things, but in general these do not determine the +-- validity of the transaction. There are two exceptions: +-- +-- - Each transaction has a ttl (time-to-live) value. If the slot is beyond this +-- value, then the transaction is invalid. +-- - If the transaction contains a protocol update proposal, then it may only be +-- included until a certain number of slots before the end of the epoch. A +-- protocol update proposal submitted after this is considered invalid. +mkMempoolEnv :: + EraGov era => + NewEpochState era -> + SlotNo -> + MempoolEnv era +mkMempoolEnv + LedgerState.NewEpochState + { LedgerState.nesEs + } + slot = + Ledger.LedgerEnv + { Ledger.ledgerSlotNo = slot + , Ledger.ledgerIx = minBound + , Ledger.ledgerPp = nesEs ^. curPParamsEpochStateL + , Ledger.ledgerAccount = LedgerState.esAccountState nesEs + } + +-- | Construct a mempool state from the wider ledger state. +-- +-- The given mempool state may then be evolved using 'applyTxs', but should be +-- regenerated when the ledger state gets updated (e.g. through application of +-- a new block). +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) + +-- TODO: This instance can be switched back to a derived version, once we are officially +-- in the Conway era: +-- +-- deriving newtype instance +-- ( Era era +-- , EncCBOR (PredicateFailure (EraRule "LEDGER" era)) +-- ) => +-- EncCBOR (ApplyTxError era) + +instance + ( Era era + , EncCBOR (PredicateFailure (EraRule "LEDGER" era)) + ) => + EncCBOR (ApplyTxError era) + where + encCBOR (ApplyTxError failures) = + ifEncodingVersionAtLeast + (natVersion @9) + (encCBOR failures) + (encodeFoldableAsIndefLenList encCBOR failures) + +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 + +-- | Old 'applyTxs' +applyTxs :: + (ApplyTx era, MonadError (ApplyTxError era) m, EraGov era) => + Globals -> + SlotNo -> + Seq (Tx era) -> + NewEpochState era -> + m (NewEpochState era) +applyTxs + globals + slot + txs + state = + overNewEpochState (applyTxsTransition globals mempoolEnv txs) state + where + mempoolEnv = mkMempoolEnv state slot + +applyTxsTransition :: + forall era m. + ( ApplyTx era + , MonadError (ApplyTxError era) m + ) => + Globals -> + MempoolEnv era -> + Seq (Tx era) -> + MempoolState era -> + m (MempoolState era) +applyTxsTransition globals env txs state = + foldM + (\st tx -> fst <$> applyTx globals env st tx) + state + txs + +-- | Transform a function over mempool states to one over the full +-- 'NewEpochState'. +overNewEpochState :: + Functor f => + (MempoolState era -> f (MempoolState era)) -> + NewEpochState era -> + f (NewEpochState era) +overNewEpochState f st = do + f (mkMempoolState st) + <&> \ls -> + st + { LedgerState.nesEs = + (LedgerState.nesEs st) + { LedgerState.esLState = ls + } + } diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/API/Validation.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/API/Validation.hs new file mode 100644 index 00000000000..0e9737c649f --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/API/Validation.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Interface to the block validation and chain extension logic in the Shelley +-- API. +module Cardano.Ledger.Babel.API.Validation ( + ApplyBlock (..), + applyBlock, + applyTick, + TickTransitionError (..), + BlockTransitionError (..), + chainChecks, + ShelleyEraCrypto, +) +where + +import Cardano.Ledger.BHeaderView (BHeaderView) +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Babel.Rules.Bbody (BabelBbodyState (BbodyState)) +import Cardano.Ledger.Babel.Rules.Zones () +import Cardano.Ledger.BaseTypes (Globals (..), ShelleyBase, Version) +import Cardano.Ledger.Binary (EncCBORGroup) +import Cardano.Ledger.Block (Block) +import qualified Cardano.Ledger.Chain as STS +import Cardano.Ledger.Conway.Rules () +import Cardano.Ledger.Core +import Cardano.Ledger.Crypto (Crypto) +import Cardano.Ledger.Keys (DSignable, Hash) +import Cardano.Ledger.Shelley.Core (EraGov) +import Cardano.Ledger.Shelley.LedgerState (LedgerState (..), NewEpochState, curPParamsEpochStateL) +import qualified Cardano.Ledger.Shelley.LedgerState as LedgerState +import Cardano.Ledger.Shelley.PParams () +import Cardano.Ledger.Shelley.Rules () +import qualified Cardano.Ledger.Shelley.Rules as STS +import Cardano.Ledger.Slot (SlotNo) +import Control.Arrow (left, right) +import Control.Monad.Except +import Control.Monad.Trans.Reader (runReader) +import Control.State.Transition.Extended +import Data.List.NonEmpty (NonEmpty) +import GHC.Generics (Generic) +import Lens.Micro ((^.)) +import NoThunks.Class (NoThunks (..)) + +{------------------------------------------------------------------------------- + Block validation API +-------------------------------------------------------------------------------} + +class + ( STS (EraRule "TICK" era) + , BaseM (EraRule "TICK" era) ~ ShelleyBase + , Environment (EraRule "TICK" era) ~ () + , State (EraRule "TICK" era) ~ NewEpochState era + , Signal (EraRule "TICK" era) ~ SlotNo + , STS (EraRule "BBODY" era) + , BaseM (EraRule "BBODY" era) ~ ShelleyBase + , Environment (EraRule "BBODY" era) ~ STS.BbodyEnv era + , State (EraRule "BBODY" era) ~ BabelBbodyState era + , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era + , EncCBORGroup (TxZones era) + , State (EraRule "ZONES" era) ~ LedgerState era + ) => + ApplyBlock era + where + -- | Apply the header level ledger transition. + -- + -- This handles checks and updates that happen on a slot tick, as well as a + -- few header level checks, such as size constraints. + applyTickOpts :: + ApplySTSOpts ep -> + Globals -> + NewEpochState era -> + SlotNo -> + EventReturnType ep (EraRule "TICK" era) (NewEpochState era) + applyTickOpts opts globals state hdr = + either err id + . flip runReader globals + . applySTSOptsEither @(EraRule "TICK" era) opts + $ TRC ((), state, hdr) + where + err :: Show a => a -> b + err msg = error $ "Panic! applyTick failed: " <> show msg + + -- | Apply the block level ledger transition. + applyBlockOpts :: + forall ep m. + (EventReturnTypeRep ep, MonadError (BlockTransitionError era) m) => + ApplySTSOpts ep -> + Globals -> + NewEpochState era -> + Block (BHeaderView (EraCrypto era)) era -> + m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era)) + default applyBlockOpts :: + forall ep m. + (EventReturnTypeRep ep, MonadError (BlockTransitionError era) m, EraGov era) => + ApplySTSOpts ep -> + Globals -> + NewEpochState era -> + Block (BHeaderView (EraCrypto era)) era -> + m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era)) + applyBlockOpts opts globals state blk = + liftEither + . left BlockTransitionError + . right + ( mapEventReturn @ep @(EraRule "BBODY" era) $ + updateNewEpochState state + ) + $ res + where + res = + flip runReader globals + . applySTSOptsEither @(EraRule "BBODY" era) + opts + $ TRC (mkBbodyEnv state, bbs, blk) + bbs = + BbodyState + (LedgerState.esLState $ LedgerState.nesEs state) + (LedgerState.nesBcur state) + + -- | Re-apply a ledger block to the same state it has been applied to before. + -- + -- This function does no validation of whether the block applies successfully; + -- the caller implicitly guarantees that they have previously called + -- 'applyBlockTransition' on the same block and that this was successful. + reapplyBlock :: + Globals -> + NewEpochState era -> + Block (BHeaderView (EraCrypto era)) era -> + NewEpochState era + default reapplyBlock :: + EraGov era => + Globals -> + NewEpochState era -> + Block (BHeaderView (EraCrypto era)) era -> + NewEpochState era + reapplyBlock globals state blk = + updateNewEpochState state res + where + res = + flip runReader globals . reapplySTS @(EraRule "BBODY" era) $ + TRC (mkBbodyEnv state, bbs, blk) + bbs = + BbodyState + (LedgerState.esLState $ LedgerState.nesEs state) + (LedgerState.nesBcur state) + +applyTick :: + ApplyBlock era => + Globals -> + NewEpochState era -> + SlotNo -> + NewEpochState era +applyTick = + applyTickOpts $ + ApplySTSOpts + { asoAssertions = globalAssertionPolicy + , asoValidation = ValidateAll + , asoEvents = EPDiscard + } + +applyBlock :: + ( ApplyBlock era + , MonadError (BlockTransitionError era) m + ) => + Globals -> + NewEpochState era -> + Block (BHeaderView (EraCrypto era)) era -> + m (NewEpochState era) +applyBlock = + applyBlockOpts $ + ApplySTSOpts + { asoAssertions = globalAssertionPolicy + , asoValidation = ValidateAll + , asoEvents = EPDiscard + } + +type ShelleyEraCrypto c = + ( Crypto c + , DSignable c (Hash c EraIndependentTxBody) + ) + +{-# DEPRECATED ShelleyEraCrypto "Constraint synonyms are being removed" #-} + +instance + ( Crypto c + , DSignable c (Hash c EraIndependentTxBody) + , STS (EraRule "TICK" (BabelEra c)) + , STS (EraRule "BBODY" (BabelEra c)) + ) => + ApplyBlock (BabelEra c) + +{------------------------------------------------------------------------------- + CHAIN Transition checks +-------------------------------------------------------------------------------} + +chainChecks :: + forall c m. + MonadError STS.ChainPredicateFailure m => + -- | Max major protocol version + Version -> + STS.ChainChecksPParams -> + BHeaderView c -> + m () +chainChecks = STS.chainChecks + +{------------------------------------------------------------------------------- + Applying blocks +-------------------------------------------------------------------------------} + +mkBbodyEnv :: + EraGov era => + NewEpochState era -> + STS.BbodyEnv era +mkBbodyEnv + LedgerState.NewEpochState + { LedgerState.nesEs + } = + STS.BbodyEnv + { STS.bbodyPp = nesEs ^. curPParamsEpochStateL + , STS.bbodyAccount = LedgerState.esAccountState nesEs + } + +updateNewEpochState :: + (LedgerState era ~ State (EraRule "ZONES" era), EraGov era) => + NewEpochState era -> + BabelBbodyState era -> + NewEpochState era +updateNewEpochState ss (BbodyState ls bcur) = + LedgerState.updateNES ss bcur ls + +newtype TickTransitionError era + = TickTransitionError (NonEmpty (STS.PredicateFailure (EraRule "TICK" era))) + deriving (Generic) + +instance + NoThunks (STS.PredicateFailure (EraRule "TICK" era)) => + NoThunks (TickTransitionError era) + +deriving stock instance + Eq (STS.PredicateFailure (EraRule "TICK" era)) => + Eq (TickTransitionError era) + +deriving stock instance + Show (STS.PredicateFailure (EraRule "TICK" era)) => + Show (TickTransitionError era) + +newtype BlockTransitionError era + = BlockTransitionError (NonEmpty (STS.PredicateFailure (EraRule "BBODY" era))) + deriving (Generic) + +deriving stock instance + Eq (STS.PredicateFailure (EraRule "BBODY" era)) => + Eq (BlockTransitionError era) + +deriving stock instance + Show (STS.PredicateFailure (EraRule "BBODY" era)) => + Show (BlockTransitionError era) + +instance + NoThunks (STS.PredicateFailure (EraRule "BBODY" era)) => + NoThunks (BlockTransitionError era) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Core.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Core.hs new file mode 100644 index 00000000000..acdba2d9670 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Core.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE PatternSynonyms #-} + +module Cardano.Ledger.Babel.Core ( + BabelEraTxBody (..), + ppPoolVotingThresholdsL, + ppDRepVotingThresholdsL, + ppCommitteeMinSizeL, + ppCommitteeMaxTermLengthL, + ppGovActionLifetimeL, + ppGovActionDepositL, + ppDRepDepositL, + ppDRepActivityL, + ppuPoolVotingThresholdsL, + ppuDRepVotingThresholdsL, + ppuCommitteeMinSizeL, + ppuCommitteeMaxTermLengthL, + ppuGovActionLifetimeL, + ppuGovActionDepositL, + ppuDRepDepositL, + ppuDRepActivityL, + PoolVotingThresholds (..), + DRepVotingThresholds (..), + dvtPPNetworkGroupL, + dvtPPGovGroupL, + dvtPPTechnicalGroupL, + dvtPPEconomicGroupL, + dvtUpdateToConstitutionL, + BabelEraScript (..), + pattern VotingPurpose, + pattern ProposingPurpose, + module Cardano.Ledger.Babbage.Core, +) +where + +import Cardano.Ledger.Babbage.Core +import Cardano.Ledger.Babel.Scripts ( + BabelEraScript (..), + pattern ProposingPurpose, + pattern VotingPurpose, + ) +import Cardano.Ledger.Babel.Tx () +import Cardano.Ledger.Babel.TxBody (BabelEraTxBody (..)) +import Cardano.Ledger.Conway.PParams ( + DRepVotingThresholds (..), + PoolVotingThresholds (..), + dvtPPEconomicGroupL, + dvtPPGovGroupL, + dvtPPNetworkGroupL, + dvtPPTechnicalGroupL, + dvtUpdateToConstitutionL, + ppCommitteeMaxTermLengthL, + ppCommitteeMinSizeL, + ppDRepActivityL, + ppDRepDepositL, + ppDRepVotingThresholdsL, + ppGovActionDepositL, + ppGovActionLifetimeL, + ppPoolVotingThresholdsL, + ppuCommitteeMaxTermLengthL, + ppuCommitteeMinSizeL, + ppuDRepActivityL, + ppuDRepDepositL, + ppuDRepVotingThresholdsL, + ppuGovActionDepositL, + ppuGovActionLifetimeL, + ppuPoolVotingThresholdsL, + ) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Era.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Era.hs new file mode 100644 index 00000000000..92d4de8aeaf --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Era.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Ledger.Babel.Era ( + BabelBBODY, + BabelEra, + BabelLEDGERS, + BabelUTXO, + BabelUTXOS, + BabelUTXOW, + BabelLEDGER, + BabelZONE, + BabelZONES, +) where + +import Cardano.Ledger.Conway (ConwayEra) +import Cardano.Ledger.Conway.Rules ( + ConwayCERT, + ConwayCERTS, + ConwayDELEG, + ConwayENACT, + ConwayEPOCH, + ConwayGOV, + ConwayGOVCERT, + ConwayNEWEPOCH, + ConwayRATIFY, + ConwayTICKF, + ) +import Cardano.Ledger.Core +import Cardano.Ledger.Crypto (Crypto) +import Cardano.Ledger.Mary.Value (MaryValue) +import qualified Cardano.Ledger.Shelley.API as API +import Cardano.Ledger.Shelley.Rules ( + ShelleyPOOL, + ShelleyRUPD, + ShelleySNAP, + ShelleyTICK, + ) + +-- ===================================================== + +-- | The Babel era +data BabelEra c + +instance Crypto c => Era (BabelEra c) where + type PreviousEra (BabelEra c) = ConwayEra c + type EraCrypto (BabelEra c) = c + type ProtVerLow (BabelEra c) = 9 + type ProtVerHigh (BabelEra c) = 10 + + eraName = "Babel" + +type instance Value (BabelEra c) = MaryValue c + +------------------------------------------------------------------------------- +-- Deprecated rules +------------------------------------------------------------------------------- + +type instance EraRule "UPEC" (BabelEra c) = VoidEraRule "UPEC" (BabelEra c) +type instance EraRuleFailure "UPEC" (BabelEra c) = VoidEraRule "UPEC" (BabelEra c) +type instance EraRuleEvent "UPEC" (BabelEra c) = VoidEraRule "UPEC" (BabelEra c) + +type instance EraRule "NEWPP" (BabelEra c) = VoidEraRule "NEWPP" (BabelEra c) +type instance EraRuleFailure "NEWPP" (BabelEra c) = VoidEraRule "NEWPP" (BabelEra c) +type instance EraRuleEvent "NEWPP" (BabelEra c) = VoidEraRule "NEWPP" (BabelEra c) + +type instance EraRule "PPUP" (BabelEra c) = VoidEraRule "PPUP" (BabelEra c) +type instance EraRuleFailure "PPUP" (BabelEra c) = VoidEraRule "PPUP" (BabelEra c) +type instance EraRuleEvent "PPUP" (BabelEra c) = VoidEraRule "PPUP" (BabelEra c) + +type instance EraRule "MIR" (BabelEra c) = VoidEraRule "MIR" (BabelEra c) +type instance EraRuleFailure "MIR" (BabelEra c) = VoidEraRule "MIR" (BabelEra c) +type instance EraRuleEvent "MIR" (BabelEra c) = VoidEraRule "MIR" (BabelEra c) + +type instance EraRule "DELEGS" (BabelEra c) = VoidEraRule "DELEGS" (BabelEra c) +type instance EraRuleFailure "DELEGS" (BabelEra c) = VoidEraRule "DELEGS" (BabelEra c) +type instance EraRuleEvent "DELEGS" (BabelEra c) = VoidEraRule "DELEGS" (BabelEra c) + +------------------------------------------------------------------------------- +-- Era Mapping +------------------------------------------------------------------------------- + +data BabelUTXOS era + +type instance EraRule "UTXOS" (BabelEra c) = BabelUTXOS (BabelEra c) + +data BabelZONES era + +type instance EraRule "ZONES" (BabelEra c) = BabelZONES (BabelEra c) + +data BabelZONE era + +type instance EraRule "ZONE" (BabelEra c) = BabelZONE (BabelEra c) + +data BabelLEDGER era + +type instance EraRule "LEDGER" (BabelEra c) = BabelLEDGER (BabelEra c) + +data BabelLEDGERS era + +type instance EraRule "LEDGERS" (BabelEra c) = BabelLEDGERS (BabelEra c) + +data BabelUTXOW era + +type instance EraRule "UTXOW" (BabelEra c) = BabelUTXOW (BabelEra c) + +data BabelUTXO era + +type instance EraRule "UTXO" (BabelEra c) = BabelUTXO (BabelEra c) + +data BabelBBODY era + +type instance EraRule "BBODY" (BabelEra c) = BabelBBODY (BabelEra c) + +-- Rules inherited from Shelley + +type instance EraRule "POOLREAP" (BabelEra c) = API.ShelleyPOOLREAP (BabelEra c) + +type instance EraRule "RUPD" (BabelEra c) = ShelleyRUPD (BabelEra c) + +type instance EraRule "SNAP" (BabelEra c) = ShelleySNAP (BabelEra c) + +type instance EraRule "TICK" (BabelEra c) = ShelleyTICK (BabelEra c) + +type instance EraRule "POOL" (BabelEra c) = ShelleyPOOL (BabelEra c) + +-- Rules inherited from Conway + +type instance EraRule "RATIFY" (BabelEra c) = ConwayRATIFY (BabelEra c) + +type instance EraRule "ENACT" (BabelEra c) = ConwayENACT (BabelEra c) + +type instance EraRule "GOV" (BabelEra c) = ConwayGOV (BabelEra c) + +type instance EraRule "GOVCERT" (BabelEra c) = ConwayGOVCERT (BabelEra c) + +type instance EraRule "TICKF" (BabelEra c) = ConwayTICKF (BabelEra c) + +type instance EraRule "NEWEPOCH" (BabelEra c) = ConwayNEWEPOCH (BabelEra c) + +type instance EraRule "EPOCH" (BabelEra c) = ConwayEPOCH (BabelEra c) + +type instance EraRule "CERTS" (BabelEra c) = ConwayCERTS (BabelEra c) + +type instance EraRule "CERT" (BabelEra c) = ConwayCERT (BabelEra c) + +type instance EraRule "DELEG" (BabelEra c) = ConwayDELEG (BabelEra c) + +-- ================================================= diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/FRxO.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/FRxO.hs new file mode 100644 index 00000000000..661832b00e7 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/FRxO.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Cardano.Ledger.Babel.FRxO where + +import Cardano.Ledger.Babel.TxBody ( + BabelEraTxBody (fulfillsTxBodyL, requestsTxBodyL, requiredTxsTxBodyL), + ) +import Cardano.Ledger.Binary (sizedValue) +import Cardano.Ledger.Core ( + Era (EraCrypto), + EraTxBody (TxBody), + EraTxOut (TxOut), + txIdTxBody, + ) +import Cardano.Ledger.FRxO (FRxO (FRxO)) +import Cardano.Ledger.TxIn (TxIn (TxIn)) +import Data.Foldable (toList) +import qualified Data.Map as Map +import qualified Data.Sequence.Strict as SSeq +import Data.Set (Set) +import Lens.Micro ((^.)) + +-- | The unspent transaction outputs. +-- | Compute the transaction requests of a transaction. +-- TODO WG: Put this in the FRxO module (along with other helpers). Probably refactor so the actual logic is done on maps, then unwrap both UTxO and FRxO and call the functions you refactored. +txfrxo :: + forall era. + BabelEraTxBody era => + TxBody era -> + FRxO era +txfrxo txBody = + FRxO $ + Map.fromList + [ (TxIn transId idx, out) + | (out, idx) <- + zip + (toList $ fmap sizedValue $ txBody ^. requestsTxBodyL) + [minBound ..] + ] + where + transId = txIdTxBody txBody + +txrequests :: BabelEraTxBody era => TxBody era -> SSeq.StrictSeq (TxOut era) +txrequests = fmap sizedValue . (^. requestsTxBodyL) + +txrequired :: BabelEraTxBody era => TxBody era -> Set (TxIn (EraCrypto era)) +txrequired = (^. requiredTxsTxBodyL) + +txfulfills :: BabelEraTxBody era => TxBody era -> Set (TxIn (EraCrypto era)) +txfulfills = (^. fulfillsTxBodyL) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Genesis.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Genesis.hs new file mode 100644 index 00000000000..a0da801b4fb --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Genesis.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Ledger.Babel.Genesis ( + BabelGenesis (..), + toBabelGenesisPairs, + cgDelegsL, +) +where + +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Babel.TxCert (Delegatee) +import Cardano.Ledger.Binary ( + DecCBOR (..), + EncCBOR (..), + ) +import Cardano.Ledger.Binary.Coders +import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Conway.PParams (UpgradeConwayPParams, toUpgradeConwayPParamsUpdatePairs) +import Cardano.Ledger.Credential (Credential) +import Cardano.Ledger.Crypto (Crypto) +import Cardano.Ledger.DRep (DRepState) +import Cardano.Ledger.Keys (KeyRole (..)) +import Data.Aeson ( + FromJSON (..), + KeyValue (..), + ToJSON (..), + Value (..), + object, + pairs, + withObject, + (.!=), + (.:), + (.:?), + ) +import Data.Functor.Identity (Identity) +import Data.ListMap (ListMap) +import GHC.Generics (Generic) +import Lens.Micro (Lens', lens) +import NoThunks.Class (NoThunks) + +data BabelGenesis c = BabelGenesis + { cgUpgradePParams :: !(UpgradeConwayPParams Identity) + , cgConstitution :: !(Constitution (BabelEra c)) + , cgCommittee :: !(Committee (BabelEra c)) + , cgDelegs :: ListMap (Credential 'Staking c) (Delegatee c) + , cgInitialDReps :: ListMap (Credential 'DRepRole c) (DRepState c) + } + deriving (Eq, Generic, Show) + +cgDelegsL :: Lens' (BabelGenesis c) (ListMap (Credential 'Staking c) (Delegatee c)) +cgDelegsL = lens cgDelegs (\x y -> x {cgDelegs = y}) + +instance Crypto c => NoThunks (BabelGenesis c) + +-- | Genesis are always encoded with the version of era they are defined in. +instance Crypto c => DecCBOR (BabelGenesis c) where + decCBOR = decode $ RecD BabelGenesis EncCBOR (BabelGenesis c) where + encCBOR (BabelGenesis pparams constitution committee delegs initialDReps) = + encode $ + Rec (BabelGenesis @c) + !> To pparams + !> To constitution + !> To committee + !> To delegs + !> To initialDReps + +instance Crypto c => ToJSON (BabelGenesis c) where + toJSON = object . toBabelGenesisPairs + toEncoding = pairs . mconcat . toBabelGenesisPairs + +instance Crypto c => FromJSON (BabelGenesis c) where + parseJSON = + withObject "BabelGenesis" $ \obj -> do + upgradeProtocolPParams <- parseJSON (Object obj) + BabelGenesis + <$> pure upgradeProtocolPParams + <*> obj .: "constitution" + <*> obj .: "committee" + <*> obj .:? "delegs" .!= mempty + <*> obj .:? "initialDReps" .!= mempty + +toBabelGenesisPairs :: (Crypto c, KeyValue e a) => BabelGenesis c -> [a] +toBabelGenesisPairs cg@(BabelGenesis _ _ _ _ _) = + let BabelGenesis {..} = cg + in [ "constitution" .= cgConstitution + , "committee" .= cgCommittee + ] + ++ ["delegs" .= cgDelegs | not (null cgDelegs)] + ++ ["initialDReps" .= cgInitialDReps | not (null cgInitialDReps)] + ++ toUpgradeConwayPParamsUpdatePairs cgUpgradePParams diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Governance.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Governance.hs new file mode 100644 index 00000000000..de101b39d43 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Governance.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Governance where + +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Babel.PParams () +import Cardano.Ledger.Conway.Governance ( + ConwayEraGov (..), + cgsCommitteeL, + cgsConstitutionL, + cgsDRepPulsingStateL, + cgsProposalsL, + ) +import Cardano.Ledger.Crypto (Crypto) + +instance Crypto c => ConwayEraGov (BabelEra c) where + constitutionGovStateL = cgsConstitutionL + proposalsGovStateL = cgsProposalsL + drepPulsingStateGovStateL = cgsDRepPulsingStateL + committeeGovStateL = cgsCommitteeL \ No newline at end of file diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs new file mode 100644 index 00000000000..84c828a355c --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Cardano.Ledger.Babel.LedgerState.Types where + +import Cardano.Ledger.Coin (Coin) +import Cardano.Ledger.Conway.Core (EraCrypto, EraGov, EraTxOut, GovState) +import Cardano.Ledger.FRxO (FRxO) +import Cardano.Ledger.Shelley.LedgerState ( + CertState, + IncrementalStake, + ) +import Cardano.Ledger.UTxO (UTxO) +import Control.DeepSeq (NFData) +import Data.Default.Class (Default (def)) +import GHC.Generics (Generic) + +-- type instance Ledger (ConwayEra c) = LedgerStateTemp (ConwayEra c) + +-- | The state associated with a 'Ledger'. +data LedgerStateTemp era = LedgerStateTemp + { lstUTxOState :: !(UTxOStateTemp era) + -- ^ The current unspent transaction outputs. + , lstCertState :: !(CertState era) + } + deriving (Generic) + +deriving stock instance + ( EraTxOut era + , Show (GovState era) + ) => + Show (LedgerStateTemp era) + +deriving stock instance + ( EraTxOut era + , Eq (GovState era) + ) => + Eq (LedgerStateTemp era) + +-------- + +data UTxOStateTemp era = UTxOStateTemp + { utxostUtxo :: !(UTxO era) + , utxostFrxo :: !(FRxO era) + , utxostDeposited :: Coin + -- ^ This field is left lazy, because we only use it for assertions + , utxostFees :: !Coin + , utxostGovState :: !(GovState era) + , utxostStakeDistr :: !(IncrementalStake (EraCrypto era)) + , utxostDonation :: !Coin + } + deriving (Generic) + +-- ==================================================== + +-------------------------------------------------------------------------------- +-- Default instances +-------------------------------------------------------------------------------- + +instance EraGov era => Default (UTxOStateTemp era) where + def = UTxOStateTemp mempty mempty mempty mempty def mempty mempty + +------- + +instance + ( EraTxOut era + , NFData (GovState era) + ) => + NFData (UTxOStateTemp era) + +deriving stock instance + ( EraTxOut era + , Show (GovState era) + ) => + Show (UTxOStateTemp era) + +deriving stock instance + ( EraTxOut era + , Eq (GovState era) + ) => + Eq (UTxOStateTemp era) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/PParams.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/PParams.hs new file mode 100644 index 00000000000..740e1ad5531 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/PParams.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | This module contains the type of protocol parameters and EraPParams instance +module Cardano.Ledger.Babel.PParams ( + ppPoolVotingThresholdsL, + ppDRepVotingThresholdsL, + ppCommitteeMinSizeL, + ppCommitteeMaxTermLengthL, + ppGovActionLifetimeL, + ppGovActionDepositL, + ppDRepDepositL, + ppDRepActivityL, + ppuPoolVotingThresholdsL, + ppuDRepVotingThresholdsL, + ppuCommitteeMinSizeL, + ppuCommitteeMaxTermLengthL, + ppuGovActionLifetimeL, + ppuGovActionDepositL, + ppuDRepDepositL, + ppuDRepActivityL, + PoolVotingThresholds (..), + DRepVotingThresholds (..), + dvtPPNetworkGroupL, + dvtPPGovGroupL, + dvtPPTechnicalGroupL, + dvtPPEconomicGroupL, + dvtUpdateToConstitutionL, + THKD (..), +) +where + +import Cardano.Ledger.Alonzo.PParams (AlonzoEraPParams (..), OrdExUnits (..)) +import Cardano.Ledger.Alonzo.Scripts ( + ExUnits (..), + ) +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.BaseTypes ( + EpochInterval (..), + StrictMaybe (..), + ) +import Cardano.Ledger.CertState +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Conway.Core +import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Conway.PParams ( + ConwayEraPParams (..), + ConwayPParams (..), + THKD (THKD, unTHKD), + UpgradeConwayPParams (..), + conwayApplyPPUpdates, + conwayModifiedPPGroups, + conwayPParamsPairs, + emptyConwayPParams, + emptyConwayPParamsUpdate, + ) +import Cardano.Ledger.Core +import Cardano.Ledger.Crypto +import Cardano.Ledger.HKD ( + HKD, + HKDApplicative, + HKDFunctor (..), + ) +import Cardano.Ledger.Val (Val (..)) +import Data.Aeson hiding (Encoding, Value, decode, encode) +import Data.Coerce (coerce) +import Data.Foldable (Foldable (..)) +import Data.Functor.Identity (Identity) +import Data.Proxy +import Lens.Micro + +instance Crypto c => EraPParams (BabelEra c) where + type PParamsHKD f (BabelEra c) = ConwayPParams f (BabelEra c) + + type UpgradePParams f (BabelEra c) = UpgradeConwayPParams f + type DowngradePParams f (BabelEra c) = () + + applyPPUpdates (PParams pp) (PParamsUpdate ppu) = + PParams $ conwayApplyPPUpdates pp ppu + + emptyPParamsIdentity = emptyConwayPParams + emptyPParamsStrictMaybe = emptyConwayPParamsUpdate + + upgradePParamsHKD :: + forall f. + HKDApplicative f => + UpgradePParams f (BabelEra c) -> + PParamsHKD f (PreviousEra (BabelEra c)) -> + PParamsHKD f (BabelEra c) + upgradePParamsHKD = upgradeBabelPParamsHKD + downgradePParamsHKD () = coerce + + hkdMinFeeAL = lens (unTHKD . cppMinFeeA) $ \pp x -> pp {cppMinFeeA = THKD x} + hkdMinFeeBL = lens (unTHKD . cppMinFeeB) $ \pp x -> pp {cppMinFeeB = THKD x} + hkdMaxBBSizeL = lens (unTHKD . cppMaxBBSize) $ \pp x -> pp {cppMaxBBSize = THKD x} + hkdMaxTxSizeL = lens (unTHKD . cppMaxTxSize) $ \pp x -> pp {cppMaxTxSize = THKD x} + hkdMaxBHSizeL = lens (unTHKD . cppMaxBHSize) $ \pp x -> pp {cppMaxBHSize = THKD x} + hkdKeyDepositL = lens (unTHKD . cppKeyDeposit) $ \pp x -> pp {cppKeyDeposit = THKD x} + hkdPoolDepositL = lens (unTHKD . cppPoolDeposit) $ \pp x -> pp {cppPoolDeposit = THKD x} + hkdEMaxL = lens (unTHKD . cppEMax) $ \pp x -> pp {cppEMax = THKD x} + hkdNOptL = lens (unTHKD . cppNOpt) $ \pp x -> pp {cppNOpt = THKD x} + hkdA0L = lens (unTHKD . cppA0) $ \pp x -> pp {cppA0 = THKD x} + hkdRhoL = lens (unTHKD . cppRho) $ \pp x -> pp {cppRho = THKD x} + hkdTauL = lens (unTHKD . cppTau) $ \pp x -> pp {cppTau = THKD x} + hkdProtocolVersionL = notSupportedInThisEraL + hkdMinPoolCostL = lens (unTHKD . cppMinPoolCost) $ \pp x -> pp {cppMinPoolCost = THKD x} + ppProtocolVersionL = ppLens . lens cppProtocolVersion (\pp x -> pp {cppProtocolVersion = x}) + + ppDG = to (const minBound) + ppuProtocolVersionL = notSupportedInThisEraL + hkdDL = notSupportedInThisEraL + hkdExtraEntropyL = notSupportedInThisEraL + hkdMinUTxOValueL = notSupportedInThisEraL + +instance Crypto c => AlonzoEraPParams (BabelEra c) where + hkdCoinsPerUTxOWordL = notSupportedInThisEraL + hkdCostModelsL = lens (unTHKD . cppCostModels) $ \pp x -> pp {cppCostModels = THKD x} + hkdPricesL = lens (unTHKD . cppPrices) $ \pp x -> pp {cppPrices = THKD x} + + hkdMaxTxExUnitsL :: forall f. HKDFunctor f => Lens' (PParamsHKD f (BabelEra c)) (HKD f ExUnits) + hkdMaxTxExUnitsL = + lens (hkdMap (Proxy @f) unOrdExUnits . unTHKD . cppMaxTxExUnits) $ \pp x -> + pp {cppMaxTxExUnits = THKD $ hkdMap (Proxy @f) OrdExUnits x} + hkdMaxBlockExUnitsL :: forall f. HKDFunctor f => Lens' (PParamsHKD f (BabelEra c)) (HKD f ExUnits) + hkdMaxBlockExUnitsL = + lens (hkdMap (Proxy @f) unOrdExUnits . unTHKD . cppMaxBlockExUnits) $ \pp x -> + pp {cppMaxBlockExUnits = THKD $ hkdMap (Proxy @f) OrdExUnits x} + hkdMaxValSizeL = lens (unTHKD . cppMaxValSize) $ \pp x -> pp {cppMaxValSize = THKD x} + hkdCollateralPercentageL = + lens (unTHKD . cppCollateralPercentage) $ \pp x -> pp {cppCollateralPercentage = THKD x} + hkdMaxCollateralInputsL = + lens (unTHKD . cppMaxCollateralInputs) $ \pp x -> pp {cppMaxCollateralInputs = THKD x} + +instance Crypto c => BabbageEraPParams (BabelEra c) where + hkdCoinsPerUTxOByteL = + lens (unTHKD . cppCoinsPerUTxOByte) $ \pp x -> pp {cppCoinsPerUTxOByte = THKD x} + +instance Crypto c => ConwayEraPParams (BabelEra c) where + modifiedPPGroups (PParamsUpdate ppu) = conwayModifiedPPGroups ppu + ppuWellFormed ppu = + and + [ -- Numbers + isValid (/= 0) ppuMaxBBSizeL + , isValid (/= 0) ppuMaxTxSizeL + , isValid (/= 0) ppuMaxBHSizeL + , isValid (/= 0) ppuMaxValSizeL + , isValid (/= 0) ppuCollateralPercentageL + , isValid (/= EpochInterval 0) ppuCommitteeMaxTermLengthL + , isValid (/= EpochInterval 0) ppuGovActionLifetimeL + , -- Coins + isValid (/= zero) ppuPoolDepositL + , isValid (/= zero) ppuGovActionDepositL + , isValid (/= zero) ppuDRepDepositL + , ppu /= emptyPParamsUpdate + ] + where + isValid :: + (t -> Bool) -> + Lens' (PParamsUpdate (BabelEra c)) (StrictMaybe t) -> + Bool + isValid p l = case ppu ^. l of + SJust x -> p x + SNothing -> True + hkdPoolVotingThresholdsL = + lens (unTHKD . cppPoolVotingThresholds) $ \pp x -> pp {cppPoolVotingThresholds = THKD x} + hkdDRepVotingThresholdsL = + lens (unTHKD . cppDRepVotingThresholds) $ \pp x -> pp {cppDRepVotingThresholds = THKD x} + hkdCommitteeMinSizeL = + lens (unTHKD . cppCommitteeMinSize) $ \pp x -> pp {cppCommitteeMinSize = THKD x} + hkdCommitteeMaxTermLengthL = + lens (unTHKD . cppCommitteeMaxTermLength) $ \pp x -> pp {cppCommitteeMaxTermLength = THKD x} + hkdGovActionLifetimeL = + lens (unTHKD . cppGovActionLifetime) $ \pp x -> pp {cppGovActionLifetime = THKD x} + hkdGovActionDepositL = + lens (unTHKD . cppGovActionDeposit) $ \pp x -> pp {cppGovActionDeposit = THKD x} + hkdDRepDepositL = + lens (unTHKD . cppDRepDeposit) $ \pp x -> pp {cppDRepDeposit = THKD x} + hkdDRepActivityL = + lens (unTHKD . cppDRepActivity) $ \pp x -> pp {cppDRepActivity = THKD x} + hkdMinFeeRefScriptCostPerByteL = + lens (unTHKD . cppMinFeeRefScriptCostPerByte) $ \pp x -> pp {cppMinFeeRefScriptCostPerByte = THKD x} + +instance Crypto c => ToJSON (ConwayPParams Identity (BabelEra c)) where + toJSON = object . conwayPParamsPairs + toEncoding = pairs . mconcat . conwayPParamsPairs + +instance Crypto c => EraGov (BabelEra c) where + type GovState (BabelEra c) = ConwayGovState (BabelEra c) + + curPParamsGovStateL :: Lens' (GovState (BabelEra c)) (PParams (BabelEra c)) + curPParamsGovStateL = cgsCurPParamsL + + prevPParamsGovStateL = cgsPrevPParamsL + + obligationGovState st = + Obligations + { oblProposal = foldMap' gasDeposit $ proposalsActions (st ^. cgsProposalsL) + , oblDRep = Coin 0 + , oblStake = Coin 0 + , oblPool = Coin 0 + } + +upgradeBabelPParamsHKD :: + forall f c. + ( HKDApplicative f + , Crypto c + ) => + UpgradeConwayPParams f -> + PParamsHKD f (PreviousEra (BabelEra c)) -> + ConwayPParams f (BabelEra c) +upgradeBabelPParamsHKD UpgradeConwayPParams {..} prevPParams = + ConwayPParams + { cppMinFeeA = THKD $ prevPParams ^. hkdMinFeeAL + , cppMinFeeB = THKD $ prevPParams ^. hkdMinFeeBL + , cppMaxBBSize = THKD $ prevPParams ^. hkdMaxBBSizeL + , cppMaxTxSize = THKD $ prevPParams ^. hkdMaxTxSizeL + , cppMaxBHSize = THKD $ prevPParams ^. hkdMaxBHSizeL + , cppKeyDeposit = THKD $ prevPParams ^. hkdKeyDepositL + , cppPoolDeposit = THKD $ prevPParams ^. hkdPoolDepositL + , cppEMax = THKD $ prevPParams ^. hkdEMaxL + , cppNOpt = THKD $ prevPParams ^. hkdNOptL + , cppA0 = THKD $ prevPParams ^. hkdA0L + , cppRho = THKD $ prevPParams ^. hkdRhoL + , cppTau = THKD $ prevPParams ^. hkdTauL + , cppProtocolVersion = cppProtocolVersion prevPParams + , cppMinPoolCost = THKD $ prevPParams ^. hkdMinPoolCostL + , cppCoinsPerUTxOByte = THKD $ prevPParams ^. hkdCoinsPerUTxOByteL + , cppCostModels = THKD $ prevPParams ^. hkdCostModelsL + , cppPrices = THKD $ prevPParams ^. hkdPricesL + , cppMaxTxExUnits = + THKD $ hkdMap (Proxy @f) OrdExUnits $ prevPParams ^. hkdMaxTxExUnitsL + , cppMaxBlockExUnits = THKD $ hkdMap (Proxy @f) OrdExUnits $ prevPParams ^. hkdMaxBlockExUnitsL + , cppMaxValSize = THKD $ prevPParams ^. hkdMaxValSizeL + , cppCollateralPercentage = THKD $ prevPParams ^. hkdCollateralPercentageL + , cppMaxCollateralInputs = THKD $ prevPParams ^. hkdMaxCollateralInputsL + , -- New for Babel + cppPoolVotingThresholds = THKD ucppPoolVotingThresholds + , cppDRepVotingThresholds = THKD ucppDRepVotingThresholds + , cppCommitteeMinSize = THKD ucppCommitteeMinSize + , cppCommitteeMaxTermLength = THKD ucppCommitteeMaxTermLength + , cppGovActionLifetime = THKD ucppGovActionLifetime + , cppGovActionDeposit = THKD ucppGovActionDeposit + , cppDRepDeposit = THKD ucppDRepDeposit + , cppDRepActivity = THKD ucppDRepActivity + , cppMinFeeRefScriptCostPerByte = THKD ucppMinFeeRefScriptCostPerByte + } \ No newline at end of file diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Plutus/Context.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Plutus/Context.hs new file mode 100644 index 00000000000..e7caac2a442 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Plutus/Context.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Plutus.Context ( + BabelEraPlutusTxInfo (..), +) where + +import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusTxInfo) +import Cardano.Ledger.Core ( + PParamsUpdate, + ) +import Cardano.Ledger.Plutus.Language (Language (..)) +import Cardano.Ledger.Plutus.ToPlutusData (ToPlutusData (..)) +import qualified PlutusLedgerApi.V4 as PV4 + +-- =========================================================== +-- A class to compute the changed parameters in the TxInfo +-- given a ToPlutusData instance for PParamsUpdate + +class + ( ToPlutusData (PParamsUpdate era) + , EraPlutusTxInfo l era + ) => + BabelEraPlutusTxInfo (l :: Language) era + where + toBabelPlutusChangedParameters :: proxy l -> PParamsUpdate era -> PV4.ChangedParameters diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules.hs new file mode 100644 index 00000000000..4efee386d7c --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Rules ( + module Cardano.Ledger.Babel.Rules.Ledger, + module Cardano.Ledger.Babel.Rules.Ledgers, + module Cardano.Ledger.Babel.Rules.Utxo, + module Cardano.Ledger.Babel.Rules.Utxos, + module Cardano.Ledger.Babel.Rules.Utxow, + module Cardano.Ledger.Babel.Rules.Zone, + module Cardano.Ledger.Babel.Rules.Zones, +) +where + +import Cardano.Ledger.Babel.Core (EraRuleEvent, InjectRuleEvent (..)) +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Babel.Rules.Bbody () +import Cardano.Ledger.Babel.Rules.Ledger +import Cardano.Ledger.Babel.Rules.Ledgers +import Cardano.Ledger.Babel.Rules.Pool () +import Cardano.Ledger.Babel.Rules.Utxo +import Cardano.Ledger.Babel.Rules.Utxos +import Cardano.Ledger.Babel.Rules.Utxow +import Cardano.Ledger.Babel.Rules.Zone +import Cardano.Ledger.Babel.Rules.Zones +import Cardano.Ledger.Conway.Rules +import Cardano.Ledger.Shelley.Rules (ShelleyTickEvent (..)) + +type instance EraRuleEvent "TICK" (BabelEra c) = ShelleyTickEvent (BabelEra c) + +instance InjectRuleEvent "TICK" ConwayEpochEvent (BabelEra c) where + injectEvent = TickNewEpochEvent . EpochEvent diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs new file mode 100644 index 00000000000..13b9688c84c --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Rules.Bbody where + +import Cardano.Ledger.BHeaderView ( + BHeaderView (bhviewBHash, bhviewBSize, bhviewID, bhviewSlot), + isOverlaySlot, + ) +import Cardano.Ledger.Babel.Era (BabelBBODY, BabelEra) +import Cardano.Ledger.Babel.Rules.Ledger (BabelLedgerPredFailure) +import Cardano.Ledger.Babel.Rules.Ledgers () +import Cardano.Ledger.Babel.Rules.Utxo (BabelUtxoPredFailure) +import Cardano.Ledger.Babel.Rules.Utxow (BabelUtxowPredFailure) +import Cardano.Ledger.Babel.Rules.Zone (BabelZonePredFailure) +import Cardano.Ledger.Babel.Rules.Zones (BabelZonesPredFailure) +import Cardano.Ledger.BaseTypes (BlocksMade, ShelleyBase, epochInfoPure) +import Cardano.Ledger.Core +import Cardano.Ledger.Keys (DSignable, HasKeyRole (coerceKeyRole), Hash) +import Cardano.Ledger.Shelley.API ( + Block (UnserialisedBlock), + ShelleyLedgersEnv (LedgersEnv), + ) +import Cardano.Ledger.Shelley.BlockChain (incrBlocks) +import Cardano.Ledger.Shelley.Rules ( + BbodyEnv (BbodyEnv), + ShelleyBbodyPredFailure, + ShelleyLedgersPredFailure, + ) +import Cardano.Ledger.Slot (epochInfoEpoch, epochInfoFirst) +import Control.Monad.Trans.Reader (asks) +import Control.State.Transition ( + Embed (wrapEvent), + STS (..), + TRC (TRC), + TransitionRule, + judgmentContext, + liftSTS, + trans, + (?!), + ) +import Control.State.Transition.Simple (Embed (wrapFailed)) +import Data.Sequence (Seq) +import qualified Data.Sequence.Strict as StrictSeq +import GHC.Generics (Generic) +import Lens.Micro ((^.)) +import NoThunks.Class (NoThunks) + +data BabelBbodyState era + = BbodyState !(State (EraRule "ZONES" era)) !(BlocksMade (EraCrypto era)) + +data BabelBbodyPredFailure era + = WrongBlockBodySizeBBODY + !Int -- Actual Body Size + !Int -- Claimed Body Size in Header + | InvalidBodyHashBBODY + !(Hash (EraCrypto era) EraIndependentBlockBody) -- Actual Hash + !(Hash (EraCrypto era) EraIndependentBlockBody) -- Claimed Hash + | ZonesFailure (PredicateFailure (EraRule "ZONES" era)) -- Subtransition Failures + | ShellyInBabelBbodyPredFailure (ShelleyBbodyPredFailure era) + deriving (Generic) + +type instance EraRuleFailure "BBODY" (BabelEra c) = BabelBbodyPredFailure (BabelEra c) + +instance InjectRuleFailure "BBODY" BabelBbodyPredFailure (BabelEra c) + +instance InjectRuleFailure "BBODY" BabelZonesPredFailure (BabelEra c) where + injectFailure :: BabelZonesPredFailure (BabelEra c) -> BabelBbodyPredFailure (BabelEra c) + injectFailure = ZonesFailure + +instance InjectRuleFailure "BBODY" BabelZonePredFailure (BabelEra c) where + injectFailure = ZonesFailure . injectFailure + +instance InjectRuleFailure "BBODY" ShelleyLedgersPredFailure (BabelEra c) where + injectFailure = ZonesFailure . injectFailure + +instance InjectRuleFailure "BBODY" BabelLedgerPredFailure (BabelEra c) where + injectFailure = ZonesFailure . injectFailure + +instance InjectRuleFailure "BBODY" BabelUtxowPredFailure (BabelEra c) where + injectFailure = ZonesFailure . injectFailure + +instance InjectRuleFailure "BBODY" BabelUtxoPredFailure (BabelEra c) where + injectFailure = ZonesFailure . injectFailure + +newtype BabelBbodyEvent era + = LedgersEvent (Event (EraRule "ZONES" era)) + +deriving stock instance + ( Era era + , Show (PredicateFailure (EraRule "LEDGERS" era)) + , Show (PredicateFailure (EraRule "ZONES" era)) + ) => + Show (BabelBbodyPredFailure era) + +deriving stock instance + ( Era era + , Eq (PredicateFailure (EraRule "LEDGERS" era)) + , Eq (PredicateFailure (EraRule "ZONES" era)) + ) => + Eq (BabelBbodyPredFailure era) + +instance + ( Era era + , NoThunks (PredicateFailure (EraRule "LEDGERS" era)) + , NoThunks (PredicateFailure (EraRule "ZONES" era)) + ) => + NoThunks (BabelBbodyPredFailure era) + +instance + ( EraSegWits era + , DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody) + , Embed (EraRule "ZONES" era) (BabelBBODY era) + , Environment (EraRule "ZONES" era) ~ ShelleyLedgersEnv era + , Signal (EraRule "ZONES" era) ~ Seq (Seq (Tx era)) + , Eq (PredicateFailure (EraRule "LEDGERS" era)) + , Show (PredicateFailure (EraRule "LEDGERS" era)) + ) => + STS (BabelBBODY era) + where + type State (BabelBBODY era) = BabelBbodyState era + + type Signal (BabelBBODY era) = Block (BHeaderView (EraCrypto era)) era + + type Environment (BabelBBODY era) = BbodyEnv era + + type BaseM (BabelBBODY era) = ShelleyBase + + type PredicateFailure (BabelBBODY era) = BabelBbodyPredFailure era + + type Event (BabelBBODY era) = BabelBbodyEvent era + + initialRules = [] + transitionRules = [bbodyTransition] + +bbodyTransition :: + forall era. + ( STS (BabelBBODY era) + , EraSegWits era + , Embed (EraRule "ZONES" era) (BabelBBODY era) + , Environment (EraRule "ZONES" era) ~ ShelleyLedgersEnv era + , Signal (EraRule "ZONES" era) ~ Seq (Seq (Tx era)) + ) => + TransitionRule (BabelBBODY era) +bbodyTransition = + judgmentContext + >>= \( TRC + ( BbodyEnv pp account + , BbodyState ls b + , UnserialisedBlock bhview txsSeq + ) + ) -> do + let txs = fromTxZones txsSeq + actualBodySize = bBodySize (pp ^. ppProtocolVersionL) txsSeq + actualBodyHash = hashTxZones txsSeq + + actualBodySize + == fromIntegral (bhviewBSize bhview) + ?! WrongBlockBodySizeBBODY actualBodySize (fromIntegral $ bhviewBSize bhview) + + actualBodyHash + == bhviewBHash bhview + ?! InvalidBodyHashBBODY actualBodyHash (bhviewBHash bhview) + + ls' <- + trans @(EraRule "ZONES" era) $ + TRC + ( LedgersEnv (bhviewSlot bhview) pp account + , ls + , StrictSeq.fromStrict <$> StrictSeq.fromStrict txs + ) + + -- Note that this may not actually be a stake pool - it could be a genesis key + -- delegate. However, this would only entail an overhead of 7 counts, and it's + -- easier than differentiating here. + let hkAsStakePool = coerceKeyRole $ bhviewID bhview + slot = bhviewSlot bhview + firstSlotNo <- liftSTS $ do + ei <- asks epochInfoPure + e <- epochInfoEpoch ei slot + epochInfoFirst ei e + let isOverlay = isOverlaySlot firstSlotNo (pp ^. ppDG) slot + pure $ BbodyState ls' (incrBlocks isOverlay hkAsStakePool b) + +instance + forall era zones. + ( Era era + , BaseM zones ~ ShelleyBase + , zones ~ EraRule "ZONES" era + , STS zones + , DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody) + , Era era + ) => + Embed zones (BabelBBODY era) + where + wrapFailed = ZonesFailure + wrapEvent = LedgersEvent diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Cert.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Cert.hs new file mode 100644 index 00000000000..fba3c3916e2 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Cert.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Rules.Cert where + +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Conway.Rules ( + ConwayCertPredFailure, + ) +import Cardano.Ledger.Core (EraRuleFailure, InjectRuleFailure) + +type instance EraRuleFailure "CERT" (BabelEra c) = ConwayCertPredFailure (BabelEra c) + +instance InjectRuleFailure "CERT" ConwayCertPredFailure (BabelEra c) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Certs.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Certs.hs new file mode 100644 index 00000000000..3c21ef1d066 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Certs.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Rules.Certs where + +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Conway.Rules ( + ConwayCertsPredFailure, + ) +import Cardano.Ledger.Core (EraRuleFailure, InjectRuleFailure) + +type instance EraRuleFailure "CERTS" (BabelEra c) = ConwayCertsPredFailure (BabelEra c) + +instance InjectRuleFailure "CERTS" ConwayCertsPredFailure (BabelEra c) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Deleg.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Deleg.hs new file mode 100644 index 00000000000..9c481542754 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Deleg.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Rules.Deleg where + +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Conway.Rules ( + ConwayDelegPredFailure, + ) +import Cardano.Ledger.Core (EraRuleFailure, InjectRuleFailure) + +type instance EraRuleFailure "DELEG" (BabelEra c) = ConwayDelegPredFailure (BabelEra c) + +instance InjectRuleFailure "DELEG" ConwayDelegPredFailure (BabelEra c) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Gov.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Gov.hs new file mode 100644 index 00000000000..f2eda69bdee --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Gov.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Rules.Gov where + +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Conway.Rules ( + ConwayGovPredFailure, + ) +import Cardano.Ledger.Core (EraRuleFailure, InjectRuleFailure) + +type instance EraRuleFailure "GOV" (BabelEra c) = ConwayGovPredFailure (BabelEra c) + +instance InjectRuleFailure "GOV" ConwayGovPredFailure (BabelEra c) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/GovCert.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/GovCert.hs new file mode 100644 index 00000000000..37d67630185 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/GovCert.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Rules.GovCert where + +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Conway.Rules ( + ConwayGovCertPredFailure, + ) +import Cardano.Ledger.Core (EraRuleFailure, InjectRuleFailure) + +type instance EraRuleFailure "GOVCERT" (BabelEra c) = ConwayGovCertPredFailure (BabelEra c) + +instance InjectRuleFailure "GOVCERT" ConwayGovCertPredFailure (BabelEra c) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledger.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledger.hs new file mode 100644 index 00000000000..4684923494d --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledger.hs @@ -0,0 +1,431 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Rules.Ledger ( + BabelLEDGER, + BabelLedgerPredFailure (..), + BabelLedgerEvent (..), +) where + +import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..)) +import Cardano.Crypto.Hash.Class (Hash) +import Cardano.Ledger.Address (RewardAccount (..)) +import Cardano.Ledger.Alonzo.Rules ( + AlonzoUtxowEvent, + ) +import Cardano.Ledger.Alonzo.Scripts (AlonzoScript) +import Cardano.Ledger.Alonzo.UTxO (AlonzoScriptsNeeded (..)) +import Cardano.Ledger.Babbage.Rules ( + BabbageUtxoPredFailure, + ) +import Cardano.Ledger.Babbage.Tx (IsValid (..)) +import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..)) +import Cardano.Ledger.Babel.Core (BabelEraTxBody) +import Cardano.Ledger.Babel.Era ( + BabelEra, + BabelLEDGER, + BabelUTXOW, + ) +import Cardano.Ledger.Babel.Rules.Cert () +import Cardano.Ledger.Babel.Rules.Certs () +import Cardano.Ledger.Babel.Rules.Deleg () +import Cardano.Ledger.Babel.Rules.GovCert () +import Cardano.Ledger.Babel.Rules.Utxo (BabelUtxoPredFailure) +import Cardano.Ledger.Babel.Rules.Utxos (BabelUtxosPredFailure) +import Cardano.Ledger.Babel.Rules.Utxow (BabelUtxowPredFailure) +import Cardano.Ledger.BaseTypes (ShelleyBase, StrictMaybe (..), epochInfoPure) +import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) +import Cardano.Ledger.Binary.Coders +import Cardano.Ledger.Coin (Coin) +import Cardano.Ledger.Conway.Core +import Cardano.Ledger.Conway.Governance ( + ConwayEraGov (..), + ConwayGovState (..), + GovProcedures (..), + Proposals, + constitutionScriptL, + pRootsL, + proposalsGovStateL, + toPrevGovActionIds, + ) +import Cardano.Ledger.Conway.Rules ( + CertEnv, + CertsEnv (CertsEnv), + ConwayCERTS, + ConwayCertsEvent, + ConwayCertsPredFailure, + ConwayGOV, + ConwayGovEvent, + ConwayGovPredFailure, + GovEnv (GovEnv), + ) +import Cardano.Ledger.Credential (Credential) +import Cardano.Ledger.Crypto (Crypto (..)) +import Cardano.Ledger.Keys (KeyRole (..)) +import Cardano.Ledger.Shelley.LedgerState ( + CertState (..), + DState (..), + LedgerState (..), + UTxOState (..), + asTreasuryL, + certVStateL, + utxosGovStateL, + vsCommitteeStateL, + ) +import Cardano.Ledger.Shelley.Rules ( + LedgerEnv (..), + UtxoEnv (..), + renderDepositEqualsObligationViolation, + shelleyLedgerAssertions, + ) +import Cardano.Ledger.Slot (epochInfoEpoch) +import Cardano.Ledger.UMap (UView (..), dRepMap) +import qualified Cardano.Ledger.UMap as UMap +import Cardano.Ledger.UTxO (EraUTxO (..)) +import Control.DeepSeq (NFData) +import Control.Monad (when) +import Control.Monad.Trans.Reader (asks) +import Control.State.Transition.Extended ( + Embed (..), + STS (..), + TRC (..), + TransitionRule, + judgmentContext, + liftSTS, + trans, + (?!), + ) +import Data.Kind (Type) +import qualified Data.Map.Strict as Map +import Data.Sequence (Seq) +import qualified Data.Sequence.Strict as StrictSeq +import Data.Set (Set) +import qualified Data.Set as Set +import GHC.Generics (Generic (..)) +import Lens.Micro as L +import NoThunks.Class (NoThunks (..)) + +data BabelLedgerPredFailure era + = BabelUtxowFailure (PredicateFailure (EraRule "UTXOW" era)) + | BabelCertsFailure (PredicateFailure (EraRule "CERTS" era)) + | BabelGovFailure (PredicateFailure (EraRule "GOV" era)) + | BabelWdrlNotDelegatedToDRep (Set (Credential 'Staking (EraCrypto era))) + | BabelTreasuryValueMismatch + -- | Actual + Coin + -- | Submitted in transaction + Coin + deriving (Generic) + +type instance EraRuleFailure "LEDGER" (BabelEra c) = BabelLedgerPredFailure (BabelEra c) + +type instance EraRuleEvent "LEDGER" (BabelEra c) = BabelLedgerEvent (BabelEra c) + +instance InjectRuleFailure "LEDGER" BabelLedgerPredFailure (BabelEra c) + +instance InjectRuleFailure "LEDGER" BabelUtxowPredFailure (BabelEra c) where + injectFailure = BabelUtxowFailure . injectFailure + +instance InjectRuleFailure "LEDGER" BabelUtxoPredFailure (BabelEra c) where + injectFailure = BabelUtxowFailure . injectFailure + +instance InjectRuleFailure "LEDGER" BabbageUtxoPredFailure (BabelEra c) where + injectFailure = BabelUtxowFailure . injectFailure + +instance InjectRuleFailure "LEDGER" BabelUtxosPredFailure (BabelEra c) where + injectFailure = BabelUtxowFailure . injectFailure + +deriving instance + ( Era era + , Eq (PredicateFailure (EraRule "UTXOW" era)) + , Eq (PredicateFailure (EraRule "CERTS" era)) + , Eq (PredicateFailure (EraRule "GOV" era)) + ) => + Eq (BabelLedgerPredFailure era) + +deriving instance + ( Era era + , Show (PredicateFailure (EraRule "UTXOW" era)) + , Show (PredicateFailure (EraRule "CERTS" era)) + , Show (PredicateFailure (EraRule "GOV" era)) + ) => + Show (BabelLedgerPredFailure era) + +instance + ( Era era + , NoThunks (PredicateFailure (EraRule "UTXOW" era)) + , NoThunks (PredicateFailure (EraRule "CERTS" era)) + , NoThunks (PredicateFailure (EraRule "GOV" era)) + ) => + NoThunks (BabelLedgerPredFailure era) + +instance + ( Era era + , NFData (PredicateFailure (EraRule "UTXOW" era)) + , NFData (PredicateFailure (EraRule "CERTS" era)) + , NFData (PredicateFailure (EraRule "GOV" era)) + ) => + NFData (BabelLedgerPredFailure era) + +instance + ( Era era + , EncCBOR (PredicateFailure (EraRule "UTXOW" era)) + , EncCBOR (PredicateFailure (EraRule "CERTS" era)) + , EncCBOR (PredicateFailure (EraRule "GOV" era)) + ) => + EncCBOR (BabelLedgerPredFailure era) + where + encCBOR = + encode . \case + BabelUtxowFailure x -> Sum (BabelUtxowFailure @era) 1 !> To x + BabelCertsFailure x -> Sum (BabelCertsFailure @era) 2 !> To x + BabelGovFailure x -> Sum (BabelGovFailure @era) 3 !> To x + BabelWdrlNotDelegatedToDRep x -> + Sum (BabelWdrlNotDelegatedToDRep @era) 4 !> To x + BabelTreasuryValueMismatch actual submitted -> + Sum (BabelTreasuryValueMismatch @era) 5 !> To actual !> To submitted + +instance + ( Era era + , DecCBOR (PredicateFailure (EraRule "UTXOW" era)) + , DecCBOR (PredicateFailure (EraRule "CERTS" era)) + , DecCBOR (PredicateFailure (EraRule "GOV" era)) + ) => + DecCBOR (BabelLedgerPredFailure era) + where + decCBOR = + decode $ Summands "BabelLedgerPredFailure" $ \case + 1 -> SumD BabelUtxowFailure SumD BabelCertsFailure SumD BabelGovFailure SumD BabelWdrlNotDelegatedToDRep SumD BabelTreasuryValueMismatch Invalid n + +data BabelLedgerEvent era + = UtxowEvent (Event (EraRule "UTXOW" era)) + | CertsEvent (Event (EraRule "CERTS" era)) + | GovEvent (Event (EraRule "GOV" era)) + deriving (Generic) + +deriving instance + ( Eq (Event (EraRule "CERTS" era)) + , Eq (Event (EraRule "UTXOW" era)) + , Eq (Event (EraRule "GOV" era)) + ) => + Eq (BabelLedgerEvent era) + +instance + ( NFData (Event (EraRule "CERTS" era)) + , NFData (Event (EraRule "UTXOW" era)) + , NFData (Event (EraRule "GOV" era)) + ) => + NFData (BabelLedgerEvent era) + +instance + ( AlonzoEraTx era + , BabelEraTxBody era + , ConwayEraGov era + , GovState era ~ ConwayGovState era + , Embed (EraRule "UTXOW" era) (BabelLEDGER era) + , Embed (EraRule "GOV" era) (BabelLEDGER era) + , Embed (EraRule "CERTS" era) (BabelLEDGER era) + , State (EraRule "UTXOW" era) ~ UTxOState era + , State (EraRule "CERTS" era) ~ CertState era + , State (EraRule "GOV" era) ~ Proposals era + , Environment (EraRule "UTXOW" era) ~ UtxoEnv era + , Environment (EraRule "CERTS" era) ~ CertsEnv era + , Environment (EraRule "GOV" era) ~ GovEnv era + , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "CERTS" era) ~ Seq (TxCert era) + , Signal (EraRule "GOV" era) ~ GovProcedures era + ) => + STS (BabelLEDGER era) + where + type State (BabelLEDGER era) = LedgerState era + type Signal (BabelLEDGER era) = Tx era + type Environment (BabelLEDGER era) = LedgerEnv era + type BaseM (BabelLEDGER era) = ShelleyBase + type PredicateFailure (BabelLEDGER era) = BabelLedgerPredFailure era + type Event (BabelLEDGER era) = BabelLedgerEvent era + + initialRules = [] + transitionRules = [ledgerTransition @BabelLEDGER] + + renderAssertionViolation = renderDepositEqualsObligationViolation + + assertions = shelleyLedgerAssertions @era @BabelLEDGER + +-- ======================================= + +ledgerTransition :: + forall (someLEDGER :: Type -> Type) era. + ( AlonzoEraTx era + , BabelEraTxBody era + , ConwayEraGov era + , GovState era ~ ConwayGovState era + , Signal (someLEDGER era) ~ Tx era + , State (someLEDGER era) ~ LedgerState era + , Environment (someLEDGER era) ~ LedgerEnv era + , PredicateFailure (someLEDGER era) ~ BabelLedgerPredFailure era + , Embed (EraRule "UTXOW" era) (someLEDGER era) + , Embed (EraRule "GOV" era) (someLEDGER era) + , Embed (EraRule "CERTS" era) (someLEDGER era) + , State (EraRule "UTXOW" era) ~ UTxOState era + , State (EraRule "CERTS" era) ~ CertState era + , State (EraRule "GOV" era) ~ Proposals era + , Environment (EraRule "UTXOW" era) ~ UtxoEnv era + , Environment (EraRule "GOV" era) ~ GovEnv era + , Environment (EraRule "CERTS" era) ~ CertsEnv era + , Signal (EraRule "UTXOW" era) ~ Tx era + , Signal (EraRule "CERTS" era) ~ Seq (TxCert era) + , Signal (EraRule "GOV" era) ~ GovProcedures era + , BaseM (someLEDGER era) ~ ShelleyBase + , STS (someLEDGER era) + ) => + TransitionRule (someLEDGER era) +ledgerTransition = do + TRC (LedgerEnv slot _txIx pp account, LedgerState utxoState certState, tx) <- judgmentContext + + let actualTreasuryValue = account ^. asTreasuryL + in case tx ^. bodyTxL . currentTreasuryValueTxBodyL of + SNothing -> pure () + SJust submittedTreasuryValue -> + submittedTreasuryValue + == actualTreasuryValue + ?! BabelTreasuryValueMismatch actualTreasuryValue submittedTreasuryValue + + currentEpoch <- liftSTS $ do + ei <- asks epochInfoPure + epochInfoEpoch ei slot + + let txBody = tx ^. bodyTxL + + (utxoState', certStateAfterCERTS) <- + if tx ^. isValidTxL == IsValid True + then do + certStateAfterCERTS <- + trans @(EraRule "CERTS" era) $ + TRC + ( CertsEnv tx pp slot currentEpoch + , certState + , StrictSeq.fromStrict $ txBody ^. certsTxBodyL + ) + let wdrlAddrs = Map.keysSet . unWithdrawals $ tx ^. bodyTxL . withdrawalsTxBodyL + wdrlCreds = Set.map raCredential wdrlAddrs + dUnified = dsUnified $ certDState certStateAfterCERTS + delegatedAddrs = DRepUView dUnified + + -- TODO enable this check once delegation is fully implemented in cardano-api + when False $ do + all (`UMap.member` delegatedAddrs) wdrlCreds + ?! BabelWdrlNotDelegatedToDRep (wdrlCreds Set.\\ Map.keysSet (dRepMap dUnified)) + + -- Votes and proposals from signal tx + let govProcedures = + GovProcedures + { gpVotingProcedures = txBody ^. votingProceduresTxBodyL + , gpProposalProcedures = txBody ^. proposalProceduresTxBodyL + } + proposalsState <- + trans @(EraRule "GOV" era) $ + TRC + ( GovEnv + (txIdTxBody txBody) + currentEpoch + pp + (utxoState ^. utxosGovStateL . proposalsGovStateL . pRootsL . L.to toPrevGovActionIds) + (utxoState ^. utxosGovStateL . constitutionGovStateL . constitutionScriptL) + (certState ^. certVStateL . vsCommitteeStateL) + , utxoState ^. utxosGovStateL . proposalsGovStateL + , govProcedures + ) + let utxoState' = + utxoState + & utxosGovStateL + . proposalsGovStateL + .~ proposalsState + pure (utxoState', certStateAfterCERTS) + else pure (utxoState, certState) + + utxoState'' <- + trans @(EraRule "UTXOW" era) $ + TRC + -- Pass to UTXOW the unmodified CertState in its Environment, + -- so it can process refunds of deposits for deregistering + -- stake credentials and DReps. The modified CertState + -- (certStateAfterCERTS) has these already removed from its + -- UMap. + ( UtxoEnv @era slot pp certState + , utxoState' + , tx + ) + pure $ LedgerState utxoState'' certStateAfterCERTS + +instance + ( EraTx era + , ConwayEraTxBody era + , ConwayEraPParams era + , ConwayEraGov era + , Embed (EraRule "CERT" era) (ConwayCERTS era) + , State (EraRule "CERT" era) ~ CertState era + , Environment (EraRule "CERT" era) ~ CertEnv era + , Signal (EraRule "CERT" era) ~ TxCert era + , PredicateFailure (EraRule "CERTS" era) ~ ConwayCertsPredFailure era + , Event (EraRule "CERTS" era) ~ ConwayCertsEvent era + , EraRule "CERTS" era ~ ConwayCERTS era + ) => + Embed (ConwayCERTS era) (BabelLEDGER era) + where + wrapFailed = BabelCertsFailure + wrapEvent = CertsEvent + +instance + ( ConwayEraPParams era + , BaseM (BabelLEDGER era) ~ ShelleyBase + , PredicateFailure (EraRule "GOV" era) ~ ConwayGovPredFailure era + , Event (EraRule "GOV" era) ~ ConwayGovEvent era + , EraRule "GOV" era ~ ConwayGOV era + , InjectRuleFailure "GOV" ConwayGovPredFailure era + ) => + Embed (ConwayGOV era) (BabelLEDGER era) + where + wrapFailed = BabelGovFailure + wrapEvent = GovEvent + +instance + ( Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentTxBody) + , BaseM (BabelUTXOW era) ~ ShelleyBase + , AlonzoEraTx era + , EraUTxO era + , BabbageEraTxBody era + , Embed (EraRule "UTXO" era) (BabelUTXOW era) + , State (EraRule "UTXO" era) ~ UTxOState era + , Environment (EraRule "UTXO" era) ~ UtxoEnv era + , Script era ~ AlonzoScript era + , TxOut era ~ BabbageTxOut era + , ScriptsNeeded era ~ AlonzoScriptsNeeded era + , Signal (EraRule "UTXO" era) ~ Tx era + , PredicateFailure (EraRule "UTXOW" era) ~ BabelUtxowPredFailure era + , Event (EraRule "UTXOW" era) ~ AlonzoUtxowEvent era + , STS (BabelUTXOW era) + , PredicateFailure (BabelUTXOW era) ~ BabelUtxowPredFailure era + , Event (BabelUTXOW era) ~ AlonzoUtxowEvent era + ) => + Embed (BabelUTXOW era) (BabelLEDGER era) + where + wrapFailed = BabelUtxowFailure + wrapEvent = UtxowEvent diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledgers.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledgers.hs new file mode 100644 index 00000000000..7cdf8862ce5 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledgers.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Rules.Ledgers (BabelLEDGERS, BabelLedgersEnv (..)) where + +import Cardano.Ledger.Babel.Era (BabelEra, BabelLEDGERS) +import Cardano.Ledger.Babel.Rules.Ledger (BabelLEDGER, BabelLedgerEvent, BabelLedgerPredFailure) +import Cardano.Ledger.Babel.Rules.Pool () +import Cardano.Ledger.Babel.Rules.Utxo (BabelUtxoPredFailure) +import Cardano.Ledger.Babel.Rules.Utxos (BabelUtxosPredFailure) +import Cardano.Ledger.Babel.Rules.Utxow (BabelUtxowPredFailure) +import Cardano.Ledger.BaseTypes (ShelleyBase) +import Cardano.Ledger.Core +import Cardano.Ledger.Keys (DSignable, Hash) +import Cardano.Ledger.Shelley.API.Types (AccountState, LedgerEnv (LedgerEnv), LedgerState) +import Cardano.Ledger.Shelley.Rules ( + ShelleyLedgersEvent (LedgerEvent), + ShelleyLedgersPredFailure (..), + ) +import Cardano.Ledger.Slot (SlotNo) +import Cardano.Ledger.TxIn (TxIx) +import Control.Monad (foldM) +import Control.State.Transition ( + Embed (wrapEvent, wrapFailed), + STS (..), + TRC (TRC), + TransitionRule, + judgmentContext, + trans, + ) +import Data.Default.Class (Default) +import Data.Foldable (toList) +import Data.Sequence (Seq) +import GHC.Generics (Generic) + +data BabelLedgersEnv era = BabelLedgersEnv + { ledgerSlotNo :: !SlotNo + , ledgerIxStart :: !TxIx + , ledgerPp :: !(PParams era) + , ledgerAccount :: !AccountState + } + deriving (Generic) + +type instance EraRuleFailure "LEDGERS" (BabelEra c) = ShelleyLedgersPredFailure (BabelEra c) + +type instance EraRuleEvent "LEDGERS" (BabelEra c) = ShelleyLedgersEvent (BabelEra c) + +instance InjectRuleFailure "LEDGERS" ShelleyLedgersPredFailure (BabelEra c) + +instance InjectRuleFailure "LEDGERS" BabelLedgerPredFailure (BabelEra c) where + injectFailure = LedgerFailure + +instance InjectRuleFailure "LEDGERS" BabelUtxowPredFailure (BabelEra c) where + injectFailure = LedgerFailure . injectFailure + +instance InjectRuleFailure "LEDGERS" BabelUtxosPredFailure (BabelEra c) where + injectFailure = LedgerFailure . injectFailure + +instance InjectRuleFailure "LEDGERS" BabelUtxoPredFailure (BabelEra c) where + injectFailure = LedgerFailure . injectFailure + +instance + ( Era era + , Embed (EraRule "LEDGER" era) (BabelLEDGERS era) + , Environment (EraRule "LEDGER" era) ~ LedgerEnv era + , State (EraRule "LEDGER" era) ~ LedgerState era + , Signal (EraRule "LEDGER" era) ~ Tx era + , DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody) + , Default (LedgerState era) + ) => + STS (BabelLEDGERS era) + where + type State (BabelLEDGERS era) = LedgerState era + type Signal (BabelLEDGERS era) = Seq (Tx era) + type Environment (BabelLEDGERS era) = BabelLedgersEnv era + type BaseM (BabelLEDGERS era) = ShelleyBase + type PredicateFailure (BabelLEDGERS era) = ShelleyLedgersPredFailure era + type Event (BabelLEDGERS era) = ShelleyLedgersEvent era + + transitionRules = [ledgersTransition] + +ledgersTransition :: + forall era. + ( Embed (EraRule "LEDGER" era) (BabelLEDGERS era) + , Environment (EraRule "LEDGER" era) ~ LedgerEnv era + , State (EraRule "LEDGER" era) ~ LedgerState era + , Signal (EraRule "LEDGER" era) ~ Tx era + ) => + TransitionRule (BabelLEDGERS era) +ledgersTransition = do + TRC (BabelLedgersEnv slot ixStart pp account, ls, txwits) <- + judgmentContext + foldM + ( \ !ls' (ix, tx) -> + trans @(EraRule "LEDGER" era) $ + TRC (LedgerEnv slot ix pp account, ls', tx) + ) + ls + $ zip [ixStart ..] + $ toList txwits + +instance + ( Era era + , STS (BabelLEDGER era) + , PredicateFailure (EraRule "LEDGER" era) ~ BabelLedgerPredFailure era + , Event (EraRule "LEDGER" era) ~ BabelLedgerEvent era + ) => + Embed (BabelLEDGER era) (BabelLEDGERS era) + where + wrapFailed = LedgerFailure + wrapEvent = LedgerEvent \ No newline at end of file diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Pool.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Pool.hs new file mode 100644 index 00000000000..59e710b64fd --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Pool.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Rules.Pool where + +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Core (EraRuleEvent, EraRuleFailure) +import Cardano.Ledger.Shelley.Rules (PoolEvent, ShelleyPoolPredFailure) + +type instance EraRuleFailure "POOL" (BabelEra c) = ShelleyPoolPredFailure (BabelEra c) + +type instance EraRuleEvent "POOL" (BabelEra c) = PoolEvent (BabelEra c) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxo.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxo.hs new file mode 100644 index 00000000000..905eaee5af6 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxo.hs @@ -0,0 +1,577 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Rules.Utxo ( + allegraToBabelUtxoPredFailure, + babbageToBabelUtxoPredFailure, + alonzoToBabelUtxoPredFailure, + BabelUtxoPredFailure (..), +) where + +import Cardano.Ledger.Address (Addr, RewardAccount) +import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure, shelleyToAllegraUtxoPredFailure) +import qualified Cardano.Ledger.Allegra.Rules as Allegra ( + AllegraUtxoPredFailure (..), + validateOutsideValidityIntervalUTxO, + ) +import Cardano.Ledger.Alonzo.Rules ( + AlonzoUtxoEvent, + AlonzoUtxoPredFailure, + AlonzoUtxosPredFailure, + ) +import qualified Cardano.Ledger.Alonzo.Rules as Alonzo ( + AlonzoUtxoEvent (UtxosEvent), + AlonzoUtxoPredFailure (..), + validateExUnitsTooBigUTxO, + validateOutputTooBigUTxO, + validateOutsideForecast, + validateTooManyCollateralInputs, + validateWrongNetworkInTxBody, + ) +import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..)) +import Cardano.Ledger.Babbage (BabbageEra) +import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, feesOK, validateOutputTooSmallUTxO) +import qualified Cardano.Ledger.Babbage.Rules as Babbage ( + BabbageUtxoPredFailure (..), + ) +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Era (BabelEra, BabelUTXO, BabelUTXOS) +import Cardano.Ledger.Babel.Rules.Utxos ( + BabelUtxosPredFailure (..), + ) +import Cardano.Ledger.BaseTypes ( + Globals (epochInfo, networkId, systemStart), + Network, + ProtVer (pvMajor), + ShelleyBase, + SlotNo, + ) +import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), Sized (sizedValue)) +import Cardano.Ledger.Binary.Coders ( + Decode (..), + Encode (..), + decode, + encode, + (!>), + ( + Show (BabelUtxoPredFailure era) + +deriving instance + ( Era era + , Eq (Value era) + , Eq (PredicateFailure (EraRule "UTXOS" era)) + , Eq (TxOut era) + , Eq (Script era) + , Eq (TxIn (EraCrypto era)) + ) => + Eq (BabelUtxoPredFailure era) + +deriving via + InspectHeapNamed "BabelUtxoPred" (BabelUtxoPredFailure era) + instance + NoThunks (BabelUtxoPredFailure era) + +instance + ( Era era + , NFData (Value era) + , NFData (TxOut era) + , NFData (PredicateFailure (EraRule "UTXOS" era)) + ) => + NFData (BabelUtxoPredFailure era) + +-------------------------------------------------------------------------------- +-- BabelUTXO STS +-------------------------------------------------------------------------------- + +-- | The UTxO transition rule for the Babbage eras. +utxoTransition :: + forall era. + ( EraUTxO era + , BabbageEraTxBody era + , AlonzoEraTxWits era + , Tx era ~ AlonzoTx era + , InjectRuleFailure "UTXO" ShelleyUtxoPredFailure era + , InjectRuleFailure "UTXO" AllegraUtxoPredFailure era + , InjectRuleFailure "UTXO" AlonzoUtxoPredFailure era + , InjectRuleFailure "UTXO" BabbageUtxoPredFailure era + , Environment (EraRule "UTXO" era) ~ Shelley.UtxoEnv era + , State (EraRule "UTXO" era) ~ Shelley.UTxOState era + , Signal (EraRule "UTXO" era) ~ AlonzoTx era + , BaseM (EraRule "UTXO" era) ~ ShelleyBase + , STS (EraRule "UTXO" era) + , -- In this function we we call the UTXOS rule, so we need some assumptions + Embed (EraRule "UTXOS" era) (EraRule "UTXO" era) + , Environment (EraRule "UTXOS" era) ~ Shelley.UtxoEnv era + , State (EraRule "UTXOS" era) ~ Shelley.UTxOState era + , Signal (EraRule "UTXOS" era) ~ Tx era + , InjectRuleFailure "UTXO" BabelUtxoPredFailure era + ) => + TransitionRule (EraRule "UTXO" era) +utxoTransition = do + TRC (Shelley.UtxoEnv slot pp certState, utxos, tx) <- judgmentContext + let utxo = utxosUtxo utxos + + {- txb := txbody tx -} + let txBody = body tx + allInputs = txBody ^. allInputsTxBodyF + refInputs :: Set (TxIn (EraCrypto era)) + refInputs = txBody ^. referenceInputsTxBodyL + inputs :: Set (TxIn (EraCrypto era)) + inputs = txBody ^. inputsTxBodyL + + {- inputs ∩ refInputs = ∅ -} + runTest $ disjointRefInputs pp inputs refInputs + + {- ininterval slot (txvld txb) -} + runTest $ Allegra.validateOutsideValidityIntervalUTxO slot txBody + + sysSt <- liftSTS $ asks systemStart + ei <- liftSTS $ asks epochInfo + + {- epochInfoSlotToUTCTime epochInfo systemTime i_f ≠ ◇ -} + runTest $ Alonzo.validateOutsideForecast ei slot sysSt tx + + {- txins txb ≠ ∅ -} + runTestOnSignal $ Shelley.validateInputSetEmptyUTxO txBody + + {- feesOK pp tx utxo -} + validate $ feesOK pp tx utxo -- Generalizes the fee to small from earlier Era's + + {- allInputs = spendInputs txb ∪ collInputs txb ∪ refInputs txb -} + {- (spendInputs txb ∪ collInputs txb ∪ refInputs txb) ⊆ dom utxo -} + runTest $ Shelley.validateBadInputsUTxO utxo allInputs + + {- consumed pp utxo txb = produced pp poolParams txb -} + runTest $ Shelley.validateValueNotConservedUTxO pp utxo certState txBody + + {- adaID ∉ supp mint tx - check not needed because mint field of type MultiAsset + cannot contain ada -} + + {- ∀ txout ∈ allOuts txb, getValue txout ≥ inject (serSize txout ∗ coinsPerUTxOByte pp) -} + let allSizedOutputs = txBody ^. allSizedOutputsTxBodyF + runTest $ validateOutputTooSmallUTxO pp allSizedOutputs + + let allOutputs = fmap sizedValue allSizedOutputs + {- ∀ txout ∈ allOuts txb, serSize (getValue txout) ≤ maxValSize pp -} + runTest $ Alonzo.validateOutputTooBigUTxO pp allOutputs + + {- ∀ ( _ ↦ (a,_)) ∈ allOuts txb, a ∈ Addrbootstrap → bootstrapAttrsSize a ≤ 64 -} + runTestOnSignal $ Shelley.validateOutputBootAddrAttrsTooBig allOutputs + + netId <- liftSTS $ asks networkId + + {- ∀(_ → (a, _)) ∈ allOuts txb, netId a = NetworkId -} + runTestOnSignal $ Shelley.validateWrongNetwork netId allOutputs + + {- ∀(a → ) ∈ txwdrls txb, netId a = NetworkId -} + runTestOnSignal $ Shelley.validateWrongNetworkWithdrawal netId txBody + + {- (txnetworkid txb = NetworkId) ∨ (txnetworkid txb = ◇) -} + runTestOnSignal $ Alonzo.validateWrongNetworkInTxBody netId txBody + + {- txsize tx ≤ maxTxSize pp -} + -- We've moved this to the ZONE rule. See https://github.com/IntersectMBO/formal-ledger-specifications/commit/c3e18ac1d3da92dd4894bbc32057a143f9720f52#diff-5f67369ed62c0dab01e13a73f072b664ada237d094bbea4582365264dd163bf9 + -- runTestOnSignal $ Shelley.validateMaxTxSizeUTxO pp tx + + {- totExunits tx ≤ maxTxExUnits pp -} + runTest $ Alonzo.validateExUnitsTooBigUTxO pp tx + + {- ‖collateral tx‖ ≤ maxCollInputs pp -} + runTest $ Alonzo.validateTooManyCollateralInputs pp txBody + + trans @(EraRule "UTXOS" era) =<< coerce <$> judgmentContext + +-- \| Test that inputs and refInpts are disjoint, in Babel and later Eras. +disjointRefInputs :: + forall era. + EraPParams era => + PParams era -> + Set (TxIn (EraCrypto era)) -> + Set (TxIn (EraCrypto era)) -> + Test (BabelUtxoPredFailure era) +disjointRefInputs pp inputs refInputs = + when + (pvMajor (pp ^. ppProtocolVersionL) > eraProtVerHigh @(BabbageEra (EraCrypto era))) + (failureOnNonEmpty common BabbageNonDisjointRefInputs) + where + common = inputs `Set.intersection` refInputs + +instance + forall era. + ( EraTx era + , EraUTxO era + , BabelEraTxBody era + , AlonzoEraTxWits era + , Tx era ~ AlonzoTx era + , EraRule "UTXO" era ~ BabelUTXO era + , InjectRuleFailure "UTXO" ShelleyUtxoPredFailure era + , InjectRuleFailure "UTXO" AllegraUtxoPredFailure era + , InjectRuleFailure "UTXO" AlonzoUtxoPredFailure era + , InjectRuleFailure "UTXO" BabbageUtxoPredFailure era + , InjectRuleFailure "UTXO" BabelUtxoPredFailure era + , Embed (EraRule "UTXOS" era) (BabelUTXO era) + , Environment (EraRule "UTXOS" era) ~ Shelley.UtxoEnv era + , State (EraRule "UTXOS" era) ~ Shelley.UTxOState era + , Signal (EraRule "UTXOS" era) ~ Tx era + , PredicateFailure (EraRule "UTXO" era) ~ BabelUtxoPredFailure era + ) => + STS (BabelUTXO era) + where + type State (BabelUTXO era) = Shelley.UTxOState era + type Signal (BabelUTXO era) = AlonzoTx era + type Environment (BabelUTXO era) = Shelley.UtxoEnv era + type BaseM (BabelUTXO era) = ShelleyBase + type PredicateFailure (BabelUTXO era) = BabelUtxoPredFailure era + type Event (BabelUTXO era) = AlonzoUtxoEvent era + + initialRules = [] + + transitionRules = [utxoTransition @era] + +instance + ( Era era + , STS (BabelUTXOS era) + , PredicateFailure (EraRule "UTXOS" era) ~ BabelUtxosPredFailure era + , Event (EraRule "UTXOS" era) ~ Event (BabelUTXOS era) + ) => + Embed (BabelUTXOS era) (BabelUTXO era) + where + wrapFailed = UtxosFailure + wrapEvent = Alonzo.UtxosEvent + +-------------------------------------------------------------------------------- +-- Serialisation +-------------------------------------------------------------------------------- + +instance + ( Era era + , EncCBOR (TxOut era) + , EncCBOR (Value era) + , EncCBOR (PredicateFailure (EraRule "UTXOS" era)) + ) => + EncCBOR (BabelUtxoPredFailure era) + where + encCBOR = + encode . \case + UtxosFailure a -> Sum (UtxosFailure @era) 0 !> To a + BadInputsUTxO ins -> Sum (BadInputsUTxO @era) 1 !> To ins + OutsideValidityIntervalUTxO a b -> Sum OutsideValidityIntervalUTxO 2 !> To a !> To b + MaxTxSizeUTxO a b -> Sum MaxTxSizeUTxO 3 !> To a !> To b + InputSetEmptyUTxO -> Sum InputSetEmptyUTxO 4 + FeeTooSmallUTxO a b -> Sum FeeTooSmallUTxO 5 !> To a !> To b + ValueNotConservedUTxO a b -> Sum (ValueNotConservedUTxO @era) 6 !> To a !> To b + WrongNetwork right wrongs -> Sum (WrongNetwork @era) 7 !> To right !> To wrongs + WrongNetworkWithdrawal right wrongs -> Sum (WrongNetworkWithdrawal @era) 8 !> To right !> To wrongs + OutputTooSmallUTxO outs -> Sum (OutputTooSmallUTxO @era) 9 !> To outs + OutputBootAddrAttrsTooBig outs -> Sum (OutputBootAddrAttrsTooBig @era) 10 !> To outs + OutputTooBigUTxO outs -> Sum (OutputTooBigUTxO @era) 11 !> To outs + InsufficientCollateral a b -> Sum InsufficientCollateral 12 !> To a !> To b + ScriptsNotPaidUTxO a -> Sum ScriptsNotPaidUTxO 13 !> To a + ExUnitsTooBigUTxO a b -> Sum ExUnitsTooBigUTxO 14 !> To a !> To b + CollateralContainsNonADA a -> Sum CollateralContainsNonADA 15 !> To a + WrongNetworkInTxBody a b -> Sum WrongNetworkInTxBody 16 !> To a !> To b + OutsideForecast a -> Sum OutsideForecast 17 !> To a + TooManyCollateralInputs a b -> Sum TooManyCollateralInputs 18 !> To a !> To b + NoCollateralInputs -> Sum NoCollateralInputs 19 + IncorrectTotalCollateralField c1 c2 -> Sum IncorrectTotalCollateralField 20 !> To c1 !> To c2 + BabbageOutputTooSmallUTxO x -> Sum BabbageOutputTooSmallUTxO 21 !> To x + BabbageNonDisjointRefInputs x -> Sum BabbageNonDisjointRefInputs 22 !> To x + CheckRqTxFailure -> Sum CheckRqTxFailure 23 + CheckLinearFailure -> Sum CheckLinearFailure 24 + MoreThanOneInvalidTransaction -> Sum MoreThanOneInvalidTransaction 25 + +instance + ( Era era + , DecCBOR (TxOut era) + , DecCBOR (Value era) + , DecCBOR (PredicateFailure (EraRule "UTXOS" era)) + ) => + DecCBOR (BabelUtxoPredFailure era) + where + decCBOR = decode . Summands "BabelUtxoPred" $ \case + 0 -> SumD UtxosFailure SumD BadInputsUTxO SumD OutsideValidityIntervalUTxO SumD MaxTxSizeUTxO SumD InputSetEmptyUTxO + 5 -> SumD FeeTooSmallUTxO SumD ValueNotConservedUTxO SumD WrongNetwork SumD WrongNetworkWithdrawal SumD OutputTooSmallUTxO SumD OutputBootAddrAttrsTooBig SumD OutputTooBigUTxO SumD InsufficientCollateral SumD ScriptsNotPaidUTxO decCBOR) + 14 -> SumD ExUnitsTooBigUTxO SumD CollateralContainsNonADA SumD WrongNetworkInTxBody SumD OutsideForecast SumD TooManyCollateralInputs SumD NoCollateralInputs + 20 -> SumD IncorrectTotalCollateralField SumD BabbageOutputTooSmallUTxO SumD BabbageNonDisjointRefInputs Invalid n + +-- ===================================================== +-- Injecting from one PredicateFailure to another + +babbageToBabelUtxoPredFailure :: + forall era. + BabbageUtxoPredFailure era -> + BabelUtxoPredFailure era +babbageToBabelUtxoPredFailure = \case + Babbage.AlonzoInBabbageUtxoPredFailure a -> alonzoToBabelUtxoPredFailure a + Babbage.IncorrectTotalCollateralField c1 c2 -> IncorrectTotalCollateralField c1 c2 + Babbage.BabbageOutputTooSmallUTxO ts -> BabbageOutputTooSmallUTxO ts + Babbage.BabbageNonDisjointRefInputs ts -> BabbageNonDisjointRefInputs ts + +alonzoToBabelUtxoPredFailure :: + forall era. + AlonzoUtxoPredFailure era -> + BabelUtxoPredFailure era +alonzoToBabelUtxoPredFailure = \case + Alonzo.BadInputsUTxO x -> BadInputsUTxO x + Alonzo.OutsideValidityIntervalUTxO vi slotNo -> OutsideValidityIntervalUTxO vi slotNo + Alonzo.MaxTxSizeUTxO x y -> MaxTxSizeUTxO x y + Alonzo.InputSetEmptyUTxO -> InputSetEmptyUTxO + Alonzo.FeeTooSmallUTxO c1 c2 -> FeeTooSmallUTxO c1 c2 + Alonzo.ValueNotConservedUTxO vc vp -> ValueNotConservedUTxO vc vp + Alonzo.WrongNetwork x y -> WrongNetwork x y + Alonzo.WrongNetworkWithdrawal x y -> WrongNetworkWithdrawal x y + Alonzo.OutputTooSmallUTxO x -> OutputTooSmallUTxO x + Alonzo.UtxosFailure x -> UtxosFailure x + Alonzo.OutputBootAddrAttrsTooBig xs -> OutputBootAddrAttrsTooBig xs + Alonzo.TriesToForgeADA -> + error + "Impossible case, soon to be removed. See: https://github.com/IntersectMBO/cardano-ledger/issues/4085" + Alonzo.OutputTooBigUTxO xs -> + let + -- TODO: Remove this once the other eras will make the switch from Integer to Int + -- as per #4015. + -- https://github.com/IntersectMBO/cardano-ledger/issues/4085 + toRestricted :: (Integer, Integer, TxOut era) -> (Int, Int, TxOut era) + toRestricted (sz, mv, out) = (fromIntegral sz, fromIntegral mv, out) + in + OutputTooBigUTxO $ map toRestricted xs + Alonzo.InsufficientCollateral c1 c2 -> InsufficientCollateral c1 c2 + Alonzo.ScriptsNotPaidUTxO u -> ScriptsNotPaidUTxO u + Alonzo.ExUnitsTooBigUTxO e1 e2 -> ExUnitsTooBigUTxO e1 e2 + Alonzo.CollateralContainsNonADA v -> CollateralContainsNonADA v + Alonzo.WrongNetworkInTxBody nid nidb -> WrongNetworkInTxBody nid nidb + Alonzo.OutsideForecast sno -> OutsideForecast sno + Alonzo.TooManyCollateralInputs n1 n2 -> TooManyCollateralInputs n1 n2 + Alonzo.NoCollateralInputs -> NoCollateralInputs + +allegraToBabelUtxoPredFailure :: + forall era. + EraRuleFailure "PPUP" era ~ VoidEraRule "PPUP" era => + Allegra.AllegraUtxoPredFailure era -> + BabelUtxoPredFailure era +allegraToBabelUtxoPredFailure = \case + Allegra.BadInputsUTxO x -> BadInputsUTxO x + Allegra.OutsideValidityIntervalUTxO vi slotNo -> OutsideValidityIntervalUTxO vi slotNo + Allegra.MaxTxSizeUTxO x y -> MaxTxSizeUTxO x y + Allegra.InputSetEmptyUTxO -> InputSetEmptyUTxO + Allegra.FeeTooSmallUTxO c1 c2 -> FeeTooSmallUTxO c1 c2 + Allegra.ValueNotConservedUTxO vc vp -> ValueNotConservedUTxO vc vp + Allegra.WrongNetwork x y -> WrongNetwork x y + Allegra.WrongNetworkWithdrawal x y -> WrongNetworkWithdrawal x y + Allegra.OutputTooSmallUTxO x -> OutputTooSmallUTxO x + Allegra.UpdateFailure x -> absurdEraRule @"PPUP" @era x + Allegra.OutputBootAddrAttrsTooBig xs -> OutputBootAddrAttrsTooBig xs + Allegra.TriesToForgeADA -> + error + "Impossible case, soon to be removed. See: https://github.com/IntersectMBO/cardano-ledger/issues/4085" + Allegra.OutputTooBigUTxO xs -> OutputTooBigUTxO (map (0,0,) xs) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs new file mode 100644 index 00000000000..ca07d304280 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs @@ -0,0 +1,376 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Rules.Utxos ( + BabelUTXOS, + BabelUtxosPredFailure (..), + BabelUtxosEvent (..), +) where + +import Cardano.Ledger.Alonzo.Plutus.Context (ContextError, EraPlutusContext) +import Cardano.Ledger.Alonzo.Plutus.Evaluate ( + CollectError (..), + ) +import Cardano.Ledger.Alonzo.Rules ( + AlonzoUtxoEvent (..), + AlonzoUtxoPredFailure (..), + AlonzoUtxosEvent, + AlonzoUtxosPredFailure, + TagMismatchDescription, + validBegin, + validEnd, + ) +import qualified Cardano.Ledger.Alonzo.Rules as Alonzo ( + AlonzoUtxosEvent (..), + AlonzoUtxosPredFailure (..), + ) +import Cardano.Ledger.Alonzo.UTxO ( + AlonzoEraUTxO, + AlonzoScriptsNeeded, + ) +import Cardano.Ledger.Babbage.Rules ( + BabbageUTXO, + BabbageUtxoPredFailure (..), + babbageEvalScriptsTxInvalid, + expectScriptsToPass, + ) +import Cardano.Ledger.Babbage.Tx +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Era (BabelEra, BabelUTXOS) +import Cardano.Ledger.Babel.FRxO (txfrxo) +import Cardano.Ledger.Babel.TxInfo () +import Cardano.Ledger.BaseTypes (ShelleyBase) +import Cardano.Ledger.Binary ( + DecCBOR (..), + EncCBOR (..), + ) +import Cardano.Ledger.Binary.Coders +import Cardano.Ledger.CertState (certsTotalDepositsTxBody, certsTotalRefundsTxBody) +import Cardano.Ledger.Coin (Coin) +import Cardano.Ledger.Conway.Core (ConwayEraPParams, ConwayEraTxBody (treasuryDonationTxBodyL)) +import Cardano.Ledger.Conway.Governance (ConwayGovState (..)) +import Cardano.Ledger.FRxO (FRxO (FRxO, unFRxO)) +import Cardano.Ledger.Plutus ( + PlutusWithContext, + ) +import Cardano.Ledger.SafeHash (SafeHash, hashAnnotated) +import Cardano.Ledger.Shelley.LedgerState ( + CertState, + UTxOState (..), + updateStakeDistribution, + utxosDonationL, + ) +import Cardano.Ledger.Shelley.Rules (UtxoEnv (..)) +import Cardano.Ledger.UTxO (EraUTxO (..), UTxO (UTxO, unUTxO)) +import Cardano.Ledger.Val ((<->)) +import Control.DeepSeq (NFData) +import Control.State.Transition.Extended +import Data.List.NonEmpty (NonEmpty) +import qualified Data.Map as Map +import Data.MapExtras (extractKeys) +import Debug.Trace (traceEvent) +import GHC.Generics (Generic) +import Lens.Micro +import NoThunks.Class (NoThunks) + +data BabelUtxosPredFailure era + = -- | The 'isValid' tag on the transaction is incorrect. The tag given + -- here is that provided on the transaction (whereas evaluation of the + -- scripts gives the opposite.). The Text tries to explain why it failed. + ValidationTagMismatch IsValid TagMismatchDescription + | -- | We could not find all the necessary inputs for a Plutus Script. + -- Previous PredicateFailure tests should make this impossible, but the + -- consequences of not detecting this means scripts get dropped, so things + -- might validate that shouldn't. So we double check in the function + -- collectTwoPhaseScriptInputs, it should find data for every Script. + CollectErrors [CollectError era] + deriving + (Generic) + +data BabelUtxosEvent era + = TotalDeposits (SafeHash (EraCrypto era) EraIndependentTxBody) Coin + | SuccessfulPlutusScriptsEvent (NonEmpty (PlutusWithContext (EraCrypto era))) + | FailedPlutusScriptsEvent (NonEmpty (PlutusWithContext (EraCrypto era))) + | -- | The UTxOs consumed and created by a signal tx + TxUTxODiff + -- | UTxO consumed + (UTxO era) + -- | UTxO created + (UTxO era) + deriving (Generic) + +deriving instance (Era era, Eq (TxOut era)) => Eq (BabelUtxosEvent era) + +instance (Era era, NFData (TxOut era)) => NFData (BabelUtxosEvent era) + +type instance EraRuleFailure "UTXOS" (BabelEra c) = BabelUtxosPredFailure (BabelEra c) + +type instance EraRuleEvent "UTXOS" (BabelEra c) = BabelUtxosEvent (BabelEra c) + +instance InjectRuleFailure "UTXOS" BabelUtxosPredFailure (BabelEra c) + +instance InjectRuleEvent "UTXOS" BabelUtxosEvent (BabelEra c) + +instance InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure (BabelEra c) where + injectFailure = alonzoToBabelUtxosPredFailure + +instance InjectRuleEvent "UTXOS" AlonzoUtxosEvent (BabelEra c) where + injectEvent = alonzoToBabelUtxosEvent + +alonzoToBabelUtxosPredFailure :: + forall era. + EraRuleFailure "PPUP" era ~ VoidEraRule "PPUP" era => + Alonzo.AlonzoUtxosPredFailure era -> + BabelUtxosPredFailure era +alonzoToBabelUtxosPredFailure = \case + Alonzo.ValidationTagMismatch t x -> ValidationTagMismatch t x + Alonzo.CollectErrors x -> CollectErrors x + Alonzo.UpdateFailure x -> absurdEraRule @"PPUP" @era x + +alonzoToBabelUtxosEvent :: + forall era. + EraRuleEvent "PPUP" era ~ VoidEraRule "PPUP" era => + Alonzo.AlonzoUtxosEvent era -> + BabelUtxosEvent era +alonzoToBabelUtxosEvent = \case + Alonzo.AlonzoPpupToUtxosEvent x -> absurdEraRule @"PPUP" @era x + Alonzo.TotalDeposits h c -> TotalDeposits h c + Alonzo.SuccessfulPlutusScriptsEvent l -> SuccessfulPlutusScriptsEvent l + Alonzo.FailedPlutusScriptsEvent l -> FailedPlutusScriptsEvent l + Alonzo.TxUTxODiff x y -> TxUTxODiff x y + +instance + ( EraTxCert era + , BabelEraScript era + , EncCBOR (ContextError era) + ) => + EncCBOR (BabelUtxosPredFailure era) + where + encCBOR = + encode . \case + ValidationTagMismatch v descr -> Sum ValidationTagMismatch 0 !> To v !> To descr + CollectErrors cs -> Sum (CollectErrors @era) 1 !> To cs + +instance + ( EraTxCert era + , BabelEraScript era + , DecCBOR (ContextError era) + ) => + DecCBOR (BabelUtxosPredFailure era) + where + decCBOR = decode (Summands "BabelUtxosPredicateFailure" dec) + where + dec 0 = SumD ValidationTagMismatch + Show (BabelUtxosPredFailure era) + +deriving stock instance + ( BabelEraScript era + , Eq (TxCert era) + , Eq (ContextError era) + , Eq (UTxOState era) + ) => + Eq (BabelUtxosPredFailure era) + +instance + ( BabelEraScript era + , NoThunks (TxCert era) + , NoThunks (ContextError era) + , NoThunks (UTxOState era) + ) => + NoThunks (BabelUtxosPredFailure era) + +instance + ( BabelEraScript era + , NFData (TxCert era) + , NFData (ContextError era) + , NFData (UTxOState era) + ) => + NFData (BabelUtxosPredFailure era) + +instance + ( AlonzoEraTx era + , AlonzoEraUTxO era + , BabelEraTxBody era + , ConwayEraPParams era + , EraGov era + , EraPlutusContext era + , GovState era ~ ConwayGovState era + , ScriptsNeeded era ~ AlonzoScriptsNeeded era + , Signal (BabelUTXOS era) ~ Tx era + , EraRule "UTXOS" era ~ BabelUTXOS era + , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era + , InjectRuleEvent "UTXOS" AlonzoUtxosEvent era + , InjectRuleEvent "UTXOS" BabelUtxosEvent era + ) => + STS (BabelUTXOS era) + where + type BaseM (BabelUTXOS era) = Cardano.Ledger.BaseTypes.ShelleyBase + type Environment (BabelUTXOS era) = UtxoEnv era + type State (BabelUTXOS era) = UTxOState era + type Signal (BabelUTXOS era) = AlonzoTx era + type PredicateFailure (BabelUTXOS era) = BabelUtxosPredFailure era + type Event (BabelUTXOS era) = BabelUtxosEvent era + + transitionRules = [utxosTransition] + +instance + ( AlonzoEraTx era + , AlonzoEraUTxO era + , BabelEraTxBody era + , ConwayEraPParams era + , EraGov era + , EraPlutusContext era + , GovState era ~ ConwayGovState era + , PredicateFailure (EraRule "UTXOS" era) ~ BabelUtxosPredFailure era + , ScriptsNeeded era ~ AlonzoScriptsNeeded era + , Signal (BabelUTXOS era) ~ Tx era + , EraRule "UTXOS" era ~ BabelUTXOS era + , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era + , InjectRuleEvent "UTXOS" AlonzoUtxosEvent era + , InjectRuleEvent "UTXOS" BabelUtxosEvent era + ) => + Embed (BabelUTXOS era) (BabbageUTXO era) + where + wrapFailed = AlonzoInBabbageUtxoPredFailure . UtxosFailure + wrapEvent = UtxosEvent + +utxosTransition :: + forall era. + ( AlonzoEraTx era + , AlonzoEraUTxO era + , BabelEraTxBody era + , EraPlutusContext era + , ScriptsNeeded era ~ AlonzoScriptsNeeded era + , Signal (EraRule "UTXOS" era) ~ Tx era + , STS (EraRule "UTXOS" era) + , Environment (EraRule "UTXOS" era) ~ UtxoEnv era + , State (EraRule "UTXOS" era) ~ UTxOState era + , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era + , BaseM (EraRule "UTXOS" era) ~ ShelleyBase + , InjectRuleEvent "UTXOS" AlonzoUtxosEvent era + , InjectRuleEvent "UTXOS" BabelUtxosEvent era + ) => + TransitionRule (EraRule "UTXOS" era) +utxosTransition = + judgmentContext >>= \(TRC (_, _, tx)) -> do + case tx ^. isValidTxL of + IsValid True -> babelEvalScriptsTxValid + IsValid False -> babbageEvalScriptsTxInvalid + +babelEvalScriptsTxValid :: + forall era. + ( AlonzoEraTx era + , AlonzoEraUTxO era + , BabelEraTxBody era + , EraPlutusContext era + , ScriptsNeeded era ~ AlonzoScriptsNeeded era + , Signal (EraRule "UTXOS" era) ~ Tx era + , STS (EraRule "UTXOS" era) + , State (EraRule "UTXOS" era) ~ UTxOState era + , Environment (EraRule "UTXOS" era) ~ UtxoEnv era + , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era + , BaseM (EraRule "UTXOS" era) ~ ShelleyBase + , InjectRuleEvent "UTXOS" AlonzoUtxosEvent era + , InjectRuleEvent "UTXOS" BabelUtxosEvent era + ) => + TransitionRule (EraRule "UTXOS" era) +babelEvalScriptsTxValid = do + TRC (UtxoEnv _ pp certState, utxos@(UTxOState utxo _frxo _ _ govState _ _), tx) <- + judgmentContext + let txBody = tx ^. bodyTxL + + () <- pure $! traceEvent validBegin () + expectScriptsToPass pp tx utxo + () <- pure $! traceEvent validEnd () + + utxos' <- + updateUTxOState + pp + utxos + txBody + certState + govState + (tellEvent . injectEvent . TotalDeposits (hashAnnotated txBody)) + (\a b -> tellEvent . injectEvent $ TxUTxODiff a b) + pure $! utxos' & utxosDonationL <>~ txBody ^. treasuryDonationTxBodyL + +-- | This monadic action captures the final stages of the UTXO(S) rule. In particular it +-- applies all of the UTxO related aditions and removals, gathers all of the fees into the +-- fee pot `utxosFees` and updates the `utxosDeposited` field. Continuation supplied will +-- be called on the @deposit - refund@ change, which is normally used to emit the +-- `TotalDeposits` event. + +-- TODO WG: This shouldn't be here. Need to figure out how to alter original without changing tons of callsites +updateUTxOState :: + (BabelEraTxBody era, Monad m) => + PParams era -> + UTxOState era -> + TxBody era -> + CertState era -> + GovState era -> + (Coin -> m ()) -> + (UTxO era -> UTxO era -> m ()) -> + m (UTxOState era) +updateUTxOState pp utxos txBody certState govState depositChangeEvent txUtxODiffEvent = do + let UTxOState + { utxosUtxo + , utxosFrxo + , utxosDeposited + , utxosFees + , utxosStakeDistr + , utxosDonation + } = utxos + UTxO utxo = utxosUtxo + !utxoAdd = txouts txBody -- These will be inserted into the UTxO + {- utxoDel = txins txb ◁ utxo -} + !(utxoWithout, utxoDel) = extractKeys utxo (txBody ^. inputsTxBodyL) + {- newUTxO = (txins txb ⋪ utxo) ∪ outs txb -} + newUTxO = utxoWithout `Map.union` unUTxO utxoAdd + FRxO frxo = utxosFrxo + !frxoAdd = txfrxo txBody -- These will be inserted into the FRxO + {- utxoDel = txins txb ◁ utxo -} + !(frxoWithout, _frxoDel) = extractKeys frxo (txBody ^. fulfillsTxBodyL) + {- newUTxO = (txins txb ⋪ utxo) ∪ outs txb -} + newFRxO = frxoWithout `Map.union` unFRxO frxoAdd + deletedUTxO = UTxO utxoDel + newIncStakeDistro = updateStakeDistribution pp utxosStakeDistr deletedUTxO utxoAdd + totalRefunds = certsTotalRefundsTxBody pp certState txBody + totalDeposits = certsTotalDepositsTxBody pp certState txBody + depositChange = totalDeposits <-> totalRefunds + depositChangeEvent depositChange + txUtxODiffEvent deletedUTxO utxoAdd + pure $! + UTxOState + { utxosUtxo = UTxO newUTxO + , utxosFrxo = FRxO newFRxO + , utxosDeposited = utxosDeposited <> depositChange + , utxosFees = utxosFees <> txBody ^. feeTxBodyL + , utxosGovState = govState + , utxosStakeDistr = newIncStakeDistro + , utxosDonation = utxosDonation + } diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs new file mode 100644 index 00000000000..10d6740b8be --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs @@ -0,0 +1,532 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} + +module Cardano.Ledger.Babel.Rules.Utxow ( + alonzoToBabelUtxowPredFailure, + babbageToBabelUtxowPredFailure, + BabelUTXOW, + BabelUtxowPredFailure (..), + babelWitsVKeyNeeded, + shelleyToBabelUtxowPredFailure, +) +where + +import Cardano.Crypto.DSIGN.Class (DSIGNAlgorithm (..), Signable) +import Cardano.Crypto.Hash.Class (Hash) +import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure) +import Cardano.Ledger.Alonzo.Rules ( + AlonzoUtxoEvent, + AlonzoUtxoPredFailure, + AlonzoUtxosPredFailure, + AlonzoUtxowEvent (WrappedShelleyEraEvent), + AlonzoUtxowPredFailure, + hasExactSetOfRedeemers, + missingRequiredDatums, + ppViewHashesMatch, + ) +import qualified Cardano.Ledger.Alonzo.Rules as Alonzo (AlonzoUtxowPredFailure (..)) +import Cardano.Ledger.Alonzo.UTxO (AlonzoEraUTxO, AlonzoScriptsNeeded) +import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash) +import Cardano.Ledger.Babbage.Rules ( + BabbageUtxoPredFailure, + BabbageUtxowPredFailure, + -- babbageUtxowTransition, + + babbageMissingScripts, + validateFailedBabbageScripts, + validateScriptsWellFormed, + ) +import qualified Cardano.Ledger.Babbage.Rules as Babbage ( + BabbageUtxowPredFailure (..), + ) +import Cardano.Ledger.Babbage.UTxO (getReferenceScripts) +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Era (BabelEra, BabelUTXO, BabelUTXOW) +import Cardano.Ledger.Babel.Rules.Utxo (BabelUtxoPredFailure) +import Cardano.Ledger.Babel.Rules.Utxos (BabelUtxosPredFailure) +import Cardano.Ledger.Babel.UTxO (getBabelWitsVKeyNeeded) +import Cardano.Ledger.BaseTypes (ShelleyBase, StrictMaybe) +import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) +import Cardano.Ledger.Binary.Coders ( + Decode (..), + Encode (..), + decode, + encode, + (!>), + ( + UTxO era -> + TxBody era -> + Set (KeyHash 'Witness (EraCrypto era)) +babelWitsVKeyNeeded = getBabelWitsVKeyNeeded +{-# DEPRECATED babelWitsVKeyNeeded "In favor of `getBabelWitsVKeyNeeded` or `getWitsVKeyNeeded`" #-} + +-- ================================ + +-- | Predicate failure type for the Babel Era +data BabelUtxowPredFailure era + = UtxoFailure (PredicateFailure (EraRule "UTXO" era)) + | InvalidWitnessesUTXOW + ![VKey 'Witness (EraCrypto era)] + | -- | witnesses which failed in verifiedWits function + MissingVKeyWitnessesUTXOW + -- | witnesses which were needed and not supplied + !(Set (KeyHash 'Witness (EraCrypto era))) + | -- | missing scripts + MissingScriptWitnessesUTXOW + !(Set (ScriptHash (EraCrypto era))) + | -- | failed scripts + ScriptWitnessNotValidatingUTXOW + !(Set (ScriptHash (EraCrypto era))) + | -- | hash of the full metadata + MissingTxBodyMetadataHash + !(AuxiliaryDataHash (EraCrypto era)) + | -- | hash of the metadata included in the transaction body + MissingTxMetadata + !(AuxiliaryDataHash (EraCrypto era)) + | ConflictingMetadataHash + -- | hash of the metadata included in the transaction body + !(AuxiliaryDataHash (EraCrypto era)) + -- | expected hash of the full metadata + !(AuxiliaryDataHash (EraCrypto era)) + | -- | Contains out of range values (string`s too long) + InvalidMetadata + | -- | extraneous scripts + ExtraneousScriptWitnessesUTXOW + !(Set (ScriptHash (EraCrypto era))) + | MissingRedeemers + ![(PlutusPurpose AsItem era, ScriptHash (EraCrypto era))] + | MissingRequiredDatums + -- | Set of missing data hashes + !(Set (DataHash (EraCrypto era))) + -- | Set of received data hashes + !(Set (DataHash (EraCrypto era))) + | NotAllowedSupplementalDatums + -- | 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))) + | -- | Set of transaction inputs that are TwoPhase scripts, and should have a DataHash but don't + UnspendableUTxONoDatumHash + (Set (TxIn (EraCrypto era))) + | -- | List of redeemers not needed + ExtraRedeemers ![PlutusPurpose AsIx era] + | -- | Embed UTXO rule failures + MalformedScriptWitnesses + !(Set (ScriptHash (EraCrypto era))) + | -- | the set of malformed script witnesses + MalformedReferenceScripts + !(Set (ScriptHash (EraCrypto era))) + deriving (Generic) + +type instance EraRuleFailure "UTXOW" (BabelEra c) = BabelUtxowPredFailure (BabelEra c) + +type instance EraRuleEvent "UTXOW" (BabelEra c) = AlonzoUtxowEvent (BabelEra c) + +instance InjectRuleFailure "UTXOW" BabelUtxowPredFailure (BabelEra c) + +instance InjectRuleFailure "UTXOW" BabbageUtxowPredFailure (BabelEra c) where + injectFailure = babbageToBabelUtxowPredFailure + +instance InjectRuleFailure "UTXOW" AlonzoUtxowPredFailure (BabelEra c) where + injectFailure = alonzoToBabelUtxowPredFailure + +instance InjectRuleFailure "UTXOW" ShelleyUtxowPredFailure (BabelEra c) where + injectFailure = shelleyToBabelUtxowPredFailure + +instance InjectRuleFailure "UTXOW" BabelUtxoPredFailure (BabelEra c) where + injectFailure = UtxoFailure . injectFailure + +instance InjectRuleFailure "UTXOW" BabbageUtxoPredFailure (BabelEra c) where + injectFailure = UtxoFailure . injectFailure + +instance InjectRuleFailure "UTXOW" AlonzoUtxoPredFailure (BabelEra c) where + injectFailure = UtxoFailure . injectFailure + +instance InjectRuleFailure "UTXOW" AlonzoUtxosPredFailure (BabelEra c) where + injectFailure = UtxoFailure . injectFailure + +instance InjectRuleFailure "UTXOW" BabelUtxosPredFailure (BabelEra c) where + injectFailure = UtxoFailure . injectFailure + +instance InjectRuleFailure "UTXOW" ShelleyUtxoPredFailure (BabelEra c) where + injectFailure = UtxoFailure . injectFailure + +instance InjectRuleFailure "UTXOW" AllegraUtxoPredFailure (BabelEra c) where + injectFailure = UtxoFailure . injectFailure + +deriving instance + ( BabelEraScript era + , Show (PredicateFailure (EraRule "UTXO" era)) + ) => + Show (BabelUtxowPredFailure era) + +deriving instance + ( BabelEraScript era + , Eq (PredicateFailure (EraRule "UTXO" era)) + ) => + Eq (BabelUtxowPredFailure era) + +deriving via + InspectHeapNamed "BabelUtxowPred" (BabelUtxowPredFailure era) + instance + NoThunks (BabelUtxowPredFailure era) + +instance + ( BabelEraScript era + , NFData (TxCert era) + , NFData (PredicateFailure (EraRule "UTXO" era)) + , NFData (VerKeyDSIGN (DSIGN (EraCrypto era))) + ) => + NFData (BabelUtxowPredFailure era) + +-------------------------------------------------------------------------------- +-- BabelUTXOW STS +-------------------------------------------------------------------------------- + +instance + forall era. + ( AlonzoEraTx era + , AlonzoEraUTxO era + , ScriptsNeeded era ~ AlonzoScriptsNeeded era + , BabelEraTxBody era + , Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentTxBody) + , Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentRequiredTxs) + , EraRule "UTXOW" era ~ BabelUTXOW era + , InjectRuleFailure "UTXOW" ShelleyUtxowPredFailure era + , InjectRuleFailure "UTXOW" AlonzoUtxowPredFailure era + , InjectRuleFailure "UTXOW" BabbageUtxowPredFailure era + , -- Allow UTXOW to call UTXO + Embed (EraRule "UTXO" era) (BabelUTXOW era) + , Environment (EraRule "UTXO" era) ~ Shelley.UtxoEnv era + , State (EraRule "UTXO" era) ~ Shelley.UTxOState era + , Signal (EraRule "UTXO" era) ~ Tx era + , Eq (PredicateFailure (EraRule "UTXOS" era)) + , Show (PredicateFailure (EraRule "UTXOS" era)) + ) => + STS (BabelUTXOW era) + where + type State (BabelUTXOW era) = Shelley.UTxOState era + type Signal (BabelUTXOW era) = Tx era + type Environment (BabelUTXOW era) = Shelley.UtxoEnv era + type BaseM (BabelUTXOW era) = ShelleyBase + type PredicateFailure (BabelUTXOW era) = BabelUtxowPredFailure era + type Event (BabelUTXOW era) = AlonzoUtxowEvent era + transitionRules = [babelUtxowTransition @era] + initialRules = [] + +instance + ( Era era + , STS (BabelUTXO era) + , PredicateFailure (EraRule "UTXO" era) ~ BabelUtxoPredFailure era + , Event (EraRule "UTXO" era) ~ AlonzoUtxoEvent era + , BaseM (BabelUTXOW era) ~ ShelleyBase + , PredicateFailure (BabelUTXOW era) ~ BabelUtxowPredFailure era + , Event (BabelUTXOW era) ~ AlonzoUtxowEvent era + ) => + Embed (BabelUTXO era) (BabelUTXOW era) + where + wrapFailed = UtxoFailure + wrapEvent = WrappedShelleyEraEvent . UtxoEvent + +-------------------------------------------------------------------------------- +-- Serialisation +-------------------------------------------------------------------------------- + +instance + ( BabelEraScript era + , EncCBOR (PredicateFailure (EraRule "UTXO" era)) + ) => + EncCBOR (BabelUtxowPredFailure era) + where + encCBOR = + encode . \case + UtxoFailure x -> Sum UtxoFailure 0 !> To x + InvalidWitnessesUTXOW xs -> Sum InvalidWitnessesUTXOW 1 !> To xs + MissingVKeyWitnessesUTXOW xs -> Sum MissingVKeyWitnessesUTXOW 2 !> To xs + MissingScriptWitnessesUTXOW xs -> Sum MissingScriptWitnessesUTXOW 3 !> To xs + ScriptWitnessNotValidatingUTXOW xs -> Sum ScriptWitnessNotValidatingUTXOW 4 !> To xs + MissingTxBodyMetadataHash xs -> Sum MissingTxBodyMetadataHash 5 !> To xs + MissingTxMetadata xs -> Sum MissingTxMetadata 6 !> To xs + ConflictingMetadataHash a b -> Sum ConflictingMetadataHash 7 !> To a !> To b + InvalidMetadata -> Sum InvalidMetadata 8 + ExtraneousScriptWitnessesUTXOW xs -> Sum ExtraneousScriptWitnessesUTXOW 9 !> To xs + MissingRedeemers x -> Sum MissingRedeemers 10 !> To x + MissingRequiredDatums x y -> Sum MissingRequiredDatums 11 !> To x !> To y + NotAllowedSupplementalDatums x y -> Sum NotAllowedSupplementalDatums 12 !> To x !> To y + PPViewHashesDontMatch x y -> Sum PPViewHashesDontMatch 13 !> To x !> To y + UnspendableUTxONoDatumHash x -> Sum UnspendableUTxONoDatumHash 14 !> To x + ExtraRedeemers x -> Sum ExtraRedeemers 15 !> To x + MalformedScriptWitnesses x -> Sum MalformedScriptWitnesses 16 !> To x + MalformedReferenceScripts x -> Sum MalformedReferenceScripts 17 !> To x + +instance + ( BabelEraScript era + , DecCBOR (PredicateFailure (EraRule "UTXO" era)) + ) => + DecCBOR (BabelUtxowPredFailure era) + where + decCBOR = decode . Summands "BabelUtxowPred" $ \case + 0 -> SumD UtxoFailure SumD InvalidWitnessesUTXOW SumD MissingVKeyWitnessesUTXOW SumD MissingScriptWitnessesUTXOW SumD ScriptWitnessNotValidatingUTXOW SumD MissingTxBodyMetadataHash SumD MissingTxMetadata SumD ConflictingMetadataHash SumD InvalidMetadata + 9 -> SumD ExtraneousScriptWitnessesUTXOW SumD MissingRedeemers SumD MissingRequiredDatums SumD NotAllowedSupplementalDatums SumD PPViewHashesDontMatch SumD UnspendableUTxONoDatumHash SumD ExtraRedeemers SumD MalformedScriptWitnesses SumD MalformedReferenceScripts Invalid n + +-- ===================================================== +-- Injecting from one PredicateFailure to another + +babbageToBabelUtxowPredFailure :: + forall era. + BabbageUtxowPredFailure era -> + BabelUtxowPredFailure era +babbageToBabelUtxowPredFailure = \case + Babbage.AlonzoInBabbageUtxowPredFailure x -> alonzoToBabelUtxowPredFailure x + Babbage.UtxoFailure x -> UtxoFailure x + Babbage.MalformedScriptWitnesses xs -> MalformedScriptWitnesses xs + Babbage.MalformedReferenceScripts xs -> MalformedReferenceScripts xs + +alonzoToBabelUtxowPredFailure :: + forall era. + AlonzoUtxowPredFailure era -> + BabelUtxowPredFailure era +alonzoToBabelUtxowPredFailure = \case + Alonzo.ShelleyInAlonzoUtxowPredFailure f -> shelleyToBabelUtxowPredFailure f + Alonzo.MissingRedeemers rs -> MissingRedeemers rs + Alonzo.MissingRequiredDatums mds rds -> MissingRequiredDatums mds rds + Alonzo.NotAllowedSupplementalDatums uds ads -> NotAllowedSupplementalDatums uds ads + Alonzo.PPViewHashesDontMatch a b -> PPViewHashesDontMatch a b + Alonzo.MissingRequiredSigners _xs -> + error "Impossible case. It will be removed once we are in Babel. See #3972" + Alonzo.UnspendableUTxONoDatumHash ins -> UnspendableUTxONoDatumHash ins + Alonzo.ExtraRedeemers xs -> ExtraRedeemers xs + +shelleyToBabelUtxowPredFailure :: ShelleyUtxowPredFailure era -> BabelUtxowPredFailure era +shelleyToBabelUtxowPredFailure = \case + Shelley.InvalidWitnessesUTXOW xs -> InvalidWitnessesUTXOW xs + Shelley.MissingVKeyWitnessesUTXOW xs -> MissingVKeyWitnessesUTXOW xs + Shelley.MissingScriptWitnessesUTXOW xs -> MissingScriptWitnessesUTXOW xs + Shelley.ScriptWitnessNotValidatingUTXOW xs -> ScriptWitnessNotValidatingUTXOW xs + Shelley.UtxoFailure x -> UtxoFailure x + Shelley.MIRInsufficientGenesisSigsUTXOW _xs -> + error "Impossible: MIR has been removed in Babel" + Shelley.MissingTxBodyMetadataHash x -> MissingTxBodyMetadataHash x + Shelley.MissingTxMetadata x -> MissingTxMetadata x + Shelley.ConflictingMetadataHash a b -> ConflictingMetadataHash a b + Shelley.InvalidMetadata -> InvalidMetadata + Shelley.ExtraneousScriptWitnessesUTXOW xs -> ExtraneousScriptWitnessesUTXOW xs + +------------ + +-- | UTXOW transition rule that is used in Babbage and Babel era. +babelUtxowTransition :: + forall era. + ( AlonzoEraTx era + , AlonzoEraUTxO era + , ScriptsNeeded era ~ AlonzoScriptsNeeded era + , BabbageEraTxBody era + , Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentTxBody) + , -- , Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentRequiredTxs) + Environment (EraRule "UTXOW" era) ~ Shelley.UtxoEnv era + , Signal (EraRule "UTXOW" era) ~ Tx era + , State (EraRule "UTXOW" era) ~ Shelley.UTxOState era + , InjectRuleFailure "UTXOW" ShelleyUtxowPredFailure era + , InjectRuleFailure "UTXOW" AlonzoUtxowPredFailure era + , InjectRuleFailure "UTXOW" BabbageUtxowPredFailure era + , -- Allow UTXOW to call UTXO + Embed (EraRule "UTXO" era) (EraRule "UTXOW" era) + , Environment (EraRule "UTXO" era) ~ Shelley.UtxoEnv era + , Signal (EraRule "UTXO" era) ~ Tx era + , State (EraRule "UTXO" era) ~ Shelley.UTxOState era + ) => + TransitionRule (EraRule "UTXOW" era) +babelUtxowTransition = do + TRC (utxoEnv@(UtxoEnv _ pp certState), u, tx) <- judgmentContext + + {- (utxo,_,_,_ ) := utxoSt -} + {- txb := txbody tx -} + {- txw := txwits tx -} + {- witsKeyHashes := { hashKey vk | vk ∈ dom(txwitsVKey txw) } -} + let utxo = utxosUtxo u + txBody = tx ^. bodyTxL + witsKeyHashes = witsFromTxWitnesses tx + inputs = (txBody ^. referenceInputsTxBodyL) `Set.union` (txBody ^. inputsTxBodyL) + + -- check scripts + {- neededHashes := {h | ( , h) ∈ scriptsNeeded utxo txb} -} + {- neededHashes − dom(refScripts tx utxo) = dom(txwitscripts txw) -} + let scriptsNeeded = getScriptsNeeded utxo txBody + scriptsProvided = getScriptsProvided utxo tx + scriptHashesNeeded = getScriptsHashesNeeded scriptsNeeded + {- ∀s ∈ (txscripts txw utxo neededHashes ) ∩ Scriptph1 , validateScript s tx -} + -- CHANGED In BABBAGE txscripts depends on UTxO + runTest $ validateFailedBabbageScripts tx scriptsProvided scriptHashesNeeded + + {- neededHashes − dom(refScripts tx utxo) = dom(txwitscripts txw) -} + let sReceived = Map.keysSet $ tx ^. witsTxL . scriptTxWitsL + sRefs = Map.keysSet $ getReferenceScripts utxo inputs + runTest $ babbageMissingScripts pp scriptHashesNeeded sRefs sReceived + + {- inputHashes ⊆ dom(txdats txw) ⊆ allowed -} + runTest $ missingRequiredDatums utxo tx + + {- dom (txrdmrs tx) = { rdptr txb sp | (sp, h) ∈ scriptsNeeded utxo tx, + h ↦ s ∈ txscripts txw, s ∈ Scriptph2} -} + runTest $ hasExactSetOfRedeemers tx scriptsProvided scriptsNeeded + + -- TODO WG: This probably isn't exactly right, but it's close enough for now + -- ∀[ (vk , σ) ∈ vkSigs ] isSigned vk (txidBytes (tx .Tx.body .TxBody.txid) + sumReqs (tx .requiredTxs)) σ + -- check VKey witnesses + -- let txbodyHash = hashAnnotated @(Crypto era) txbody + {- ∀ (vk ↦ σ) ∈ (txwitsVKey txw), V_vk⟦ txbodyHash ⟧_σ -} + runTestOnSignal $ validateVerifiedWits tx + + {- witsVKeyNeeded utxo tx genDelegs ⊆ witsKeyHashes -} + runTest $ validateNeededWitnesses witsKeyHashes certState utxo txBody + + -- check metadata hash + {- adh := txADhash txb; ad := auxiliaryData tx -} + {- ((adh = ◇) ∧ (ad= ◇)) ∨ (adh = hashAD ad) -} + runTestOnSignal $ Shelley.validateMetadata pp tx + + {- ∀x ∈ range(txdats txw) ∪ range(txwitscripts txw) ∪ (⋃ ( , ,d,s) ∈ txouts tx {s, d}), + x ∈ Script ∪ Datum ⇒ isWellFormed x + -} + runTest $ validateScriptsWellFormed pp tx + -- Note that Datum validation is done during deserialization, + -- as given by the decoders in the Plutus libraray + + {- languages tx utxo ⊆ dom(costmdls pp) -} + -- This check is checked when building the TxInfo using collectTwoPhaseScriptInputs, if it fails + -- It raises 'NoCostModel' a construcotr of the predicate failure 'CollectError'. + + {- scriptIntegrityHash txb = hashScriptIntegrity pp (languages txw) (txrdmrs txw) -} + runTest $ ppViewHashesMatch tx pp scriptsProvided scriptHashesNeeded + + trans @(EraRule "UTXO" era) $ TRC (utxoEnv, u, tx) + +-- | Determine if the UTxO witnesses in a given transaction are correct. +validateVerifiedWits :: + forall era. + ( EraTx era + , Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentTxBody) + -- , Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentRequiredTxs) + ) => + Tx era -> + Test (ShelleyUtxowPredFailure era) +validateVerifiedWits tx = + case failed of + [] -> pure () + nonEmpty -> failure $ Shelley.InvalidWitnessesUTXOW nonEmpty + where + txBody = tx ^. bodyTxL + -- txRequiredTxs = tx ^. requiredTxsTxL + failed = + failed' witVKeyVerifier + <> failedBootstrap bootstrapWitVerifier + (witVKeyVerifier, bootstrapWitVerifier) = + -- case txRequiredTxs == mempty of + -- True -> + let txBodyHash = extractHash (hashAnnotated txBody) + in (verifyWitVKey txBodyHash, verifyBootstrapWit txBodyHash) + -- False -> + -- let _a = extractHash (hashAnnotated txBody) + -- _b = extractHash (hashAnnotated txRequiredTxs) + -- in undefined + -- let compositeHash = extractHash (hashAnnotated (txBody, txs)) + -- in (verifyWitVKeyRequiredTxs compositeHash, verifyBootstrapWitRequiredTxs compositeHash) + wvkKey (WitVKey k _) = k + + failed' witnessVerification = + wvkKey + <$> filter + (not . witnessVerification) + (Set.toList $ tx ^. witsTxL . addrTxWitsL) + failedBootstrap witnessVerification = + bwKey + <$> filter + (not . witnessVerification) + (Set.toList $ tx ^. witsTxL . bootAddrTxWitsL) \ No newline at end of file diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs new file mode 100644 index 00000000000..efa5d77bdb7 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs @@ -0,0 +1,491 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Rules.Zone where + +import Cardano.Ledger.Alonzo.Core (AlonzoEraTx) +import Cardano.Ledger.Alonzo.Tx (IsValid (IsValid), totExUnits) +import Cardano.Ledger.Babel.Core ( + BabelEraTxBody (fulfillsTxBodyL), + Era (EraCrypto), + EraRule, + EraTx (Tx, bodyTxL), + EraTxBody (TxBody, inputsTxBodyL), + InjectRuleFailure (..), + collateralInputsTxBodyL, + isValidTxL, + requiredTxsTxBodyL, + ) +import Cardano.Ledger.Babel.Era (BabelEra, BabelZONE) +import Cardano.Ledger.BaseTypes ( + ShelleyBase, + epochInfo, + systemStart, + ) +import Cardano.Ledger.Conway.PParams ( + ConwayEraPParams, + ) +import Cardano.Ledger.Core ( + EraRuleEvent, + EraRuleFailure, + txIdTx, + ) +import Cardano.Ledger.Shelley.API ( + LedgerState (LedgerState), + TxIn (TxIn), + UTxO (..), + UTxOState (..), + ) +import Cardano.Ledger.TxIn (TxId) +import Control.State.Transition.Extended ( + Embed (..), + STS (..), + TRC (..), + TransitionRule, + failBecause, + judgmentContext, + liftSTS, + tellEvent, + trans, + whenFailureFree, + ) +import qualified Data.Foldable as Foldable +import Data.Sequence (Seq) +import Data.Set (Set, toList) +import qualified Data.Set as Set +import GHC.Generics (Generic) +import Lens.Micro ((^.)) +import Lens.Micro.Type (Lens') + +import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext) +import Cardano.Ledger.Alonzo.Plutus.Evaluate (collectPlutusScriptsWithContext, evalPlutusScripts) +import Cardano.Ledger.Alonzo.Rules ( + AlonzoUtxosPredFailure (ValidationTagMismatch), + TagMismatchDescription (PassedUnexpectedly), + invalidBegin, + invalidEnd, + when2Phase, + ) +import Cardano.Ledger.Alonzo.UTxO (AlonzoEraUTxO, AlonzoScriptsNeeded) +import Cardano.Ledger.Babbage.Collateral (collAdaBalance, collOuts) +import Cardano.Ledger.Babel.Core (ppMaxTxExUnitsL) +import Cardano.Ledger.Babel.Rules.Ledger (BabelLedgerPredFailure) +import Cardano.Ledger.Babel.Rules.Ledgers (BabelLEDGERS, BabelLedgersEnv (BabelLedgersEnv)) +import Cardano.Ledger.Babel.Rules.Utxo (BabelUtxoPredFailure (..)) +import Cardano.Ledger.Babel.Rules.Utxos (BabelUtxosPredFailure (CollectErrors)) +import Cardano.Ledger.Babel.Rules.Utxow (BabelUtxowPredFailure) +import Cardano.Ledger.Coin (Coin (..), DeltaCoin (DeltaCoin)) +import Cardano.Ledger.Core (PParams, ppMaxTxSizeL, sizeTxF) +import Cardano.Ledger.Plutus ( + PlutusWithContext, + ScriptFailure (scriptFailurePlutus), + ScriptResult (..), + ) +import Cardano.Ledger.Plutus.ExUnits (pointWiseExUnits) +import Cardano.Ledger.Rules.ValidationMode (Test, runTestOnSignal) +import Cardano.Ledger.Shelley.LedgerState (updateStakeDistribution) +import Cardano.Ledger.Shelley.Rules ( + ShelleyLedgersEvent, + ShelleyLedgersPredFailure (..), + ) +import Cardano.Ledger.UTxO (EraUTxO (ScriptsNeeded)) +import Control.Monad.RWS (asks) +import Data.List.NonEmpty (NonEmpty, nonEmpty) +import qualified Data.Map as Map +import Data.MapExtras (extractKeys) +import Debug.Trace (traceEvent) +import NoThunks.Class (NoThunks) +import Validation (failureUnless) + +data BabelZonePredFailure era + = LedgersFailure (PredicateFailure (BabelLEDGERS era)) -- Subtransition Failures + | -- | ShelleyInBabelPredFailure (ShelleyLedgersPredFailure era) -- Subtransition Failures + ShelleyInBabelPredFailure (ShelleyLedgersPredFailure era) -- Subtransition Failures + deriving (Generic) + +data BabelZoneEvent era + = ShelleyInBabelEvent (ShelleyLedgersEvent era) + | ZoneFailedPlutusScriptsEvent (NonEmpty (PlutusWithContext (EraCrypto era))) + | ZoneSuccessfulPlutusScriptsEvent (NonEmpty (PlutusWithContext (EraCrypto era))) + +type instance EraRuleFailure "ZONE" (BabelEra c) = BabelZonePredFailure (BabelEra c) + +instance InjectRuleFailure "ZONE" BabelZonePredFailure (BabelEra c) + +type instance EraRuleEvent "ZONE" (BabelEra c) = BabelZoneEvent (BabelEra c) + +instance InjectRuleFailure "ZONE" ShelleyLedgersPredFailure (BabelEra c) where + injectFailure = LedgersFailure + +instance InjectRuleFailure "ZONE" BabelLedgerPredFailure (BabelEra c) where + injectFailure :: BabelLedgerPredFailure (BabelEra c) -> BabelZonePredFailure (BabelEra c) + injectFailure = LedgersFailure . injectFailure + +instance InjectRuleFailure "ZONE" BabelUtxowPredFailure (BabelEra c) where + injectFailure = LedgersFailure . injectFailure + +instance InjectRuleFailure "ZONE" BabelUtxoPredFailure (BabelEra c) where + injectFailure = LedgersFailure . injectFailure + +instance InjectRuleFailure "ZONE" BabelUtxosPredFailure (BabelEra c) where + injectFailure = LedgersFailure . injectFailure + +deriving instance + ( Era era + , Show (PredicateFailure (EraRule "LEDGER" era)) + , Show (PredicateFailure (EraRule "LEDGERS" era)) + ) => + Show (BabelZonePredFailure era) + +deriving instance + ( Era era + , Eq (PredicateFailure (EraRule "LEDGER" era)) + , Eq (PredicateFailure (EraRule "LEDGERS" era)) + ) => + Eq (BabelZonePredFailure era) + +deriving anyclass instance + ( Era era + , NoThunks (PredicateFailure (EraRule "LEDGER" era)) + , NoThunks (PredicateFailure (EraRule "LEDGERS" era)) + ) => + NoThunks (BabelZonePredFailure era) + +instance + ( EraRule "ZONE" era ~ BabelZONE era + , Eq (PredicateFailure (EraRule "LEDGER" era)) + , Show (PredicateFailure (EraRule "LEDGER" era)) + , ConwayEraPParams era + , Environment (EraRule "LEDGERS" era) ~ BabelLedgersEnv era + , State (EraRule "LEDGERS" era) ~ LedgerState era + , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) + , Embed (EraRule "LEDGERS" era) (BabelZONE era) + , EraTx era + , BabelEraTxBody era + , AlonzoEraTx era + , AlonzoEraUTxO era + , EraPlutusContext era + , InjectRuleFailure "ZONE" AlonzoUtxosPredFailure era + , ScriptsNeeded era ~ AlonzoScriptsNeeded era + , InjectRuleFailure "ZONE" BabelUtxosPredFailure era + , PredicateFailure (EraRule "ZONE" era) ~ BabelZonePredFailure era + , InjectRuleFailure "ZONE" BabelUtxoPredFailure era + ) => + STS (BabelZONE era) + where + type Environment (BabelZONE era) = BabelLedgersEnv era + type PredicateFailure (BabelZONE era) = BabelZonePredFailure era + type Signal (BabelZONE era) = Seq (Tx era) + type State (BabelZONE era) = LedgerState era + type BaseM (BabelZONE era) = ShelleyBase + type Event (BabelZONE era) = BabelZoneEvent era + + initialRules = [] + transitionRules = [zoneTransition] + +{- txsize tx ≤ maxTxSize pp -} +-- We've moved this to the ZONE rule. See https://github.com/IntersectMBO/formal-ledger-specifications/commit/c3e18ac1d3da92dd4894bbc32057a143f9720f52#diff-5f67369ed62c0dab01e13a73f072b664ada237d094bbea4582365264dd163bf9 +-- ((totSizeZone ltx) ≤ᵇ (Γ .LEnv.pparams .PParams.maxTxSize)) ≡ true +-- runTestOnSignal $ Shelley.validateMaxTxSizeUTxO pp tx + +zoneTransition :: + forall era. + ( EraRule "ZONE" era ~ BabelZONE era + , Environment (EraRule "LEDGERS" era) ~ BabelLedgersEnv era + , State (EraRule "LEDGERS" era) ~ LedgerState era + , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) + , Embed (EraRule "LEDGERS" era) (BabelZONE era) + , BabelEraTxBody era + , AlonzoEraTx era + , AlonzoEraUTxO era + , Eq (PredicateFailure (EraRule "LEDGER" era)) + , Show (PredicateFailure (EraRule "LEDGER" era)) + , EraPlutusContext era + , InjectRuleFailure "ZONE" AlonzoUtxosPredFailure era + , ScriptsNeeded era ~ AlonzoScriptsNeeded era + , InjectRuleFailure "ZONE" BabelUtxosPredFailure era + , PredicateFailure (EraRule "ZONE" era) ~ BabelZonePredFailure era + , InjectRuleFailure "ZONE" BabelUtxoPredFailure era + ) => + TransitionRule (BabelZONE era) +zoneTransition = + judgmentContext + -- I guess we want UTxOStateTemp here? + >>= \( TRC + ( BabelLedgersEnv slotNo ixRange pParams accountState + , LedgerState utxoState certState + , txs :: Seq (Tx era) + ) + ) -> do + {- ((totSizeZone ltx) ≤ᵇ (Γ .LEnv.pparams .PParams.maxTxSize)) ≡ true -} + runTestOnSignal $ validateMaxTxSizeUTxO pParams (Foldable.toList txs) + if all chkIsValid txs -- ZONE-V + then do + -- TODO WG: make sure `runTestOnSignal` is correct rather than `runTest` + {- All (chkRqTx ltx) (fromList ltx) -} + runTestOnSignal $ failureUnless (all (chkRqTx txs) txs) CheckRqTxFailure + {- noCycles ltx -} + runTestOnSignal $ failureUnless (chkLinear (Foldable.toList txs)) CheckLinearFailure + {- totExunits tx ≤ maxTxExUnits pp -} + runTestOnSignal $ validateExUnitsTooBigUTxO pParams (Foldable.toList txs) + trans @(EraRule "LEDGERS" era) $ + TRC (BabelLedgersEnv slotNo ixRange pParams accountState, LedgerState utxoState certState, txs) + else -- ZONE-N + do + -- Check that only the last transaction is invalid + runTestOnSignal $ + failureUnless (chkExactlyLastInvalid (Foldable.toList txs)) MoreThanOneInvalidTransaction + babelEvalScriptsTxInvalid @era + where + chkLinear :: [Tx era] -> Bool + chkLinear txs = + topSortTxs + (mkAllEdges txs txs) + (mkAllEdges txs txs) + (nodesWithNoIncomingEdge txs (mkAllEdges txs txs)) + [] + == Just [] + -- chkRqTx txs tx = ∀[ txrid ∈ tx .Tx.body .TxBody.requiredTxs ] Any (txrid ≡_) ( getIDs txs ) + chkRqTx :: Seq (Tx era) -> Tx era -> Bool + chkRqTx txs tx = all chk txrids + where + chk txrid = txrid `elem` ids + -- asd = tx ^. requiredTxsTxL + txrids = fmap txInTxId $ toList $ tx ^. bodyTxL . requiredTxsTxBodyL + ids :: Set (TxId (EraCrypto era)) + ids = getIDs $ Foldable.toList txs + -- chkIsValid tx = tx .Tx.isValid ≡ true + chkIsValid :: Tx era -> Bool + chkIsValid tx = tx ^. isValidTxL == IsValid True + sizeTx :: Tx era -> Integer + sizeTx t = t ^. sizeTxF + totSizeZone :: [Tx era] -> Integer + totSizeZone z = sum (map sizeTx z) + validateMaxTxSizeUTxO :: + PParams era -> + [Tx era] -> + Test (BabelUtxoPredFailure era) + validateMaxTxSizeUTxO pp z = + failureUnless (zoneSize <= maxTxSize) $ MaxTxSizeUTxO zoneSize maxTxSize + where + maxTxSize = toInteger (pp ^. ppMaxTxSizeL) + zoneSize = totSizeZone z + validateExUnitsTooBigUTxO :: + PParams era -> + [Tx era] -> + Test (BabelUtxoPredFailure era) + validateExUnitsTooBigUTxO pp txs = + failureUnless (pointWiseExUnits (<=) totalExUnits maxTxExUnits) $ + ExUnitsTooBigUTxO maxTxExUnits totalExUnits + where + maxTxExUnits = pp ^. ppMaxTxExUnitsL + -- This sums up the ExUnits for all embedded Plutus Scripts anywhere in the zone: + totalExUnits = Foldable.foldl' (<>) mempty $ fmap totExUnits txs + -- TODO WG: This can probably be rolled in with the main check in the if expression + chkExactlyLastInvalid :: [Tx era] -> Bool + chkExactlyLastInvalid txs = case reverse txs of + (l : txs') -> (l ^. isValidTxL == IsValid False) && all ((== IsValid True) . (^. isValidTxL)) txs' + [] -> True + +-- data BabelUtxosEvent era +-- = TotalDeposits (SafeHash (EraCrypto era) EraIndependentTxBody) Coin +-- | SuccessfulPlutusScriptsEvent (NonEmpty (PlutusWithContext (EraCrypto era))) +-- | FailedPlutusScriptsEvent (NonEmpty (PlutusWithContext (EraCrypto era))) +-- | -- | The UTxOs consumed and created by a signal tx +-- TxUTxODiff +-- -- | UTxO consumed +-- (UTxO era) +-- -- | UTxO created +-- (UTxO era) +-- deriving (Generic) + +babelEvalScriptsTxInvalid :: + forall era. + ( EraRule "ZONE" era ~ BabelZONE era + , BabelEraTxBody era + , AlonzoEraTx era + , Environment (EraRule "LEDGERS" era) ~ BabelLedgersEnv era + , State (EraRule "LEDGERS" era) ~ LedgerState era + , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) + , Embed (EraRule "LEDGERS" era) (BabelZONE era) + , Eq (PredicateFailure (EraRule "LEDGER" era)) + , Show (PredicateFailure (EraRule "LEDGER" era)) + , ScriptsNeeded era ~ AlonzoScriptsNeeded era + , AlonzoEraUTxO era + , EraPlutusContext era + , EraRuleFailure "ZONE" era ~ BabelZonePredFailure era + , InjectRuleFailure "ZONE" AlonzoUtxosPredFailure era + , InjectRuleFailure "ZONE" BabelUtxosPredFailure era + , InjectRuleFailure "ZONE" BabelUtxoPredFailure era + ) => + TransitionRule (BabelZONE era) +babelEvalScriptsTxInvalid = + do + TRC + ( BabelLedgersEnv _slotNo _ixRange pp _accountState + , LedgerState us@(UTxOState utxo _ _ fees _ _ _) certState + , txs :: Seq (Tx era) + ) <- + judgmentContext + -- TODO WG: Is the list last first or last...last (Probably last last) + let tx = last (Foldable.toList txs) -- TODO WG use safe head + txBody = tx ^. bodyTxL + + -- TRC (UtxoEnv _ pp _, us@(UTxOState utxo _ _ fees _ _ _), tx) <- judgmentContext + -- {- txb := txbody tx -} + sysSt <- liftSTS $ asks systemStart + ei <- liftSTS $ asks epochInfo + + () <- pure $! traceEvent invalidBegin () + + {- TODO WG: + I think you actually need a different function that collects Plutus scripts from + ALL transactions, but just using the collateral for the last one? Or evals scripts from ALL txs? Or something like that? + Basically, yes, the last TX is the one that failed, but we need to collect collat for all the other ones, too. -} + case collectPlutusScriptsWithContext ei sysSt pp tx utxo of + Right sLst -> + {- sLst := collectTwoPhaseScriptInputs pp tx utxo -} + {- isValid tx = evalScripts tx sLst = False -} + whenFailureFree $ + when2Phase $ case evalPlutusScripts tx sLst of + Passes _ -> + failBecause $ + injectFailure @"ZONE" $ + ValidationTagMismatch (tx ^. isValidTxL) PassedUnexpectedly + Fails ps fs -> do + mapM_ (tellEvent . ZoneSuccessfulPlutusScriptsEvent @era) (nonEmpty ps) + tellEvent (ZoneFailedPlutusScriptsEvent @era (scriptFailurePlutus <$> fs)) + Left info -> failBecause (injectFailure $ CollectErrors info) + () <- pure $! traceEvent invalidEnd () + + {- utxoKeep = txBody ^. collateralInputsTxBodyL ⋪ utxo -} + {- utxoDel = txBody ^. collateralInputsTxBodyL ◁ utxo -} + let !(utxoKeep, utxoDel) = extractKeys (unUTxO utxo) (txBody ^. collateralInputsTxBodyL) + UTxO collouts = collOuts txBody + DeltaCoin collateralFees = collAdaBalance txBody utxoDel -- NEW to Babbage + pure $! + LedgerState + us {- (collInputs txb ⋪ utxo) ∪ collouts tx -} + { utxosUtxo = UTxO (Map.union utxoKeep collouts) -- NEW to Babbage + {- fees + collateralFees -} + , utxosFees = fees <> Coin collateralFees -- NEW to Babbage + , utxosStakeDistr = updateStakeDistribution pp (utxosStakeDistr us) (UTxO utxoDel) (UTxO collouts) + } + certState + +txInTxId :: TxIn era -> TxId era +txInTxId (TxIn x _) = x + +-- get a set of TxIds containing all IDs of transaction in given list tb +getIDs :: EraTx era => [Tx era] -> Set (TxId (EraCrypto era)) +getIDs = foldr (\tx ls -> ls `Set.union` Set.singleton (txIdTx tx)) mempty + +mkEdges :: + EraTx era => + Lens' (TxBody era) (Set (TxIn (EraCrypto era))) -> + Tx era -> + [Tx era] -> + [(Tx era, Tx era)] +mkEdges l = go + where + go _ [] = [] + go tx (h : txs) = + if txIdTx tx `elem` fmap (\(TxIn x _) -> x) (toList $ h ^. bodyTxL . l) + then (tx, h) : go tx txs + else go tx txs + +-- make edges for a given transaction +mkIOEdges :: EraTx era => Tx era -> [Tx era] -> [(Tx era, Tx era)] +mkIOEdges = mkEdges inputsTxBodyL + +-- make FR edges for a given transaction +mkFREdges :: (EraTx era, BabelEraTxBody era) => Tx era -> [Tx era] -> [(Tx era, Tx era)] +mkFREdges = mkEdges fulfillsTxBodyL + +-- make all edges for all transactions +mkAllEdges :: (EraTx era, BabelEraTxBody era) => [Tx era] -> [Tx era] -> [(Tx era, Tx era)] +mkAllEdges [] _ = [] +mkAllEdges (h : txs) ls = mkIOEdges h ls ++ mkFREdges h ls ++ mkAllEdges txs ls + +-- -- for a given tx, and set of edges, +-- -- returns a list of transactions ls such that for each e in ls is such that e -> tx is a dependency +-- -- i.e. returns all ends of incoming edges +hasIncEdges :: EraTx era => Tx era -> [(Tx era, Tx era)] -> [Tx era] +hasIncEdges _ [] = [] +hasIncEdges tx ((e, tx') : edges) = + if txIdTx tx == txIdTx tx' + then e : hasIncEdges tx edges + else hasIncEdges tx edges + +-- -- filters a list of transactions such that only ones with no incoming edges remain +nodesWithNoIncomingEdge :: EraTx era => [Tx era] -> [(Tx era, Tx era)] -> [Tx era] +nodesWithNoIncomingEdge [] _ = [] +nodesWithNoIncomingEdge (tx : txs) edges = case hasIncEdges tx edges of + [] -> tx : nodesWithNoIncomingEdge txs edges + _ -> nodesWithNoIncomingEdge txs edges + +-- -- remove the first instance of a transaction in a list +removeTx :: EraTx era => Tx era -> [Tx era] -> [Tx era] +removeTx _ [] = [] +removeTx tx (n : ne) = + if txIdTx tx == txIdTx n + then ne + else n : removeTx tx ne + +-- remove a transaction from a list if it has no incoming edges +ifNoEdgeRemove :: EraTx era => Tx era -> [(Tx era, Tx era)] -> [Tx era] -> [Tx era] +ifNoEdgeRemove tx edges s = case hasIncEdges tx edges of + [] -> removeTx tx s + _ -> s + +-- given tx1, for all tx such that (tx1 , tx) in edges, +-- remove (tx1 , tx) from the graph +-- if tx has no other incoming edges then +-- insert tx into S +updateRES :: EraTx era => Tx era -> [(Tx era, Tx era)] -> [Tx era] -> ([(Tx era, Tx era)], [Tx era]) +updateRES _ [] s = ([], s) +updateRES tx1 ((tx, tx') : em) s = + if txIdTx tx == txIdTx tx1 + then (fst (updateRES tx1 em (ifNoEdgeRemove tx em s)), ifNoEdgeRemove tx em s) + else ((tx, tx') : fst (updateRES tx1 em s), s) + +-- -- topologically sorts a tx list +-- -- arguments : tracking edges for agda termination check, remaining edges, remaining txs with no incoming edge (S), current sorted list (L) +-- -- returns nothing if there are remaining edges the graph, but S is empty +topSortTxs :: + EraTx era => [(Tx era, Tx era)] -> [(Tx era, Tx era)] -> [Tx era] -> [Tx era] -> Maybe [Tx era] +topSortTxs _ [] _ srtd = Just srtd +topSortTxs [] _ _ _ = Nothing +topSortTxs _ _ [] _ = Nothing +topSortTxs ((tx1, _) : dges) (r : em) (tx : rls) srtd = + uncurry (topSortTxs dges) updRES (srtd ++ [tx1]) + where + updRES = updateRES tx1 (r : em) (removeTx tx1 (tx : rls)) + +instance + ( Era era + , STS (BabelLEDGERS era) + , PredicateFailure (EraRule "LEDGERS" era) ~ ShelleyLedgersPredFailure era + ) => + Embed (BabelLEDGERS era) (BabelZONE era) + where + wrapFailed = LedgersFailure + wrapEvent = ShelleyInBabelEvent \ No newline at end of file diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zones.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zones.hs new file mode 100644 index 00000000000..a635c3e9272 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zones.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Rules.Zones where + +import Cardano.Ledger.Babel.Core ( + Era (EraCrypto), + EraGov, + EraRule, + EraTx (Tx), + InjectRuleFailure (..), + ) +import Cardano.Ledger.Babel.Era (BabelEra, BabelZONES) +import Cardano.Ledger.BaseTypes ( + ShelleyBase, + mkTxIx, + txIxFromIntegral, + txIxToInt, + ) +import Cardano.Ledger.Shelley.API ( + ShelleyLedgersEnv (LedgersEnv), + TxIx, + ) +import Control.State.Transition.Extended ( + Embed (..), + STS (..), + TRC (..), + TransitionRule, + judgmentContext, + trans, + ) +import Data.Sequence (Seq) +import GHC.Generics (Generic) + +import Cardano.Crypto.Hash (Hash) +import Cardano.Ledger.Core ( + EraIndependentTxBody, + EraRuleEvent, + EraRuleFailure, + ) +import Cardano.Ledger.Era (EraSegWits) +import Cardano.Ledger.Keys (DSignable) +import Cardano.Ledger.Shelley.Rules ( + ShelleyBbodyPredFailure, + ShelleyLedgersEvent, + ShelleyLedgersPredFailure, + ) + +import Cardano.Ledger.Babel.Rules.Ledger (BabelLedgerPredFailure) +import Cardano.Ledger.Babel.Rules.Ledgers (BabelLedgersEnv (BabelLedgersEnv)) +import Cardano.Ledger.Babel.Rules.Utxo (BabelUtxoPredFailure) +import Cardano.Ledger.Babel.Rules.Utxos (BabelUtxosPredFailure) +import Cardano.Ledger.Babel.Rules.Utxow (BabelUtxowPredFailure) +import Cardano.Ledger.Babel.Rules.Zone (BabelZonePredFailure) +import Cardano.Ledger.Shelley.LedgerState (LedgerState) +import Control.Monad (foldM) +import qualified Data.Foldable as Foldale +import Data.Maybe (fromJust) +import NoThunks.Class (NoThunks) + +data BabelZonesPredFailure era + = ZoneFailure (PredicateFailure (EraRule "ZONE" era)) -- Subtransition Failures + | ZonesShelleyInBabelPredFailure (ShelleyBbodyPredFailure era) -- Subtransition Failures + deriving (Generic) + +data BabelZonesEvent era + = ZoneEvent (Event (EraRule "ZONE" era)) + | ZonesShelleyInBabelEvent (ShelleyLedgersEvent era) + +type instance EraRuleFailure "ZONES" (BabelEra c) = BabelZonesPredFailure (BabelEra c) + +instance InjectRuleFailure "ZONES" BabelZonesPredFailure (BabelEra c) + +type instance EraRuleFailure "ZONES" (BabelEra c) = BabelZonesPredFailure (BabelEra c) + +type instance EraRuleEvent "ZONES" (BabelEra c) = BabelZonesEvent (BabelEra c) + +instance InjectRuleFailure "ZONES" BabelZonePredFailure (BabelEra c) where + injectFailure = ZoneFailure + +instance InjectRuleFailure "ZONES" ShelleyLedgersPredFailure (BabelEra c) where + injectFailure = ZoneFailure . injectFailure + +instance InjectRuleFailure "ZONES" BabelLedgerPredFailure (BabelEra c) where + injectFailure = ZoneFailure . injectFailure + +instance InjectRuleFailure "ZONES" BabelUtxowPredFailure (BabelEra c) where + injectFailure = ZoneFailure . injectFailure + +instance InjectRuleFailure "ZONES" BabelUtxoPredFailure (BabelEra c) where + injectFailure = ZoneFailure . injectFailure + +instance InjectRuleFailure "ZONES" BabelUtxosPredFailure (BabelEra c) where + injectFailure = ZoneFailure . injectFailure + +deriving stock instance + ( Era era + , Show (PredicateFailure (EraRule "LEDGERS" era)) + , Show (PredicateFailure (EraRule "ZONE" era)) + ) => + Show (BabelZonesPredFailure era) + +deriving stock instance + ( Era era + , Eq (PredicateFailure (EraRule "LEDGERS" era)) + , Eq (PredicateFailure (EraRule "ZONE" era)) + ) => + Eq (BabelZonesPredFailure era) + +instance + ( Era era + , NoThunks (PredicateFailure (EraRule "LEDGERS" era)) + , NoThunks (PredicateFailure (EraRule "ZONE" era)) + ) => + NoThunks (BabelZonesPredFailure era) + +instance + ( EraSegWits era + , EraGov era + , DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody) + , Embed (EraRule "ZONE" era) (BabelZONES era) + , Environment (EraRule "ZONE" era) ~ BabelLedgersEnv era + , State (EraRule "ZONE" era) ~ LedgerState era + , Signal (EraRule "ZONE" era) ~ Seq (Tx era) + , Eq (PredicateFailure (EraRule "LEDGERS" era)) + , Show (PredicateFailure (EraRule "LEDGERS" era)) + ) => + STS (BabelZONES era) + where + type State (BabelZONES era) = LedgerState era + type Environment (BabelZONES era) = ShelleyLedgersEnv era + + type Signal (BabelZONES era) = Seq (Seq (Tx era)) + + type BaseM (BabelZONES era) = ShelleyBase + + type PredicateFailure (BabelZONES era) = BabelZonesPredFailure era + + type Event (BabelZONES era) = BabelZonesEvent era + + transitionRules = [zonesTransition] + +-- Need to index each transaction in the list of lists by its index in the flattened list +-- Do we care about +zonesTransition :: + forall era. + ( Embed (EraRule "ZONE" era) (BabelZONES era) + , Environment (EraRule "ZONE" era) ~ BabelLedgersEnv era + , State (EraRule "ZONE" era) ~ LedgerState era + , Signal (EraRule "ZONE" era) ~ Seq (Tx era) + ) => + TransitionRule (BabelZONES era) +zonesTransition = do + TRC (LedgersEnv slot pp account, ls, txwits) <- judgmentContext + let indexedList = indexLists $ Foldale.toList (txwits :: Seq (Seq (Tx era))) + + case indexedList of + Nothing -> undefined -- fail + Just indexedTxList -> + foldM + ( \ !ls' (ix, tx) -> + trans @(EraRule "ZONE" era) $ + TRC (BabelLedgersEnv slot ix pp account, ls', tx) + ) + ls + indexedTxList + +indexLists :: [Seq a] -> Maybe [(TxIx, Seq a)] +indexLists = go (mkTxIx 0) + where + go :: TxIx -> [Seq a] -> Maybe [(TxIx, Seq a)] + go _ [] = Just [] + go n (x : xs) = ((n, x) :) <$> next + where + mbIx = txIxFromIntegral $ length x + -- This is technically partial, but only because the type inside TxIx is wrong (Word64 instead of Word16) + next = (\n' -> go (fromJust $ txIxFromIntegral $ txIxToInt n + txIxToInt n') xs) =<< mbIx + +instance + forall era zone. + ( Era era + , BaseM zone ~ ShelleyBase + , zone ~ EraRule "ZONE" era + , STS zone + , DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody) + , Era era + ) => + Embed zone (BabelZONES era) + where + wrapFailed = ZoneFailure + wrapEvent = ZoneEvent \ No newline at end of file diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Scripts.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Scripts.hs new file mode 100644 index 00000000000..f159b3de638 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Scripts.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Scripts ( + BabelEraScript (..), + AlonzoScript (..), + PlutusScript (..), + isPlutusScript, + BabelPlutusPurpose (..), + pattern VotingPurpose, + pattern ProposingPurpose, +) +where + +import Cardano.Ledger.Address (RewardAccount) +import Cardano.Ledger.Allegra.Scripts (Timelock, translateTimelock) +import Cardano.Ledger.Alonzo.Scripts ( + AlonzoScript (..), + alonzoScriptPrefixTag, + isPlutusScript, + ) +import Cardano.Ledger.Babbage.Core +import Cardano.Ledger.Babbage.Scripts (PlutusScript (..)) +import Cardano.Ledger.Babel.Era +import Cardano.Ledger.Babel.TxCert () +import Cardano.Ledger.BaseTypes (kindObject) +import Cardano.Ledger.Binary ( + CBORGroup (..), + DecCBOR (decCBOR), + DecCBORGroup (..), + EncCBOR (..), + EncCBORGroup (..), + decodeWord8, + encodeWord8, + ) +import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Conway.Scripts (ConwayPlutusPurpose (..), PlutusScript (..)) +import Cardano.Ledger.Crypto +import Cardano.Ledger.Mary.Value (PolicyID) +import Cardano.Ledger.Plutus.Language +import Cardano.Ledger.SafeHash (SafeToHash (..)) +import Cardano.Ledger.TxIn (TxIn) +import Control.DeepSeq (NFData (..), rwhnf) +import Data.Aeson (ToJSON (..), (.=)) +import Data.Typeable +import Data.Word (Word16, Word32, Word8) +import GHC.Generics +import NoThunks.Class (NoThunks (..)) + +class AlonzoEraScript era => BabelEraScript era where + mkVotingPurpose :: f Word32 (Voter (EraCrypto era)) -> PlutusPurpose f era + + toVotingPurpose :: PlutusPurpose f era -> Maybe (f Word32 (Voter (EraCrypto era))) + + mkProposingPurpose :: f Word32 (ProposalProcedure era) -> PlutusPurpose f era + + toProposingPurpose :: PlutusPurpose f era -> Maybe (f Word32 (ProposalProcedure era)) + +instance Crypto c => EraScript (BabelEra c) where + type Script (BabelEra c) = AlonzoScript (BabelEra c) + type NativeScript (BabelEra c) = Timelock (BabelEra c) + + upgradeScript = \case + TimelockScript ts -> TimelockScript $ translateTimelock ts + PlutusScript (ConwayPlutusV1 ps) -> PlutusScript $ BabelPlutusV1 ps + PlutusScript (ConwayPlutusV2 ps) -> PlutusScript $ BabelPlutusV2 ps + PlutusScript (ConwayPlutusV3 ps) -> PlutusScript $ BabelPlutusV3 ps + + scriptPrefixTag = alonzoScriptPrefixTag + + getNativeScript = \case + TimelockScript ts -> Just ts + _ -> Nothing + + fromNativeScript = TimelockScript + +instance Crypto c => AlonzoEraScript (BabelEra c) where + data PlutusScript (BabelEra c) + = BabelPlutusV1 !(Plutus 'PlutusV1) + | BabelPlutusV2 !(Plutus 'PlutusV2) + | BabelPlutusV3 !(Plutus 'PlutusV3) + | BabelPlutusV4 !(Plutus 'PlutusV4) + deriving (Eq, Ord, Show, Generic) + + type PlutusPurpose f (BabelEra c) = BabelPlutusPurpose f (BabelEra c) + + eraMaxLanguage = PlutusV3 + + mkPlutusScript plutus = + case plutusSLanguage plutus of + SPlutusV1 -> Just $ BabelPlutusV1 plutus + SPlutusV2 -> Just $ BabelPlutusV2 plutus + SPlutusV3 -> Just $ BabelPlutusV3 plutus + SPlutusV4 -> Just $ BabelPlutusV4 plutus + + withPlutusScript (BabelPlutusV1 plutus) f = f plutus + withPlutusScript (BabelPlutusV2 plutus) f = f plutus + withPlutusScript (BabelPlutusV3 plutus) f = f plutus + withPlutusScript (BabelPlutusV4 plutus) f = f plutus + + hoistPlutusPurpose f = \case + BabelSpending x -> BabelSpending $ f x + BabelMinting x -> BabelMinting $ f x + BabelCertifying x -> BabelCertifying $ f x + BabelRewarding x -> BabelRewarding $ f x + BabelVoting x -> BabelVoting $ f x + BabelProposing x -> BabelProposing $ f x + + mkSpendingPurpose = BabelSpending + + toSpendingPurpose (BabelSpending i) = Just i + toSpendingPurpose _ = Nothing + + mkMintingPurpose = BabelMinting + + toMintingPurpose (BabelMinting i) = Just i + toMintingPurpose _ = Nothing + + mkCertifyingPurpose = BabelCertifying + + toCertifyingPurpose (BabelCertifying i) = Just i + toCertifyingPurpose _ = Nothing + + mkRewardingPurpose = BabelRewarding + + toRewardingPurpose (BabelRewarding i) = Just i + toRewardingPurpose _ = Nothing + + upgradePlutusPurposeAsIx = \case + ConwaySpending (AsIx ix) -> BabelSpending (AsIx ix) + ConwayMinting (AsIx ix) -> BabelMinting (AsIx ix) + ConwayCertifying (AsIx ix) -> BabelCertifying (AsIx ix) + ConwayRewarding (AsIx ix) -> BabelRewarding (AsIx ix) + ConwayVoting (AsIx ix) -> BabelVoting (AsIx ix) + ConwayProposing (AsIx ix) -> BabelProposing (AsIx ix) + +instance Crypto c => BabelEraScript (BabelEra c) where + mkVotingPurpose = BabelVoting + + toVotingPurpose (BabelVoting i) = Just i + toVotingPurpose _ = Nothing + + mkProposingPurpose = BabelProposing + + toProposingPurpose (BabelProposing i) = Just i + toProposingPurpose _ = Nothing + +instance NFData (PlutusScript (BabelEra c)) where + rnf = rwhnf +instance NoThunks (PlutusScript (BabelEra c)) +instance Crypto c => SafeToHash (PlutusScript (BabelEra c)) where + originalBytes ps = withPlutusScript ps originalBytes + +data BabelPlutusPurpose f era + = BabelSpending !(f Word32 (TxIn (EraCrypto era))) + | BabelMinting !(f Word32 (PolicyID (EraCrypto era))) + | BabelCertifying !(f Word32 (TxCert era)) + | BabelRewarding !(f Word32 (RewardAccount (EraCrypto era))) + | BabelVoting !(f Word32 (Voter (EraCrypto era))) + | BabelProposing !(f Word32 (ProposalProcedure era)) + deriving (Generic) + +deriving instance Eq (BabelPlutusPurpose AsIx era) +deriving instance Ord (BabelPlutusPurpose AsIx era) +deriving instance Show (BabelPlutusPurpose AsIx era) +instance NoThunks (BabelPlutusPurpose AsIx era) + +deriving instance (Eq (TxCert era), EraPParams era) => Eq (BabelPlutusPurpose AsItem era) +deriving instance (Show (TxCert era), EraPParams era) => Show (BabelPlutusPurpose AsItem era) +instance (NoThunks (TxCert era), EraPParams era) => NoThunks (BabelPlutusPurpose AsItem era) +deriving via + (CBORGroup (BabelPlutusPurpose f era)) + instance + ( forall a b. (EncCBOR a, EncCBOR b) => EncCBOR (f a b) + , EraPParams era + , Typeable f + , EncCBOR (TxCert era) + ) => + EncCBOR (BabelPlutusPurpose f era) +deriving via + (CBORGroup (BabelPlutusPurpose f era)) + instance + ( forall a b. (EncCBOR a, EncCBOR b) => EncCBOR (f a b) + , forall a b. (DecCBOR a, DecCBOR b) => DecCBOR (f a b) + , EraPParams era + , Typeable f + , EncCBOR (TxCert era) + , DecCBOR (TxCert era) + ) => + DecCBOR (BabelPlutusPurpose f era) + +deriving instance (Eq (TxCert era), EraPParams era) => Eq (BabelPlutusPurpose AsIxItem era) +deriving instance (Show (TxCert era), EraPParams era) => Show (BabelPlutusPurpose AsIxItem era) +instance (NoThunks (TxCert era), EraPParams era) => NoThunks (BabelPlutusPurpose AsIxItem era) + +instance + (forall a b. (NFData a, NFData b) => NFData (f a b), NFData (TxCert era), EraPParams era) => + NFData (BabelPlutusPurpose f era) + where + rnf = \case + BabelSpending x -> rnf x + BabelMinting x -> rnf x + BabelCertifying x -> rnf x + BabelRewarding x -> rnf x + BabelVoting x -> rnf x + BabelProposing x -> rnf x + +instance + ( forall a b. (EncCBOR a, EncCBOR b) => EncCBOR (f a b) + , EraPParams era + , Typeable f + , EncCBOR (TxCert era) + ) => + EncCBORGroup (BabelPlutusPurpose f era) + where + listLen _ = 2 + listLenBound _ = 2 + encCBORGroup = \case + BabelSpending p -> encodeWord8 0 <> encCBOR p + BabelMinting p -> encodeWord8 1 <> encCBOR p + BabelCertifying p -> encodeWord8 2 <> encCBOR p + BabelRewarding p -> encodeWord8 3 <> encCBOR p + BabelVoting p -> encodeWord8 4 <> encCBOR p + BabelProposing p -> encodeWord8 5 <> encCBOR p + encodedGroupSizeExpr size_ _proxy = + encodedSizeExpr size_ (Proxy :: Proxy Word8) + + encodedSizeExpr size_ (Proxy :: Proxy Word16) + +instance + ( forall a b. (DecCBOR a, DecCBOR b) => DecCBOR (f a b) + , EraPParams era + , Typeable f + , DecCBOR (TxCert era) + ) => + DecCBORGroup (BabelPlutusPurpose f era) + where + decCBORGroup = + decodeWord8 >>= \case + 0 -> BabelSpending <$> decCBOR + 1 -> BabelMinting <$> decCBOR + 2 -> BabelCertifying <$> decCBOR + 3 -> BabelRewarding <$> decCBOR + 4 -> BabelVoting <$> decCBOR + 5 -> BabelProposing <$> decCBOR + n -> fail $ "Unexpected tag for BabelPlutusPurpose: " <> show n + +instance + ( forall a b. (ToJSON a, ToJSON b) => ToJSON (f a b) + , ToJSON (TxCert era) + , EraPParams era + ) => + ToJSON (BabelPlutusPurpose f era) + where + toJSON = \case + BabelSpending n -> kindObjectWithValue "BabelSpending" n + BabelMinting n -> kindObjectWithValue "BabelMinting" n + BabelCertifying n -> kindObjectWithValue "BabelCertifying" n + BabelRewarding n -> kindObjectWithValue "BabelRewarding" n + BabelVoting n -> kindObjectWithValue "BabelVoting" n + BabelProposing n -> kindObjectWithValue "BabelProposing" n + where + kindObjectWithValue name n = kindObject name ["value" .= n] + +pattern VotingPurpose :: + BabelEraScript era => f Word32 (Voter (EraCrypto era)) -> PlutusPurpose f era +pattern VotingPurpose c <- (toVotingPurpose -> Just c) + where + VotingPurpose c = mkVotingPurpose c + +pattern ProposingPurpose :: + BabelEraScript era => f Word32 (ProposalProcedure era) -> PlutusPurpose f era +pattern ProposingPurpose c <- (toProposingPurpose -> Just c) + where + ProposingPurpose c = mkProposingPurpose c diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Transition.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Transition.hs new file mode 100644 index 00000000000..2eb1cc1fffb --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Transition.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Transition ( + BabelEraTransition (..), + TransitionConfig (..), + toBabelTransitionConfigPairs, +) where + +import Cardano.Ledger.Babbage.Transition (TransitionConfig (BabbageTransitionConfig)) +import Cardano.Ledger.Babel.Core (Era (..)) +import Cardano.Ledger.Babel.Era +import Cardano.Ledger.Babel.Genesis (BabelGenesis (..), toBabelGenesisPairs) +import Cardano.Ledger.Babel.Translation () +import Cardano.Ledger.Babel.TxCert (Delegatee) +import Cardano.Ledger.Conway.Transition (toConwayTransitionConfigPairs) +import Cardano.Ledger.Conway.TxCert (getStakePoolDelegatee, getVoteDelegatee) +import Cardano.Ledger.Credential (Credential) +import Cardano.Ledger.Crypto +import Cardano.Ledger.DRep (DRepState) +import Cardano.Ledger.Keys (KeyRole (..)) +import Cardano.Ledger.Shelley.LedgerState ( + NewEpochState, + certDStateL, + certVStateL, + dsUnifiedL, + esLStateL, + lsCertStateL, + nesEsL, + vsDRepsL, + ) +import Cardano.Ledger.Shelley.Transition +import Cardano.Ledger.UMap (UMElem (..), umElemsL) +import Control.Applicative (Alternative (..)) +import Data.Aeson ( + FromJSON (..), + KeyValue (..), + ToJSON (..), + Value (..), + object, + pairs, + withObject, + (.:), + ) +import Data.ListMap (ListMap) +import qualified Data.ListMap as ListMap +import qualified Data.Map.Strict as Map +import Data.Maybe.Strict (StrictMaybe (..), maybeToStrictMaybe) +import GHC.Generics +import Lens.Micro +import NoThunks.Class (NoThunks (..)) + +class EraTransition era => BabelEraTransition era where + tcDelegsL :: + Lens' + (TransitionConfig era) + (ListMap (Credential 'Staking (EraCrypto era)) (Delegatee (EraCrypto era))) + + tcInitialDRepsL :: + Lens' + (TransitionConfig era) + (ListMap (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))) + + tcBabelGenesisL :: Lens' (TransitionConfig era) (BabelGenesis (EraCrypto era)) + +registerDRepsThenDelegs :: + BabelEraTransition era => + TransitionConfig era -> + NewEpochState era -> + NewEpochState era +registerDRepsThenDelegs cfg = + -- NOTE: The order of registration does not matter. + registerDelegs cfg . registerInitialDReps cfg + +instance Crypto c => EraTransition (BabelEra c) where + data TransitionConfig (BabelEra c) = BabelTransitionConfig + { ctcBabelGenesis :: !(BabelGenesis c) + , ctcBabbageTransitionConfig :: !(TransitionConfig (PreviousEra (BabelEra c))) + } + deriving (Show, Eq, Generic) + + mkTransitionConfig = BabelTransitionConfig + + injectIntoTestState cfg = + registerDRepsThenDelegs cfg + . registerInitialFundsThenStaking cfg + + tcPreviousEraConfigL = + lens ctcBabbageTransitionConfig (\ctc pc -> ctc {ctcBabbageTransitionConfig = pc}) + + tcTranslationContextL = + lens ctcBabelGenesis (\ctc ag -> ctc {ctcBabelGenesis = ag}) + +instance Crypto c => BabelEraTransition (BabelEra c) where + tcBabelGenesisL = lens ctcBabelGenesis (\g x -> g {ctcBabelGenesis = x}) + + tcDelegsL = + protectMainnetLens "BabelDelegs" null $ + tcBabelGenesisL . lens cgDelegs (\g x -> g {cgDelegs = x}) + + tcInitialDRepsL = + protectMainnetLens "InitialDReps" null $ + tcBabelGenesisL . lens cgInitialDReps (\g x -> g {cgInitialDReps = x}) + +instance Crypto c => NoThunks (TransitionConfig (BabelEra c)) + +instance Crypto c => ToJSON (TransitionConfig (BabelEra c)) where + toJSON = object . toBabelTransitionConfigPairs + toEncoding = pairs . mconcat . toBabelTransitionConfigPairs + +toBabelTransitionConfigPairs :: (KeyValue e a, Crypto c) => TransitionConfig (BabelEra c) -> [a] +toBabelTransitionConfigPairs babelConfig = + toConwayTransitionConfigPairs conwayConfig + ++ ["Babel" .= object (toBabelGenesisPairs (babelConfig ^. tcTranslationContextL))] + where + conwayConfig = babelConfig ^. tcPreviousEraConfigL + +instance Crypto c => FromJSON (TransitionConfig (BabelEra c)) where + parseJSON = withObject "BabelTransitionConfig" $ \o -> do + pc <- parseJSON (Object o) + ag <- o .: "Babel" + pure $ mkTransitionConfig pc ag + +registerInitialDReps :: + BabelEraTransition era => + TransitionConfig era -> + NewEpochState era -> + NewEpochState era +registerInitialDReps cfg = + nesEsL . esLStateL . lsCertStateL . certVStateL . vsDRepsL .~ drepsMap + where + drepsMap = ListMap.toMap $ cfg ^. tcInitialDRepsL + +registerDelegs :: + forall era. + BabelEraTransition era => + TransitionConfig era -> + NewEpochState era -> + NewEpochState era +registerDelegs cfg = + nesEsL + . esLStateL + . lsCertStateL + . certDStateL + . dsUnifiedL + . umElemsL + %~ \m -> ListMap.foldrWithKey (\(k, v) -> Map.insertWith joinUMElems k $ delegateeToUMElem v) m delegs + where + delegs = cfg ^. tcDelegsL + delegateeToUMElem d = + UMElem + SNothing + mempty + (maybeToStrictMaybe $ getStakePoolDelegatee d) + (maybeToStrictMaybe $ getVoteDelegatee d) + joinUMElems + (UMElem _ _ newStakePool newDRep) + (UMElem rdp ptrs oldStakePool oldDRrep) = + UMElem + rdp + ptrs + (oldStakePool <|> newStakePool) + (oldDRrep <|> newDRep) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Translation.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Translation.hs new file mode 100644 index 00000000000..d7882d4dbc7 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Translation.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.Translation ( + Tx (..), + addrPtrNormalize, + translateDatum, + translateTxOut, +) where + +import Cardano.Ledger.Address (addrPtrNormalize) +import Cardano.Ledger.Babel.Core hiding (Tx) +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Babel.Genesis (BabelGenesis (..)) +import Cardano.Ledger.Babel.Scripts () +import Cardano.Ledger.Babel.Tx () +import Cardano.Ledger.Binary (DecoderError) +import Cardano.Ledger.CertState (CommitteeState (..)) +import Cardano.Ledger.Conway.Governance ( + ConwayEraGov, + cgsCommitteeL, + cgsConstitutionL, + cgsCurPParamsL, + cgsPrevPParamsL, + mkEnactState, + rsEnactStateL, + setCompleteDRepPulsingState, + ) +import qualified Cardano.Ledger.Core as Core (Tx) +import Cardano.Ledger.Crypto (Crypto) +import Cardano.Ledger.Plutus.Data (translateDatum) +import Cardano.Ledger.Shelley.API ( + CertState (..), + DState (..), + EpochState (..), + NewEpochState (..), + PState (..), + StrictMaybe (..), + UTxOState (..), + VState (..), + ) +import qualified Cardano.Ledger.Shelley.API as API +import Cardano.Ledger.Shelley.LedgerState ( + epochStateGovStateL, + ) +import Data.Default.Class (Default (def)) +import qualified Data.Map.Strict as Map +import Lens.Micro + +-------------------------------------------------------------------------------- +-- Translation from Babbage to Babel +-- +-- The instances below are needed by the consensus layer. Do not remove any of +-- them without coordinating with consensus. +-- +-- Please add auxiliary instances and other declarations at the bottom of this +-- module, not in the list below so that it remains clear which instances the +-- consensus layer needs. +-- +-- WARNING: when a translation instance currently uses the default +-- 'TranslationError', i.e., 'Void', it means the consensus layer relies on it +-- being total. Do not change it! +-------------------------------------------------------------------------------- + +type instance TranslationContext (BabelEra c) = BabelGenesis c + +instance (Crypto c, ConwayEraGov (BabelEra c)) => TranslateEra (BabelEra c) NewEpochState where + translateEra ctxt nes = do + let es = translateEra' ctxt $ nesEs nes + -- We need to ensure that we have the same initial EnactState in the pulser as + -- well as in the current EnactState, otherwise in the very first EPOCH rule call + -- the pulser will reset it. + ratifyState = + def + & rsEnactStateL + .~ mkEnactState (es ^. epochStateGovStateL) + pure $ + NewEpochState + { nesEL = nesEL nes + , nesBprev = nesBprev nes + , nesBcur = nesBcur nes + , nesEs = setCompleteDRepPulsingState def ratifyState es + , nesRu = nesRu nes + , nesPd = nesPd nes + , stashedAVVMAddresses = () + } + +newtype Tx era = Tx {unTx :: Core.Tx era} + +instance Crypto c => TranslateEra (BabelEra c) Tx where + type TranslationError (BabelEra c) Tx = DecoderError + translateEra _ctxt (Tx tx) = do + -- Note that this does not preserve the hidden bytes field of the transaction. + -- This is under the premise that this is irrelevant for TxInBlocks, which are + -- not transmitted as contiguous chunks. + txBody <- translateEraThroughCBOR "TxBody" $ tx ^. bodyTxL + txWits <- translateEraThroughCBOR "TxWitness" $ tx ^. witsTxL + auxData <- mapM (translateEraThroughCBOR "AuxData") (tx ^. auxDataTxL) + let isValidTx = tx ^. isValidTxL + newTx = + mkBasicTx txBody + & witsTxL + .~ txWits + & isValidTxL + .~ isValidTx + & auxDataTxL + .~ auxData + pure $ Tx newTx + +-------------------------------------------------------------------------------- +-- Auxiliary instances and functions +-------------------------------------------------------------------------------- + +instance Crypto c => TranslateEra (BabelEra c) PParams where + translateEra BabelGenesis {cgUpgradePParams} = pure . upgradePParams cgUpgradePParams + +instance Crypto c => TranslateEra (BabelEra c) EpochState where + translateEra ctxt es = + pure $ + EpochState + { esAccountState = esAccountState es + , esSnapshots = esSnapshots es + , esLState = translateEra' ctxt $ esLState es + , esNonMyopic = esNonMyopic es + } + +instance Crypto c => TranslateEra (BabelEra c) DState where + translateEra _ DState {..} = pure DState {..} + +instance Crypto c => TranslateEra (BabelEra c) CommitteeState where + translateEra _ CommitteeState {..} = pure CommitteeState {..} + +instance Crypto c => TranslateEra (BabelEra c) VState where + translateEra ctx VState {..} = do + committeeState <- translateEra ctx vsCommitteeState + pure VState {vsCommitteeState = committeeState, ..} + +instance Crypto c => TranslateEra (BabelEra c) PState where + translateEra _ PState {..} = pure PState {..} + +instance Crypto c => TranslateEra (BabelEra c) CertState where + translateEra ctxt ls = + pure + CertState + { certDState = translateEra' ctxt $ certDState ls + , certPState = translateEra' ctxt $ certPState ls + , certVState = translateEra' ctxt $ certVState ls + } + +instance Crypto c => TranslateEra (BabelEra c) API.LedgerState where + translateEra babelGenesis ls = + pure + API.LedgerState + { API.lsUTxOState = translateEra' babelGenesis $ API.lsUTxOState ls + , API.lsCertState = translateEra' babelGenesis $ API.lsCertState ls + } + +translateGovState :: + Crypto c => + TranslationContext (BabelEra c) -> + GovState (PreviousEra (BabelEra c)) -> + GovState (BabelEra c) +translateGovState ctxt@BabelGenesis {..} sgov = + let curPParams = translateEra' ctxt (sgov ^. curPParamsGovStateL) + prevPParams = translateEra' ctxt (sgov ^. prevPParamsGovStateL) + in emptyGovState + & cgsCurPParamsL + .~ curPParams + & cgsPrevPParamsL + .~ prevPParams + & cgsCommitteeL + .~ SJust cgCommittee + & cgsConstitutionL + .~ cgConstitution + +instance Crypto c => TranslateEra (BabelEra c) UTxOState where + translateEra ctxt us = + pure + UTxOState + { API.utxosUtxo = translateEra' ctxt $ API.utxosUtxo us + , API.utxosFrxo = mempty + , API.utxosDeposited = API.utxosDeposited us + , API.utxosFees = API.utxosFees us + , API.utxosGovState = + translateGovState ctxt $ + API.utxosGovState us + , API.utxosStakeDistr = API.utxosStakeDistr us + , API.utxosDonation = API.utxosDonation us + } + +instance Crypto c => TranslateEra (BabelEra c) API.UTxO where + translateEra _ctxt utxo = + pure $ API.UTxO $ upgradeTxOut `Map.map` API.unUTxO utxo + +-- | Filter out `TxOut`s with zero Coins and normalize Pointers, +-- while converting `TxOut`s to Babel era. +translateTxOut :: + Crypto c => + TxOut (PreviousEra (BabelEra c)) -> + TxOut (BabelEra c) +translateTxOut = upgradeTxOut +{-# DEPRECATED translateTxOut "In favor of `upgradeTxOut`" #-} diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Tx.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Tx.hs new file mode 100644 index 00000000000..98aec771699 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Tx.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} + +module Cardano.Ledger.Babel.Tx ( + module BabbageTxReExport, + BabelTxZones, + pattern BabelTxZones, +) +where + +import Cardano.Crypto.Hash () +import qualified Cardano.Crypto.Hash as Hash hiding (Hash) +import Cardano.Ledger.Allegra.Tx (validateTimelock) +import Cardano.Ledger.Alonzo.Tx ( + IsValid (IsValid), + alonzoSegwitTx, + auxDataAlonzoTxL, + bodyAlonzoTxL, + isValidAlonzoTxL, + mkBasicAlonzoTx, + sizeAlonzoTxF, + witsAlonzoTxL, + ) +import Cardano.Ledger.Babbage.Tx as BabbageTxReExport ( + AlonzoEraTx (..), + AlonzoTx (..), + ) +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Babel.TxAuxData () +import Cardano.Ledger.Babel.TxBody () +import Cardano.Ledger.Babel.TxWits () +import Cardano.Ledger.BaseTypes (strictMaybeToMaybe) +import Cardano.Ledger.Binary ( + Annotator, + DecCBOR (decCBOR), + EncCBOR (encCBOR, encodedSizeExpr), + EncCBORGroup (encodedGroupSizeExpr), + encCBOR, + encCBORGroup, + encodeFoldableEncoder, + encodeFoldableMapEncoder, + encodePreEncoded, + listLenBound, + serialize, + withSlice, + ) +import Cardano.Ledger.Binary.Group (EncCBORGroup (listLen)) +import Cardano.Ledger.Conway.Tx (getConwayMinFeeTx) +import Cardano.Ledger.Core ( + Era, + EraTx (auxDataTxL), + Tx, + bodyTxL, + eraProtVerLow, + upgradeTxAuxData, + upgradeTxBody, + upgradeTxWits, + witsTxL, + ) +import qualified Cardano.Ledger.Core as Core +import Cardano.Ledger.Crypto +import Cardano.Ledger.Keys (Hash) +import Cardano.Ledger.SafeHash (SafeToHash (..)) +import Cardano.Ledger.Shelley.BlockChain (constructMetadata) +import Control.Monad (unless) +import Data.ByteString (ByteString) +import Data.ByteString.Builder (shortByteString, toLazyByteString) +import qualified Data.ByteString.Lazy as BSL +import Data.Coerce (coerce) +import Data.Data (Proxy) +import qualified Data.Map as Map +import Data.Proxy (Proxy (..)) +import qualified Data.Sequence as Seq +import Data.Sequence.Strict (StrictSeq) +import qualified Data.Sequence.Strict as StrictSeq +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Lens.Micro hiding (set) +import Lens.Micro.Extras (view) +import NoThunks.Class (AllowThunksIn (AllowThunksIn), NoThunks) + +instance Crypto c => Core.EraTx (BabelEra c) where + {-# SPECIALIZE instance Core.EraTx (BabelEra StandardCrypto) #-} + + type Tx (BabelEra c) = AlonzoTx (BabelEra c) + type TxUpgradeError (BabelEra c) = Core.TxBodyUpgradeError (BabelEra c) + + mkBasicTx = mkBasicAlonzoTx + + bodyTxL = bodyAlonzoTxL + {-# INLINE bodyTxL #-} + + witsTxL = witsAlonzoTxL + {-# INLINE witsTxL #-} + + auxDataTxL = auxDataAlonzoTxL + {-# INLINE auxDataTxL #-} + + -- requiredTxsTxL = lens (const mempty) const + -- {-# INLINE requiredTxsTxL #-} + + sizeTxF = sizeAlonzoTxF + {-# INLINE sizeTxF #-} + + validateNativeScript = validateTimelock + {-# INLINE validateNativeScript #-} + + getMinFeeTx = getConwayMinFeeTx + + upgradeTx (AlonzoTx b w valid aux) = + AlonzoTx + <$> upgradeTxBody b + <*> pure (upgradeTxWits w) + <*> pure valid + <*> pure (fmap upgradeTxAuxData aux) + +instance Crypto c => AlonzoEraTx (BabelEra c) where + {-# SPECIALIZE instance AlonzoEraTx (BabelEra StandardCrypto) #-} + + isValidTxL = isValidAlonzoTxL + {-# INLINE isValidTxL #-} + +-- instance Crypto c => Core.EraRequiredTxsData (BabelEra c) where +-- type RequiredTxs (BabelEra c) = ShelleyRequiredTx (BabelEra c) + +instance Crypto c => Core.EraSegWits (BabelEra c) where + type TxZones (BabelEra c) = BabelTxZones (BabelEra c) + fromTxZones = txZonesTxns + toTxZones = BabelTxZones + hashTxZones = hashBabelTxZones + numSegComponents = 4 + +-- hashAlonzoTxSeq :: forall era. +-- Era era => +-- AlonzoTxSeq era -> Hash (EraCrypto era) EraIndependentBlockBody +-- Defined at /home/will/git/cardano-ledger/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs:177:1 + +-- _ :: TxZones (AlonzoEra c) +-- -> Hash (HASH (EraCrypto (AlonzoEra c))) EraIndependentBlockBody +-- _ :: forall era. +-- Era era => +-- AlonzoTxSeq era -> Hash (EraCrypto era) EraIndependentBlockBody + +-------------------------------------------------------------------------------- +-- Serialisation and hashing +-------------------------------------------------------------------------------- + +instance Era era => EncCBORGroup (TxZones era) where + encCBORGroup (BabelTxZonesRaw _ bodyBytes witsBytes metadataBytes invalidBytes) = + encodePreEncoded $ + BSL.toStrict $ + bodyBytes <> witsBytes <> metadataBytes <> invalidBytes + encodedGroupSizeExpr size _proxy = + encodedSizeExpr size (Proxy :: Proxy BSL.ByteString) + + encodedSizeExpr size (Proxy :: Proxy BSL.ByteString) + + encodedSizeExpr size (Proxy :: Proxy BSL.ByteString) + + encodedSizeExpr size (Proxy :: Proxy BSL.ByteString) + listLen _ = 4 + listLenBound _ = 4 + +instance AlonzoEraTx era => DecCBOR (Annotator (TxZones era)) where + decCBOR = do + (bodies, bodiesAnn) <- withSlice decCBOR + (ws, witsAnn) <- withSlice decCBOR + let b = length bodies + inRange x = (0 <= x) && (x <= (b - 1)) + w = length ws + (auxData :: Seq.Seq (Maybe (Annotator (Core.TxAuxData era))), auxDataAnn) <- withSlice $ + do + m <- decCBOR + unless + (all inRange (Map.keysSet m)) + ( fail + ( "Some Auxiliarydata index is not in the range: 0 .. " + ++ show (b - 1) + ) + ) + pure (constructMetadata b m) + (isValIdxs, isValAnn) <- withSlice decCBOR + let vs = alignedValidFlags b isValIdxs + unless + (b == w) + ( fail $ + "different number of transaction bodies (" + <> show b + <> ") and witness sets (" + <> show w + <> ")" + ) + unless + (all inRange isValIdxs) + ( fail + ( "Some IsValid index is not in the range: 0 .. " + ++ show (b - 1) + ++ ", " + ++ show isValIdxs + ) + ) + let + -- TODO WG: This might not actually make sense. Think about it. + txns :: Annotator (StrictSeq (StrictSeq (Tx era))) + txns = + traverse + ( \bodies' -> + sequenceA $ + StrictSeq.forceToStrict $ + Seq.zipWith4 alonzoSegwitTx bodies' ws vs auxData + ) + (StrictSeq.forceToStrict bodies) + + pure $ + BabelTxZonesRaw + <$> txns + <*> bodiesAnn + <*> witsAnn + <*> auxDataAnn + <*> isValAnn + +-- | Hash a given block body +hashBabelTxZones :: + forall era. + Era era => + BabelTxZones era -> + Hash (Core.EraCrypto era) Core.EraIndependentBlockBody +hashBabelTxZones (BabelTxZonesRaw _ bodies ws md vs) = + coerce $ + hashStrict $ + BSL.toStrict $ + toLazyByteString $ + mconcat + [ hashPart bodies + , hashPart ws + , hashPart md + , hashPart vs + ] + where + hashStrict :: ByteString -> Hash (Core.EraCrypto era) ByteString + hashStrict = Hash.hashWith id + hashPart = shortByteString . Hash.hashToBytesShort . hashStrict . BSL.toStrict + +data BabelTxZones era = BabelTxZonesRaw + { txZonesTxns :: !(StrictSeq (StrictSeq (Core.Tx era))) + , txZonesBodyBytes :: BSL.ByteString + -- ^ Bytes encoding @Seq ('AlonzoTxBody' era)@ + , txZonesWitsBytes :: BSL.ByteString + -- ^ Bytes encoding @Seq ('TxWitness' era)@ + , txZonesMetadataBytes :: BSL.ByteString + -- ^ Bytes encoding a @Map Int ('AuxiliaryData')@. Missing indices have + -- 'SNothing' for metadata + , txZonesIsValidBytes :: BSL.ByteString + -- ^ Bytes representing a set of integers. These are the indices of + -- transactions with 'isValid' == False. + } + deriving (Generic) + +pattern BabelTxZones :: + forall era. + ( AlonzoEraTx era + , SafeToHash (Core.TxWits era) + ) => + StrictSeq (StrictSeq (Core.Tx era)) -> + BabelTxZones era +pattern BabelTxZones xs <- + BabelTxZonesRaw xs _ _ _ _ + where + BabelTxZones txns = + let version = eraProtVerLow @era + serializeFoldablePreEncoded x = + serialize version $ + encodeFoldableEncoder encodePreEncoded x + metaChunk index m = encodeIndexed <$> strictMaybeToMaybe m + where + encodeIndexed metadata = encCBOR index <> encodePreEncoded metadata + flattenedTxns = + StrictSeq.forceToStrict + (StrictSeq.fromStrict =<< StrictSeq.fromStrict txns) + in BabelTxZonesRaw + { txZonesTxns = txns + , txZonesBodyBytes = + serializeFoldablePreEncoded $ originalBytes . view bodyTxL <$> flattenedTxns + , txZonesWitsBytes = + serializeFoldablePreEncoded $ originalBytes . view witsTxL <$> flattenedTxns + , txZonesMetadataBytes = + serialize version . encodeFoldableMapEncoder metaChunk $ + fmap originalBytes . view auxDataTxL + <$> StrictSeq.forceToStrict + (StrictSeq.fromStrict =<< StrictSeq.fromStrict txns) + , txZonesIsValidBytes = + serialize version $ encCBOR $ nonValidatingIndices flattenedTxns + } + +{-# COMPLETE BabelTxZones #-} + +type TxZones era = BabelTxZones era + +{-# DEPRECATED TxZones "Use `BabelTxZones` instead" #-} + +deriving via + AllowThunksIn + '[ "txZonesBodyBytes" + , "txZonesWitsBytes" + , "txZonesMetadataBytes" + , "txZonesIsValidBytes" + ] + (TxZones era) + instance + (Typeable era, NoThunks (Core.Tx era)) => NoThunks (TxZones era) + +deriving stock instance Show (Core.Tx era) => Show (TxZones era) + +deriving stock instance Eq (Core.Tx era) => Eq (TxZones era) + +-------------------------------------------------------------------------------- +-- Internal utility functions +-------------------------------------------------------------------------------- + +-- | Given a sequence of transactions, return the indices of those which do not +-- validate. We store the indices of the non-validating transactions because we +-- expect this to be a much smaller set than the validating transactions. +nonValidatingIndices :: AlonzoEraTx era => StrictSeq (Tx era) -> [Int] +nonValidatingIndices (StrictSeq.fromStrict -> xs) = + Seq.foldrWithIndex + ( \idx tx acc -> + if tx ^. isValidTxL == IsValid False + then idx : acc + else acc + ) + [] + xs + +-- | Given the number of transactions, and the set of indices for which these +-- transactions do not validate, create an aligned sequence of `IsValid` +-- flags. +-- +-- This function operates much as the inverse of 'nonValidatingIndices'. +alignedValidFlags :: Int -> [Int] -> Seq.Seq IsValid +alignedValidFlags = alignedValidFlags' (-1) + where + alignedValidFlags' _ n [] = Seq.replicate n $ IsValid True + alignedValidFlags' prev n (x : xs) = + Seq.replicate (x - prev - 1) (IsValid True) + Seq.>< IsValid False + Seq.<| alignedValidFlags' x (n - (x - prev)) xs diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/TxAuxData.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/TxAuxData.hs new file mode 100644 index 00000000000..ea6fb1246c4 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/TxAuxData.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.TxAuxData () where + +import Cardano.Ledger.Alonzo.Core +import Cardano.Ledger.Alonzo.TxAuxData ( + AlonzoTxAuxData (..), + hashAlonzoTxAuxData, + metadataAlonzoTxAuxDataL, + plutusScriptsAllegraTxAuxDataL, + timelockScriptsAlonzoTxAuxDataL, + translateAlonzoTxAuxData, + validateAlonzoTxAuxData, + ) +import Cardano.Ledger.Babel.Era +import Cardano.Ledger.Babel.Scripts () +import Cardano.Ledger.Crypto + +instance Crypto c => EraTxAuxData (BabelEra c) where + type TxAuxData (BabelEra c) = AlonzoTxAuxData (BabelEra c) + + mkBasicTxAuxData = AlonzoTxAuxData mempty mempty mempty + + metadataTxAuxDataL = metadataAlonzoTxAuxDataL + + upgradeTxAuxData = translateAlonzoTxAuxData + + hashTxAuxData = hashAlonzoTxAuxData + + validateTxAuxData = validateAlonzoTxAuxData + +instance Crypto c => AllegraEraTxAuxData (BabelEra c) where + timelockScriptsTxAuxDataL = timelockScriptsAlonzoTxAuxDataL + +instance Crypto c => AlonzoEraTxAuxData (BabelEra c) where + plutusScriptsTxAuxDataL = plutusScriptsAllegraTxAuxDataL diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/TxBody.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/TxBody.hs new file mode 100644 index 00000000000..6b1c58e5175 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/TxBody.hs @@ -0,0 +1,769 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.TxBody ( + BabelEraTxBody (..), + BabelTxBody ( + BabelTxBody, + bbtbSpendInputs, + bbtbCollateralInputs, + bbtbReferenceInputs, + bbtbOutputs, + bbtbCollateralReturn, + bbtbTotalCollateral, + bbtbCerts, + bbtbWithdrawals, + bbtbTxfee, + bbtbVldt, + bbtbReqSignerHashes, + bbtbMint, + bbtbScriptIntegrityHash, + bbtbAdHash, + bbtbTxNetworkId, + bbtbVotingProcedures, + bbtbProposalProcedures, + bbtbCurrentTreasuryValue, + bbtbTreasuryDonation, + bbtbFulfills, + bbtbRequests, + bbtbRequiredTxs + ), + BabelTxBodyRaw, +) where + +import Cardano.Ledger.Alonzo.TxAuxData (AuxiliaryDataHash (..)) +import Cardano.Ledger.Alonzo.TxBody (Indexable (..)) +import Cardano.Ledger.Babbage.Core +import Cardano.Ledger.Babbage.TxBody ( + allSizedOutputsBabbageTxBodyF, + babbageAllInputsTxBodyF, + babbageSpendableInputsTxBodyF, + ) +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Babel.Scripts (BabelEraScript, BabelPlutusPurpose (..)) +import Cardano.Ledger.Babel.TxCert ( + BabelEraTxCert, + -- BabelTxCert (..), + BabelTxCertUpgradeError, + ) +import Cardano.Ledger.Babel.TxOut () +import Cardano.Ledger.BaseTypes (Network, fromSMaybe) +import Cardano.Ledger.Binary ( + Annotator, + DecCBOR (..), + EncCBOR (..), + Sized (..), + ToCBOR (..), + mkSized, + ) +import Cardano.Ledger.Binary.Coders ( + Decode (..), + Density (..), + Encode (..), + Field (..), + Wrapped (..), + decode, + encode, + encodeKeyedStrictMaybe, + field, + fieldGuarded, + ofield, + (!>), + ) +import Cardano.Ledger.Coin (Coin (..), decodePositiveCoin) +import Cardano.Ledger.Conway.Core (ConwayEraScript (mkVotingPurpose), ConwayEraTxBody (..)) +import Cardano.Ledger.Conway.Governance (ProposalProcedure, VotingProcedures (..)) +import Cardano.Ledger.Conway.PParams (ConwayEraPParams) +import Cardano.Ledger.Conway.Scripts ( + ConwayEraScript (mkProposingPurpose, toProposingPurpose, toVotingPurpose), + ) +import Cardano.Ledger.Conway.TxBody ( + ConwayTxBody (..), + conwayTotalDepositsTxBody, + ) +import Cardano.Ledger.Conway.TxCert (ConwayTxCert) +import Cardano.Ledger.Crypto +import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..)) +import Cardano.Ledger.Mary.Value ( + MaryValue (..), + MultiAsset (..), + PolicyID, + policies, + ) +import Cardano.Ledger.MemoBytes ( + EqRaw, + Mem, + MemoBytes (..), + MemoHashIndex, + Memoized (..), + getMemoRawType, + getMemoSafeHash, + lensMemoRawType, + mkMemoized, + ) +import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeToHash) +import Cardano.Ledger.TxIn (Fulfill, TxIn (..)) +import Cardano.Ledger.Val (Val (..)) +import Control.Arrow (left) +import Control.DeepSeq (NFData) +import Control.Monad (unless) +import Data.Maybe.Strict (StrictMaybe (..)) +import qualified Data.OSet.Strict as OSet +import Data.Sequence.Strict (StrictSeq) +import Data.Set (Set) +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Lens.Micro (Lens', to, (^.)) +import NoThunks.Class (NoThunks) + +instance Memoized BabelTxBody where + type RawType BabelTxBody = BabelTxBodyRaw + +data BabelTxBodyRaw era = BabelTxBodyRaw + { bbtbrSpendInputs :: !(Set (TxIn (EraCrypto era))) + , bbtbrCollateralInputs :: !(Set (TxIn (EraCrypto era))) + , bbtbrReferenceInputs :: !(Set (TxIn (EraCrypto era))) + , bbtbrOutputs :: !(StrictSeq (Sized (TxOut era))) + , bbtbrCollateralReturn :: !(StrictMaybe (Sized (TxOut era))) + , bbtbrTotalCollateral :: !(StrictMaybe Coin) + , bbtbrCerts :: !(OSet.OSet (ConwayTxCert era)) + , bbtbrWithdrawals :: !(Withdrawals (EraCrypto era)) + , bbtbrTxfee :: !Coin + , bbtbrVldt :: !ValidityInterval + , bbtbrReqSignerHashes :: !(Set (KeyHash 'Witness (EraCrypto era))) + , bbtbrMint :: !(MultiAsset (EraCrypto era)) + , bbtbrScriptIntegrityHash :: !(StrictMaybe (ScriptIntegrityHash (EraCrypto era))) + , bbtbrAuxDataHash :: !(StrictMaybe (AuxiliaryDataHash (EraCrypto era))) + , bbtbrTxNetworkId :: !(StrictMaybe Network) + , bbtbrVotingProcedures :: !(VotingProcedures era) + , bbtbrProposalProcedures :: !(OSet.OSet (ProposalProcedure era)) + , bbtbrCurrentTreasuryValue :: !(StrictMaybe Coin) + , bbtbrTreasuryDonation :: !Coin + , -- Tx body fields for intents (babel-fees) + bbtbrFulfills :: !(Set (Fulfill (EraCrypto era))) + , bbtbrRequests :: !(StrictSeq (Sized (TxOut era))) + , bbtbrRequiredTxs :: !(Set (TxIn (EraCrypto era))) -- TODO WG You need to remove this right (for general atomic zones)? + } + deriving (Generic, Typeable) + +deriving instance (EraPParams era, Eq (TxOut era)) => Eq (BabelTxBodyRaw era) + +instance + (EraPParams era, NoThunks (TxOut era)) => + NoThunks (BabelTxBodyRaw era) + +instance + (EraPParams era, NFData (TxOut era)) => + NFData (BabelTxBodyRaw era) + +deriving instance + (EraPParams era, Show (TxOut era)) => + Show (BabelTxBodyRaw era) + +instance + ( EraPParams era + , DecCBOR (TxOut era) + , ShelleyEraTxCert era + , TxCert era ~ ConwayTxCert era + ) => + DecCBOR (BabelTxBodyRaw era) + where + decCBOR = + decode $ + SparseKeyed + "TxBodyRaw" + basicBabelTxBodyRaw + bodyFields + requiredFields + where + bodyFields :: Word -> Field (BabelTxBodyRaw era) + bodyFields 0 = field (\x tx -> tx {bbtbrSpendInputs = x}) From + bodyFields 1 = field (\x tx -> tx {bbtbrOutputs = x}) From + bodyFields 2 = field (\x tx -> tx {bbtbrTxfee = x}) From + bodyFields 3 = + ofield + (\x tx -> tx {bbtbrVldt = (bbtbrVldt tx) {invalidHereafter = x}}) + From + bodyFields 4 = + fieldGuarded + (emptyFailure "Certificates" "non-empty") + OSet.null + (\x tx -> tx {bbtbrCerts = x}) + From + bodyFields 5 = + fieldGuarded + (emptyFailure "Withdrawals" "non-empty") + (null . unWithdrawals) + (\x tx -> tx {bbtbrWithdrawals = x}) + From + bodyFields 7 = ofield (\x tx -> tx {bbtbrAuxDataHash = x}) From + bodyFields 8 = + ofield + (\x tx -> tx {bbtbrVldt = (bbtbrVldt tx) {invalidBefore = x}}) + From + bodyFields 9 = + fieldGuarded + (emptyFailure "Mint" "non-empty") + (== mempty) + (\x tx -> tx {bbtbrMint = x}) + From + bodyFields 11 = ofield (\x tx -> tx {bbtbrScriptIntegrityHash = x}) From + bodyFields 13 = + fieldGuarded + (emptyFailure "Collateral Inputs" "non-empty") + null + (\x tx -> tx {bbtbrCollateralInputs = x}) + From + bodyFields 14 = + fieldGuarded + (emptyFailure "Required Signer Hashes" "non-empty") + null + (\x tx -> tx {bbtbrReqSignerHashes = x}) + From + bodyFields 15 = ofield (\x tx -> tx {bbtbrTxNetworkId = x}) From + bodyFields 16 = ofield (\x tx -> tx {bbtbrCollateralReturn = x}) From + bodyFields 17 = ofield (\x tx -> tx {bbtbrTotalCollateral = x}) From + bodyFields 18 = + fieldGuarded + (emptyFailure "Reference Inputs" "non-empty") + null + (\x tx -> tx {bbtbrReferenceInputs = x}) + From + bodyFields 19 = + fieldGuarded + (emptyFailure "VotingProcedures" "non-empty") + (null . unVotingProcedures) + (\x tx -> tx {bbtbrVotingProcedures = x}) + From + bodyFields 20 = + fieldGuarded + (emptyFailure "ProposalProcedures" "non-empty") + OSet.null + (\x tx -> tx {bbtbrProposalProcedures = x}) + From + bodyFields 21 = ofield (\x tx -> tx {bbtbrCurrentTreasuryValue = x}) From + bodyFields 22 = + ofield + (\x tx -> tx {bbtbrTreasuryDonation = fromSMaybe zero x}) + (D (decodePositiveCoin $ emptyFailure "Treasury Donation" "non-zero")) + bodyFields 23 = field (\x tx -> tx {bbtbrFulfills = x}) From + bodyFields 24 = field (\x tx -> tx {bbtbrRequests = x}) From + bodyFields 25 = field (\x tx -> tx {bbtbrRequiredTxs = x}) From + bodyFields n = field (\_ t -> t) (Invalid n) + requiredFields :: [(Word, String)] + requiredFields = + [ (0, "inputs") + , (1, "outputs") + , (2, "fee") + ] + emptyFailure fieldName requirement = + "TxBody: '" <> fieldName <> "' must be " <> requirement <> " when supplied" + +newtype BabelTxBody era = TxBodyConstr (MemoBytes BabelTxBodyRaw era) + deriving (Generic, SafeToHash, ToCBOR) + +deriving instance + (EraPParams era, NoThunks (TxOut era)) => + NoThunks (BabelTxBody era) + +deriving instance + (EraPParams era, Eq (TxOut era)) => + Eq (BabelTxBody era) + +deriving newtype instance + (EraPParams era, NFData (TxOut era)) => + NFData (BabelTxBody era) + +deriving instance + (EraPParams era, Show (TxOut era)) => + Show (BabelTxBody era) + +type instance MemoHashIndex BabelTxBodyRaw = EraIndependentTxBody + +instance c ~ EraCrypto era => HashAnnotated (BabelTxBody era) EraIndependentTxBody c where + hashAnnotated = getMemoSafeHash + +instance + ( DecCBOR (TxOut era) + , EraPParams era + , ShelleyEraTxCert era + , TxCert era ~ ConwayTxCert era + ) => + DecCBOR (Annotator (BabelTxBodyRaw era)) + where + decCBOR = pure <$> decCBOR + +deriving via + (Mem BabelTxBodyRaw era) + instance + ( DecCBOR (TxOut era) + , EraPParams era + , ShelleyEraTxCert era + , TxCert era ~ ConwayTxCert era + ) => + DecCBOR (Annotator (BabelTxBody era)) + +mkBabelTxBody :: BabelEraTxBody era => BabelTxBody era +mkBabelTxBody = mkMemoized basicBabelTxBodyRaw + +basicBabelTxBodyRaw :: BabelTxBodyRaw era +basicBabelTxBodyRaw = + BabelTxBodyRaw + mempty + mempty + mempty + mempty + SNothing + SNothing + OSet.empty + (Withdrawals mempty) + mempty + (ValidityInterval SNothing SNothing) + mempty + mempty + SNothing + SNothing + SNothing + (VotingProcedures mempty) + OSet.empty + SNothing + mempty + mempty + mempty + mempty + +data BabelTxBodyUpgradeError c + = CTBUETxCert BabelTxCertUpgradeError + | -- | The TxBody contains an update proposal from a pre-Babel era. Since + -- this can only have come from the genesis delegates, we just discard it. + CTBUEContainsUpdate + | -- | In eras prior to Babel duplicate certificates where allowed + CTBUEContainsDuplicateCerts (Set (TxCert (BabelEra c))) + deriving (Eq, Show) + +instance Crypto c => EraTxBody (BabelEra c) where + {-# SPECIALIZE instance EraTxBody (BabelEra StandardCrypto) #-} + + type TxBody (BabelEra c) = BabelTxBody (BabelEra c) + type TxBodyUpgradeError (BabelEra c) = BabelTxBodyUpgradeError c + + mkBasicTxBody = mkBabelTxBody + + inputsTxBodyL = lensMemoRawType bbtbrSpendInputs (\txb x -> txb {bbtbrSpendInputs = x}) + {-# INLINE inputsTxBodyL #-} + + outputsTxBodyL = + lensMemoRawType + (fmap sizedValue . bbtbrOutputs) + (\txb x -> txb {bbtbrOutputs = mkSized (eraProtVerLow @(BabelEra c)) <$> x}) + {-# INLINE outputsTxBodyL #-} + + feeTxBodyL = lensMemoRawType bbtbrTxfee (\txb x -> txb {bbtbrTxfee = x}) + {-# INLINE feeTxBodyL #-} + + auxDataHashTxBodyL = lensMemoRawType bbtbrAuxDataHash (\txb x -> txb {bbtbrAuxDataHash = x}) + {-# INLINE auxDataHashTxBodyL #-} + + spendableInputsTxBodyF = babbageSpendableInputsTxBodyF + {-# INLINE spendableInputsTxBodyF #-} + + allInputsTxBodyF = babbageAllInputsTxBodyF + {-# INLINE allInputsTxBodyF #-} + + withdrawalsTxBodyL = lensMemoRawType bbtbrWithdrawals (\txb x -> txb {bbtbrWithdrawals = x}) + {-# INLINE withdrawalsTxBodyL #-} + + certsTxBodyL = + lensMemoRawType (OSet.toStrictSeq . bbtbrCerts) (\txb x -> txb {bbtbrCerts = OSet.fromStrictSeq x}) + {-# INLINE certsTxBodyL #-} + + getTotalDepositsTxBody = conwayTotalDepositsTxBody + + getTotalRefundsTxBody pp lookupStakingDeposit lookupDRepDeposit txBody = + getTotalRefundsTxCerts pp lookupStakingDeposit lookupDRepDeposit (txBody ^. certsTxBodyL) + + upgradeTxBody ctb = do + certs <- traverse (left CTBUETxCert . upgradeTxCert) (OSet.toStrictSeq $ ctbCerts ctb) + let (duplicates, certsOSet) = OSet.fromStrictSeqDuplicates certs + unless (null duplicates) $ Left $ CTBUEContainsDuplicateCerts duplicates + pure $ + BabelTxBody + { bbtbSpendInputs = ctbSpendInputs ctb + , bbtbOutputs = + mkSized (eraProtVerLow @(BabelEra c)) + . upgradeTxOut + . sizedValue + <$> ctbOutputs ctb + , bbtbCerts = certsOSet + , bbtbWithdrawals = ctbWithdrawals ctb + , bbtbTxfee = ctbTxfee ctb + , bbtbVldt = ctbVldt ctb + , bbtbAdHash = ctbAdHash ctb + , bbtbMint = ctbMint ctb + , bbtbCollateralInputs = ctbCollateralInputs ctb + , bbtbReqSignerHashes = ctbReqSignerHashes ctb + , bbtbScriptIntegrityHash = ctbScriptIntegrityHash ctb + , bbtbTxNetworkId = ctbTxNetworkId ctb + , bbtbReferenceInputs = ctbReferenceInputs ctb + , bbtbCollateralReturn = + mkSized (eraProtVerLow @(BabelEra c)) + . upgradeTxOut + . sizedValue + <$> ctbCollateralReturn ctb + , bbtbTotalCollateral = ctbTotalCollateral ctb + , bbtbCurrentTreasuryValue = SNothing + , bbtbProposalProcedures = OSet.empty + , bbtbVotingProcedures = VotingProcedures mempty + , bbtbTreasuryDonation = Coin 0 + , bbtbFulfills = mempty + , bbtbRequests = mempty + , bbtbRequiredTxs = mempty + } + +instance Crypto c => AllegraEraTxBody (BabelEra c) where + {-# SPECIALIZE instance AllegraEraTxBody (BabelEra StandardCrypto) #-} + + vldtTxBodyL = lensMemoRawType bbtbrVldt (\txb x -> txb {bbtbrVldt = x}) + {-# INLINE vldtTxBodyL #-} + +instance Crypto c => MaryEraTxBody (BabelEra c) where + {-# SPECIALIZE instance MaryEraTxBody (BabelEra StandardCrypto) #-} + + mintTxBodyL = lensMemoRawType bbtbrMint (\txb x -> txb {bbtbrMint = x}) + {-# INLINE mintTxBodyL #-} + + mintValueTxBodyF = mintTxBodyL . to (MaryValue mempty) + + mintedTxBodyF = + to (\(TxBodyConstr (Memo txBodyRaw _)) -> policies (bbtbrMint txBodyRaw)) + {-# INLINE mintedTxBodyF #-} + +instance Crypto c => AlonzoEraTxBody (BabelEra c) where + {-# SPECIALIZE instance AlonzoEraTxBody (BabelEra StandardCrypto) #-} + + collateralInputsTxBodyL = + lensMemoRawType bbtbrCollateralInputs (\txb x -> txb {bbtbrCollateralInputs = x}) + {-# INLINE collateralInputsTxBodyL #-} + + reqSignerHashesTxBodyL = + lensMemoRawType bbtbrReqSignerHashes (\txb x -> txb {bbtbrReqSignerHashes = x}) + {-# INLINE reqSignerHashesTxBodyL #-} + + scriptIntegrityHashTxBodyL = + lensMemoRawType bbtbrScriptIntegrityHash (\txb x -> txb {bbtbrScriptIntegrityHash = x}) + {-# INLINE scriptIntegrityHashTxBodyL #-} + + networkIdTxBodyL = lensMemoRawType bbtbrTxNetworkId (\txb x -> txb {bbtbrTxNetworkId = x}) + {-# INLINE networkIdTxBodyL #-} + + redeemerPointer = babelRedeemerPointer + + redeemerPointerInverse = babelRedeemerPointerInverse + +instance Crypto c => BabbageEraTxBody (BabelEra c) where + {-# SPECIALIZE instance BabbageEraTxBody (BabelEra StandardCrypto) #-} + + sizedOutputsTxBodyL = lensMemoRawType bbtbrOutputs (\txb x -> txb {bbtbrOutputs = x}) + {-# INLINE sizedOutputsTxBodyL #-} + + referenceInputsTxBodyL = + lensMemoRawType bbtbrReferenceInputs (\txb x -> txb {bbtbrReferenceInputs = x}) + {-# INLINE referenceInputsTxBodyL #-} + + totalCollateralTxBodyL = + lensMemoRawType bbtbrTotalCollateral (\txb x -> txb {bbtbrTotalCollateral = x}) + {-# INLINE totalCollateralTxBodyL #-} + + collateralReturnTxBodyL = + lensMemoRawType + (fmap sizedValue . bbtbrCollateralReturn) + (\txb x -> txb {bbtbrCollateralReturn = mkSized (eraProtVerLow @(BabelEra c)) <$> x}) + {-# INLINE collateralReturnTxBodyL #-} + + sizedCollateralReturnTxBodyL = + lensMemoRawType bbtbrCollateralReturn (\txb x -> txb {bbtbrCollateralReturn = x}) + {-# INLINE sizedCollateralReturnTxBodyL #-} + + allSizedOutputsTxBodyF = allSizedOutputsBabbageTxBodyF + {-# INLINE allSizedOutputsTxBodyF #-} + +instance Crypto c => ConwayEraScript (BabelEra c) where + mkVotingPurpose = BabelVoting + + toVotingPurpose (BabelVoting i) = Just i + toVotingPurpose _ = Nothing + + mkProposingPurpose = BabelProposing + + toProposingPurpose (BabelProposing i) = Just i + toProposingPurpose _ = Nothing + +instance Crypto c => ConwayEraTxBody (BabelEra c) where + {-# SPECIALIZE instance ConwayEraTxBody (BabelEra StandardCrypto) #-} + + currentTreasuryValueTxBodyL = + lensMemoRawType bbtbrCurrentTreasuryValue (\txb x -> txb {bbtbrCurrentTreasuryValue = x}) + {-# INLINE currentTreasuryValueTxBodyL #-} + + votingProceduresTxBodyL = + lensMemoRawType bbtbrVotingProcedures (\txb x -> txb {bbtbrVotingProcedures = x}) + {-# INLINE votingProceduresTxBodyL #-} + + proposalProceduresTxBodyL = + lensMemoRawType bbtbrProposalProcedures (\txb x -> txb {bbtbrProposalProcedures = x}) + {-# INLINE proposalProceduresTxBodyL #-} + + treasuryDonationTxBodyL = + lensMemoRawType bbtbrTreasuryDonation (\txb x -> txb {bbtbrTreasuryDonation = x}) + {-# INLINE treasuryDonationTxBodyL #-} + +instance (Crypto c, ConwayEraTxBody (BabelEra c)) => BabelEraTxBody (BabelEra c) where + fulfillsTxBodyL = lensMemoRawType bbtbrFulfills (\txb x -> txb {bbtbrFulfills = x}) + {-# INLINE fulfillsTxBodyL #-} + requestsTxBodyL = lensMemoRawType bbtbrRequests (\txb x -> txb {bbtbrRequests = x}) + {-# INLINE requestsTxBodyL #-} + requiredTxsTxBodyL = lensMemoRawType bbtbrRequiredTxs (\txb x -> txb {bbtbrRequiredTxs = x}) + {-# INLINE requiredTxsTxBodyL #-} + +instance + (EraPParams era, Eq (TxOut era), Eq (TxCert era)) => + EqRaw (BabelTxBody era) + +pattern BabelTxBody :: + BabelEraTxBody era => + Set (TxIn (EraCrypto era)) -> + Set (TxIn (EraCrypto era)) -> + Set (TxIn (EraCrypto era)) -> + StrictSeq (Sized (TxOut era)) -> + StrictMaybe (Sized (TxOut era)) -> + StrictMaybe Coin -> + OSet.OSet (ConwayTxCert era) -> + Withdrawals (EraCrypto era) -> + Coin -> + ValidityInterval -> + Set (KeyHash 'Witness (EraCrypto era)) -> + MultiAsset (EraCrypto era) -> + StrictMaybe (ScriptIntegrityHash (EraCrypto era)) -> + StrictMaybe (AuxiliaryDataHash (EraCrypto era)) -> + StrictMaybe Network -> + VotingProcedures era -> + OSet.OSet (ProposalProcedure era) -> + StrictMaybe Coin -> + Coin -> + Set (Fulfill (EraCrypto era)) -> + StrictSeq (Sized (TxOut era)) -> + Set (TxIn (EraCrypto era)) -> + BabelTxBody era +pattern BabelTxBody + { bbtbSpendInputs + , bbtbCollateralInputs + , bbtbReferenceInputs + , bbtbOutputs + , bbtbCollateralReturn + , bbtbTotalCollateral + , bbtbCerts + , bbtbWithdrawals + , bbtbTxfee + , bbtbVldt + , bbtbReqSignerHashes + , bbtbMint + , bbtbScriptIntegrityHash + , bbtbAdHash + , bbtbTxNetworkId + , bbtbVotingProcedures + , bbtbProposalProcedures + , bbtbCurrentTreasuryValue + , bbtbTreasuryDonation + , bbtbFulfills + , bbtbRequests + , bbtbRequiredTxs + } <- + ( getMemoRawType -> + BabelTxBodyRaw + { bbtbrSpendInputs = bbtbSpendInputs + , bbtbrCollateralInputs = bbtbCollateralInputs + , bbtbrReferenceInputs = bbtbReferenceInputs + , bbtbrOutputs = bbtbOutputs + , bbtbrCollateralReturn = bbtbCollateralReturn + , bbtbrTotalCollateral = bbtbTotalCollateral + , bbtbrCerts = bbtbCerts + , bbtbrWithdrawals = bbtbWithdrawals + , bbtbrTxfee = bbtbTxfee + , bbtbrVldt = bbtbVldt + , bbtbrReqSignerHashes = bbtbReqSignerHashes + , bbtbrMint = bbtbMint + , bbtbrScriptIntegrityHash = bbtbScriptIntegrityHash + , bbtbrAuxDataHash = bbtbAdHash + , bbtbrTxNetworkId = bbtbTxNetworkId + , bbtbrVotingProcedures = bbtbVotingProcedures + , bbtbrProposalProcedures = bbtbProposalProcedures + , bbtbrCurrentTreasuryValue = bbtbCurrentTreasuryValue + , bbtbrTreasuryDonation = bbtbTreasuryDonation + , bbtbrFulfills = bbtbFulfills + , bbtbrRequests = bbtbRequests + , bbtbrRequiredTxs = bbtbRequiredTxs + } + ) + where + BabelTxBody + inputsX + collateralX + referenceInputsX + outputsX + collateralReturnX + totalCollateralX + certsX + withdrawalsX + txfeeX + vldtX + reqSignerHashesX + mintX + scriptIntegrityHashX + adHashX + txnetworkidX + votingProcedures + proposalProcedures + currentTreasuryValue + treasuryDonation + fulfills + requests + requiredTxs = + mkMemoized $ + BabelTxBodyRaw + inputsX + collateralX + referenceInputsX + outputsX + collateralReturnX + totalCollateralX + certsX + withdrawalsX + txfeeX + vldtX + reqSignerHashesX + mintX + scriptIntegrityHashX + adHashX + txnetworkidX + votingProcedures + proposalProcedures + currentTreasuryValue + treasuryDonation + fulfills + requests + requiredTxs + +{-# COMPLETE BabelTxBody #-} + +-------------------------------------------------------------------------------- +-- Serialisation +-------------------------------------------------------------------------------- + +encodeTxBodyRaw :: + BabelEraTxBody era => + BabelTxBodyRaw era -> + Encode ('Closed 'Sparse) (BabelTxBodyRaw era) +encodeTxBodyRaw BabelTxBodyRaw {..} = + let ValidityInterval bot top = bbtbrVldt + in Keyed + ( \i ci ri o cr tc f t c w b -> + BabelTxBodyRaw i ci ri o cr tc c w f (ValidityInterval b t) + ) + !> Key 0 (To bbtbrSpendInputs) + !> Omit null (Key 13 (To bbtbrCollateralInputs)) + !> Omit null (Key 18 (To bbtbrReferenceInputs)) + !> Key 1 (To bbtbrOutputs) + !> encodeKeyedStrictMaybe 16 bbtbrCollateralReturn + !> encodeKeyedStrictMaybe 17 bbtbrTotalCollateral + !> Key 2 (To bbtbrTxfee) + !> encodeKeyedStrictMaybe 3 top + !> Omit OSet.null (Key 4 (To bbtbrCerts)) + !> Omit (null . unWithdrawals) (Key 5 (To bbtbrWithdrawals)) + !> encodeKeyedStrictMaybe 8 bot + !> Omit null (Key 14 (To bbtbrReqSignerHashes)) + !> Omit (== mempty) (Key 9 (To bbtbrMint)) + !> encodeKeyedStrictMaybe 11 bbtbrScriptIntegrityHash + !> encodeKeyedStrictMaybe 7 bbtbrAuxDataHash + !> encodeKeyedStrictMaybe 15 bbtbrTxNetworkId + !> Omit (null . unVotingProcedures) (Key 19 (To bbtbrVotingProcedures)) + !> Omit OSet.null (Key 20 (To bbtbrProposalProcedures)) + !> encodeKeyedStrictMaybe 21 bbtbrCurrentTreasuryValue + !> Omit (== mempty) (Key 22 $ To bbtbrTreasuryDonation) + !> Omit (== mempty) (Key 23 (To bbtbrFulfills)) + !> Omit (== mempty) (Key 24 (To bbtbrRequests)) + !> Omit (== mempty) (Key 25 (To bbtbrRequiredTxs)) + +instance BabelEraTxBody era => EncCBOR (BabelTxBodyRaw era) where + encCBOR = encode . encodeTxBodyRaw + +-- | Encodes memoized bytes created upon construction. +instance Era era => EncCBOR (BabelTxBody era) + +class + (ConwayEraTxBody era, BabelEraTxCert era, ConwayEraPParams era, BabelEraScript era) => + BabelEraTxBody era + where + fulfillsTxBodyL :: Lens' (TxBody era) (Set (Fulfill (EraCrypto era))) + + requestsTxBodyL :: Lens' (TxBody era) (StrictSeq (Sized (TxOut era))) + + requiredTxsTxBodyL :: Lens' (TxBody era) (Set (TxIn (EraCrypto era))) + +babelRedeemerPointer :: + forall era. + BabelEraTxBody era => + TxBody era -> + BabelPlutusPurpose AsItem era -> + StrictMaybe (BabelPlutusPurpose AsIx era) +babelRedeemerPointer txBody = \case + BabelMinting policyID -> + BabelMinting <$> indexOf policyID (txBody ^. mintedTxBodyF :: Set (PolicyID (EraCrypto era))) + BabelSpending txIn -> + BabelSpending <$> indexOf txIn (txBody ^. inputsTxBodyL) + BabelRewarding rewardAccount -> + BabelRewarding <$> indexOf rewardAccount (unWithdrawals (txBody ^. withdrawalsTxBodyL)) + BabelCertifying txCert -> + BabelCertifying <$> indexOf txCert (txBody ^. certsTxBodyL) + BabelVoting votingProcedure -> + BabelVoting <$> indexOf votingProcedure (txBody ^. votingProceduresTxBodyL) + BabelProposing proposalProcedure -> + BabelProposing <$> indexOf proposalProcedure (txBody ^. proposalProceduresTxBodyL) + +babelRedeemerPointerInverse :: + BabelEraTxBody era => + TxBody era -> + BabelPlutusPurpose AsIx era -> + StrictMaybe (BabelPlutusPurpose AsIxItem era) +babelRedeemerPointerInverse txBody = \case + BabelMinting idx -> + BabelMinting <$> fromIndex idx (txBody ^. mintedTxBodyF) + BabelSpending idx -> + BabelSpending <$> fromIndex idx (txBody ^. inputsTxBodyL) + BabelRewarding idx -> + BabelRewarding <$> fromIndex idx (unWithdrawals (txBody ^. withdrawalsTxBodyL)) + BabelCertifying idx -> + BabelCertifying <$> fromIndex idx (txBody ^. certsTxBodyL) + BabelVoting idx -> + BabelVoting <$> fromIndex idx (txBody ^. votingProceduresTxBodyL) + BabelProposing idx -> + BabelProposing <$> fromIndex idx (txBody ^. proposalProceduresTxBodyL) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/TxCert.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/TxCert.hs new file mode 100644 index 00000000000..64ee54793a7 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/TxCert.hs @@ -0,0 +1,695 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.TxCert ( + -- BabelTxCert (..), + BabelTxCertUpgradeError (..), + BabelDelegCert (..), + BabelGovCert (..), + Delegatee (..), + BabelEraTxCert, + fromShelleyDelegCert, + toShelleyDelegCert, + -- getScriptWitnessBabelTxCert, + pattern RegDepositTxCert, + pattern UnRegDepositTxCert, + pattern DelegTxCert, + pattern RegDepositDelegTxCert, + pattern AuthCommitteeHotKeyTxCert, + pattern ResignCommitteeColdTxCert, + pattern RegDRepTxCert, + pattern UnRegDRepTxCert, + pattern UpdateDRepTxCert, +) +where + +import Cardano.Ledger.Babbage.Core +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Babel.PParams () +import Cardano.Ledger.BaseTypes (StrictMaybe (..), kindObject) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Conway.Governance (Anchor) +import Cardano.Ledger.Conway.PParams (ConwayEraPParams, ppDRepDepositL) +import Cardano.Ledger.Conway.TxCert ( + ConwayDelegCert (ConwayDelegCert, ConwayRegCert, ConwayRegDelegCert, ConwayUnRegCert), + ConwayEraTxCert (..), + ConwayGovCert ( + ConwayAuthCommitteeHotKey, + ConwayRegDRep, + ConwayResignCommitteeColdKey, + ConwayUnRegDRep, + ConwayUpdateDRep + ), + ConwayTxCert (ConwayTxCertDeleg, ConwayTxCertGov, ConwayTxCertPool), + Delegatee (..), + getScriptWitnessConwayTxCert, + getVKeyWitnessConwayTxCert, + ) +import Cardano.Ledger.Credential ( + Credential (..), + StakeCredential, + ) +import Cardano.Ledger.Crypto +import Cardano.Ledger.Keys (KeyHash, KeyRole (..)) +import Cardano.Ledger.Shelley.TxCert ( + ShelleyDelegCert (..), + shelleyTotalDepositsTxCerts, + shelleyTotalRefundsTxCerts, + ) +import Cardano.Ledger.Val (Val (..)) +import Control.DeepSeq (NFData) +import Data.Aeson (ToJSON (..), (.=)) +import Data.Foldable (foldMap', foldl') +import qualified Data.Map.Strict as Map +import Data.Monoid (Sum (getSum)) +import GHC.Generics (Generic) +import Lens.Micro +import NoThunks.Class (NoThunks) + +data BabelTxCertUpgradeError + = MirTxCertExpunged + | GenesisDelegTxCertExpunged + deriving (Eq, Show) + +instance Crypto c => EraTxCert (BabelEra c) where + type TxCert (BabelEra c) = ConwayTxCert (BabelEra c) + + type TxCertUpgradeError (BabelEra c) = BabelTxCertUpgradeError + + upgradeTxCert = \case + RegPoolTxCert poolParams -> Right $ RegPoolTxCert poolParams + RetirePoolTxCert poolId epochNo -> Right $ RetirePoolTxCert poolId epochNo + RegTxCert cred -> Right $ RegTxCert cred + UnRegTxCert cred -> Right $ UnRegTxCert cred + DelegStakeTxCert cred poolId -> Right $ DelegStakeTxCert cred poolId + -- Using wildcard here instead of a pattern match on GenesisDelegTxCert in order to + -- workaround ghc-8.10 disrespecting the completeness pragma. + _ -> Left GenesisDelegTxCertExpunged + + getVKeyWitnessTxCert = getVKeyWitnessConwayTxCert + + getScriptWitnessTxCert = getScriptWitnessConwayTxCert + + mkRegPoolTxCert = ConwayTxCertPool . RegPool + + getRegPoolTxCert (ConwayTxCertPool (RegPool poolParams)) = Just poolParams + getRegPoolTxCert _ = Nothing + + mkRetirePoolTxCert poolId epochNo = ConwayTxCertPool $ RetirePool poolId epochNo + + getRetirePoolTxCert (ConwayTxCertPool (RetirePool poolId epochNo)) = Just (poolId, epochNo) + getRetirePoolTxCert _ = Nothing + + lookupRegStakeTxCert = \case + RegTxCert c -> Just c + RegDepositTxCert c _ -> Just c + RegDepositDelegTxCert c _ _ -> Just c + _ -> Nothing + lookupUnRegStakeTxCert = \case + UnRegTxCert c -> Just c + UnRegDepositTxCert c _ -> Just c + _ -> Nothing + + getTotalRefundsTxCerts = babelTotalRefundsTxCerts + + getTotalDepositsTxCerts = babelTotalDepositsTxCerts + +instance Crypto c => ShelleyEraTxCert (BabelEra c) where + mkRegTxCert c = ConwayTxCertDeleg $ ConwayRegCert c SNothing + + getRegTxCert (ConwayTxCertDeleg (ConwayRegCert c _)) = Just c + getRegTxCert _ = Nothing + + mkUnRegTxCert c = ConwayTxCertDeleg $ ConwayUnRegCert c SNothing + + getUnRegTxCert (ConwayTxCertDeleg (ConwayUnRegCert c _)) = Just c + getUnRegTxCert _ = Nothing + + mkDelegStakeTxCert c kh = ConwayTxCertDeleg $ ConwayDelegCert c (DelegStake kh) + + getDelegStakeTxCert (ConwayTxCertDeleg (ConwayDelegCert c (DelegStake kh))) = Just (c, kh) + getDelegStakeTxCert _ = Nothing + + mkGenesisDelegTxCert = notSupportedInThisEra + getGenesisDelegTxCert _ = Nothing + + mkMirTxCert = notSupportedInThisEra + getMirTxCert = const Nothing + +instance Crypto c => ConwayEraTxCert (BabelEra c) where + mkRegDepositTxCert cred c = ConwayTxCertDeleg $ ConwayRegCert cred $ SJust c + + getRegDepositTxCert (ConwayTxCertDeleg (ConwayRegCert cred (SJust c))) = Just (cred, c) + getRegDepositTxCert _ = Nothing + + mkUnRegDepositTxCert cred c = ConwayTxCertDeleg $ ConwayUnRegCert cred (SJust c) + getUnRegDepositTxCert (ConwayTxCertDeleg (ConwayUnRegCert cred (SJust c))) = Just (cred, c) + getUnRegDepositTxCert _ = Nothing + + mkDelegTxCert cred d = ConwayTxCertDeleg $ ConwayDelegCert cred d + getDelegTxCert (ConwayTxCertDeleg (ConwayDelegCert cred d)) = Just (cred, d) + getDelegTxCert _ = Nothing + + mkRegDepositDelegTxCert cred d c = ConwayTxCertDeleg $ ConwayRegDelegCert cred d c + getRegDepositDelegTxCert (ConwayTxCertDeleg (ConwayRegDelegCert cred d c)) = Just (cred, d, c) + getRegDepositDelegTxCert _ = Nothing + + mkAuthCommitteeHotKeyTxCert ck hk = ConwayTxCertGov $ ConwayAuthCommitteeHotKey ck hk + getAuthCommitteeHotKeyTxCert (ConwayTxCertGov (ConwayAuthCommitteeHotKey ck hk)) = Just (ck, hk) + getAuthCommitteeHotKeyTxCert _ = Nothing + + mkResignCommitteeColdTxCert ck a = ConwayTxCertGov $ ConwayResignCommitteeColdKey ck a + getResignCommitteeColdTxCert (ConwayTxCertGov (ConwayResignCommitteeColdKey ck a)) = Just (ck, a) + getResignCommitteeColdTxCert _ = Nothing + + mkRegDRepTxCert cred deposit mAnchor = ConwayTxCertGov $ ConwayRegDRep cred deposit mAnchor + getRegDRepTxCert = \case + ConwayTxCertGov (ConwayRegDRep cred deposit mAnchor) -> Just (cred, deposit, mAnchor) + _ -> Nothing + + mkUnRegDRepTxCert cred deposit = ConwayTxCertGov $ ConwayUnRegDRep cred deposit + getUnRegDRepTxCert = \case + ConwayTxCertGov (ConwayUnRegDRep cred deposit) -> Just (cred, deposit) + _ -> Nothing + + mkUpdateDRepTxCert cred mAnchor = ConwayTxCertGov $ ConwayUpdateDRep cred mAnchor + getUpdateDRepTxCert = \case + ConwayTxCertGov (ConwayUpdateDRep cred mAnchor) -> Just (cred, mAnchor) + _ -> Nothing + +class ConwayEraTxCert era => BabelEraTxCert era + +instance Crypto c => BabelEraTxCert (BabelEra c) + +pattern RegDepositTxCert :: + BabelEraTxCert era => + StakeCredential (EraCrypto era) -> + Coin -> + TxCert era +pattern RegDepositTxCert cred c <- (getRegDepositTxCert -> Just (cred, c)) + where + RegDepositTxCert cred c = mkRegDepositTxCert cred c + +pattern UnRegDepositTxCert :: + BabelEraTxCert era => + StakeCredential (EraCrypto era) -> + Coin -> + TxCert era +pattern UnRegDepositTxCert cred c <- (getUnRegDepositTxCert -> Just (cred, c)) + where + UnRegDepositTxCert cred c = mkUnRegDepositTxCert cred c + +pattern DelegTxCert :: + BabelEraTxCert era => + StakeCredential (EraCrypto era) -> + Delegatee (EraCrypto era) -> + TxCert era +pattern DelegTxCert cred d <- (getDelegTxCert -> Just (cred, d)) + where + DelegTxCert cred d = mkDelegTxCert cred d + +pattern RegDepositDelegTxCert :: + BabelEraTxCert era => + StakeCredential (EraCrypto era) -> + Delegatee (EraCrypto era) -> + Coin -> + TxCert era +pattern RegDepositDelegTxCert cred d c <- (getRegDepositDelegTxCert -> Just (cred, d, c)) + where + RegDepositDelegTxCert cred d c = mkRegDepositDelegTxCert cred d c + +pattern AuthCommitteeHotKeyTxCert :: + BabelEraTxCert era => + Credential 'ColdCommitteeRole (EraCrypto era) -> + Credential 'HotCommitteeRole (EraCrypto era) -> + TxCert era +pattern AuthCommitteeHotKeyTxCert ck hk <- (getAuthCommitteeHotKeyTxCert -> Just (ck, hk)) + where + AuthCommitteeHotKeyTxCert ck hk = mkAuthCommitteeHotKeyTxCert ck hk + +pattern ResignCommitteeColdTxCert :: + BabelEraTxCert era => + Credential 'ColdCommitteeRole (EraCrypto era) -> + StrictMaybe (Anchor (EraCrypto era)) -> + TxCert era +pattern ResignCommitteeColdTxCert ck a <- (getResignCommitteeColdTxCert -> Just (ck, a)) + where + ResignCommitteeColdTxCert ck = mkResignCommitteeColdTxCert ck + +pattern RegDRepTxCert :: + BabelEraTxCert era => + Credential 'DRepRole (EraCrypto era) -> + Coin -> + StrictMaybe (Anchor (EraCrypto era)) -> + TxCert era +pattern RegDRepTxCert cred deposit mAnchor <- (getRegDRepTxCert -> Just (cred, deposit, mAnchor)) + where + RegDRepTxCert cred deposit mAnchor = mkRegDRepTxCert cred deposit mAnchor + +pattern UnRegDRepTxCert :: + BabelEraTxCert era => + Credential 'DRepRole (EraCrypto era) -> + Coin -> + TxCert era +pattern UnRegDRepTxCert cred deposit <- (getUnRegDRepTxCert -> Just (cred, deposit)) + where + UnRegDRepTxCert cred deposit = mkUnRegDRepTxCert cred deposit + +pattern UpdateDRepTxCert :: + BabelEraTxCert era => + Credential 'DRepRole (EraCrypto era) -> + StrictMaybe (Anchor (EraCrypto era)) -> + TxCert era +pattern UpdateDRepTxCert cred mAnchor <- (getUpdateDRepTxCert -> Just (cred, mAnchor)) + where + UpdateDRepTxCert cred mAnchor = mkUpdateDRepTxCert cred mAnchor + +{-# COMPLETE + RegPoolTxCert + , RetirePoolTxCert + , RegTxCert + , UnRegTxCert + , RegDepositTxCert + , UnRegDepositTxCert + , DelegTxCert + , RegDepositDelegTxCert + , AuthCommitteeHotKeyTxCert + , ResignCommitteeColdTxCert + , RegDRepTxCert + , UnRegDRepTxCert + , UpdateDRepTxCert + #-} + +-- | Certificates for registration and delegation of stake to Pools and DReps. Comparing +-- to previous eras, there is now ability to: +-- +-- * Register and delegate with a single certificate: `BabelRegDelegCert` +-- +-- * Ability to delegate to DReps with `DelegVote` and `DelegStakeVote` +-- +-- * Ability to specify the deposit amount. Deposits during registration and +-- unregistration in Babel are optional, which will change in the future era. They are +-- optional only for the smooth transition from Babbage to Babel. Validity of deposits +-- is checked by the @CERT@ rule. +data BabelDelegCert c + = -- | Register staking credential. Deposit, when present, must match the expected deposit + -- amount specified by `ppKeyDepositL` in the protocol parameters. + BabelRegCert !(StakeCredential c) !(StrictMaybe Coin) + | -- | De-Register the staking credential. Deposit, if present, must match the amount + -- that was left as a deposit upon stake credential registration. + BabelUnRegCert !(StakeCredential c) !(StrictMaybe Coin) + | -- | Redelegate to another delegatee. Staking credential must already be registered. + BabelDelegCert !(StakeCredential c) !(Delegatee c) + | -- | This is a new type of certificate, which allows to register staking credential + -- and delegate within a single certificate. Deposit is required and must match the + -- expected deposit amount specified by `ppKeyDepositL` in the protocol parameters. + BabelRegDelegCert !(StakeCredential c) !(Delegatee c) !Coin + deriving (Show, Generic, Eq, Ord) + +instance NFData (BabelDelegCert c) + +instance NoThunks (BabelDelegCert c) + +instance Crypto c => ToJSON (BabelDelegCert c) where + toJSON = \case + BabelRegCert cred deposit -> + kindObject "RegCert" $ + [ "credential" .= toJSON cred + , "deposit" .= toJSON deposit + ] + BabelUnRegCert cred refund -> + kindObject "UnRegCert" $ + [ "credential" .= toJSON cred + , "refund" .= toJSON refund + ] + BabelDelegCert cred delegatee -> + kindObject "DelegCert" $ + [ "credential" .= toJSON cred + , "delegatee" .= toJSON delegatee + ] + BabelRegDelegCert cred delegatee deposit -> + kindObject "RegDelegCert" $ + [ "credential" .= toJSON cred + , "delegatee" .= toJSON delegatee + , "deposit" .= toJSON deposit + ] + +data BabelGovCert c + = BabelRegDRep !(Credential 'DRepRole c) !Coin !(StrictMaybe (Anchor c)) + | BabelUnRegDRep !(Credential 'DRepRole c) !Coin + | BabelUpdateDRep !(Credential 'DRepRole c) !(StrictMaybe (Anchor c)) + | BabelAuthCommitteeHotKey !(Credential 'ColdCommitteeRole c) !(Credential 'HotCommitteeRole c) + | BabelResignCommitteeColdKey !(Credential 'ColdCommitteeRole c) !(StrictMaybe (Anchor c)) + deriving (Show, Generic, Eq, Ord) + +instance Crypto c => NFData (BabelGovCert c) + +instance NoThunks (BabelGovCert c) + +instance Crypto c => ToJSON (BabelGovCert c) where + toJSON = \case + BabelRegDRep dRep deposit anchor -> + kindObject "RegDRep" $ + [ "dRep" .= toJSON dRep + , "deposit" .= toJSON deposit + , "anchor" .= toJSON anchor + ] + BabelUnRegDRep dRep refund -> + kindObject "UnRegDRep" $ + [ "dRep" .= toJSON dRep + , "refund" .= toJSON refund + ] + BabelUpdateDRep dRep anchor -> + kindObject "UpdateDRep" $ + [ "dRep" .= toJSON dRep + , "anchor" .= toJSON anchor + ] + BabelAuthCommitteeHotKey coldCred hotCred -> + kindObject "AuthCommitteeHotKey" $ + [ "coldCredential" .= toJSON coldCred + , "hotCredential" .= toJSON hotCred + ] + BabelResignCommitteeColdKey coldCred anchor -> + kindObject "ResignCommitteeColdKey" $ + [ "coldCredential" .= toJSON coldCred + , "anchor" .= toJSON anchor + ] + +-- data BabelTxCert era +-- = BabelTxCertDeleg !(BabelDelegCert (EraCrypto era)) +-- | BabelTxCertPool !(PoolCert (EraCrypto era)) +-- | BabelTxCertGov !(BabelGovCert (EraCrypto era)) +-- deriving (Show, Generic, Eq, Ord) + +-- instance Crypto (EraCrypto era) => NFData (BabelTxCert era) + +-- instance NoThunks (BabelTxCert era) + +-- instance Era era => ToJSON (BabelTxCert era) where +-- toJSON = \case +-- BabelTxCertDeleg delegCert -> toJSON delegCert +-- BabelTxCertPool poolCert -> toJSON poolCert +-- BabelTxCertGov govCert -> toJSON govCert + +-- instance +-- ( ShelleyEraTxCert era +-- , TxCert era ~ BabelTxCert era +-- ) => +-- FromCBOR (BabelTxCert era) +-- where +-- fromCBOR = toPlainDecoder (eraProtVerLow @era) decCBOR + +-- instance +-- ( BabelEraTxCert era +-- , TxCert era ~ BabelTxCert era +-- ) => +-- DecCBOR (BabelTxCert era) +-- where +-- decCBOR = decodeRecordSum "BabelTxCert" $ \case +-- t +-- | 0 <= t && t < 3 -> shelleyTxCertDelegDecoder t +-- | 3 <= t && t < 5 -> poolTxCertDecoder t +-- | t == 5 -> fail "Genesis delegation certificates are no longer supported" +-- | t == 6 -> fail "MIR certificates are no longer supported" +-- | 7 <= t -> babelTxCertDelegDecoder t +-- t -> invalidKey t + +-- babelTxCertDelegDecoder :: BabelEraTxCert era => Word -> Decoder s (Int, TxCert era) +-- babelTxCertDelegDecoder = \case +-- 7 -> do +-- cred <- decCBOR +-- deposit <- decCBOR +-- pure (3, RegDepositTxCert cred deposit) +-- 8 -> do +-- cred <- decCBOR +-- deposit <- decCBOR +-- pure (3, UnRegDepositTxCert cred deposit) +-- 9 -> delegCertDecoder 3 (DelegVote <$> decCBOR) +-- 10 -> delegCertDecoder 4 (DelegStakeVote <$> decCBOR <*> decCBOR) +-- 11 -> regDelegCertDecoder 4 (DelegStake <$> decCBOR) +-- 12 -> regDelegCertDecoder 4 (DelegVote <$> decCBOR) +-- 13 -> regDelegCertDecoder 5 (DelegStakeVote <$> decCBOR <*> decCBOR) +-- 14 -> do +-- cred <- decCBOR +-- key <- decCBOR +-- pure (3, AuthCommitteeHotKeyTxCert cred key) +-- 15 -> do +-- cred <- decCBOR +-- a <- decodeNullStrictMaybe decCBOR +-- pure (3, ResignCommitteeColdTxCert cred a) +-- 16 -> do +-- cred <- decCBOR +-- deposit <- decCBOR +-- mAnchor <- decodeNullStrictMaybe decCBOR +-- pure (4, RegDRepTxCert cred deposit mAnchor) +-- 17 -> do +-- cred <- decCBOR +-- deposit <- decCBOR +-- pure (3, UnRegDRepTxCert cred deposit) +-- 18 -> do +-- cred <- decCBOR +-- mAnchor <- decodeNullStrictMaybe decCBOR +-- pure (3, UpdateDRepTxCert cred mAnchor) +-- k -> invalidKey k +-- where +-- delegCertDecoder n decodeDelegatee = do +-- cred <- decCBOR +-- delegatee <- decodeDelegatee +-- pure (n, DelegTxCert cred delegatee) +-- {-# INLINE delegCertDecoder #-} +-- regDelegCertDecoder n decodeDelegatee = do +-- cred <- decCBOR +-- delegatee <- decodeDelegatee +-- deposit <- decCBOR +-- pure (n, RegDepositDelegTxCert cred delegatee deposit) +-- {-# INLINE regDelegCertDecoder #-} +-- {-# INLINE babelTxCertDelegDecoder #-} + +-- instance (Era era, Val (Value era)) => ToCBOR (BabelTxCert era) where +-- toCBOR = toPlainEncoding (eraProtVerLow @era) . encCBOR + +-- instance (Era era, Val (Value era)) => EncCBOR (BabelTxCert era) where +-- encCBOR = \case +-- BabelTxCertDeleg delegCert -> encodeBabelDelegCert delegCert +-- BabelTxCertPool poolCert -> encodePoolCert poolCert +-- BabelTxCertGov govCert -> encodeGovCert govCert + +-- encodeBabelDelegCert :: Crypto c => BabelDelegCert c -> Encoding +-- encodeBabelDelegCert = \case +-- -- Shelley backwards compatibility +-- BabelRegCert cred SNothing -> encodeShelleyDelegCert $ ShelleyRegCert cred +-- BabelUnRegCert cred SNothing -> encodeShelleyDelegCert $ ShelleyUnRegCert cred +-- BabelDelegCert cred (DelegStake poolId) -> encodeShelleyDelegCert $ ShelleyDelegCert cred poolId +-- -- New in Babel +-- BabelRegCert cred (SJust deposit) -> +-- encodeListLen 3 +-- <> encodeWord8 7 +-- <> encCBOR cred +-- <> encCBOR deposit +-- BabelUnRegCert cred (SJust deposit) -> +-- encodeListLen 3 +-- <> encodeWord8 8 +-- <> encCBOR cred +-- <> encCBOR deposit +-- BabelDelegCert cred (DelegVote drep) -> +-- encodeListLen 3 +-- <> encodeWord8 9 +-- <> encCBOR cred +-- <> encCBOR drep +-- BabelDelegCert cred (DelegStakeVote poolId dRep) -> +-- encodeListLen 4 +-- <> encodeWord8 10 +-- <> encCBOR cred +-- <> encCBOR poolId +-- <> encCBOR dRep +-- BabelRegDelegCert cred (DelegStake poolId) deposit -> +-- encodeListLen 4 +-- <> encodeWord8 11 +-- <> encCBOR cred +-- <> encCBOR poolId +-- <> encCBOR deposit +-- BabelRegDelegCert cred (DelegVote drep) deposit -> +-- encodeListLen 4 +-- <> encodeWord8 12 +-- <> encCBOR cred +-- <> encCBOR drep +-- <> encCBOR deposit +-- BabelRegDelegCert cred (DelegStakeVote poolId dRep) deposit -> +-- encodeListLen 5 +-- <> encodeWord8 13 +-- <> encCBOR cred +-- <> encCBOR poolId +-- <> encCBOR dRep +-- <> encCBOR deposit + +-- encodeGovCert :: Crypto c => BabelGovCert c -> Encoding +-- encodeGovCert = \case +-- BabelAuthCommitteeHotKey cred key -> +-- encodeListLen 3 +-- <> encodeWord8 14 +-- <> encCBOR cred +-- <> encCBOR key +-- BabelResignCommitteeColdKey cred a -> +-- encodeListLen 3 +-- <> encodeWord8 15 +-- <> encCBOR cred +-- <> encodeNullStrictMaybe encCBOR a +-- BabelRegDRep cred deposit mAnchor -> +-- encodeListLen 4 +-- <> encodeWord8 16 +-- <> encCBOR cred +-- <> encCBOR deposit +-- <> encodeNullStrictMaybe encCBOR mAnchor +-- BabelUnRegDRep cred deposit -> +-- encodeListLen 3 +-- <> encodeWord8 17 +-- <> encCBOR cred +-- <> encCBOR deposit +-- BabelUpdateDRep cred mAnchor -> +-- encodeListLen 3 +-- <> encodeWord8 18 +-- <> encCBOR cred +-- <> encodeNullStrictMaybe encCBOR mAnchor + +fromShelleyDelegCert :: ShelleyDelegCert c -> BabelDelegCert c +fromShelleyDelegCert = \case + ShelleyRegCert cred -> BabelRegCert cred SNothing + ShelleyUnRegCert cred -> BabelUnRegCert cred SNothing + ShelleyDelegCert cred poolId -> BabelDelegCert cred (DelegStake poolId) + +toShelleyDelegCert :: BabelDelegCert c -> Maybe (ShelleyDelegCert c) +toShelleyDelegCert = \case + BabelRegCert cred SNothing -> Just $ ShelleyRegCert cred + BabelUnRegCert cred SNothing -> Just $ ShelleyUnRegCert cred + BabelDelegCert cred (DelegStake poolId) -> Just $ ShelleyDelegCert cred poolId + _ -> Nothing + +-- For both of the functions `getScriptWitnessBabelTxCert` and +-- `getVKeyWitnessBabelTxCert` we preserve the old behavior of not requiring a witness +-- for staking credential registration, but only during the transitional period of Babel +-- era and only for staking credential registration certificates without a deposit. Future +-- eras will require a witness for registration certificates, because the one without a +-- deposit will be removed. + +-- getScriptWitnessBabelTxCert :: +-- BabelTxCert era -> +-- Maybe (ScriptHash (EraCrypto era)) +-- getScriptWitnessBabelTxCert = \case +-- BabelTxCertDeleg delegCert -> +-- case delegCert of +-- BabelRegCert _ SNothing -> Nothing +-- BabelRegCert cred (SJust _) -> credScriptHash cred +-- BabelUnRegCert cred _ -> credScriptHash cred +-- BabelDelegCert cred _ -> credScriptHash cred +-- BabelRegDelegCert cred _ _ -> credScriptHash cred +-- -- PoolIds can't be Scripts +-- BabelTxCertPool {} -> Nothing +-- BabelTxCertGov govCert -> govWitness govCert +-- where +-- govWitness :: BabelGovCert c -> Maybe (ScriptHash c) +-- govWitness = \case +-- BabelAuthCommitteeHotKey coldCred _hotCred -> credScriptHash coldCred +-- BabelResignCommitteeColdKey coldCred _ -> credScriptHash coldCred +-- BabelRegDRep cred _ _ -> credScriptHash cred +-- BabelUnRegDRep cred _ -> credScriptHash cred +-- BabelUpdateDRep cred _ -> credScriptHash cred + +-- getVKeyWitnessBabelTxCert :: BabelTxCert era -> Maybe (KeyHash 'Witness (EraCrypto era)) +-- getVKeyWitnessBabelTxCert = \case +-- BabelTxCertDeleg delegCert -> +-- case delegCert of +-- BabelRegCert _ SNothing -> Nothing +-- BabelRegCert cred (SJust _) -> credKeyHashWitness cred +-- BabelUnRegCert cred _ -> credKeyHashWitness cred +-- BabelDelegCert cred _ -> credKeyHashWitness cred +-- BabelRegDelegCert cred _ _ -> credKeyHashWitness cred +-- BabelTxCertPool poolCert -> Just $ poolCertKeyHashWitness poolCert +-- BabelTxCertGov govCert -> govWitness govCert +-- where +-- govWitness :: BabelGovCert c -> Maybe (KeyHash 'Witness c) +-- govWitness = \case +-- BabelAuthCommitteeHotKey coldCred _hotCred -> credKeyHashWitness coldCred +-- BabelResignCommitteeColdKey coldCred _ -> credKeyHashWitness coldCred +-- BabelRegDRep cred _ _ -> credKeyHashWitness cred +-- BabelUnRegDRep cred _ -> credKeyHashWitness cred +-- BabelUpdateDRep cred _ -> credKeyHashWitness cred + +-- | Determine the total deposit amount needed from a TxBody. +-- The block may (legitimately) contain multiple registration certificates +-- for the same pool, where the first will be treated as a registration and +-- any subsequent ones as re-registration. As such, we must only take a +-- deposit for the first such registration. It is even possible for a single +-- transaction to have multiple pool registration for the same pool, so as +-- we process pool registrations, we must keep track of those that are already +-- registered, so we do not add a Deposit for the same pool twice. +-- +-- Note that this is not an issue for key registrations since subsequent +-- registration certificates would be invalid. +babelTotalDepositsTxCerts :: + (ConwayEraPParams era, Foldable f, BabelEraTxCert era) => + PParams era -> + -- | Check whether a pool with a supplied PoolStakeId is already registered. + (KeyHash 'StakePool (EraCrypto era) -> Bool) -> + f (TxCert era) -> + Coin +babelTotalDepositsTxCerts pp isRegPoolRegistered certs = + shelleyTotalDepositsTxCerts pp isRegPoolRegistered certs + <+> babelDRepDepositsTxCerts pp certs + +babelDRepDepositsTxCerts :: + (ConwayEraPParams era, Foldable f, BabelEraTxCert era) => + PParams era -> + f (TxCert era) -> + Coin +babelDRepDepositsTxCerts pp certs = nDReps <×> depositPerDRep + where + nDReps = getSum @Int (foldMap' (\case RegDRepTxCert {} -> 1; _ -> 0) certs) + depositPerDRep = pp ^. ppDRepDepositL + +-- | Compute the key deregistration refunds in a transaction +babelTotalRefundsTxCerts :: + (EraPParams era, Foldable f, BabelEraTxCert era) => + PParams era -> + -- | Function that can lookup current deposit, in case when the Staking credential is registered. + (Credential 'Staking (EraCrypto era) -> Maybe Coin) -> + -- | Function that can lookup current deposit, in case when the DRep credential is registered. + (Credential 'DRepRole (EraCrypto era) -> Maybe Coin) -> + f (TxCert era) -> + Coin +babelTotalRefundsTxCerts pp lookupStakingDeposit lookupDRepDeposit certs = + shelleyTotalRefundsTxCerts pp lookupStakingDeposit certs + <+> babelDRepRefundsTxCerts lookupDRepDeposit certs + +-- | Compute the Refunds from a TxBody, given a function that computes a partial Coin for +-- known Credentials. +babelDRepRefundsTxCerts :: + (Foldable f, BabelEraTxCert era) => + (Credential 'DRepRole (EraCrypto era) -> Maybe Coin) -> + f (TxCert era) -> + Coin +babelDRepRefundsTxCerts lookupDRepDeposit = snd . foldl' go (Map.empty, Coin 0) + where + go accum@(!drepRegsInTx, !totalRefund) = \case + RegDRepTxCert cred deposit _ -> + -- Track registrations + (Map.insert cred deposit drepRegsInTx, totalRefund) + UnRegDRepTxCert cred _ + -- DRep previously registered in the same tx. + | Just deposit <- Map.lookup cred drepRegsInTx -> + (Map.delete cred drepRegsInTx, totalRefund <+> deposit) + -- DRep previously registered in some other tx. + | Just deposit <- lookupDRepDeposit cred -> (drepRegsInTx, totalRefund <+> deposit) + _ -> accum diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/TxInfo.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/TxInfo.hs new file mode 100644 index 00000000000..c4b8766a0f9 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/TxInfo.hs @@ -0,0 +1,916 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.TxInfo ( + BabelContextError (..), + transTxBodyWithdrawals, + transTxCert, + transDRepCred, + transColdCommitteeCred, + transHotCommitteeCred, + transDelegatee, + transDRep, + transScriptPurpose, + transMap, + transTxInInfoV1, + transTxOutV1, +) where + +import Cardano.Crypto.Hash.Class (hashToBytes) +import Cardano.Ledger.Alonzo.Plutus.Context ( + EraPlutusContext (..), + EraPlutusTxInfo (..), + PlutusTxCert, + mkPlutusLanguageContext, + ) +import Cardano.Ledger.Alonzo.Plutus.TxInfo (AlonzoContextError (..), TxOutSource (..)) +import qualified Cardano.Ledger.Alonzo.Plutus.TxInfo as Alonzo +import Cardano.Ledger.Alonzo.Scripts (AlonzoPlutusPurpose (..), toAsItem) +import Cardano.Ledger.Babbage.TxInfo (BabbageContextError (..), transTxOutV2) +import qualified Cardano.Ledger.Babbage.TxInfo as Babbage +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Babel.Plutus.Context +import Cardano.Ledger.Babel.Scripts (BabelPlutusPurpose (..), PlutusScript (..)) +import Cardano.Ledger.Babel.Tx () +import Cardano.Ledger.Babel.TxCert +import Cardano.Ledger.BaseTypes ( + Inject (..), + ProtVer (..), + StrictMaybe (..), + getVersion64, + isSJust, + kindObject, + strictMaybe, + txIxToInt, + ) +import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) +import Cardano.Ledger.Binary.Coders ( + Decode (..), + Encode (..), + decode, + encode, + (!>), + ( EraPlutusContext (BabelEra c) where + type ContextError (BabelEra c) = BabelContextError (BabelEra c) + + mkPlutusScriptContext = \case + BabelPlutusV1 p -> mkPlutusLanguageContext p + BabelPlutusV2 p -> mkPlutusLanguageContext p + BabelPlutusV3 p -> mkPlutusLanguageContext p + BabelPlutusV4 p -> mkPlutusLanguageContext p + +data BabelContextError era + = BabbageContextError !(BabbageContextError era) + | CertificateNotSupported !(TxCert era) + | PlutusPurposeNotSupported !(PlutusPurpose AsItem era) + | CurrentTreasuryFieldNotSupported !Coin + | VotingProceduresFieldNotSupported !(VotingProcedures era) + | ProposalProceduresFieldNotSupported !(OSet.OSet (ProposalProcedure era)) + | TreasuryDonationFieldNotSupported !Coin + deriving (Generic) + +deriving instance + ( Eq (BabbageContextError era) + , Eq (TxCert era) + , Eq (PlutusPurpose AsItem era) + , Eq (PlutusPurpose AsIx era) + , EraPParams era + ) => + Eq (BabelContextError era) + +deriving instance + ( Show (BabbageContextError era) + , Show (TxCert era) + , Show (PlutusPurpose AsItem era) + , Show (PlutusPurpose AsIx era) + , EraPParams era + ) => + Show (BabelContextError era) + +instance Inject (BabelContextError era) (BabelContextError era) + +instance Inject (BabbageContextError era) (BabelContextError era) where + inject = BabbageContextError + +instance Inject (AlonzoContextError era) (BabelContextError era) where + inject = BabbageContextError . inject + +instance + ( NoThunks (TxCert era) + , NoThunks (PlutusPurpose AsIx era) + , NoThunks (PlutusPurpose AsItem era) + , EraPParams era + ) => + NoThunks (BabelContextError era) + +instance + ( EraPParams era + , NFData (TxCert era) + , NFData (PlutusPurpose AsIx era) + , NFData (PlutusPurpose AsItem era) + ) => + NFData (BabelContextError era) + +instance + ( EraPParams era + , EncCBOR (TxCert era) + , EncCBOR (PlutusPurpose AsIx era) + , EncCBOR (PlutusPurpose AsItem era) + ) => + EncCBOR (BabelContextError era) + where + encCBOR = \case + -- We start at tag 8, just in case to avoid clashes with previous eras. + BabbageContextError babbageContextError -> + encode $ Sum BabbageContextError 8 !> To babbageContextError + CertificateNotSupported txCert -> + encode $ Sum CertificateNotSupported 9 !> To txCert + PlutusPurposeNotSupported purpose -> + encode $ Sum PlutusPurposeNotSupported 10 !> To purpose + CurrentTreasuryFieldNotSupported scoin -> + encode $ Sum CurrentTreasuryFieldNotSupported 11 !> To scoin + VotingProceduresFieldNotSupported votingProcedures -> + encode $ Sum VotingProceduresFieldNotSupported 12 !> To votingProcedures + ProposalProceduresFieldNotSupported proposalProcedures -> + encode $ Sum ProposalProceduresFieldNotSupported 13 !> To proposalProcedures + TreasuryDonationFieldNotSupported coin -> + encode $ Sum TreasuryDonationFieldNotSupported 14 !> To coin + +instance + ( EraPParams era + , DecCBOR (TxCert era) + , DecCBOR (PlutusPurpose AsIx era) + , DecCBOR (PlutusPurpose AsItem era) + ) => + DecCBOR (BabelContextError era) + where + decCBOR = decode $ Summands "ContextError" $ \case + 8 -> SumD BabbageContextError SumD CertificateNotSupported SumD PlutusPurposeNotSupported SumD CurrentTreasuryFieldNotSupported SumD VotingProceduresFieldNotSupported SumD ProposalProceduresFieldNotSupported SumD TreasuryDonationFieldNotSupported Invalid n + +instance + ( ToJSON (TxCert era) + , ToJSON (PlutusPurpose AsIx era) + , ToJSON (PlutusPurpose AsItem era) + , EraPParams era + ) => + ToJSON (BabelContextError era) + where + toJSON = \case + BabbageContextError err -> toJSON err + CertificateNotSupported txCert -> + kindObject "CertificateNotSupported" ["certificate" .= toJSON txCert] + PlutusPurposeNotSupported purpose -> + kindObject "PlutusPurposeNotSupported" ["purpose" .= toJSON purpose] + CurrentTreasuryFieldNotSupported scoin -> + kindObject + "CurrentTreasuryFieldNotSupported" + ["current_treasury_value" .= toJSON scoin] + VotingProceduresFieldNotSupported votingProcedures -> + kindObject + "VotingProceduresFieldNotSupported" + ["voting_procedures" .= toJSON votingProcedures] + ProposalProceduresFieldNotSupported proposalProcedures -> + kindObject + "ProposalProceduresFieldNotSupported" + ["proposal_procedures" .= toJSON proposalProcedures] + TreasuryDonationFieldNotSupported coin -> + kindObject + "TreasuryDonationFieldNotSupported" + ["treasury_donation" .= toJSON coin] + +-- | Given a TxOut, translate it for V2 and return (Right transalation). +-- If the transaction contains any Byron addresses or Babbage features, return Left. +transTxOutV1 :: + forall era. + ( Inject (BabbageContextError era) (ContextError era) + , Value era ~ MaryValue (EraCrypto era) + , BabbageEraTxOut era + ) => + TxOutSource (EraCrypto era) -> + TxOut era -> + Either (ContextError era) PV1.TxOut +transTxOutV1 txOutSource txOut = do + when (isSJust (txOut ^. dataTxOutL)) $ do + Left $ inject $ InlineDatumsNotSupported @era txOutSource + case Alonzo.transTxOut txOut of + Nothing -> Left $ inject $ ByronTxOutInContext @era txOutSource + Just plutusTxOut -> Right plutusTxOut + +-- | Given a TxIn, look it up in the UTxO. If it exists, translate it to the V1 context +transTxInInfoV1 :: + forall era. + ( Inject (BabbageContextError era) (ContextError era) + , Value era ~ MaryValue (EraCrypto era) + , BabbageEraTxOut era + ) => + UTxO era -> + TxIn (EraCrypto era) -> + Either (ContextError era) PV1.TxInInfo +transTxInInfoV1 utxo txIn = do + txOut <- left (inject . AlonzoContextError @era) $ Alonzo.transLookupTxOut utxo txIn + plutusTxOut <- transTxOutV1 (TxOutFromInput txIn) txOut + Right (PV1.TxInInfo (TxInfo.transTxIn txIn) plutusTxOut) + +-- | Given a TxIn, look it up in the UTxO. If it exists, translate it to the V3 context +transTxInInfoV3 :: + forall era. + ( Inject (BabbageContextError era) (ContextError era) + , Value era ~ MaryValue (EraCrypto era) + , BabbageEraTxOut era + ) => + UTxO era -> + TxIn (EraCrypto era) -> + Either (ContextError era) PV3.TxInInfo +transTxInInfoV3 utxo txIn = do + txOut <- left (inject . AlonzoContextError @era) $ Alonzo.transLookupTxOut utxo txIn + plutusTxOut <- transTxOutV2 (TxOutFromInput txIn) txOut + Right (PV3.TxInInfo (transTxIn txIn) plutusTxOut) + +guardBabelFeaturesForPlutusV1V2 :: + forall era. + ( EraTx era + , BabelEraTxBody era + , Inject (BabelContextError era) (ContextError era) + ) => + Tx era -> + Either (ContextError era) () +guardBabelFeaturesForPlutusV1V2 tx = do + let txBody = tx ^. bodyTxL + currentTreasuryValue = txBody ^. currentTreasuryValueTxBodyL + votingProcedures = txBody ^. votingProceduresTxBodyL + proposalProcedures = txBody ^. proposalProceduresTxBodyL + treasuryDonation = txBody ^. treasuryDonationTxBodyL + unless (null $ unVotingProcedures votingProcedures) $ + Left $ + inject $ + VotingProceduresFieldNotSupported @era votingProcedures + unless (null proposalProcedures) $ + Left $ + inject $ + ProposalProceduresFieldNotSupported @era proposalProcedures + unless (treasuryDonation == Coin 0) $ + Left $ + inject $ + TreasuryDonationFieldNotSupported @era treasuryDonation + case currentTreasuryValue of + SNothing -> Right () + SJust treasury -> + Left $ inject $ CurrentTreasuryFieldNotSupported @era treasury + +transTxCertV1V2 :: + ( BabelEraTxCert era + , Inject (BabelContextError era) (ContextError era) + ) => + TxCert era -> + Either (ContextError era) PV1.DCert +transTxCertV1V2 = \case + RegDepositTxCert stakeCred _deposit -> + Right $ PV1.DCertDelegRegKey (PV1.StakingHash (transCred stakeCred)) + UnRegDepositTxCert stakeCred _refund -> + Right $ PV1.DCertDelegDeRegKey (PV1.StakingHash (transCred stakeCred)) + txCert + | Just dCert <- Alonzo.transTxCertCommon txCert -> Right dCert + | otherwise -> Left $ inject $ CertificateNotSupported txCert + +instance Crypto c => EraPlutusTxInfo 'PlutusV1 (BabelEra c) where + toPlutusTxCert _ = transTxCertV1V2 + + toPlutusScriptPurpose proxy = transPlutusPurposeV1V2 proxy . hoistPlutusPurpose toAsItem + + toPlutusTxInfo proxy pp epochInfo systemStart utxo tx = do + guardBabelFeaturesForPlutusV1V2 tx + timeRange <- Alonzo.transValidityInterval pp epochInfo systemStart (txBody ^. vldtTxBodyL) + inputs <- mapM (transTxInInfoV1 utxo) (Set.toList (txBody ^. inputsTxBodyL)) + mapM_ (transTxInInfoV1 utxo) (Set.toList (txBody ^. referenceInputsTxBodyL)) + outputs <- + zipWithM + (transTxOutV1 . TxOutFromOutput) + [minBound ..] + (F.toList (txBody ^. outputsTxBodyL)) + txCerts <- Alonzo.transTxBodyCerts proxy txBody + pure + PV1.TxInfo + { PV1.txInfoInputs = inputs + , PV1.txInfoOutputs = outputs + , PV1.txInfoFee = transCoinToValue (txBody ^. feeTxBodyL) + , PV1.txInfoMint = Alonzo.transMintValue (txBody ^. mintTxBodyL) + , PV1.txInfoDCert = txCerts + , PV1.txInfoWdrl = Alonzo.transTxBodyWithdrawals txBody + , PV1.txInfoValidRange = timeRange + , PV1.txInfoSignatories = Alonzo.transTxBodyReqSignerHashes txBody + , PV1.txInfoData = Alonzo.transTxWitsDatums (tx ^. witsTxL) + , PV1.txInfoId = Alonzo.transTxBodyId txBody + } + where + txBody = tx ^. bodyTxL + + toPlutusScriptContext proxy txInfo scriptPurpose = + PV1.ScriptContext txInfo <$> toPlutusScriptPurpose proxy scriptPurpose + +instance Crypto c => EraPlutusTxInfo 'PlutusV2 (BabelEra c) where + toPlutusTxCert _ = transTxCertV1V2 + + toPlutusScriptPurpose proxy = transPlutusPurposeV1V2 proxy . hoistPlutusPurpose toAsItem + + toPlutusTxInfo proxy pp epochInfo systemStart utxo tx = do + guardBabelFeaturesForPlutusV1V2 tx + timeRange <- Alonzo.transValidityInterval pp epochInfo systemStart (txBody ^. vldtTxBodyL) + inputs <- mapM (Babbage.transTxInInfoV2 utxo) (Set.toList (txBody ^. inputsTxBodyL)) + refInputs <- mapM (Babbage.transTxInInfoV2 utxo) (Set.toList (txBody ^. referenceInputsTxBodyL)) + outputs <- + zipWithM + (Babbage.transTxOutV2 . TxOutFromOutput) + [minBound ..] + (F.toList (txBody ^. outputsTxBodyL)) + txCerts <- Alonzo.transTxBodyCerts proxy txBody + plutusRedeemers <- Babbage.transTxRedeemers proxy tx + pure + PV2.TxInfo + { PV2.txInfoInputs = inputs + , PV2.txInfoOutputs = outputs + , PV2.txInfoReferenceInputs = refInputs + , PV2.txInfoFee = transCoinToValue (txBody ^. feeTxBodyL) + , PV2.txInfoMint = Alonzo.transMintValue (txBody ^. mintTxBodyL) + , PV2.txInfoDCert = txCerts + , PV2.txInfoWdrl = PV2.unsafeFromList $ Alonzo.transTxBodyWithdrawals txBody + , PV2.txInfoValidRange = timeRange + , PV2.txInfoSignatories = Alonzo.transTxBodyReqSignerHashes txBody + , PV2.txInfoRedeemers = plutusRedeemers + , PV2.txInfoData = PV2.unsafeFromList $ Alonzo.transTxWitsDatums (tx ^. witsTxL) + , PV2.txInfoId = Alonzo.transTxBodyId txBody + } + where + txBody = tx ^. bodyTxL + + toPlutusScriptContext proxy txInfo scriptPurpose = + PV2.ScriptContext txInfo <$> toPlutusScriptPurpose proxy scriptPurpose + +instance Crypto c => EraPlutusTxInfo 'PlutusV3 (BabelEra c) where + toPlutusTxCert _ = pure . transTxCert + + toPlutusScriptPurpose = transScriptPurpose + + toPlutusTxInfo proxy pp epochInfo systemStart utxo tx = do + timeRange <- Alonzo.transValidityInterval pp epochInfo systemStart (txBody ^. vldtTxBodyL) + -- TODO WG: realizedInputs. Add realizedFulfills here. Put them in PV4 TxInfo. + inputs <- mapM (transTxInInfoV3 utxo) (Set.toList (txBody ^. inputsTxBodyL)) + refInputs <- mapM (transTxInInfoV3 utxo) (Set.toList (txBody ^. referenceInputsTxBodyL)) + outputs <- + zipWithM + (Babbage.transTxOutV2 . TxOutFromOutput) + [minBound ..] + (F.toList (txBody ^. outputsTxBodyL)) + txCerts <- Alonzo.transTxBodyCerts proxy txBody + plutusRedeemers <- Babbage.transTxRedeemers proxy tx + pure + PV3.TxInfo + { PV3.txInfoInputs = inputs + , PV3.txInfoOutputs = outputs + , PV3.txInfoReferenceInputs = refInputs + , PV3.txInfoFee = transCoinToLovelace (txBody ^. feeTxBodyL) + , PV3.txInfoMint = Alonzo.transMultiAsset (txBody ^. mintTxBodyL) + , PV3.txInfoTxCerts = txCerts + , PV3.txInfoWdrl = transTxBodyWithdrawals txBody + , PV3.txInfoValidRange = timeRange + , PV3.txInfoSignatories = Alonzo.transTxBodyReqSignerHashes txBody + , PV3.txInfoRedeemers = plutusRedeemers + , PV3.txInfoData = PV3.unsafeFromList $ Alonzo.transTxWitsDatums (tx ^. witsTxL) + , PV3.txInfoId = transTxBodyId txBody + , PV3.txInfoVotes = transVotingProcedures (txBody ^. votingProceduresTxBodyL) + , PV3.txInfoProposalProcedures = + map (transProposal proxy) $ toList (txBody ^. proposalProceduresTxBodyL) + , PV3.txInfoCurrentTreasuryAmount = + strictMaybe Nothing (Just . transCoinToLovelace) $ txBody ^. currentTreasuryValueTxBodyL + , PV3.txInfoTreasuryDonation = + case txBody ^. treasuryDonationTxBodyL of + Coin 0 -> Nothing + coin -> Just $ transCoinToLovelace coin + } + where + txBody = tx ^. bodyTxL + + toPlutusScriptContext proxy txInfo scriptPurpose = do + let redeemers :: PMap.Map PV3.ScriptPurpose PV3.Redeemer = PV3.txInfoRedeemers txInfo + purpose <- toPlutusScriptPurpose proxy scriptPurpose + let redeemer = fromJust $ PMap.lookup purpose redeemers -- TODO WG obviously partial + pure $ PV3.ScriptContext txInfo redeemer (fromScriptPurpose purpose) + +fromScriptPurpose :: PV3.ScriptPurpose -> PV3.ScriptInfo +fromScriptPurpose = \case + PV3.Minting cs -> PV3.MintingScript cs + PV3.Spending txOutRef -> PV3.SpendingScript txOutRef Nothing + PV3.Rewarding cred -> PV3.RewardingScript cred + PV3.Certifying index txCert -> PV3.CertifyingScript index txCert + PV3.Voting voter -> PV3.VotingScript voter + PV3.Proposing index proposal -> PV3.ProposingScript index proposal + +transTxId :: TxId c -> PV3.TxId +transTxId txId = PV3.TxId (transSafeHash (unTxId txId)) + +transTxBodyId :: EraTxBody era => TxBody era -> PV3.TxId +transTxBodyId txBody = PV3.TxId (transSafeHash (hashAnnotated txBody)) + +transTxIn :: TxIn c -> PV3.TxOutRef +transTxIn (TxIn txid txIx) = PV3.TxOutRef (transTxId txid) (toInteger (txIxToInt txIx)) + +-- | Translate all `Withdrawal`s from within a `TxBody` +transTxBodyWithdrawals :: EraTxBody era => TxBody era -> PV3.Map PV3.Credential PV3.Lovelace +transTxBodyWithdrawals txBody = + transMap transRewardAccount transCoinToLovelace (unWithdrawals $ txBody ^. withdrawalsTxBodyL) + +transTxCert :: BabelEraTxCert era => TxCert era -> PV3.TxCert +transTxCert = \case + RegPoolTxCert PoolParams {ppId, ppVrf} -> + PV3.TxCertPoolRegister (transKeyHash ppId) (PV3.PubKeyHash (PV3.toBuiltin (hashToBytes ppVrf))) + RetirePoolTxCert poolId retireEpochNo -> + PV3.TxCertPoolRetire (transKeyHash poolId) (transEpochNo retireEpochNo) + RegTxCert stakeCred -> + PV3.TxCertRegStaking (transCred stakeCred) Nothing + UnRegTxCert stakeCred -> + PV3.TxCertUnRegStaking (transCred stakeCred) Nothing + RegDepositTxCert stakeCred deposit -> + PV3.TxCertRegStaking (transCred stakeCred) (Just (transCoinToLovelace deposit)) + UnRegDepositTxCert stakeCred refund -> + PV3.TxCertUnRegStaking (transCred stakeCred) (Just (transCoinToLovelace refund)) + DelegTxCert stakeCred delegatee -> + PV3.TxCertDelegStaking (transCred stakeCred) (transDelegatee delegatee) + RegDepositDelegTxCert stakeCred delegatee deposit -> + PV3.TxCertRegDeleg (transCred stakeCred) (transDelegatee delegatee) (transCoinToLovelace deposit) + AuthCommitteeHotKeyTxCert coldCred hotCred -> + PV3.TxCertAuthHotCommittee (transColdCommitteeCred coldCred) (transHotCommitteeCred hotCred) + ResignCommitteeColdTxCert coldCred _anchor -> + PV3.TxCertResignColdCommittee (transColdCommitteeCred coldCred) + RegDRepTxCert drepCred deposit _anchor -> + PV3.TxCertRegDRep (transDRepCred drepCred) (transCoinToLovelace deposit) + UnRegDRepTxCert drepCred refund -> + PV3.TxCertUnRegDRep (transDRepCred drepCred) (transCoinToLovelace refund) + UpdateDRepTxCert drepCred _anchor -> + PV3.TxCertUpdateDRep (transDRepCred drepCred) + +transDRepCred :: Credential 'DRepRole c -> PV3.DRepCredential +transDRepCred = PV3.DRepCredential . transCred + +transColdCommitteeCred :: Credential 'ColdCommitteeRole c -> PV3.ColdCommitteeCredential +transColdCommitteeCred = PV3.ColdCommitteeCredential . transCred + +transHotCommitteeCred :: Credential 'HotCommitteeRole c -> PV3.HotCommitteeCredential +transHotCommitteeCred = PV3.HotCommitteeCredential . transCred + +transDelegatee :: Delegatee c -> PV3.Delegatee +transDelegatee = \case + DelegStake poolId -> PV3.DelegStake (transKeyHash poolId) + DelegVote drep -> PV3.DelegVote (transDRep drep) + DelegStakeVote poolId drep -> PV3.DelegStakeVote (transKeyHash poolId) (transDRep drep) + +transDRep :: DRep c -> PV3.DRep +transDRep = \case + DRepCredential drepCred -> PV3.DRep (transDRepCred drepCred) + DRepAlwaysAbstain -> PV3.DRepAlwaysAbstain + DRepAlwaysNoConfidence -> PV3.DRepAlwaysNoConfidence + +-- | In Babel we have `Anchor`s in some certificates and all proposals. However, because +-- we do not translate anchors to plutus context, it is not always possible to deduce +-- which item the script purpose is responsible for, without also including the index for +-- that item. For this reason starting with PlutusV3, besides the item, `PV3.Certifying` +-- and `PV3.Proposing` also have an index. Moreover, other script purposes rely on Ledger +-- `Ord` instances for types that dictate the order, so it might not be a good idea to pass +-- that information to Plutus for those purposes. +transScriptPurpose :: + (ConwayEraPlutusTxInfo l era, PlutusTxCert l ~ PV3.TxCert) => + proxy l -> + BabelPlutusPurpose AsIxItem era -> + Either (ContextError era) PV3.ScriptPurpose +transScriptPurpose proxy = \case + BabelSpending (AsIxItem _ txIn) -> pure $ PV3.Spending (transTxIn txIn) + BabelMinting (AsIxItem _ policyId) -> pure $ PV3.Minting (Alonzo.transPolicyID policyId) + BabelCertifying (AsIxItem ix txCert) -> + PV3.Certifying (toInteger ix) <$> toPlutusTxCert proxy txCert + BabelRewarding (AsIxItem _ rewardAccount) -> pure $ PV3.Rewarding (transRewardAccount rewardAccount) + BabelVoting (AsIxItem _ voter) -> pure $ PV3.Voting (transVoter voter) + BabelProposing (AsIxItem ix proposal) -> + pure $ PV3.Proposing (toInteger ix) (transProposal proxy proposal) + +transVoter :: Voter c -> PV3.Voter +transVoter = \case + CommitteeVoter cred -> PV3.CommitteeVoter $ PV3.HotCommitteeCredential $ transCred cred + DRepVoter cred -> PV3.DRepVoter $ PV3.DRepCredential $ transCred cred + StakePoolVoter keyHash -> PV3.StakePoolVoter $ transKeyHash keyHash + +transGovActionId :: GovActionId c -> PV3.GovernanceActionId +transGovActionId GovActionId {gaidTxId, gaidGovActionIx} = + PV3.GovernanceActionId + { PV3.gaidTxId = transTxId gaidTxId + , PV3.gaidGovActionIx = toInteger $ unGovActionIx gaidGovActionIx + } + +transGovAction :: ConwayEraPlutusTxInfo l era => proxy l -> GovAction era -> PV3.GovernanceAction +transGovAction proxy = \case + ParameterChange pGovActionId ppu govPolicy -> + PV3.ParameterChange + (transPrevGovActionId pGovActionId) + (toPlutusChangedParameters proxy ppu) + (transGovPolicy govPolicy) + HardForkInitiation pGovActionId protVer -> + PV3.HardForkInitiation + (transPrevGovActionId pGovActionId) + (transProtVer protVer) + TreasuryWithdrawals withdrawals govPolicy -> + PV3.TreasuryWithdrawals + (transMap transRewardAccount transCoinToLovelace withdrawals) + (transGovPolicy govPolicy) + NoConfidence pGovActionId -> PV3.NoConfidence (transPrevGovActionId pGovActionId) + UpdateCommittee pGovActionId ccToRemove ccToAdd threshold -> + PV3.UpdateCommittee + (transPrevGovActionId pGovActionId) + (map (PV3.ColdCommitteeCredential . transCred) $ Set.toList ccToRemove) + (transMap (PV3.ColdCommitteeCredential . transCred) transEpochNo ccToAdd) + (transBoundedRational threshold) + NewConstitution pGovActionId constitution -> + PV3.NewConstitution + (transPrevGovActionId pGovActionId) + (transConstitution constitution) + InfoAction -> PV3.InfoAction + where + transGovPolicy = \case + SJust govPolicy -> Just (transScriptHash govPolicy) + SNothing -> Nothing + transConstitution (Constitution _ govPolicy) = + PV3.Constitution (transGovPolicy govPolicy) + transPrevGovActionId = \case + SJust (GovPurposeId gaId) -> Just (transGovActionId gaId) + SNothing -> Nothing + +transMap :: (t1 -> k) -> (t2 -> v) -> Map.Map t1 t2 -> PV3.Map k v +transMap transKey transValue = + PV3.unsafeFromList . map (\(k, v) -> (transKey k, transValue v)) . Map.toList + +transVotingProcedures :: + VotingProcedures era -> PV3.Map PV3.Voter (PV3.Map PV3.GovernanceActionId PV3.Vote) +transVotingProcedures = + transMap transVoter (transMap transGovActionId (transVote . vProcVote)) . unVotingProcedures + +transVote :: Vote -> PV3.Vote +transVote = \case + VoteNo -> PV3.VoteNo + VoteYes -> PV3.VoteYes + Abstain -> PV3.Abstain + +transProposal :: + ConwayEraPlutusTxInfo l era => + proxy l -> + ProposalProcedure era -> + PV3.ProposalProcedure +transProposal proxy ProposalProcedure {pProcDeposit, pProcReturnAddr, pProcGovAction} = + PV3.ProposalProcedure + { PV3.ppDeposit = transCoinToLovelace pProcDeposit + , PV3.ppReturnAddr = transRewardAccount pProcReturnAddr + , PV3.ppGovernanceAction = transGovAction proxy pProcGovAction + } + +transPlutusPurposeV1V2 :: + ( PlutusTxCert l ~ PV2.DCert + , PlutusPurpose AsItem era ~ BabelPlutusPurpose AsItem era + , EraPlutusTxInfo l era + , Inject (BabelContextError era) (ContextError era) + ) => + proxy l -> + BabelPlutusPurpose AsItem era -> + Either (ContextError era) PV2.ScriptPurpose +transPlutusPurposeV1V2 proxy = \case + BabelSpending txIn -> Alonzo.transPlutusPurpose proxy $ AlonzoSpending txIn + BabelMinting policyId -> Alonzo.transPlutusPurpose proxy $ AlonzoMinting policyId + BabelCertifying txCert -> Alonzo.transPlutusPurpose proxy $ AlonzoCertifying txCert + BabelRewarding rewardAccount -> Alonzo.transPlutusPurpose proxy $ AlonzoRewarding rewardAccount + purpose -> Left $ inject $ PlutusPurposeNotSupported purpose + +transProtVer :: ProtVer -> PV3.ProtocolVersion +transProtVer (ProtVer major minor) = + PV3.ProtocolVersion (toInteger (getVersion64 major)) (toInteger minor) + +instance Crypto c => EraPlutusTxInfo 'PlutusV4 (BabelEra c) where + toPlutusTxCert _ = pure . transTxCertV4 + + toPlutusScriptPurpose = transScriptPurposeV4 + + toPlutusTxInfo proxy pp epochInfo systemStart utxo tx = do + timeRange <- Alonzo.transValidityInterval pp epochInfo systemStart (txBody ^. vldtTxBodyL) + -- TODO WG: realizedInputs. Add realizedFulfills here. Put them in PV4 TxInfo. + inputs <- mapM (transTxInInfoV4 utxo) (Set.toList (txBody ^. inputsTxBodyL)) + refInputs <- mapM (transTxInInfoV4 utxo) (Set.toList (txBody ^. referenceInputsTxBodyL)) + outputs <- + zipWithM + (Babbage.transTxOutV2 . TxOutFromOutput) + [minBound ..] + (F.toList (txBody ^. outputsTxBodyL)) + txCerts <- Alonzo.transTxBodyCerts proxy txBody + plutusRedeemers <- Babbage.transTxRedeemers proxy tx + pure + PV4.TxInfo + { PV4.txInfoInputs = inputs + , PV4.txInfoOutputs = outputs + , PV4.txInfoReferenceInputs = refInputs + , PV4.txInfoFee = transCoinToLovelace (txBody ^. feeTxBodyL) + , PV4.txInfoMint = Alonzo.transMultiAsset (txBody ^. mintTxBodyL) + , PV4.txInfoTxCerts = txCerts + , PV4.txInfoWdrl = transTxBodyWithdrawals txBody + , PV4.txInfoValidRange = timeRange + , PV4.txInfoSignatories = Alonzo.transTxBodyReqSignerHashes txBody + , PV4.txInfoRedeemers = plutusRedeemers + , PV4.txInfoData = PV3.unsafeFromList $ Alonzo.transTxWitsDatums (tx ^. witsTxL) + , PV4.txInfoId = transTxBodyId txBody + , PV4.txInfoVotes = transVotingProceduresV4 (txBody ^. votingProceduresTxBodyL) + , PV4.txInfoProposalProcedures = + map (transProposalV4 proxy) $ toList (txBody ^. proposalProceduresTxBodyL) + , PV4.txInfoCurrentTreasuryAmount = + strictMaybe Nothing (Just . transCoinToLovelace) $ txBody ^. currentTreasuryValueTxBodyL + , PV4.txInfoTreasuryDonation = + case txBody ^. treasuryDonationTxBodyL of + Coin 0 -> Nothing + coin -> Just $ transCoinToLovelace coin + , PV4.txInfoFulfills = undefined + , PV4.txInfoRequests = undefined + , PV4.txInfoRequiredTxs = undefined + } + where + txBody = tx ^. bodyTxL + + toPlutusScriptContext proxy txInfo scriptPurpose = do + let redeemers :: PMap.Map PV4.ScriptPurpose PV4.Redeemer = PV4.txInfoRedeemers txInfo + purpose <- toPlutusScriptPurpose proxy scriptPurpose + let redeemer = fromJust $ PMap.lookup purpose redeemers -- TODO WG obviously partial + pure $ PV4.ScriptContext txInfo redeemer (fromScriptPurposeV4 purpose) + +-- | Given a TxIn, look it up in the UTxO. If it exists, translate it to the V4 context +transTxInInfoV4 :: + forall era. + ( Inject (BabbageContextError era) (ContextError era) + , Value era ~ MaryValue (EraCrypto era) + , BabbageEraTxOut era + ) => + UTxO era -> + TxIn (EraCrypto era) -> + Either (ContextError era) PV4.TxInInfo +transTxInInfoV4 utxo txIn = do + txOut <- left (inject . AlonzoContextError @era) $ Alonzo.transLookupTxOut utxo txIn + plutusTxOut <- transTxOutV2 (TxOutFromInput txIn) txOut + Right (PV4.TxInInfo (transTxIn txIn) plutusTxOut) + +fromScriptPurposeV4 :: PV4.ScriptPurpose -> PV4.ScriptInfo +fromScriptPurposeV4 = \case + PV4.Minting cs -> PV4.MintingScript cs + PV4.Spending txOutRef -> PV4.SpendingScript txOutRef Nothing + PV4.Rewarding cred -> PV4.RewardingScript cred + PV4.Certifying index txCert -> PV4.CertifyingScript index txCert + PV4.Voting voter -> PV4.VotingScript voter + PV4.Proposing index proposal -> PV4.ProposingScript index proposal + +transTxCertV4 :: BabelEraTxCert era => TxCert era -> PV4.TxCert +transTxCertV4 = \case + RegPoolTxCert PoolParams {ppId, ppVrf} -> + PV4.TxCertPoolRegister (transKeyHash ppId) (PV4.PubKeyHash (PV4.toBuiltin (hashToBytes ppVrf))) + RetirePoolTxCert poolId retireEpochNo -> + PV4.TxCertPoolRetire (transKeyHash poolId) (transEpochNo retireEpochNo) + RegTxCert stakeCred -> + PV4.TxCertRegStaking (transCred stakeCred) Nothing + UnRegTxCert stakeCred -> + PV4.TxCertUnRegStaking (transCred stakeCred) Nothing + RegDepositTxCert stakeCred deposit -> + PV4.TxCertRegStaking (transCred stakeCred) (Just (transCoinToLovelace deposit)) + UnRegDepositTxCert stakeCred refund -> + PV4.TxCertUnRegStaking (transCred stakeCred) (Just (transCoinToLovelace refund)) + DelegTxCert stakeCred delegatee -> + PV4.TxCertDelegStaking (transCred stakeCred) (transDelegateeV4 delegatee) + RegDepositDelegTxCert stakeCred delegatee deposit -> + PV4.TxCertRegDeleg (transCred stakeCred) (transDelegateeV4 delegatee) (transCoinToLovelace deposit) + AuthCommitteeHotKeyTxCert coldCred hotCred -> + PV4.TxCertAuthHotCommittee (transColdCommitteeCredV4 coldCred) (transHotCommitteeCredV4 hotCred) + ResignCommitteeColdTxCert coldCred _anchor -> + PV4.TxCertResignColdCommittee (transColdCommitteeCredV4 coldCred) + RegDRepTxCert drepCred deposit _anchor -> + PV4.TxCertRegDRep (transDRepCredV4 drepCred) (transCoinToLovelace deposit) + UnRegDRepTxCert drepCred refund -> + PV4.TxCertUnRegDRep (transDRepCredV4 drepCred) (transCoinToLovelace refund) + UpdateDRepTxCert drepCred _anchor -> + PV4.TxCertUpdateDRep (transDRepCredV4 drepCred) + +transDRepCredV4 :: Credential 'DRepRole c -> PV4.DRepCredential +transDRepCredV4 = PV4.DRepCredential . transCred + +transColdCommitteeCredV4 :: Credential 'ColdCommitteeRole c -> PV4.ColdCommitteeCredential +transColdCommitteeCredV4 = PV4.ColdCommitteeCredential . transCred + +transHotCommitteeCredV4 :: Credential 'HotCommitteeRole c -> PV4.HotCommitteeCredential +transHotCommitteeCredV4 = PV4.HotCommitteeCredential . transCred + +transDelegateeV4 :: Delegatee c -> PV4.Delegatee +transDelegateeV4 = \case + DelegStake poolId -> PV4.DelegStake (transKeyHash poolId) + DelegVote drep -> PV4.DelegVote (transDRepV4 drep) + DelegStakeVote poolId drep -> PV4.DelegStakeVote (transKeyHash poolId) (transDRepV4 drep) + +transDRepV4 :: DRep c -> PV4.DRep +transDRepV4 = \case + DRepCredential drepCred -> PV4.DRep (transDRepCredV4 drepCred) + DRepAlwaysAbstain -> PV4.DRepAlwaysAbstain + DRepAlwaysNoConfidence -> PV4.DRepAlwaysNoConfidence + +-- | In Babel we have `Anchor`s in some certificates and all proposals. However, because +-- we do not translate anchors to plutus context, it is not always possible to deduce +-- which item the script purpose is responsible for, without also including the index for +-- that item. For this reason starting with PlutusV3, besides the item, `PV3.Certifying` +-- and `PV3.Proposing` also have an index. Moreover, other script purposes rely on Ledger +-- `Ord` instances for types that dictate the order, so it might not be a good idea to pass +-- that information to Plutus for those purposes. +transScriptPurposeV4 :: + (BabelEraPlutusTxInfo l era, PlutusTxCert l ~ PV4.TxCert) => + proxy l -> + BabelPlutusPurpose AsIxItem era -> + Either (ContextError era) PV4.ScriptPurpose +transScriptPurposeV4 proxy = \case + BabelSpending (AsIxItem _ txIn) -> pure $ PV4.Spending (transTxIn txIn) + BabelMinting (AsIxItem _ policyId) -> pure $ PV4.Minting (Alonzo.transPolicyID policyId) + BabelCertifying (AsIxItem ix txCert) -> + PV4.Certifying (toInteger ix) <$> toPlutusTxCert proxy txCert + BabelRewarding (AsIxItem _ rewardAccount) -> pure $ PV4.Rewarding (transRewardAccount rewardAccount) + BabelVoting (AsIxItem _ voter) -> pure $ PV4.Voting (transVoterV4 voter) + BabelProposing (AsIxItem ix proposal) -> + pure $ PV4.Proposing (toInteger ix) (transProposalV4 proxy proposal) + +transVoterV4 :: Voter c -> PV4.Voter +transVoterV4 = \case + CommitteeVoter cred -> PV4.CommitteeVoter $ PV4.HotCommitteeCredential $ transCred cred + DRepVoter cred -> PV4.DRepVoter $ PV4.DRepCredential $ transCred cred + StakePoolVoter keyHash -> PV4.StakePoolVoter $ transKeyHash keyHash + +transGovActionIdV4 :: GovActionId c -> PV4.GovernanceActionId +transGovActionIdV4 GovActionId {gaidTxId, gaidGovActionIx} = + PV4.GovernanceActionId + { PV4.gaidTxId = transTxId gaidTxId + , PV4.gaidGovActionIx = toInteger $ unGovActionIx gaidGovActionIx + } + +transGovActionV4 :: + BabelEraPlutusTxInfo l era => proxy l -> GovAction era -> PV4.GovernanceAction +transGovActionV4 proxy = \case + ParameterChange pGovActionId ppu govPolicy -> + PV4.ParameterChange + (transPrevGovActionId pGovActionId) + (toBabelPlutusChangedParameters proxy ppu) + (transGovPolicy govPolicy) + HardForkInitiation pGovActionId protVer -> + PV4.HardForkInitiation + (transPrevGovActionId pGovActionId) + (transProtVerV4 protVer) + TreasuryWithdrawals withdrawals govPolicy -> + PV4.TreasuryWithdrawals + (transMap transRewardAccount transCoinToLovelace withdrawals) + (transGovPolicy govPolicy) + NoConfidence pGovActionId -> PV4.NoConfidence (transPrevGovActionId pGovActionId) + UpdateCommittee pGovActionId ccToRemove ccToAdd threshold -> + PV4.UpdateCommittee + (transPrevGovActionId pGovActionId) + (map (PV4.ColdCommitteeCredential . transCred) $ Set.toList ccToRemove) + (transMap (PV4.ColdCommitteeCredential . transCred) transEpochNo ccToAdd) + (transBoundedRational threshold) + NewConstitution pGovActionId constitution -> + PV4.NewConstitution + (transPrevGovActionId pGovActionId) + (transConstitution constitution) + InfoAction -> PV4.InfoAction + where + transGovPolicy = \case + SJust govPolicy -> Just (transScriptHash govPolicy) + SNothing -> Nothing + transConstitution (Constitution _ govPolicy) = + PV4.Constitution (transGovPolicy govPolicy) + transPrevGovActionId = \case + SJust (GovPurposeId gaId) -> Just (transGovActionIdV4 gaId) + SNothing -> Nothing + +transVotingProceduresV4 :: + VotingProcedures era -> PV4.Map PV4.Voter (PV4.Map PV4.GovernanceActionId PV4.Vote) +transVotingProceduresV4 = + transMap transVoterV4 (transMap transGovActionIdV4 (transVoteV4 . vProcVote)) . unVotingProcedures + +transVoteV4 :: Vote -> PV4.Vote +transVoteV4 = \case + VoteNo -> PV4.VoteNo + VoteYes -> PV4.VoteYes + Abstain -> PV4.Abstain + +transProposalV4 :: + BabelEraPlutusTxInfo l era => + proxy l -> + ProposalProcedure era -> + PV4.ProposalProcedure +transProposalV4 proxy ProposalProcedure {pProcDeposit, pProcReturnAddr, pProcGovAction} = + PV4.ProposalProcedure + { PV4.ppDeposit = transCoinToLovelace pProcDeposit + , PV4.ppReturnAddr = transRewardAccount pProcReturnAddr + , PV4.ppGovernanceAction = transGovActionV4 proxy pProcGovAction + } + +transProtVerV4 :: ProtVer -> PV4.ProtocolVersion +transProtVerV4 (ProtVer major minor) = + PV4.ProtocolVersion (toInteger (getVersion64 major)) (toInteger minor) + +-- ========================== +-- Instances + +instance PlutusTx.Eq.Eq PV4.ScriptPurpose where + (==) = undefined -- TODO WG (I don't want to go and recalculate the hashes of my forked Plutus repo) + +instance Crypto c => ToPlutusData (PParamsUpdate (BabelEra c)) where + toPlutusData = pparamUpdateToData conwayPParamMap + fromPlutusData = pparamUpdateFromData conwayPParamMap + +instance Crypto c => ConwayEraPlutusTxInfo 'PlutusV3 (BabelEra c) where + toPlutusChangedParameters _ x = PV3.ChangedParameters (PV3.dataToBuiltinData (toPlutusData x)) + +instance Crypto c => BabelEraPlutusTxInfo 'PlutusV4 (BabelEra c) where + toBabelPlutusChangedParameters _ x = PV4.ChangedParameters (PV4.dataToBuiltinData (toPlutusData x)) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/TxOut.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/TxOut.hs new file mode 100644 index 00000000000..59d28770609 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/TxOut.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.TxOut () where + +import Cardano.Ledger.Address (addrPtrNormalize) +import Cardano.Ledger.Babbage.Core +import Cardano.Ledger.Babbage.TxOut ( + BabbageTxOut (..), + addrEitherBabbageTxOutL, + babbageMinUTxOValue, + dataBabbageTxOutL, + dataHashBabbageTxOutL, + datumBabbageTxOutL, + getDatumBabbageTxOut, + referenceScriptBabbageTxOutL, + valueEitherBabbageTxOutL, + ) +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Babel.PParams () +import Cardano.Ledger.Babel.Scripts () +import Cardano.Ledger.Crypto +import Cardano.Ledger.Plutus.Data (Datum (..), translateDatum) +import Data.Maybe.Strict (StrictMaybe (..)) +import Lens.Micro + +instance Crypto c => EraTxOut (BabelEra c) where + {-# SPECIALIZE instance EraTxOut (BabelEra StandardCrypto) #-} + + type TxOut (BabelEra c) = BabbageTxOut (BabelEra c) + + mkBasicTxOut addr vl = BabbageTxOut addr vl NoDatum SNothing + + upgradeTxOut (BabbageTxOut addr value d s) = + BabbageTxOut (addrPtrNormalize addr) value (translateDatum d) (upgradeScript <$> s) + + addrEitherTxOutL = addrEitherBabbageTxOutL + {-# INLINE addrEitherTxOutL #-} + + valueEitherTxOutL = valueEitherBabbageTxOutL + {-# INLINE valueEitherTxOutL #-} + + getMinCoinSizedTxOut = babbageMinUTxOValue + +instance Crypto c => AlonzoEraTxOut (BabelEra c) where + {-# SPECIALIZE instance AlonzoEraTxOut (BabelEra StandardCrypto) #-} + + dataHashTxOutL = dataHashBabbageTxOutL + {-# INLINE dataHashTxOutL #-} + + datumTxOutF = to getDatumBabbageTxOut + {-# INLINE datumTxOutF #-} + +instance Crypto c => BabbageEraTxOut (BabelEra c) where + {-# SPECIALIZE instance BabbageEraTxOut (BabelEra StandardCrypto) #-} + + dataTxOutL = dataBabbageTxOutL + {-# INLINE dataTxOutL #-} + + datumTxOutL = datumBabbageTxOutL + {-# INLINE datumTxOutL #-} + + referenceScriptTxOutL = referenceScriptBabbageTxOutL + {-# INLINE referenceScriptTxOutL #-} diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/TxWits.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/TxWits.hs new file mode 100644 index 00000000000..527ed2dcbc2 --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/TxWits.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.TxWits ( + module BabbageTxWitsReExport, +) +where + +import Cardano.Ledger.Alonzo.TxWits ( + addrAlonzoTxWitsL, + bootAddrAlonzoTxWitsL, + datsAlonzoTxWitsL, + rdmrsAlonzoTxWitsL, + scriptAlonzoTxWitsL, + upgradeRedeemers, + upgradeTxDats, + ) +import Cardano.Ledger.Alonzo.TxWits as BabbageTxWitsReExport ( + AlonzoEraTxWits (..), + AlonzoTxWits (..), + ) +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.Babel.Scripts () +import Cardano.Ledger.Core +import Cardano.Ledger.Crypto + +instance Crypto c => EraTxWits (BabelEra c) where + {-# SPECIALIZE instance EraTxWits (BabelEra StandardCrypto) #-} + + type TxWits (BabelEra c) = AlonzoTxWits (BabelEra c) + + mkBasicTxWits = mempty + + addrTxWitsL = addrAlonzoTxWitsL + {-# INLINE addrTxWitsL #-} + + bootAddrTxWitsL = bootAddrAlonzoTxWitsL + {-# INLINE bootAddrTxWitsL #-} + + scriptTxWitsL = scriptAlonzoTxWitsL + {-# INLINE scriptTxWitsL #-} + + upgradeTxWits atw = + AlonzoTxWits + { txwitsVKey = txwitsVKey atw + , txwitsBoot = txwitsBoot atw + , txscripts = upgradeScript <$> txscripts atw + , txdats = upgradeTxDats (txdats atw) + , txrdmrs = upgradeRedeemers (txrdmrs atw) + } + +instance Crypto c => AlonzoEraTxWits (BabelEra c) where + {-# SPECIALIZE instance AlonzoEraTxWits (BabelEra StandardCrypto) #-} + + datsTxWitsL = datsAlonzoTxWitsL + {-# INLINE datsTxWitsL #-} + + rdmrsTxWitsL = rdmrsAlonzoTxWitsL + {-# INLINE rdmrsTxWitsL #-} diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/UTxO.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/UTxO.hs new file mode 100644 index 00000000000..48af478772b --- /dev/null +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/UTxO.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Cardano.Ledger.Babel.UTxO ( + babelProducedValue, + getBabelWitsVKeyNeeded, +) where + +import Cardano.Ledger.Alonzo.UTxO ( + AlonzoEraUTxO (..), + AlonzoScriptsNeeded (..), + getAlonzoScriptsHashesNeeded, + getMintingScriptsNeeded, + getRewardingScriptsNeeded, + getSpendingScriptsNeeded, + zipAsIxItem, + ) +import Cardano.Ledger.Babbage.UTxO ( + getBabbageScriptsProvided, + getBabbageSpendingDatum, + getBabbageSupplementalDataHashes, + getReferenceScriptsNonDistinct, + ) +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Era (BabelEra) +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) +import Cardano.Ledger.Coin (Coin) +import Cardano.Ledger.Conway.Core ( + ConwayEraTxBody (proposalProceduresTxBodyL, votingProceduresTxBodyL), + treasuryDonationTxBodyL, + ) +import Cardano.Ledger.Conway.Governance ( + GovAction (..), + ProposalProcedure (..), + Voter (..), + unVotingProcedures, + ) +import Cardano.Ledger.Credential (credKeyHashWitness, credScriptHash) +import Cardano.Ledger.Crypto (Crypto) +import Cardano.Ledger.Keys (KeyHash, KeyRole (..), asWitness) +import Cardano.Ledger.Mary.UTxO (getConsumedMaryValue, getProducedMaryValue) +import Cardano.Ledger.Mary.Value (MaryValue) +import Cardano.Ledger.SafeHash (SafeToHash (..)) +import Cardano.Ledger.Shelley.UTxO (getShelleyWitsVKeyNeededNoGov) +import Cardano.Ledger.UTxO (EraUTxO (..), UTxO (..)) +import Cardano.Ledger.Val (Val (..), inject) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes) +import Data.Monoid (Sum (..)) +import qualified Data.Set as Set +import Lens.Micro ((^.)) + +getBabelScriptsNeeded :: + BabelEraTxBody era => + UTxO era -> + TxBody era -> + AlonzoScriptsNeeded era +getBabelScriptsNeeded utxo txBody = + getSpendingScriptsNeeded utxo txBody + <> getRewardingScriptsNeeded txBody + <> certifyingScriptsNeeded + <> getMintingScriptsNeeded txBody + <> votingScriptsNeeded + <> proposingScriptsNeeded + where + certifyingScriptsNeeded = + AlonzoScriptsNeeded $ + catMaybes $ + zipAsIxItem (txBody ^. certsTxBodyL) $ + \asIxItem@(AsIxItem _ txCert) -> + (CertifyingPurpose asIxItem,) <$> getScriptWitnessTxCert txCert + + votingScriptsNeeded = + AlonzoScriptsNeeded $ + catMaybes $ + zipAsIxItem (Map.keys (unVotingProcedures (txBody ^. votingProceduresTxBodyL))) $ + \asIxItem@(AsIxItem _ voter) -> + (VotingPurpose asIxItem,) <$> getVoterScriptHash voter + where + getVoterScriptHash = \case + CommitteeVoter cred -> credScriptHash cred + DRepVoter cred -> credScriptHash cred + StakePoolVoter _ -> Nothing + + proposingScriptsNeeded = + AlonzoScriptsNeeded $ + catMaybes $ + zipAsIxItem (txBody ^. proposalProceduresTxBodyL) $ + \asIxItem@(AsIxItem _ proposal) -> + (ProposingPurpose asIxItem,) <$> getProposalScriptHash proposal + where + getProposalScriptHash ProposalProcedure {pProcGovAction} = + case pProcGovAction of + ParameterChange _ _ (SJust govPolicyHash) -> Just govPolicyHash + TreasuryWithdrawals _ (SJust govPolicyHash) -> Just govPolicyHash + _ -> Nothing + +babelProducedValue :: + (BabelEraTxBody era, Value era ~ MaryValue (EraCrypto era)) => + PParams era -> + (KeyHash 'StakePool (EraCrypto era) -> Bool) -> + TxBody era -> + Value era +babelProducedValue pp isStakePool txBody = + getProducedMaryValue pp isStakePool txBody + <+> inject (txBody ^. treasuryDonationTxBodyL) + +instance Crypto c => EraUTxO (BabelEra c) where + type ScriptsNeeded (BabelEra c) = AlonzoScriptsNeeded (BabelEra c) + + getConsumedValue = getConsumedMaryValue + + getProducedValue = babelProducedValue + + getScriptsProvided = getBabbageScriptsProvided + + getScriptsNeeded = getBabelScriptsNeeded + + getScriptsHashesNeeded = getAlonzoScriptsHashesNeeded + + getWitsVKeyNeeded _ = getBabelWitsVKeyNeeded + + getMinFeeTxUtxo = getBabelMinFeeTxUtxo + +instance Crypto c => AlonzoEraUTxO (BabelEra c) where + getSupplementalDataHashes = getBabbageSupplementalDataHashes + + getSpendingDatum = getBabbageSpendingDatum + +getBabelMinFeeTxUtxo :: + ( EraTx era + , BabbageEraTxBody era + ) => + PParams era -> + Tx era -> + UTxO era -> + Coin +getBabelMinFeeTxUtxo pparams tx utxo = + getMinFeeTx pparams tx refScriptsSize + where + ins = (tx ^. bodyTxL . referenceInputsTxBodyL) `Set.union` (tx ^. bodyTxL . inputsTxBodyL) + refScripts = getReferenceScriptsNonDistinct utxo ins + refScriptsSize = getSum $ foldMap (Sum . originalBytesSize . snd) refScripts + +getBabelWitsVKeyNeeded :: + (EraTx era, BabelEraTxBody era) => + UTxO era -> + TxBody era -> + Set.Set (KeyHash 'Witness (EraCrypto era)) +getBabelWitsVKeyNeeded utxo txBody = + getShelleyWitsVKeyNeededNoGov utxo txBody + `Set.union` (txBody ^. reqSignerHashesTxBodyL) + `Set.union` voterWitnesses txBody + +voterWitnesses :: + BabelEraTxBody era => + TxBody era -> + Set.Set (KeyHash 'Witness (EraCrypto era)) +voterWitnesses txb = + Map.foldrWithKey' accum mempty (unVotingProcedures (txb ^. votingProceduresTxBodyL)) + where + accum voter _ khs = + maybe khs (`Set.insert` khs) $ + case voter of + CommitteeVoter cred -> credKeyHashWitness cred + DRepVoter cred -> credKeyHashWitness cred + StakePoolVoter poolId -> Just $ asWitness poolId diff --git a/eras/babel/impl/test/Main.hs b/eras/babel/impl/test/Main.hs new file mode 100644 index 00000000000..75176f6b652 --- /dev/null +++ b/eras/babel/impl/test/Main.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TypeApplications #-} + +module Main where + +import Cardano.Ledger.Babel (Babel) +import qualified Test.Cardano.Ledger.Alonzo.Binary.CostModelsSpec as CostModelsSpec +import qualified Test.Cardano.Ledger.Alonzo.Binary.TxWitsSpec as TxWitsSpec +import qualified Test.Cardano.Ledger.Alonzo.Imp as AlonzoImp +import Test.Cardano.Ledger.Common +import qualified Test.Cardano.Ledger.Babel.Binary.CddlSpec as Cddl +import qualified Test.Cardano.Ledger.Babel.Binary.Regression as Regression +import qualified Test.Cardano.Ledger.Babel.BinarySpec as Binary +import qualified Test.Cardano.Ledger.Babel.CommitteeRatifySpec as CommitteeRatify +import qualified Test.Cardano.Ledger.Babel.DRepRatifySpec as DRepRatify +import qualified Test.Cardano.Ledger.Babel.GenesisSpec as Genesis +import qualified Test.Cardano.Ledger.Babel.GovActionReorderSpec as GovActionReorder +import qualified Test.Cardano.Ledger.Babel.Imp as BabelImp +import Test.Cardano.Ledger.Babel.Plutus.PlutusSpec as PlutusSpec +import qualified Test.Cardano.Ledger.Babel.Proposals as Proposals +import Test.Cardano.Ledger.Core.JSON (roundTripJsonEraSpec) +import qualified Test.Cardano.Ledger.Shelley.Imp as ShelleyImp + +main :: IO () +main = + ledgerTestMain $ + describe "Babel" $ do + Proposals.spec + Binary.spec + Cddl.spec + DRepRatify.spec + CommitteeRatify.spec + Genesis.spec + GovActionReorder.spec + roundTripJsonEraSpec @Babel + describe "Imp" $ do + AlonzoImp.spec @Babel + BabelImp.spec @Babel + ShelleyImp.spec @Babel + describe "CostModels" $ do + CostModelsSpec.spec @Babel + describe "TxWits" $ do + TxWitsSpec.spec @Babel + describe "Plutus" $ do + PlutusSpec.spec + Regression.spec @Babel diff --git a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/Binary/CddlSpec.hs b/eras/babel/impl/test/Test/Cardano/Ledger/Conway/Binary/CddlSpec.hs new file mode 100644 index 00000000000..7f08d14f252 --- /dev/null +++ b/eras/babel/impl/test/Test/Cardano/Ledger/Conway/Binary/CddlSpec.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Babel.Binary.CddlSpec (spec) where + +import Cardano.Ledger.Allegra.Scripts +import Cardano.Ledger.Alonzo.Scripts (CostModels) +import Cardano.Ledger.Alonzo.TxWits (Redeemers) +import Cardano.Ledger.Babel (Babel) +import Cardano.Ledger.Babel.Governance (GovAction, ProposalProcedure, VotingProcedure) +import Cardano.Ledger.Core +import Cardano.Ledger.Plutus.Data (Data, Datum) +import Test.Cardano.Ledger.Binary.Cddl ( + beforeAllCddlFile, + cddlRoundTripAnnCborSpec, + cddlRoundTripCborSpec, + ) +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Babel.Binary.Cddl (readBabelCddlFiles) + +spec :: Spec +spec = + describe "CDDL" $ beforeAllCddlFile 3 readBabelCddlFiles $ do + let v = eraProtVerHigh @Babel + cddlRoundTripCborSpec @(Value Babel) v "positive_coin" + cddlRoundTripCborSpec @(Value Babel) v "value" + cddlRoundTripAnnCborSpec @(TxBody Babel) v "transaction_body" + cddlRoundTripAnnCborSpec @(TxAuxData Babel) v "auxiliary_data" + cddlRoundTripAnnCborSpec @(Timelock Babel) v "native_script" + cddlRoundTripAnnCborSpec @(Data Babel) v "plutus_data" + cddlRoundTripCborSpec @(TxOut Babel) v "transaction_output" + cddlRoundTripAnnCborSpec @(Script Babel) v "script" + cddlRoundTripCborSpec @(Datum Babel) v "datum_option" + cddlRoundTripAnnCborSpec @(TxWits Babel) v "transaction_witness_set" + cddlRoundTripCborSpec @(PParamsUpdate Babel) v "protocol_param_update" + cddlRoundTripCborSpec @CostModels v "costmdls" + cddlRoundTripAnnCborSpec @(Redeemers Babel) v "redeemers" + cddlRoundTripAnnCborSpec @(Tx Babel) v "transaction" + cddlRoundTripCborSpec @(VotingProcedure Babel) v "voting_procedure" + cddlRoundTripCborSpec @(ProposalProcedure Babel) v "proposal_procedure" + cddlRoundTripCborSpec @(GovAction Babel) v "gov_action" + cddlRoundTripCborSpec @(TxCert Babel) v "certificate" diff --git a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/BinarySpec.hs b/eras/babel/impl/test/Test/Cardano/Ledger/Conway/BinarySpec.hs new file mode 100644 index 00000000000..674c353301b --- /dev/null +++ b/eras/babel/impl/test/Test/Cardano/Ledger/Conway/BinarySpec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Babel.BinarySpec (spec) where + +import Cardano.Ledger.Babel +import Cardano.Ledger.Babel.Genesis +import Cardano.Ledger.Babel.Governance +import Cardano.Ledger.Crypto +import Data.Default.Class (def) +import Test.Cardano.Ledger.Binary.RoundTrip +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Babel.Arbitrary () +import Test.Cardano.Ledger.Babel.Binary.RoundTrip (roundTripBabelCommonSpec) +import Test.Cardano.Ledger.Babel.TreeDiff () +import Test.Cardano.Ledger.Core.Binary (specUpgrade) +import Test.Cardano.Ledger.Core.Binary.RoundTrip (roundTripEraSpec) + +spec :: Spec +spec = do + specUpgrade @Babel def + describe "RoundTrip" $ do + roundTripCborSpec @(GovActionId StandardCrypto) + roundTripCborSpec @(GovPurposeId 'PParamUpdatePurpose Babel) + roundTripCborSpec @(GovPurposeId 'HardForkPurpose Babel) + roundTripCborSpec @(GovPurposeId 'CommitteePurpose Babel) + roundTripCborSpec @(GovPurposeId 'ConstitutionPurpose Babel) + roundTripCborSpec @Vote + roundTripCborSpec @(Voter StandardCrypto) + roundTripBabelCommonSpec @Babel + -- BabelGenesis only makes sense in Babel era + roundTripEraSpec @Babel @(BabelGenesis StandardCrypto) diff --git a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/CommitteeRatifySpec.hs b/eras/babel/impl/test/Test/Cardano/Ledger/Conway/CommitteeRatifySpec.hs new file mode 100644 index 00000000000..7a42d79a818 --- /dev/null +++ b/eras/babel/impl/test/Test/Cardano/Ledger/Conway/CommitteeRatifySpec.hs @@ -0,0 +1,394 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Babel.CommitteeRatifySpec (spec) where + +import Cardano.Ledger.BaseTypes (EpochNo (..), StrictMaybe (..)) +import Cardano.Ledger.CertState (CommitteeAuthorization (..), CommitteeState (..)) +import Cardano.Ledger.Babel +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Governance ( + GovAction (..), + GovActionState (..), + ProposalProcedure (..), + RatifyEnv (..), + RatifyState, + Vote (..), + ensCommitteeL, + rsEnactStateL, + ) +import Cardano.Ledger.Babel.Rules ( + committeeAccepted, + committeeAcceptedRatio, + ) +import Cardano.Ledger.Credential (Credential (..)) +import Cardano.Ledger.Keys (KeyRole (..)) +import Data.Functor.Identity (Identity) +import Data.List ((\\)) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Ratio ((%)) +import qualified Data.Set as Set +import Lens.Micro ((&), (.~)) +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Babel.Arbitrary () +import Test.Cardano.Ledger.Core.Arbitrary () + +spec :: Spec +spec = do + describe "Committee Ratification" $ do + acceptedRatioProp @Babel + acceptedProp @Babel + allYesProp @Babel + allNoProp @Babel + allAbstainProp @Babel + expiredAndResignedMembersProp @Babel + +acceptedRatioProp :: forall era. Era era => Spec +acceptedRatioProp = + prop "Committee vote count for arbitrary vote ratios" $ + forAll genRatios $ \ratios -> do + forAll (genTestData ratios) $ + \TestData {members, votes, committeeState} -> do + let acceptedRatio = + committeeAcceptedRatio @era members (totalVotes votes) committeeState (EpochNo 0) + Votes {..} = votes + -- everyone is registered and noone is resigned, + -- so we expect the accepted ratio to be yes / (yes + no + notVoted) + expectedRatio = + ratioOrZero + (length votedYes) + (length votedYes + length votedNo + length notVoted) + + acceptedRatio `shouldBe` expectedRatio + + -- we can also express this as : yes / (total - abstain) + let expectedRatioAlt = + ratioOrZero + (length votedYes) + (length members - length votedAbstain) + + acceptedRatio `shouldBe` expectedRatioAlt + +acceptedProp :: + forall era. + ( BabelEraPParams era + , Arbitrary (PParamsHKD Identity era) + , Arbitrary (PParamsHKD StrictMaybe era) + ) => + Spec +acceptedProp = + prop "Only NoConfidence or UpdateCommittee should pass without a committee" $ + forAll (arbitrary @(RatifyState era, RatifyEnv era, GovActionState era)) $ do + \(rs, rEnv, gas) -> do + committeeAccepted rEnv (rs & rsEnactStateL . ensCommitteeL .~ SNothing) gas + `shouldBe` isNoConfidenceOrUpdateCommittee gas + where + isNoConfidenceOrUpdateCommittee GovActionState {gasProposalProcedure} = + case pProcGovAction gasProposalProcedure of + NoConfidence {} -> True + UpdateCommittee {} -> True + _ -> False + +allYesProp :: forall era. Era era => Spec +allYesProp = + prop "If all vote yes, ratio is 1" $ + forAll (genTestData (Ratios {yes = 1, no = 0, abstain = 0})) $ + \TestData {members, votes, committeeState} -> do + let acceptedRatio = + committeeAcceptedRatio @era members (totalVotes votes) committeeState (EpochNo 0) + acceptedRatio `shouldBe` 1 + +allNoProp :: forall era. Era era => Spec +allNoProp = + prop "If all vote no, ratio is 0" $ + forAll (genTestData (Ratios {yes = 0, no = 1, abstain = 0})) $ + \TestData {members, votes, committeeState} -> do + let acceptedRatio = + committeeAcceptedRatio @era members (totalVotes votes) committeeState (EpochNo 0) + acceptedRatio `shouldBe` 0 + +allAbstainProp :: forall era. Era era => Spec +allAbstainProp = + prop "If all abstain, ratio is 0" $ + forAll (genTestData (Ratios {yes = 0, no = 0, abstain = 1})) $ + \TestData {members, votes, committeeState} -> do + let acceptedRatio = + committeeAcceptedRatio @era members (totalVotes votes) committeeState (EpochNo 0) + acceptedRatio `shouldBe` 0 + +expiredAndResignedMembersProp :: forall era. Era era => Spec +expiredAndResignedMembersProp = + prop "Expired or resigned members are not counted" $ + forAll genRatios $ \ratios -> do + forAll (genTestData @era ratios) $ \testData -> do + forAll ((,) <$> genEpoch <*> genExpiredEpoch) $ \(epochNo, expiredEpochNo) -> do + -- generate test data with some expired and/or resigned credentials corresponding + -- to each category of votes + forAll (genExpiredOrResignedForEachVoteType testData expiredEpochNo) $ do + \(testData', remainingYes, remainingNo, remainingNotVoted) -> do + let TestData {members, votes, committeeState} = testData' + acceptedRatio = + committeeAcceptedRatio @era members (totalVotes votes) committeeState epochNo + expectedRatio = + ratioOrZero + remainingYes + (remainingYes + remainingNo + remainingNotVoted) + acceptedRatio `shouldBe` expectedRatio + where + genExpiredOrResignedForEachVoteType :: + TestData era -> + EpochNo -> + Gen (TestData era, Int, Int, Int) + genExpiredOrResignedForEachVoteType td epochNo = do + let Votes {votedYes, votedNo, votedAbstain, notVoted} = votes td + (td', remYes) <- genExpiredOrResigned td votedYes epochNo + (td'', remNo) <- genExpiredOrResigned td' votedNo epochNo + (td''', _) <- genExpiredOrResigned td'' votedAbstain epochNo + (res, remNotVoted) <- genExpiredOrResigned td''' notVoted epochNo + pure (res, remYes, remNo, remNotVoted) + + genExpiredOrResigned :: + TestData era -> + [Credential 'HotCommitteeRole (EraCrypto era)] -> + EpochNo -> + Gen (TestData era, Int) + genExpiredOrResigned td votes epochNo = do + pct <- arbitrary @Rational + frequency + [ (4, pure $ updatePctOfCommittee @era td pct votes (expireMembers epochNo)) + , (4, pure $ updatePctOfCommittee @era td pct votes resignMembers) + , (2, pure $ updatePctOfCommittee @era td pct votes (expireAndResign epochNo)) + ] + expireAndResign :: + EpochNo -> + Set.Set (Credential 'HotCommitteeRole (EraCrypto era)) -> + TestData era -> + TestData era + expireAndResign epochNo hotCreds td = + let td' = expireMembers epochNo hotCreds td + td'' = resignMembers hotCreds td' + in td'' + +-- Updates a percentage of the committee of the given test data. +-- The update is based on a function that given a set of hot credentials, +-- updates test data based on these. +-- We pass to this update function a percentage of the given list of credentials. +-- We also calculate and return the number of credentials that haven't been affected by the update. +-- The initial list contains duplicates (these are corresponding to votes). +-- We are passing a percentage of distinct credentials to the update functions, +-- but we want to calculate correctly the number of credentials that haven't been affected by the update +-- (including duplicates, excluding all the ones that are being updated). +updatePctOfCommittee :: + TestData era -> + Rational -> + [Credential 'HotCommitteeRole (EraCrypto era)] -> + -- | The update function, which updates test data based on a set of credentials. + (Set.Set (Credential 'HotCommitteeRole (EraCrypto era)) -> TestData era -> TestData era) -> + (TestData era, Int) +updatePctOfCommittee td pct hotCreds action = + let + hotCredsSet = Set.fromList hotCreds + affectedSize = pctOfN pct (length hotCreds) + affectedCreds = Set.take affectedSize hotCredsSet + -- we want to count all the remaining credentials, including duplicates + remaining = length $ filter (`Set.notMember` affectedCreds) hotCreds + res = action affectedCreds td + in + (res, remaining) + where + pctOfN :: Rational -> Int -> Int + pctOfN p n = floor (p * fromIntegral n) + +data Ratios = Ratios + { yes :: Rational + , no :: Rational + , abstain :: Rational + } + deriving (Show) + +data TestData era = TestData + { members :: Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo + , votes :: Votes era + , committeeState :: CommitteeState era + } + deriving (Show) + +data Votes era = Votes + { votedYes :: [Credential 'HotCommitteeRole (EraCrypto era)] + , votedNo :: [Credential 'HotCommitteeRole (EraCrypto era)] + , votedAbstain :: [Credential 'HotCommitteeRole (EraCrypto era)] + , notVoted :: [Credential 'HotCommitteeRole (EraCrypto era)] + } + deriving (Show) + +genTestData :: + forall era. + Era era => + Ratios -> + Gen (TestData era) +genTestData ratios = do + coldCreds <- genNonEmptyColdCreds @era + committeeState@(CommitteeState {csCommitteeCreds}) <- genNonResignedCommitteeState @era coldCreds + members <- genMembers @era coldCreds + let hotCreds = [k | CommitteeHotCredential k <- Map.elems csCommitteeCreds] + votes = distributeVotes @era ratios hotCreds + pure $ TestData members votes committeeState + +-- Updates the given test data by resigning the given hot credentials. +resignMembers :: + Set.Set (Credential 'HotCommitteeRole (EraCrypto era)) -> + TestData era -> + TestData era +resignMembers hotCreds td@TestData {committeeState} = + td + { committeeState = + CommitteeState + ( Map.map + ( \case + CommitteeHotCredential hk + | hk `Set.member` hotCreds -> CommitteeMemberResigned SNothing + x -> x + ) + (csCommitteeCreds committeeState) + ) + } + +expireMembers :: + forall era. + EpochNo -> + Set.Set (Credential 'HotCommitteeRole (EraCrypto era)) -> + TestData era -> + TestData era +expireMembers newEpochNo hotCreds td@TestData {members, committeeState} = + td + { members = + Map.mapWithKey (\ck epochNo -> if expire ck then newEpochNo else epochNo) members + } + where + expire ck = case Map.lookup ck (csCommitteeCreds committeeState) of + Just (CommitteeHotCredential k) | k `Set.member` hotCreds -> True + _ -> False + +totalVotes :: Votes era -> Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote +totalVotes Votes {votedYes, votedNo, votedAbstain} = + Map.unions @[] + [ Map.fromList $ (,VoteYes) <$> votedYes + , Map.fromList $ (,VoteNo) <$> votedNo + , Map.fromList $ (,Abstain) <$> votedAbstain + ] + +genNonEmptyColdCreds :: Era era => Gen (Set.Set (Credential 'ColdCommitteeRole (EraCrypto era))) +genNonEmptyColdCreds = + Set.fromList <$> listOf1 arbitrary + +genMembers :: + Set.Set (Credential 'ColdCommitteeRole (EraCrypto era)) -> + Gen (Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo) +genMembers coldCreds = + Map.fromList . zip (Set.toList coldCreds) + <$> vectorOf (length coldCreds) genNonExpiredEpoch + +genEpoch :: Gen EpochNo +genEpoch = EpochNo <$> choose (100, 1000) + +genNonExpiredEpoch :: Gen EpochNo +genNonExpiredEpoch = EpochNo <$> choose (1000, maxBound) + +genExpiredEpoch :: Gen EpochNo +genExpiredEpoch = EpochNo <$> choose (0, 99) + +genNonResignedCommitteeState :: + forall era. + Era era => + Set.Set (Credential 'ColdCommitteeRole (EraCrypto era)) -> + Gen (CommitteeState era) +genNonResignedCommitteeState coldCreds = do + hotCredsMap <- + sequence $ + Map.fromSet + (const $ CommitteeHotCredential <$> arbitrary) + coldCreds + frequency + [ (9, pure $ CommitteeState hotCredsMap) + , (1, CommitteeState <$> overwriteWithDuplicate hotCredsMap) + ] + where + overwriteWithDuplicate m + | Map.size m < 2 = pure m + | otherwise = do + fromIx <- choose (0, Map.size m - 1) + toIx <- choose (0, Map.size m - 1) + let valueToDuplicate = snd $ Map.elemAt fromIx m + pure $ Map.updateAt (\_ _ -> Just valueToDuplicate) toIx m + +distributeVotes :: + Ratios -> + [Credential 'HotCommitteeRole (EraCrypto era)] -> + Votes era +distributeVotes Ratios {yes, no, abstain} hotCreds = do + let + -- The list of hot credentials, which we split into the 4 voting categories, may contain duplicates. + -- We want the duplicates to be in the same category (since this is what will happen in practice, + -- where the votes is a Map from hot credential to vote). + -- So we first remove the duplicates, then split the list into the 4 categories, + -- and then add the duplicates back. + hotCredsSet = Set.fromList hotCreds + duplicates = Set.fromList $ hotCreds \\ Set.toList hotCredsSet + (yesCreds, noCreds, abstainCreds, notVotedCreds) = splitByPct yes no abstain hotCredsSet + in + Votes + { votedYes = addDuplicates yesCreds duplicates + , votedNo = addDuplicates noCreds duplicates + , votedAbstain = addDuplicates abstainCreds duplicates + , notVoted = addDuplicates notVotedCreds duplicates + } + where + splitByPct :: + Rational -> + Rational -> + Rational -> + Set.Set a -> + (Set.Set a, Set.Set a, Set.Set a, Set.Set a) + splitByPct x y z l = + let + size = fromIntegral $ length l + (xs, rest) = Set.splitAt (round (x * size)) l + (ys, rest') = Set.splitAt (round (y * size)) rest + (zs, rest'') = Set.splitAt (round (z * size)) rest' + in + (xs, ys, zs, rest'') + addDuplicates :: Ord a => Set.Set a -> Set.Set a -> [a] + addDuplicates s dups = + if dups `Set.isSubsetOf` s + then Set.toList s ++ Set.toList dups + else Set.toList s + +genRatios :: Gen Ratios +genRatios = do + (a, b, c, _) <- genPctsOf100 + pure $ Ratios {yes = a, no = b, abstain = c} + +genPctsOf100 :: Gen (Rational, Rational, Rational, Rational) +genPctsOf100 = do + a <- choose (0, 100) + b <- choose (0, 100) + c <- choose (0, 100) + d <- choose (0, 100) + let s = a + b + c + d + pure (a % s, b % s, c % s, d % s) + +ratioOrZero :: Integral a => a -> a -> Rational +ratioOrZero a b = + if b == 0 + then 0 + else fromIntegral a % fromIntegral b diff --git a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/DRepRatifySpec.hs b/eras/babel/impl/test/Test/Cardano/Ledger/Conway/DRepRatifySpec.hs new file mode 100644 index 00000000000..eb873968791 --- /dev/null +++ b/eras/babel/impl/test/Test/Cardano/Ledger/Conway/DRepRatifySpec.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Babel.DRepRatifySpec (spec) where + +import Cardano.Ledger.BaseTypes (EpochNo (..), StrictMaybe (..)) +import Cardano.Ledger.CertState (CommitteeState (..)) +import Cardano.Ledger.Coin (Coin (..), CompactForm (..)) +import Cardano.Ledger.Compactible (Compactible (..)) +import Cardano.Ledger.Babel +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Governance ( + GovAction (..), + GovActionState (..), + RatifyEnv (..), + RatifyState, + Vote (..), + gasAction, + pparamsUpdateThreshold, + votingDRepThreshold, + ) +import Cardano.Ledger.Babel.Rules ( + dRepAccepted, + dRepAcceptedRatio, + ) +import Cardano.Ledger.Credential (Credential (..)) +import Cardano.Ledger.DRep (DRep (..), DRepState (..)) +import Cardano.Ledger.Keys (KeyRole (..)) +import Cardano.Ledger.PoolDistr (PoolDistr (..)) +import Cardano.Ledger.Val ((<+>), (<->)) +import Data.Foldable (fold) +import Data.Functor.Identity (Identity) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Ratio ((%)) +import qualified Data.Set as Set +import Data.Word (Word64) +import Lens.Micro +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Babel.Arbitrary () +import Test.Cardano.Ledger.Core.Arbitrary () +import Test.Cardano.Ledger.Core.Rational ((%!)) + +spec :: Spec +spec = do + describe "DRep Ratification" $ do + correctThresholdsProp @Babel + acceptedRatioProp @Babel + noStakeProp @Babel + allAbstainProp @Babel + noVotesProp @Babel + allYesProp @Babel + noConfidenceProp @Babel + +correctThresholdsProp :: + forall era. + ( BabelEraPParams era + , Arbitrary (PParams era) + , Arbitrary (PParamsUpdate era) + ) => + Spec +correctThresholdsProp = do + prop "PParamsUpdateThreshold always selects a threshold" $ \(pp :: PParams era) ppu -> do + let DRepVotingThresholds {..} = pp ^. ppDRepVotingThresholdsL + allDRepThresholds = + Set.fromList + [ dvtPPNetworkGroup + , dvtPPEconomicGroup + , dvtPPTechnicalGroup + , dvtPPGovGroup + ] + when (ppu /= emptyPParamsUpdate) $ + pparamsUpdateThreshold pp ppu `shouldSatisfy` (`Set.member` allDRepThresholds) + pparamsUpdateThreshold pp emptyPParamsUpdate `shouldBe` (0 %! 1) + +acceptedRatioProp :: forall era. Era era => Spec +acceptedRatioProp = do + prop "DRep vote count for arbitrary vote ratios" $ + forAll genRatios $ \ratios -> do + forAll (genTestData @era ratios) $ + \(TestData {..}) -> do + let drepState = + -- non-expired (active) dReps + Map.fromList + [(cred, DRepState (EpochNo 100) SNothing mempty) | DRepCredential cred <- Map.keys distr] + ratifyEnv = (emptyRatifyEnv @era) {reDRepDistr = distr, reDRepState = drepState} + actual = dRepAcceptedRatio @era ratifyEnv votes InfoAction + -- Check the accepted min ratio is : yes/(total - abstain), or zero if everyone abstained + expected + | totalStake == stakeAbstain <+> stakeAlwaysAbstain = 0 + | otherwise = unCoin stakeYes % unCoin (totalStake <-> stakeAbstain <-> stakeAlwaysAbstain) + actual `shouldBe` expected + + -- This can be also expressed as: yes/(yes + no + not voted + noconfidence) + let expectedRephrased + | stakeYes <+> stakeNo <+> stakeNotVoted <+> stakeNoConfidence == Coin 0 = 0 + | otherwise = + unCoin stakeYes % unCoin (stakeYes <+> stakeNo <+> stakeNotVoted <+> stakeNoConfidence) + actual `shouldBe` expectedRephrased + + let actualNoConfidence = dRepAcceptedRatio @era ratifyEnv votes (NoConfidence SNothing) + -- For NoConfidence action, we count the `NoConfidence` votes as Yes + expectedNoConfidence + | totalStake == stakeAbstain <+> stakeAlwaysAbstain = 0 + | otherwise = + unCoin (stakeYes <+> stakeNoConfidence) + % unCoin (totalStake <-> stakeAbstain <-> stakeAlwaysAbstain) + actualNoConfidence `shouldBe` expectedNoConfidence + + let allExpiredDreps = + Map.fromList + [(cred, DRepState (EpochNo 9) SNothing mempty) | DRepCredential cred <- Map.keys distr] + actualAllExpired = + dRepAcceptedRatio @era + ( (emptyRatifyEnv @era) + { reDRepDistr = distr + , reDRepState = allExpiredDreps + , reCurrentEpoch = EpochNo 10 + } + ) + votes + InfoAction + actualAllExpired `shouldBe` 0 + + -- Expire half of the DReps and check that the ratio is the same as if only the active DReps exist + let (activeDreps, expiredDreps) = splitAt (length distr `div` 2) (Map.keys distr) + activeDrepsState = + Map.fromList + [(cred, DRepState (EpochNo 10) SNothing mempty) | DRepCredential cred <- activeDreps] + expiredDrepsState = + Map.fromList + [(cred, DRepState (EpochNo 3) SNothing mempty) | DRepCredential cred <- expiredDreps] + someExpiredDrepsState = activeDrepsState `Map.union` expiredDrepsState + + actualSomeExpired = + dRepAcceptedRatio @era + ( (emptyRatifyEnv @era) + { reDRepDistr = distr + , reDRepState = someExpiredDrepsState + , reCurrentEpoch = EpochNo 5 + } + ) + (votes `Map.union` Map.fromList [(cred, VoteYes) | DRepCredential cred <- expiredDreps]) + InfoAction + + actualSomeExpired + `shouldBe` dRepAcceptedRatio @era + ( (emptyRatifyEnv @era) + { reDRepDistr = distr + , reDRepState = activeDrepsState + , reCurrentEpoch = EpochNo 5 + } + ) + votes + InfoAction + +allAbstainProp :: forall era. Era era => Spec +allAbstainProp = + prop "If all votes are abstain, accepted ratio is zero" + $ forAll + ( genTestData @era + (Ratios {yes = 0, no = 0, abstain = 50 % 100, alwaysAbstain = 50 % 100, noConfidence = 0}) + ) + $ \drepTestData -> + activeDRepAcceptedRatio drepTestData `shouldBe` 0 + +noConfidenceProp :: forall era. Era era => Spec +noConfidenceProp = + prop "If all votes are no confidence, accepted ratio is zero" + $ forAll + ( genTestData @era + (Ratios {yes = 0, no = 0, abstain = 0, alwaysAbstain = 0, noConfidence = 100 % 100}) + ) + $ \drepTestData -> + activeDRepAcceptedRatio drepTestData `shouldBe` 0 + +noVotesProp :: forall era. Era era => Spec +noVotesProp = + prop "If there are no votes, accepted ratio is zero" + $ forAll + (genTestData @era (Ratios {yes = 0, no = 0, abstain = 0, alwaysAbstain = 0, noConfidence = 0})) + $ \drepTestData -> + activeDRepAcceptedRatio drepTestData `shouldBe` 0 + +allYesProp :: forall era. Era era => Spec +allYesProp = + prop "If all vote yes, accepted ratio is 1 (unless there is no stake) " + $ forAll + ( genTestData @era + (Ratios {yes = 100 % 100, no = 0, abstain = 0, alwaysAbstain = 0, noConfidence = 0}) + ) + $ \drepTestData -> + if totalStake drepTestData == Coin 0 + then activeDRepAcceptedRatio drepTestData `shouldBe` 0 + else activeDRepAcceptedRatio drepTestData `shouldBe` 1 + +noStakeProp :: + forall era. + ( Arbitrary (PParamsHKD StrictMaybe era) + , Arbitrary (PParamsHKD Identity era) + , BabelEraPParams era + ) => + Spec +noStakeProp = + prop @((RatifyEnv era, RatifyState era, GovActionState era) -> IO ()) + "If there is no stake, accept iff threshold is zero" + ( \(env, st, gas) -> + dRepAccepted + @era + env {reDRepDistr = Map.empty} + st + gas + `shouldBe` votingDRepThreshold @era st (gasAction gas) + == SJust minBound + ) + +activeDRepAcceptedRatio :: forall era. TestData era -> Rational +activeDRepAcceptedRatio (TestData {..}) = + let activeDrepState = + -- non-expired dReps + Map.fromList + [(cred, DRepState (EpochNo 100) SNothing mempty) | DRepCredential cred <- Map.keys distr] + ratifyEnv = (emptyRatifyEnv @era) {reDRepDistr = distr, reDRepState = activeDrepState} + in dRepAcceptedRatio @era ratifyEnv votes InfoAction + +data TestData era = TestData + { distr :: Map (DRep (EraCrypto era)) (CompactForm Coin) + , votes :: Map (Credential 'DRepRole (EraCrypto era)) Vote + , totalStake :: Coin + , stakeYes :: Coin + , stakeNo :: Coin + , stakeAbstain :: Coin + , stakeAlwaysAbstain :: Coin + , stakeNoConfidence :: Coin + , stakeNotVoted :: Coin + } + deriving (Show) + +data Ratios = Ratios + { yes :: Rational + , no :: Rational + , abstain :: Rational + , alwaysAbstain :: Rational + , noConfidence :: Rational + } + deriving (Show) + +-- Prepare the stake distribution and votes according to the given ratios. +genTestData :: + forall era. + Era era => + Ratios -> + Gen (TestData era) +genTestData Ratios {yes, no, abstain, alwaysAbstain, noConfidence} = do + let inDreps = listOf (DRepCredential <$> (arbitrary @(Credential 'DRepRole (EraCrypto era)))) + dreps <- inDreps + + let drepSize = length dreps + alwaysAbstainPct :: Word64 = pct alwaysAbstain + noConfidencePct :: Word64 = pct noConfidence + distr = + Map.alter + (\case _ -> Just (CompactCoin noConfidencePct)) + DRepAlwaysNoConfidence + . Map.alter + (\case _ -> Just (CompactCoin alwaysAbstainPct)) + DRepAlwaysAbstain + $ Map.fromList [(drep, CompactCoin 1) | drep <- dreps] + (drepsYes, drepsNo, drepsAbstain, rest) = splitByPct yes no abstain dreps + notVotedStake = length rest + votes = + Map.union + (Map.fromList [(cred, VoteYes) | DRepCredential cred <- drepsYes]) + $ Map.union + (Map.fromList [(cred, VoteNo) | DRepCredential cred <- drepsNo]) + (Map.fromList [(cred, Abstain) | DRepCredential cred <- drepsAbstain]) + pct :: Integral a => Rational -> a + pct r = ceiling (r * fromIntegral drepSize) + pure + TestData + { distr = distr + , votes = votes + , totalStake = fromCompact (fold distr) + , stakeYes = Coin (fromIntegral (length drepsYes)) + , stakeNo = Coin (fromIntegral (length drepsNo)) + , stakeAbstain = Coin (fromIntegral (length drepsAbstain)) + , stakeAlwaysAbstain = Coin (fromIntegral alwaysAbstainPct) + , stakeNoConfidence = Coin (fromIntegral noConfidencePct) + , stakeNotVoted = Coin (fromIntegral notVotedStake) + } + where + splitByPct :: Rational -> Rational -> Rational -> [a] -> ([a], [a], [a], [a]) + splitByPct x y z l = + let + size = fromIntegral $ length l + (xs, rest) = splitAt (ceiling (x * size)) l + (ys, rest') = splitAt (ceiling (y * size)) rest + (zs, rest'') = splitAt (ceiling (z * size)) rest' + in + (xs, ys, zs, rest'') + +genRatios :: Gen Ratios +genRatios = do + (a, b, c, d, e, _) <- genPctsOf100 + pure $ Ratios {yes = a, no = b, abstain = c, alwaysAbstain = d, noConfidence = e} + +genPctsOf100 :: Gen (Rational, Rational, Rational, Rational, Rational, Rational) +genPctsOf100 = do + a <- choose (0, 100) + b <- choose (0, 100) + c <- choose (0, 100) + d <- choose (0, 100) + e <- choose (0, 100) + f <- choose (0, 100) + let s = a + b + c + d + e + f + pure (a % s, b % s, c % s, d % s, e % s, f % s) + +emptyRatifyEnv :: forall era. RatifyEnv era +emptyRatifyEnv = + RatifyEnv Map.empty (PoolDistr Map.empty) Map.empty Map.empty (EpochNo 0) (CommitteeState Map.empty) diff --git a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs b/eras/babel/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs new file mode 100644 index 00000000000..453dadf982a --- /dev/null +++ b/eras/babel/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Cardano.Ledger.Babel.GenesisSpec (spec, expectedBabelGenesis) where + +import Cardano.Ledger.Babbage (Babbage) +import Cardano.Ledger.Babel (Babel) +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.PParams +import Cardano.Ledger.Plutus.CostModels (costModelsValid) +import Cardano.Ledger.Plutus.Language (Language (PlutusV3)) +import Data.Aeson hiding (Encoding) +import Data.Functor.Identity (Identity) +import qualified Data.Map.Strict as Map +import Lens.Micro +import Paths_cardano_ledger_Babel (getDataFileName) +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Babel.Genesis (expectedBabelGenesis) +import Test.Cardano.Slotting.Numeric () + +spec :: Spec +spec = do + describe "BabelGenesis" $ do + describe "Golden Spec" goldenBabelGenesisJSON + prop "Upgrades" propBabelPParamsUpgrade + +fileName :: String +fileName = "test/data/Babel-genesis.json" + +goldenBabelGenesisJSON :: Spec +goldenBabelGenesisJSON = + it "should deserialize to the default value" $ do + file <- getDataFileName fileName + dec <- eitherDecodeFileStrict' file + cg <- case dec of + Left err -> error ("Failed to deserialize JSON: " ++ err) + Right x -> pure x + cg `shouldBe` expectedBabelGenesis + +propBabelPParamsUpgrade :: UpgradeBabelPParams Identity -> PParams Babbage -> Property +propBabelPParamsUpgrade ppu pp = property $ do + let pp' = upgradePParams ppu pp :: PParams Babel + pp' ^. ppPoolVotingThresholdsL `shouldBe` ucppPoolVotingThresholds ppu + pp' ^. ppDRepVotingThresholdsL `shouldBe` ucppDRepVotingThresholds ppu + pp' ^. ppCommitteeMinSizeL `shouldBe` ucppCommitteeMinSize ppu + pp' ^. ppCommitteeMaxTermLengthL `shouldBe` ucppCommitteeMaxTermLength ppu + pp' ^. ppGovActionLifetimeL `shouldBe` ucppGovActionLifetime ppu + pp' ^. ppGovActionDepositL `shouldBe` ucppGovActionDeposit ppu + pp' ^. ppDRepDepositL `shouldBe` ucppDRepDeposit ppu + pp' ^. ppDRepActivityL `shouldBe` ucppDRepActivity ppu + pp' ^. ppMinFeeRefScriptCostPerByteL `shouldBe` ucppMinFeeRefScriptCostPerByte ppu + Map.lookup PlutusV3 (costModelsValid (pp' ^. ppCostModelsL)) + `shouldBe` Just (ucppPlutusV3CostModel ppu) diff --git a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/GovActionReorderSpec.hs b/eras/babel/impl/test/Test/Cardano/Ledger/Conway/GovActionReorderSpec.hs new file mode 100644 index 00000000000..9454029dff0 --- /dev/null +++ b/eras/babel/impl/test/Test/Cardano/Ledger/Conway/GovActionReorderSpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Babel.GovActionReorderSpec (spec) where + +import Cardano.Ledger.Babel (Babel) +import Cardano.Ledger.Babel.Governance ( + GovActionState (..), + actionPriority, + gasAction, + reorderActions, + ) +import Data.Foldable (Foldable (..)) +import Data.List (sort) +import qualified Data.Sequence.Strict as Seq +import Test.Cardano.Ledger.Binary.Arbitrary () +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Babel.Arbitrary (ShuffledGovActionStates (..)) + +spec :: Spec +spec = + describe "Babel governance actions reordering" $ do + prop "preserves length when reordered" $ + \(actions :: Seq.StrictSeq (GovActionState Babel)) -> + Seq.length actions `shouldBe` Seq.length (reorderActions @Babel actions) + prop "sorts by priority" $ + \(actions :: Seq.StrictSeq (GovActionState Babel)) -> + sort (toList (actionPriority . gasAction @Babel <$> actions)) + `shouldBe` toList (actionPriority . gasAction <$> reorderActions actions) + prop "same priority actions are not rearranged" $ + \(a :: GovActionState Babel) (as :: Seq.StrictSeq (GovActionState Babel)) -> + let filterPrio b = actionPriority (gasAction a) == actionPriority (gasAction b) + in filter filterPrio (toList $ reorderActions @Babel (a Seq.:<| as)) + `shouldBe` filter filterPrio (toList $ reorderActions (a Seq.:<| as)) + prop "orders actions correctly with shuffles" $ + \(ShuffledGovActionStates gass shuffledGass :: ShuffledGovActionStates Babel) -> do + reorderActions (Seq.fromList gass) `shouldBe` reorderActions (Seq.fromList shuffledGass) diff --git a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/Plutus/PlutusSpec.hs b/eras/babel/impl/test/Test/Cardano/Ledger/Conway/Plutus/PlutusSpec.hs new file mode 100644 index 00000000000..a87bff79848 --- /dev/null +++ b/eras/babel/impl/test/Test/Cardano/Ledger/Conway/Plutus/PlutusSpec.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Babel.Plutus.PlutusSpec (spec) where + +import Cardano.Ledger.Babbage.PParams (CoinPerByte) +import Cardano.Ledger.Babel (BabelEra) +import Cardano.Ledger.Babel.PParams (DRepVotingThresholds, PoolVotingThresholds) +import Cardano.Ledger.Core (PParamsUpdate) +import Cardano.Ledger.Crypto (StandardCrypto) +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Babel.Arbitrary () +import Test.Cardano.Ledger.Core.Arbitrary () +import Test.Cardano.Ledger.Plutus.ToPlutusData (roundTripPlutusDataSpec) + +-- ================================ + +spec :: Spec +spec = do + describe "roundtrip ToPlutusData Babel instances" $ do + roundTripPlutusDataSpec @PoolVotingThresholds + roundTripPlutusDataSpec @DRepVotingThresholds + roundTripPlutusDataSpec @CoinPerByte + roundTripPlutusDataSpec @(PParamsUpdate (BabelEra StandardCrypto)) diff --git a/eras/babel/impl/test/data/conway-genesis.json b/eras/babel/impl/test/data/conway-genesis.json new file mode 100644 index 00000000000..b02d589c035 --- /dev/null +++ b/eras/babel/impl/test/data/conway-genesis.json @@ -0,0 +1,77 @@ +{ + "poolVotingThresholds": { + "committeeNormal": 0, + "committeeNoConfidence": 0, + "hardForkInitiation": 0, + "motionNoConfidence": 0, + "ppSecurityGroup": 0 + }, + "dRepVotingThresholds": { + "motionNoConfidence": 0, + "committeeNormal": 0, + "committeeNoConfidence": 0, + "updateToConstitution": 0, + "hardForkInitiation": 0, + "ppNetworkGroup": 0, + "ppEconomicGroup": 0, + "ppTechnicalGroup": 0, + "ppGovGroup": 0, + "treasuryWithdrawal": 0 + }, + "committeeMinSize": 0, + "committeeMaxTermLength": 0, + "govActionLifetime": 0, + "govActionDeposit": 0, + "dRepDeposit": 0, + "dRepActivity": 0, + "minFeeRefScriptCostPerByte": 0, + "plutusV3CostModel": [0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0], + "constitution": { + "anchor": { + "url": "", + "dataHash": "0000000000000000000000000000000000000000000000000000000000000000" + } + }, + "committee": { + "members": { + "keyHash-4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a": 1, + "scriptHash-4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a": 2 + }, + "threshold": 0.5 + }, + "delegs": { + "keyHash-4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a": { + "dRep": "drep-alwaysAbstain" + }, + "keyHash-35bc5e86c42afbc593ab4cdd78301005df84ba67fa1f12f95f8ee103": { + "dRep": "drep-alwaysNoConfidence" + }, + "scriptHash-afbc5005df84ba5f8ee93ab435bc5e83067fa1f12f9c42cdd7110386": { + "dRep": "drep-keyHash-78301005df84ba67fa1f12f95f8ee10335bc5e86c42afbc593ab4cdd" + }, + "keyHash-df93ab435bc5eafbc500583067fa1f12f9110386c42cdd784ba5f8ee": { + "dRep": "drep-scriptHash-01305df84b078ac5e86c42afbc593ab4cdd67fa1f12f95f8ee10335b" + }, + "keyHash-5df84bcdd7a5f8ee93aafbc500b435bc5e83067fa1f12f9110386c42": { + "poolId": "0335bc5e86c42afbc578301005df84ba67fa1f12f95f8ee193ab4cdd" + }, + "keyHash-8ee93a5df84bc42cdd7a5fafbc500b435bc5e83067fa1f12f9110386": { + "poolId": "086c42afbc578301005df84ba67fa1f12f95f8ee193ab4cdd335bc5e", + "dRep": "drep-alwaysAbstain" + } + }, + "initialDReps": { + "keyHash-78301005df84ba67fa1f12f95f8ee10335bc5e86c42afbc593ab4cdd": { + "expiry": 1000, + "deposit": 5000 + }, + "scriptHash-01305df84b078ac5e86c42afbc593ab4cdd67fa1f12f95f8ee10335b": { + "expiry": 300, + "deposit": 6000, + "anchor": { + "url": "example.com", + "dataHash": "0000000000000000000000000000000000000000000000000000000000000000" + } + } + } +} diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Arbitrary.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Arbitrary.hs new file mode 100644 index 00000000000..a775328042c --- /dev/null +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Arbitrary.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Cardano.Ledger.Babel.Arbitrary ( + genUpdateCommittee, + genNoConfidence, + genTreasuryWithdrawals, + genHardForkInitiation, + genParameterChange, + genNewConstitution, + govActionGenerators, + genBabelPlutusPurposePointer, + genGovAction, + genGovActionState, + genPParamUpdateGovAction, + genHardForkGovAction, + genCommitteeGovAction, + genConstitutionGovAction, + genProposals, + ProposalsNewActions (..), + ProposalsForEnactment (..), + ShuffledGovActionStates (..), +) where + +import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError) +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Genesis (BabelGenesis (..)) +import Cardano.Ledger.Babel.Rules +import Cardano.Ledger.Babel.Scripts (BabelPlutusPurpose (..)) +import Cardano.Ledger.Babel.TxCert +import Cardano.Ledger.Babel.TxInfo (BabelContextError) +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) +import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Crypto (Crypto) +import Control.State.Transition.Extended (STS (PredicateFailure)) +import Data.Default.Class (def) +import Data.Foldable (toList) +import Data.List (nubBy) +import qualified Data.Map.Strict as Map +import qualified Data.Sequence as Seq +import qualified Data.Sequence.Strict as SSeq +import qualified Data.Set as Set +import Data.Word +import Generic.Random (genericArbitraryU) +import Lens.Micro +import Test.Cardano.Data.Arbitrary () +import Test.Cardano.Ledger.Babbage.Arbitrary () +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Conway.Arbitrary () + +instance + ( EraPParams era + , Arbitrary (PlutusPurpose AsItem era) + , Arbitrary (PlutusPurpose AsIx era) + , Arbitrary (TxCert era) + , Arbitrary (PParamsHKD StrictMaybe era) + ) => + Arbitrary (BabelContextError era) + where + arbitrary = genericArbitraryU + +instance Crypto c => Arbitrary (BabelGenesis c) where + arbitrary = + BabelGenesis + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Crypto c => Arbitrary (BabelDelegCert c) where + arbitrary = + oneof + [ BabelRegCert <$> arbitrary <*> arbitrary + , BabelUnRegCert <$> arbitrary <*> arbitrary + , BabelDelegCert <$> arbitrary <*> arbitrary + , BabelRegDelegCert <$> arbitrary <*> arbitrary <*> arbitrary + ] + +instance Crypto c => Arbitrary (BabelGovCert c) where + arbitrary = + oneof + [ BabelRegDRep <$> arbitrary <*> arbitrary <*> arbitrary + , BabelUnRegDRep <$> arbitrary <*> arbitrary + , BabelAuthCommitteeHotKey <$> arbitrary <*> arbitrary + , BabelResignCommitteeColdKey <$> arbitrary <*> arbitrary + ] + +instance + ( EraTxOut era + , Arbitrary (Value era) + , Arbitrary (TxOut era) + , Arbitrary (PredicateFailure (EraRule "UTXOS" era)) + ) => + Arbitrary (BabelUtxoPredFailure era) + where + arbitrary = genericArbitraryU + +instance + ( Era era + , Arbitrary (PredicateFailure (EraRule "UTXO" era)) + , Arbitrary (TxCert era) + , Arbitrary (PlutusPurpose AsItem era) + , Arbitrary (PlutusPurpose AsIx era) + ) => + Arbitrary (BabelUtxowPredFailure era) + where + arbitrary = genericArbitraryU + +_uniqueIdGovActions :: + (Era era, Arbitrary (PParamsUpdate era)) => + Gen (SSeq.StrictSeq (GovActionState era)) +_uniqueIdGovActions = SSeq.fromList . nubBy (\x y -> gasId x == gasId y) <$> arbitrary + +data ProposalsForEnactment era + = ProposalsForEnactment + (Proposals era) + (Seq.Seq (GovActionState era)) + (Set.Set (GovActionId (EraCrypto era))) + deriving (Show, Eq) + +instance + (EraPParams era, Arbitrary (PParamsUpdate era), Arbitrary (PParamsHKD StrictMaybe era)) => + Arbitrary (ProposalsForEnactment era) + where + arbitrary = do + ps <- genProposals @era (2, 50) + pparamUpdates <- chooseLineage grPParamUpdateL ps Seq.Empty + hardForks <- chooseLineage grHardForkL ps Seq.Empty + committees <- chooseLineage grCommitteeL ps Seq.Empty + constitutions <- chooseLineage grConstitutionL ps Seq.Empty + sequencedGass <- + sequenceLineages + ( Seq.filter + (not . Seq.null) + (Seq.fromList [pparamUpdates, hardForks, committees, constitutions]) + ) + Seq.Empty + let expiredGais = + Set.fromList (toList $ proposalsIds ps) + `Set.difference` Set.fromList (gasId <$> toList sequencedGass) + pure $ ProposalsForEnactment ps sequencedGass expiredGais + where + chooseLineage :: + (forall f. Lens' (GovRelation f era) (f (GovPurposeId p era))) -> + Proposals era -> + Seq.Seq (GovActionState era) -> + Gen (Seq.Seq (GovActionState era)) + chooseLineage govRelL ps = \case + Seq.Empty -> + let children = ps ^. pRootsL . govRelL . prChildrenL + in if Set.null children + then pure Seq.Empty + else do + child <- elements $ toList children + chooseLineage govRelL ps (Seq.Empty Seq.:|> (proposalsActionsMap ps Map.! unGovPurposeId child)) + lineage@(_ Seq.:|> gas) -> + let children = ps ^. pGraphL . govRelL . pGraphNodesL . to (Map.! GovPurposeId (gasId gas)) . peChildrenL + in if Set.null children + then pure lineage + else do + child <- elements $ toList children + chooseLineage govRelL ps (lineage Seq.:|> (proposalsActionsMap ps Map.! unGovPurposeId child)) + consumeHeadAtIndex :: Int -> Seq.Seq (Seq.Seq a) -> (a, Seq.Seq (Seq.Seq a)) + consumeHeadAtIndex idx ss = (ss `Seq.index` idx `Seq.index` 0, Seq.adjust' (Seq.drop 1) idx ss) + sequenceLineages :: Seq.Seq (Seq.Seq a) -> Seq.Seq a -> Gen (Seq.Seq a) + sequenceLineages lineages sequenced = case lineages of + Seq.Empty -> pure sequenced + _ -> do + index <- chooseInt (0, length lineages - 1) + let (chosen, adjustedLineages) = consumeHeadAtIndex index lineages + sequenceLineages (Seq.filter (not . Seq.null) adjustedLineages) (sequenced Seq.:|> chosen) + +data ProposalsNewActions era = ProposalsNewActions (Proposals era) [GovActionState era] + deriving (Show, Eq) + +instance + (EraPParams era, Arbitrary (PParamsUpdate era), Arbitrary (PParamsHKD StrictMaybe era)) => + Arbitrary (ProposalsNewActions era) + where + arbitrary = do + ps <- arbitrary + i <- chooseInt (2, 20) + gass <- vectorOf i $ genGovActionState =<< genGovAction ps + pure $ ProposalsNewActions ps gass + +genProposals :: + forall era. + ( HasCallStack + , EraPParams era + , Arbitrary (PParamsHKD StrictMaybe era) + ) => + (Int, Int) -> + Gen (Proposals era) +genProposals range = do + pgais <- arbitrary + i <- chooseInt range + go (def & pRootsL .~ fromPrevGovActionIds pgais) i + where + go :: Proposals era -> Int -> Gen (Proposals era) + go ps n + | n <= 0 = pure ps + | otherwise = do + gas <- genGovActionState @era =<< genGovAction ps + case proposalsAddAction gas ps of + Nothing -> error "Error adding GovActionState to Proposals" + Just ps' -> go ps' (n - 1) + +genGovAction :: + forall era. + (Era era, Arbitrary (PParamsHKD StrictMaybe era)) => + Proposals era -> + Gen (GovAction era) +genGovAction ps = + oneof + [ genWithParent genPParamUpdateGovAction grPParamUpdateL + , genWithParent genHardForkGovAction grHardForkL + , genTreasuryWithdrawals + , genWithParent genCommitteeGovAction grCommitteeL + , genWithParent genConstitutionGovAction grConstitutionL + , pure InfoAction + ] + where + genWithParent :: + (StrictMaybe (GovPurposeId p era) -> Gen (GovAction era)) -> + (forall f. Lens' (GovRelation f era) (f (GovPurposeId p era))) -> + Gen (GovAction era) + genWithParent gen govRelL = + gen + =<< elements + ( (ps ^. pRootsL . govRelL . prRootL) + : fmap SJust (Map.keys $ ps ^. pGraphL . govRelL . pGraphNodesL) + ) + +genPParamUpdateGovAction :: + ( Era era + , Arbitrary (PParamsHKD StrictMaybe era) + ) => + StrictMaybe (GovPurposeId 'PParamUpdatePurpose era) -> + Gen (GovAction era) +genPParamUpdateGovAction parent = ParameterChange parent <$> arbitrary <*> arbitrary + +genHardForkGovAction :: + StrictMaybe (GovPurposeId 'HardForkPurpose era) -> + Gen (GovAction era) +genHardForkGovAction parent = HardForkInitiation parent <$> arbitrary + +genCommitteeGovAction :: + Era era => + StrictMaybe (GovPurposeId 'CommitteePurpose era) -> + Gen (GovAction era) +genCommitteeGovAction parent = + oneof + [ pure $ NoConfidence parent + , UpdateCommittee parent <$> arbitrary <*> arbitrary <*> arbitrary + ] + +genConstitutionGovAction :: + Era era => + StrictMaybe (GovPurposeId 'ConstitutionPurpose era) -> + Gen (GovAction era) +genConstitutionGovAction parent = NewConstitution parent <$> arbitrary + +genGovActionState :: Era era => GovAction era -> Gen (GovActionState era) +genGovActionState ga = + GovActionState + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> (ProposalProcedure <$> arbitrary <*> arbitrary <*> pure ga <*> arbitrary) + <*> arbitrary + <*> arbitrary + +-- | These lists of `GovActionStates` contain only one of a priority. +-- In other words, no two `GovActionState`s in the list have the same `actionPriority`. +data ShuffledGovActionStates era + = ShuffledGovActionStates [GovActionState era] [GovActionState era] + deriving (Show) + +instance + (Era era, Arbitrary (PParamsUpdate era)) => + Arbitrary (ShuffledGovActionStates era) + where + arbitrary = do + gass <- traverse (genGovActionState =<<) govActionGenerators + shuffledGass <- shuffle gass + pure $ ShuffledGovActionStates gass shuffledGass + +genParameterChange :: (Era era, Arbitrary (PParamsUpdate era)) => Gen (GovAction era) +genParameterChange = ParameterChange <$> arbitrary <*> arbitrary <*> arbitrary + +genHardForkInitiation :: Era era => Gen (GovAction era) +genHardForkInitiation = HardForkInitiation <$> arbitrary <*> arbitrary + +genTreasuryWithdrawals :: Era era => Gen (GovAction era) +genTreasuryWithdrawals = TreasuryWithdrawals <$> arbitrary <*> arbitrary + +genNoConfidence :: Era era => Gen (GovAction era) +genNoConfidence = NoConfidence <$> arbitrary + +genUpdateCommittee :: Era era => Gen (GovAction era) +genUpdateCommittee = + UpdateCommittee + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +genNewConstitution :: Era era => Gen (GovAction era) +genNewConstitution = NewConstitution <$> arbitrary <*> arbitrary + +govActionGenerators :: + ( Era era + , Arbitrary (PParamsUpdate era) + ) => + [Gen (GovAction era)] +govActionGenerators = + [ genParameterChange + , genHardForkInitiation + , genTreasuryWithdrawals + , genNoConfidence + , genUpdateCommittee + , genNewConstitution + , pure InfoAction + ] + +instance + ( Era era + , Arbitrary (TxCert era) + , Arbitrary (PParamsHKD StrictMaybe era) + ) => + Arbitrary (BabelPlutusPurpose AsItem era) + where + arbitrary = + oneof + [ BabelSpending <$> arbitrary + , BabelMinting <$> arbitrary + , BabelCertifying <$> arbitrary + , BabelRewarding <$> arbitrary + , BabelVoting <$> arbitrary + , BabelProposing <$> arbitrary + ] + +instance + ( Era era + , Arbitrary (TxCert era) + , Arbitrary (PParamsHKD StrictMaybe era) + ) => + Arbitrary (BabelPlutusPurpose AsIxItem era) + where + arbitrary = + oneof + [ BabelSpending <$> arbitrary + , BabelMinting <$> arbitrary + , BabelCertifying <$> arbitrary + , BabelRewarding <$> arbitrary + , BabelVoting <$> arbitrary + , BabelProposing <$> arbitrary + ] + +instance + Era era => + Arbitrary (BabelPlutusPurpose AsIx era) + where + arbitrary = arbitrary >>= genBabelPlutusPurposePointer + +genBabelPlutusPurposePointer :: Word32 -> Gen (BabelPlutusPurpose AsIx era) +genBabelPlutusPurposePointer i = + elements + [ BabelSpending (AsIx i) + , BabelMinting (AsIx i) + , BabelCertifying (AsIx i) + , BabelRewarding (AsIx i) + , BabelVoting (AsIx i) + , BabelProposing (AsIx i) + ] + +------------------------------------------------------------------------------------------ +-- Cardano.Ledger.Babel.Rules ----------------------------------------------------------- +------------------------------------------------------------------------------------------ + +instance + ( Era era + , Arbitrary (CollectError era) + ) => + Arbitrary (BabelUtxosPredFailure era) + where + arbitrary = genericArbitraryU + +instance + ( Era era + , Arbitrary (PredicateFailure (EraRule "UTXOW" era)) + , Arbitrary (PredicateFailure (EraRule "CERTS" era)) + , Arbitrary (PredicateFailure (EraRule "GOV" era)) + ) => + Arbitrary (BabelLedgerPredFailure era) + where + arbitrary = genericArbitraryU diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Binary/Cddl.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Binary/Cddl.hs new file mode 100644 index 00000000000..04264a49959 --- /dev/null +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Binary/Cddl.hs @@ -0,0 +1,18 @@ +module Test.Cardano.Ledger.Babel.Binary.Cddl ( + readBabelCddlFileNames, + readBabelCddlFiles, +) where + +import qualified Data.ByteString.Lazy as BSL +import Paths_cardano_ledger_babel + +readBabelCddlFileNames :: IO [FilePath] +readBabelCddlFileNames = do + base <- getDataFileName "cddl-files/babel.cddl" + crypto <- getDataFileName "cddl-files/crypto.cddl" + extras <- getDataFileName "cddl-files/extra.cddl" + -- extras contains the types whose restrictions cannot be expressed in CDDL + pure [base, crypto, extras] + +readBabelCddlFiles :: IO [BSL.ByteString] +readBabelCddlFiles = mapM BSL.readFile =<< readBabelCddlFileNames diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Binary/Regression.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Binary/Regression.hs new file mode 100644 index 00000000000..9ec1c929061 --- /dev/null +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Binary/Regression.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Babel.Binary.Regression where + +import Cardano.Ledger.BaseTypes (Inject (..), StrictMaybe (..), TxIx (..)) +import Cardano.Ledger.Binary ( + EncCBOR (..), + decCBOR, + decodeFull, + decodeFullAnnotatorFromHexText, + mkVersion, + serialize, + ) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Babel (Babel) +import Cardano.Ledger.Babel.Core ( + BabbageEraTxBody (..), + EraTx (..), + EraTxBody (..), + EraTxOut (..), + EraTxWits (..), + coinTxOutL, + eraProtVerLow, + txIdTx, + ) +import Cardano.Ledger.Babel.Rules ( + BabelLedgerPredFailure (..), + BabelUtxoPredFailure (..), + BabelUtxowPredFailure (..), + ) +import Cardano.Ledger.Plutus.Language (SLanguage (..), hashPlutusScript) +import Cardano.Ledger.TxIn (TxIn (..)) +import Control.Monad ((<=<)) +import qualified Data.Sequence.Strict as SSeq +import qualified Data.Set as Set +import Lens.Micro ((%~), (&), (.~)) +import Test.Cardano.Ledger.Babel.ImpTest +import Test.Cardano.Ledger.Core.KeyPair (mkScriptAddr) +import Test.Cardano.Ledger.Imp.Common +import Test.Cardano.Ledger.Plutus.Examples (guessTheNumber3) + +spec :: + forall era. + ( EraTx era + , NFData (Tx era) + ) => + Spec +spec = describe "Regression" $ do + it "DeserialiseFailure on resubmitting Babel Tx with invalid plutus script #4198" $ do + io . expectRightDeep_ $ + decodeFullAnnotatorFromHexText @(Tx era) (eraProtVerLow @era) "Unwitnessed Tx" decCBOR $ + mconcat + [ "84a700d9010282825820745f04573e7429be1404f9b936d208b81159f3fc4b300" + , "37b9d630187eec1875600825820745f04573e7429be1404f9b936d208b81159f3" + , "fc4b30037b9d630187eec18756020dd9010281825820745f04573e7429be1404f" + , "9b936d208b81159f3fc4b30037b9d630187eec1875601018282581d60fdfaa525" + , "1e9ed2186a52eeea05ac1d39834eeef09b3e41dc151577a01a001e848082581d6" + , "0fe920c980dbc1113a01db0156955479f3b91f6fb6a51bdc0c383c1b91a3b586d" + , "e61082581d60fe920c980dbc1113a01db0156955479f3b91f6fb6a51bdc0c383c" + , "1b91a001a65b0111a00041ed0021a0002bf350b5820878c73eb6ec7171b23396f" + , "71d7e5adee98b3f72cfc1c0662453ea724a4e27ad5a303d9010281581e581c010" + , "0003322323222235004007123500235300300149849848004800504d9010281d8" + , "799f182aff0581840000d8799f182aff820000f4f6" + ] + expectRightDeep_ $ + decodeFullAnnotatorFromHexText @(Tx era) (eraProtVerLow @era) "Witnessed Tx" decCBOR $ + mconcat + [ "84a700d9010282825820745f04573e7429be1404f9b936d208b81159f3fc4b300" + , "37b9d630187eec1875600825820745f04573e7429be1404f9b936d208b81159f3" + , "fc4b30037b9d630187eec18756020dd9010281825820745f04573e7429be1404f" + , "9b936d208b81159f3fc4b30037b9d630187eec1875601018282581d60fdfaa525" + , "1e9ed2186a52eeea05ac1d39834eeef09b3e41dc151577a01a001e848082581d6" + , "0fe920c980dbc1113a01db0156955479f3b91f6fb6a51bdc0c383c1b91a3b586d" + , "e61082581d60fe920c980dbc1113a01db0156955479f3b91f6fb6a51bdc0c383c" + , "1b91a001a65b0111a00041ed0021a0002bf350b5820878c73eb6ec7171b23396f" + , "71d7e5adee98b3f72cfc1c0662453ea724a4e27ad5a400d9010282825820119ca" + , "69d7aadd28f1e182176cbaa35f4e08d580b79ee749103f4106768594343584057" + , "de8c067f7b806001e94f740c9c96c51f884e264dd0b2d0cff501ad67f1d269b7a" + , "7af5adf92148f4a10855fe3b2090bc88f045603cfe14c8a5f3fed6c4008038258" + , "20468ed75ae68f72233e33b0a869ae5f00cfabe477f186184782e5a1994d189a9" + , "b58408395b8e91540804ce1860272ac72b4ecc682f567a33c33da8e835d736f1f" + , "c039ff86ee5aae0ac0e9c9d50506132e209f62a02fe04906b66a3392d48d4d627" + , "d0403d9010281581e581c01000033223232222350040071235002353003001498" + , "49848004800504d9010281d8799f182aff0581840000d8799f182aff820000f4f6" + ] + describe "ImpTest" $ + withImpState @Babel $ + it "InsufficientCollateral is not encoded with negative coin #4198" $ do + let lockedVal = inject $ Coin 100 + (_, collateralAddress) <- freshKeyAddr + (_, skp) <- freshKeyPair + let + plutusVersion = SPlutusV2 + scriptHash = hashPlutusScript $ guessTheNumber3 plutusVersion + lockScriptAddress = mkScriptAddr scriptHash skp + (_, collateralReturnAddr) <- freshKeyAddr + lockedTx <- + submitTxAnn @Babel "Script locked tx" $ + mkBasicTx mkBasicTxBody + & bodyTxL + . outputsTxBodyL + .~ SSeq.fromList + [ mkBasicTxOut lockScriptAddress lockedVal + , mkBasicTxOut collateralAddress (inject $ Coin 1) + ] + & bodyTxL + . collateralReturnTxBodyL + .~ SJust (mkBasicTxOut collateralReturnAddr . inject $ Coin 1) + let + modifyRootCoin = coinTxOutL .~ Coin 989482376 + modifyRootTxOut (x SSeq.:<| SSeq.Empty) = + modifyRootCoin x SSeq.:<| SSeq.Empty + modifyRootTxOut (x SSeq.:<| xs) = x SSeq.:<| modifyRootTxOut xs + modifyRootTxOut (xs SSeq.:|> x) = xs SSeq.:|> modifyRootCoin x + modifyRootTxOut SSeq.Empty = SSeq.Empty + breakCollaterals tx = + pure $ + tx + & bodyTxL + . collateralReturnTxBodyL + .~ SJust (mkBasicTxOut collateralReturnAddr . inject $ Coin 1_000_000_000) + & bodyTxL + . feeTxBodyL + .~ Coin 178349 + & bodyTxL + . outputsTxBodyL + %~ modifyRootTxOut + & witsTxL + . addrTxWitsL + .~ mempty + res <- + impAnn "Consume the script locked output" $ + withPostFixup (updateAddrTxWits <=< breakCollaterals) $ do + trySubmitTx @Babel $ + mkBasicTx mkBasicTxBody + & bodyTxL + . inputsTxBodyL + .~ Set.singleton (TxIn (txIdTx lockedTx) $ TxIx 0) + pFailure <- impAnn "Expecting failure" $ expectLeftDeepExpr res + let + hasInsufficientCollateral + (BabelUtxowFailure (UtxoFailure (InsufficientCollateral _ _))) = True + hasInsufficientCollateral _ = False + impAnn "Fails with InsufficientCollateral" $ + pFailure `shouldSatisfyExpr` any hasInsufficientCollateral + let encoding = encCBOR pFailure + version <- mkVersion (11 :: Int) + let + bs = serialize version encoding + decoded = decodeFull version bs + impAnn "Expecting deserialization of predicate failure to succeed" $ + decoded `shouldBe` Right pFailure diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Binary/RoundTrip.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Binary/RoundTrip.hs new file mode 100644 index 00000000000..1b5a9a83b29 --- /dev/null +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Binary/RoundTrip.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Cardano.Ledger.Babel.Binary.RoundTrip ( + roundTripBabelCommonSpec, + roundTripBabelEraTypesSpec, +) where + +import Cardano.Ledger.Babel (BabelEra) +import Cardano.Ledger.BaseTypes (StrictMaybe) +import Cardano.Ledger.Compactible +import Cardano.Ledger.Conway.Governance ( + Constitution, + DRepPulsingState, + EnactState, + EraGov, + GovAction, + GovActionState, + GovState, + ProposalProcedure, + Proposals, + PulsingSnapshot, + RatifyState, + VotingProcedure, + VotingProcedures, + ) +import Cardano.Ledger.Core +import Cardano.Ledger.Crypto (Crypto) +import Cardano.Ledger.Shelley.LedgerState +import Test.Cardano.Ledger.Alonzo.Arbitrary (FlexibleCostModels (..)) +import Test.Cardano.Ledger.Alonzo.Binary.RoundTrip (roundTripAlonzoCommonSpec) +import Test.Cardano.Ledger.Babel.Arbitrary () +import Test.Cardano.Ledger.Common +import Test.Cardano.Ledger.Core.Binary.RoundTrip + +roundTripBabelCommonSpec :: + forall era. + ( EraTx era + , EraGov era + , StashedAVVMAddresses era ~ () + , Arbitrary (Tx era) + , Arbitrary (TxBody era) + , Arbitrary (TxOut era) + , Arbitrary (TxCert era) + , Arbitrary (TxWits era) + , Arbitrary (TxAuxData era) + , Arbitrary (Value era) + , Arbitrary (CompactForm (Value era)) + , Arbitrary (Script era) + , Arbitrary (GovState era) + , Arbitrary (PParams era) + , Arbitrary (PParamsUpdate era) + , Arbitrary (PParamsHKD StrictMaybe era) + , RuleListEra era + ) => + Spec +roundTripBabelCommonSpec = do + roundTripBabelEraTypesSpec @era + roundTripAlonzoCommonSpec @era + +roundTripBabelEraTypesSpec :: + forall era. + ( Arbitrary (PParams era) + , Arbitrary (PParamsUpdate era) + , Arbitrary (PParamsHKD StrictMaybe era) + , EraPParams era + ) => + Spec +roundTripBabelEraTypesSpec = do + describe "Babel Transaction Types" $ do + roundTripEraTypeSpec @era @GovAction + roundTripEraTypeSpec @era @VotingProcedure + roundTripEraTypeSpec @era @VotingProcedures + roundTripEraTypeSpec @era @ProposalProcedure + roundTripEraTypeSpec @era @Constitution + -- Babel adds ability to serialize unknown cost models, i.e. FlexibleCostModels + prop "CostModels" $ roundTripEraExpectation @era . unFlexibleCostModels + describe "Babel State Types" $ do + roundTripShareEraTypeSpec @era @EnactState + roundTripShareEraTypeSpec @era @GovActionState + roundTripShareEraTypeSpec @era @Proposals + roundTripShareEraTypeSpec @era @DRepPulsingState + roundTripShareEraTypeSpec @era @PulsingSnapshot + roundTripShareEraTypeSpec @era @RatifyState + +instance Crypto c => RuleListEra (BabelEra c) where + type + EraRules (BabelEra c) = + '[ "GOV" + , "UTXOS" + , "LEDGER" + , "CERTS" + , "CERT" + , "DELEG" + , "GOVCERT" + , "UTXOW" + , "UTXO" + , "LEDGERS" + , "POOL" + ] diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Genesis.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Genesis.hs new file mode 100644 index 00000000000..4369a40a671 --- /dev/null +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Genesis.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Cardano.Ledger.Babel.Genesis (expectedBabelGenesis) where + +import Cardano.Ledger.Babel +import Cardano.Ledger.Babel.Genesis (BabelGenesis (..)) +import Cardano.Ledger.Babel.TxCert (Delegatee (..)) +import Cardano.Ledger.BaseTypes (EpochInterval (..), textToUrl) +import Cardano.Ledger.CertState (DRep (..), DRepState (..)) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Conway.Governance (Anchor (..), Committee (..)) +import Cardano.Ledger.Conway.PParams (UpgradeConwayPParams (..)) +import Cardano.Ledger.Core +import Cardano.Ledger.Credential +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Keys +import Cardano.Ledger.Slot (EpochNo (..)) +import Data.Default.Class (Default (def)) +import qualified Data.ListMap as ListMap +import Data.Map as Map +import Data.Maybe (fromJust) +import Data.Maybe.Strict (StrictMaybe (..)) +import Data.Ratio ((%)) +import Test.Cardano.Ledger.Babel.Arbitrary () +import Test.Cardano.Ledger.Core.Utils (unsafeBoundRational) +import Test.Cardano.Ledger.Plutus (zeroTestingCostModelV3) + +credMember :: Credential 'ColdCommitteeRole StandardCrypto +credMember = + KeyHashObj + (KeyHash "4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a") + +scriptMember :: Credential 'ColdCommitteeRole StandardCrypto +scriptMember = + ScriptHashObj + (ScriptHash "4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a") + +comm :: Committee Babel +comm = + Committee + ( Map.fromList + [ + ( credMember + , EpochNo 1 + ) + , + ( scriptMember + , EpochNo 2 + ) + ] + ) + (unsafeBoundRational (1 % 2)) + +expectedBabelGenesis :: BabelGenesis StandardCrypto +expectedBabelGenesis = + BabelGenesis + { cgCommittee = comm + , cgInitialDReps = + ListMap.fromList + [ + ( KeyHashObj + (KeyHash "78301005df84ba67fa1f12f95f8ee10335bc5e86c42afbc593ab4cdd") + , DRepState + { drepExpiry = EpochNo 1000 + , drepAnchor = SNothing + , drepDeposit = Coin 5000 + } + ) + , + ( ScriptHashObj + (ScriptHash "01305df84b078ac5e86c42afbc593ab4cdd67fa1f12f95f8ee10335b") + , DRepState + { drepExpiry = EpochNo 300 + , drepAnchor = + SJust $ + Anchor + { anchorUrl = fromJust $ textToUrl 99 "example.com" + , anchorDataHash = def + } + , drepDeposit = Coin 6000 + } + ) + ] + , cgDelegs = + ListMap.fromList + [ + ( KeyHashObj + (KeyHash "35bc5e86c42afbc593ab4cdd78301005df84ba67fa1f12f95f8ee103") + , DelegVote DRepAlwaysNoConfidence + ) + , + ( KeyHashObj + (KeyHash "4e88cc2d27c364aaf90648a87dfb95f8ee103ba67fa1f12f5e86c42a") + , DelegVote DRepAlwaysAbstain + ) + , + ( KeyHashObj + (KeyHash "5df84bcdd7a5f8ee93aafbc500b435bc5e83067fa1f12f9110386c42") + , DelegStake $ KeyHash "0335bc5e86c42afbc578301005df84ba67fa1f12f95f8ee193ab4cdd" + ) + , + ( KeyHashObj + (KeyHash "8ee93a5df84bc42cdd7a5fafbc500b435bc5e83067fa1f12f9110386") + , DelegStakeVote + (KeyHash "086c42afbc578301005df84ba67fa1f12f95f8ee193ab4cdd335bc5e") + DRepAlwaysAbstain + ) + , + ( KeyHashObj + (KeyHash "df93ab435bc5eafbc500583067fa1f12f9110386c42cdd784ba5f8ee") + , DelegVote $ + DRepCredential + (ScriptHashObj (ScriptHash "01305df84b078ac5e86c42afbc593ab4cdd67fa1f12f95f8ee10335b")) + ) + , + ( ScriptHashObj + (ScriptHash "afbc5005df84ba5f8ee93ab435bc5e83067fa1f12f9c42cdd7110386") + , DelegVote $ + DRepCredential + (KeyHashObj (KeyHash "78301005df84ba67fa1f12f95f8ee10335bc5e86c42afbc593ab4cdd")) + ) + ] + , cgConstitution = def + , cgUpgradePParams = + UpgradeConwayPParams + { ucppPoolVotingThresholds = def + , ucppDRepVotingThresholds = def + , ucppCommitteeMinSize = 0 + , ucppCommitteeMaxTermLength = EpochInterval 0 + , ucppGovActionLifetime = EpochInterval 0 + , ucppGovActionDeposit = Coin 0 + , ucppDRepDeposit = Coin 0 + , ucppDRepActivity = EpochInterval 0 + , ucppMinFeeRefScriptCostPerByte = minBound + , ucppPlutusV3CostModel = zeroTestingCostModelV3 + } + } diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp.hs new file mode 100644 index 00000000000..ebe57b23c3d --- /dev/null +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Cardano.Ledger.Babel.Imp (spec) where + +import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext (..)) +import Cardano.Ledger.Alonzo.Rules (AlonzoUtxosPredFailure) +import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure) +import Cardano.Ledger.Babbage.TxInfo (BabbageContextError) +import Cardano.Ledger.BaseTypes (Inject, natVersion) +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Governance (BabelGovState) +import Cardano.Ledger.Babel.PParams (BabelPParams) +import Cardano.Ledger.Babel.Rules ( + BabelEpochEvent, + BabelGovCertPredFailure, + BabelGovPredFailure, + BabelNewEpochEvent, + ) +import Cardano.Ledger.Babel.TxInfo (BabelContextError) +import Cardano.Ledger.Shelley.Rules (Event, ShelleyUtxoPredFailure, ShelleyUtxowPredFailure) +import Data.Functor.Identity +import Data.Typeable (Typeable) +import qualified Test.Cardano.Ledger.Babbage.Imp as BabbageImp +import Test.Cardano.Ledger.Common +import qualified Test.Cardano.Ledger.Babel.Imp.EnactSpec as Enact +import qualified Test.Cardano.Ledger.Babel.Imp.EpochSpec as Epoch +import qualified Test.Cardano.Ledger.Babel.Imp.GovCertSpec as GovCert +import qualified Test.Cardano.Ledger.Babel.Imp.GovSpec as Gov +import qualified Test.Cardano.Ledger.Babel.Imp.RatifySpec as Ratify +import qualified Test.Cardano.Ledger.Babel.Imp.UtxoSpec as Utxo +import qualified Test.Cardano.Ledger.Babel.Imp.UtxosSpec as Utxos +import Test.Cardano.Ledger.Babel.ImpTest (BabelEraImp, withImpState, withImpStateWithProtVer) + +spec :: + forall era. + ( BabelEraImp era + , GovState era ~ BabelGovState era + , PParamsHKD Identity era ~ BabelPParams Identity era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , Inject (BabbageContextError era) (ContextError era) + , Inject (BabelContextError era) (ContextError era) + , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era + , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era + , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era + , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era + , InjectRuleFailure "LEDGER" BabelGovCertPredFailure era + , NFData (Event (EraRule "ENACT" era)) + , ToExpr (Event (EraRule "ENACT" era)) + , Eq (Event (EraRule "ENACT" era)) + , Typeable (Event (EraRule "ENACT" era)) + , InjectRuleEvent "TICK" BabelEpochEvent era + , Event (EraRule "EPOCH" era) ~ BabelEpochEvent era + , Event (EraRule "NEWEPOCH" era) ~ BabelNewEpochEvent era + ) => + Spec +spec = do + BabbageImp.spec @era + describe "BabelImpSpec - post bootstrap (protocol version 10)" $ + withImpStateWithProtVer @era (natVersion @10) $ do + Enact.spec @era + Epoch.spec @era + Gov.spec @era + GovCert.spec @era + Utxo.spec @era + Utxos.spec @era + Ratify.spec @era + describe "BabelImpSpec - bootstrap phase (protocol version 9)" $ + withImpState @era $ do + Enact.relevantDuringBootstrapSpec @era + Epoch.relevantDuringBootstrapSpec @era + Gov.relevantDuringBootstrapSpec @era + GovCert.relevantDuringBootstrapSpec @era + Utxo.spec @era + Utxos.relevantDuringBootstrapSpec @era + Ratify.relevantDuringBootstrapSpec @era diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EnactSpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EnactSpec.hs new file mode 100644 index 00000000000..3af7441a94a --- /dev/null +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EnactSpec.hs @@ -0,0 +1,499 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Cardano.Ledger.Babel.Imp.EnactSpec ( + spec, + relevantDuringBootstrapSpec, +) where + +import Cardano.Ledger.Address +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Coin +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Governance +import Cardano.Ledger.Babel.PParams +import Cardano.Ledger.Babel.Rules +import Cardano.Ledger.Credential +import Cardano.Ledger.Shelley.LedgerState +import Cardano.Ledger.Val (zero, (<->)) +import Control.Monad (forM) +import Control.State.Transition.Extended (STS (..)) +import Data.Default.Class (def) +import Data.Foldable (foldl', traverse_) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Ratio ((%)) +import qualified Data.Sequence as Seq +import Data.Word (Word64) +import Lens.Micro +import Test.Cardano.Ledger.Babel.ImpTest +import Test.Cardano.Ledger.Core.Rational +import Test.Cardano.Ledger.Imp.Common +import Type.Reflection (Typeable) + +spec :: + forall era. + ( BabelEraImp era + , NFData (Event (EraRule "ENACT" era)) + , ToExpr (Event (EraRule "ENACT" era)) + , Eq (Event (EraRule "ENACT" era)) + , Typeable (Event (EraRule "ENACT" era)) + ) => + SpecWith (ImpTestState era) +spec = + describe "ENACT" $ do + relevantDuringBootstrapSpec + treasuryWithdrawalsSpec + noConfidenceSpec + constitutionSpec + actionPriorityCommitteePurposeSpec + hardForkInitiationSpec + +relevantDuringBootstrapSpec :: + BabelEraImp era => + SpecWith (ImpTestState era) +relevantDuringBootstrapSpec = do + actionPrioritySpec + hardForkInitiationNoDRepsSpec + +treasuryWithdrawalsSpec :: + forall era. + ( BabelEraImp era + , NFData (Event (EraRule "ENACT" era)) + , ToExpr (Event (EraRule "ENACT" era)) + , Eq (Event (EraRule "ENACT" era)) + , Typeable (Event (EraRule "ENACT" era)) + ) => + SpecWith (ImpTestState era) +treasuryWithdrawalsSpec = + describe "Treasury withdrawals" $ do + it "Modify EnactState as expected" $ do + rewardAcount1 <- registerRewardAccount + govActionId <- submitTreasuryWithdrawals [(rewardAcount1, Coin 666)] + gas <- getGovActionState govActionId + let govAction = gasAction gas + enactStateInit <- getEnactState + let signal = + EnactSignal + { esGovActionId = govActionId + , esGovAction = govAction + } + enactState = + enactStateInit + { ensTreasury = Coin 1000 + } + enactState' <- runImpRule @"ENACT" () enactState signal + ensWithdrawals enactState' `shouldBe` [(raCredential rewardAcount1, Coin 666)] + + rewardAcount2 <- registerRewardAccount + let withdrawals' = + [ (rewardAcount1, Coin 111) + , (rewardAcount2, Coin 222) + ] + govActionId' <- submitTreasuryWithdrawals withdrawals' + gas' <- getGovActionState govActionId' + let govAction' = gasAction gas' + let signal' = + EnactSignal + { esGovActionId = govActionId' + , esGovAction = govAction' + } + + enactState'' <- runImpRule @"ENACT" () enactState' signal' + + ensWithdrawals enactState'' + `shouldBe` [ (raCredential rewardAcount1, Coin 777) + , (raCredential rewardAcount2, Coin 222) + ] + ensTreasury enactState'' `shouldBe` Coin 1 + + it "Withdrawals exceeding treasury submitted in a single proposal" $ do + (committeeC :| _) <- registerInitialCommittee + (drepC, _, _) <- setupSingleDRep 1_000_000 + initialTreasury <- getTreasury + numWithdrawals <- choose (1, 10) + withdrawals <- genWithdrawalsExceeding initialTreasury numWithdrawals + + void $ enactTreasuryWithdrawals withdrawals drepC committeeC + checkNoWithdrawal initialTreasury withdrawals + + let sumRequested = foldMap snd withdrawals + + impAnn "Submit a treasury donation that can cover the withdrawals" $ do + let tx = + mkBasicTx mkBasicTxBody + & bodyTxL + . treasuryDonationTxBodyL + .~ (sumRequested <-> initialTreasury) + submitTx_ tx + passNEpochs 2 + getTreasury `shouldReturn` zero + sumRewardAccounts withdrawals `shouldReturn` sumRequested + + it "Withdrawals exceeding maxBound Word64 submitted in a single proposal" $ do + (committeeC :| _) <- registerInitialCommittee + (drepC, _, _) <- setupSingleDRep 1_000_000 + initialTreasury <- getTreasury + numWithdrawals <- choose (1, 10) + withdrawals <- genWithdrawalsExceeding (Coin (fromIntegral (maxBound :: Word64))) numWithdrawals + void $ enactTreasuryWithdrawals withdrawals drepC committeeC + checkNoWithdrawal initialTreasury withdrawals + + it "Withdrawals exceeding treasury submitted in several proposals within the same epoch" $ do + (committeeC :| _) <- registerInitialCommittee + (drepC, _, _) <- setupSingleDRep 1_000_000 + initialTreasury <- getTreasury + numWithdrawals <- choose (1, 10) + withdrawals <- genWithdrawalsExceeding initialTreasury numWithdrawals + + impAnn "submit in individual proposals in the same epoch" $ do + traverse_ + ( \w -> do + gaId <- submitTreasuryWithdrawals @era [w] + submitYesVote_ (DRepVoter drepC) gaId + submitYesVote_ (CommitteeVoter committeeC) gaId + ) + withdrawals + passNEpochs 2 + + let expectedTreasury = + foldl' + ( \acc (_, x) -> + if acc >= x + then acc <-> x + else acc + ) + initialTreasury + withdrawals + + getTreasury `shouldReturn` expectedTreasury + -- check that the sum of the rewards matches what was spent from the treasury + sumRewardAccounts withdrawals `shouldReturn` (initialTreasury <-> expectedTreasury) + where + getTreasury = getsNES (nesEsL . esAccountStateL . asTreasuryL) + sumRewardAccounts withdrawals = mconcat <$> traverse (getRewardAccountAmount . fst) withdrawals + genWithdrawalsExceeding (Coin val) n = do + vals <- genValuesExceeding val n + forM (Coin <$> vals) $ \coin -> (,coin) <$> registerRewardAccount + checkNoWithdrawal initialTreasury withdrawals = do + getTreasury `shouldReturn` initialTreasury + sumRewardAccounts withdrawals `shouldReturn` zero + genValuesExceeding val n = do + pcts <- replicateM (n - 1) $ choose (1, 100) + let tot = sum pcts + let amounts = map (\x -> ceiling ((x * val) % tot)) pcts + let minNeeded = max 0 (val - sum amounts + 1) + excess <- choose (minNeeded, val + 1) + pure $ excess : amounts + +hardForkInitiationSpec :: BabelEraImp era => SpecWith (ImpTestState era) +hardForkInitiationSpec = + it "HardForkInitiation" $ do + (committeeMember :| _) <- registerInitialCommittee + modifyPParams $ \pp -> + pp + & ppDRepVotingThresholdsL + . dvtHardForkInitiationL + .~ 2 + %! 3 + & ppPoolVotingThresholdsL + . pvtHardForkInitiationL + .~ 2 + %! 3 + _ <- setupPoolWithStake $ Coin 22_000_000 + (stakePoolId1, _, _) <- setupPoolWithStake $ Coin 22_000_000 + (stakePoolId2, _, _) <- setupPoolWithStake $ Coin 22_000_000 + (dRep1, _, _) <- setupSingleDRep 11_000_000 + (dRep2, _, _) <- setupSingleDRep 11_000_000 + curProtVer <- getProtVer + nextMajorVersion <- succVersion $ pvMajor curProtVer + let nextProtVer = curProtVer {pvMajor = nextMajorVersion} + govActionId <- submitGovAction $ HardForkInitiation SNothing nextProtVer + submitYesVote_ (CommitteeVoter committeeMember) govActionId + submitYesVote_ (DRepVoter dRep1) govActionId + submitYesVote_ (StakePoolVoter stakePoolId1) govActionId + passNEpochs 2 + getProtVer `shouldReturn` curProtVer + submitYesVote_ (DRepVoter dRep2) govActionId + passNEpochs 2 + getProtVer `shouldReturn` curProtVer + submitYesVote_ (StakePoolVoter stakePoolId2) govActionId + passNEpochs 2 + getProtVer `shouldReturn` nextProtVer + +hardForkInitiationNoDRepsSpec :: BabelEraImp era => SpecWith (ImpTestState era) +hardForkInitiationNoDRepsSpec = + it "HardForkInitiation without DRep voting" $ do + (committeeMember :| _) <- registerInitialCommittee + modifyPParams $ \pp -> + pp + & ppDRepVotingThresholdsL + . dvtHardForkInitiationL + .~ def + & ppPoolVotingThresholdsL + . pvtHardForkInitiationL + .~ 2 + %! 3 + _ <- setupPoolWithStake $ Coin 22_000_000 + (stakePoolId1, _, _) <- setupPoolWithStake $ Coin 22_000_000 + (stakePoolId2, _, _) <- setupPoolWithStake $ Coin 22_000_000 + curProtVer <- getProtVer + nextMajorVersion <- succVersion $ pvMajor curProtVer + let nextProtVer = curProtVer {pvMajor = nextMajorVersion} + govActionId <- submitGovAction $ HardForkInitiation SNothing nextProtVer + submitYesVote_ (CommitteeVoter committeeMember) govActionId + submitYesVote_ (StakePoolVoter stakePoolId1) govActionId + passNEpochs 2 + getProtVer `shouldReturn` curProtVer + submitYesVote_ (StakePoolVoter stakePoolId2) govActionId + passNEpochs 2 + getProtVer `shouldReturn` nextProtVer + +noConfidenceSpec :: forall era. BabelEraImp era => SpecWith (ImpTestState era) +noConfidenceSpec = + it "NoConfidence" $ do + modifyPParams $ \pp -> + pp + & ppDRepVotingThresholdsL + . dvtCommitteeNoConfidenceL + .~ 1 + %! 2 + & ppPoolVotingThresholdsL + . pvtCommitteeNoConfidenceL + .~ 1 + %! 2 + & ppCommitteeMaxTermLengthL + .~ EpochInterval 200 + let + getCommittee = + getsNES $ + nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . committeeGovStateL + assertNoCommittee :: HasCallStack => ImpTestM era () + assertNoCommittee = + do + committee <- getCommittee + impAnn "There should not be a committee" $ committee `shouldBe` SNothing + khCC <- freshKeyHash + initialCommitteeMembers <- getCommitteeMembers + + (drep, _, _) <- setupSingleDRep 1_000_000 + let committeeMap = + Map.fromList + [ (KeyHashObj khCC, EpochNo 50) + ] + prevGaidCommittee@(GovPurposeId gaidCommittee) <- + electCommittee + SNothing + drep + initialCommitteeMembers + committeeMap + (khSPO, _, _) <- setupPoolWithStake $ Coin 42_000_000 + logStakeDistr + submitYesVote_ (StakePoolVoter khSPO) gaidCommittee + replicateM_ 4 passEpoch + impAnn "Committee should be elected" $ do + committee <- getCommittee + committee `shouldBe` SJust (Committee committeeMap $ 1 %! 2) + pp <- getsNES $ nesEsL . curPParamsEpochStateL + returnAddr <- registerRewardAccount + gaidNoConf <- + submitProposal $ + ProposalProcedure + { pProcReturnAddr = returnAddr + , pProcGovAction = NoConfidence (SJust prevGaidCommittee) + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = def + } + submitYesVote_ (StakePoolVoter khSPO) gaidNoConf + submitYesVote_ (DRepVoter drep) gaidNoConf + replicateM_ 4 passEpoch + assertNoCommittee + +constitutionSpec :: BabelEraImp era => SpecWith (ImpTestState era) +constitutionSpec = + it "Constitution" $ do + (committeeMember :| _) <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep 1_000_000 + (govActionId, constitution) <- submitConstitution SNothing + initialConstitution <- getConstitution + + proposalsBeforeVotes <- getsNES $ newEpochStateGovStateL . proposalsGovStateL + pulserBeforeVotes <- getsNES newEpochStateDRepPulsingStateL + + submitYesVote_ (DRepVoter dRep) govActionId + submitYesVote_ (CommitteeVoter committeeMember) govActionId + + proposalsAfterVotes <- getsNES $ newEpochStateGovStateL . proposalsGovStateL + pulserAfterVotes <- getsNES newEpochStateDRepPulsingStateL + + impAnn "Votes are recorded in the proposals" $ do + let proposalsWithVotes = + proposalsAddVote + (CommitteeVoter committeeMember) + VoteYes + govActionId + ( proposalsAddVote + (DRepVoter dRep) + VoteYes + govActionId + proposalsBeforeVotes + ) + proposalsAfterVotes `shouldBe` proposalsWithVotes + + impAnn "Pulser has not changed" $ + pulserAfterVotes `shouldBe` pulserBeforeVotes + + passEpoch + + impAnn "New constitution is not enacted after one epoch" $ do + constitutionAfterOneEpoch <- getsNES $ newEpochStateGovStateL . constitutionGovStateL + constitutionAfterOneEpoch `shouldBe` initialConstitution + + impAnn "Pulser should reflect the constitution to be enacted" $ do + pulser <- getsNES newEpochStateDRepPulsingStateL + let ratifyState = extractDRepPulsingState pulser + gasId <$> rsEnacted ratifyState `shouldBe` govActionId Seq.:<| Seq.Empty + rsEnactState ratifyState ^. ensConstitutionL `shouldBe` constitution + + passEpoch + + impAnn "Constitution is enacted after two epochs" $ do + curConstitution <- getsNES $ newEpochStateGovStateL . constitutionGovStateL + curConstitution `shouldBe` constitution + + impAnn "Pulser is reset" $ do + pulser <- getsNES newEpochStateDRepPulsingStateL + let pulserRatifyState = extractDRepPulsingState pulser + rsEnacted pulserRatifyState `shouldBe` Seq.empty + enactState <- getEnactState + rsEnactState pulserRatifyState `shouldBe` enactState + +actionPriorityCommitteePurposeSpec :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +actionPriorityCommitteePurposeSpec = + describe "Competing proposals with different priorities" $ do + it + "higher action priority wins" + $ do + (drepC, _, _) <- setupSingleDRep 1_000_000 + (poolKH, _, _) <- setupPoolWithStake $ Coin 1_000_000 + cc <- KeyHashObj <$> freshKeyHash + gai1 <- + submitGovAction $ + UpdateCommittee SNothing mempty (Map.singleton cc (EpochNo 30)) $ + 1 %! 2 + -- gai2 is the first action of a higher priority + gai2 <- submitGovAction $ NoConfidence SNothing + gai3 <- submitGovAction $ NoConfidence SNothing + traverse_ @[] + ( \gaid -> do + submitYesVote_ (DRepVoter drepC) gaid + submitYesVote_ (StakePoolVoter poolKH) gaid + ) + [gai1, gai2, gai3] + passNEpochs 2 + getLastEnactedCommittee + `shouldReturn` SJust (GovPurposeId gai2) + expectNoCurrentProposals + + committee <- + getsNES $ + nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . committeeGovStateL + committee `shouldBe` SNothing + +actionPrioritySpec :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +actionPrioritySpec = + describe "Competing proposals ratified in the same epoch" $ do + let val1 = Coin 1_000_001 + let val2 = Coin 1_000_002 + let val3 = Coin 1_000_003 + + it "proposals of same priority are enacted in order of submission" $ do + modifyPParams $ \pp -> + pp + & ppDRepVotingThresholdsL + . dvtPPEconomicGroupL + .~ def + & ppPoolVotingThresholdsL + . pvtPPSecurityGroupL + .~ 1 + %! 1 + + (committeeC :| _) <- registerInitialCommittee + (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000 + pGai0 <- + submitParameterChange + SNothing + $ def & ppuMinFeeAL .~ SJust val1 + pGai1 <- + submitParameterChange + (SJust pGai0) + $ def & ppuMinFeeAL .~ SJust val2 + pGai2 <- + submitParameterChange + (SJust pGai1) + $ def & ppuMinFeeAL .~ SJust val3 + traverse_ @[] + ( \gaid -> do + submitYesVote_ (StakePoolVoter spoC) gaid + submitYesVote_ (CommitteeVoter committeeC) gaid + ) + [pGai0, pGai1, pGai2] + passNEpochs 2 + getLastEnactedParameterChange + `shouldReturn` SJust (GovPurposeId pGai2) + expectNoCurrentProposals + getsNES (nesEsL . curPParamsEpochStateL . ppMinFeeAL) + `shouldReturn` val3 + + it "only the first action of a transaction gets enacted" $ do + modifyPParams $ \pp -> + pp + & ppDRepVotingThresholdsL + . dvtPPEconomicGroupL + .~ def + & ppPoolVotingThresholdsL + . pvtPPSecurityGroupL + .~ 1 + %! 1 + (committeeC :| _) <- registerInitialCommittee + (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000 + gaids <- + submitGovActions $ + NE.fromList + [ ParameterChange + SNothing + (def & ppuMinFeeAL .~ SJust val1) + SNothing + , ParameterChange + SNothing + (def & ppuMinFeeAL .~ SJust val2) + SNothing + , ParameterChange + SNothing + (def & ppuMinFeeAL .~ SJust val3) + SNothing + ] + traverse_ + ( \gaid -> do + submitYesVote_ (StakePoolVoter spoC) gaid + submitYesVote_ (CommitteeVoter committeeC) gaid + ) + gaids + passNEpochs 2 + getsNES (nesEsL . curPParamsEpochStateL . ppMinFeeAL) + `shouldReturn` val1 + expectNoCurrentProposals diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EpochSpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EpochSpec.hs new file mode 100644 index 00000000000..cd830075df3 --- /dev/null +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EpochSpec.hs @@ -0,0 +1,433 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.Cardano.Ledger.Babel.Imp.EpochSpec ( + spec, + relevantDuringBootstrapSpec, +) where + +import Cardano.Ledger.Address (RewardAccount (..)) +import Cardano.Ledger.BaseTypes (EpochInterval (..), EpochNo (..)) +import Cardano.Ledger.Coin +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Governance +import Cardano.Ledger.Babel.PParams +import Cardano.Ledger.Babel.Rules (BabelEpochEvent (GovInfoEvent), BabelNewEpochEvent (..)) +import Cardano.Ledger.Credential (Credential (..)) +import Cardano.Ledger.Shelley.LedgerState +import Cardano.Ledger.Shelley.Rules (Event, ShelleyTickEvent (..)) +import Cardano.Ledger.Val +import Control.Monad.Writer (listen) +import Data.Data (cast) +import Data.Default.Class (Default (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Maybe.Strict (StrictMaybe (..)) +import qualified Data.Sequence.Strict as SSeq +import qualified Data.Set as Set +import Data.Tree +import Lens.Micro ((&), (.~)) +import Test.Cardano.Ledger.Babel.ImpTest +import Test.Cardano.Ledger.Core.Rational (IsRatio (..), (%!)) +import Test.Cardano.Ledger.Imp.Common + +spec :: + forall era. + ( BabelEraImp era + , InjectRuleEvent "TICK" BabelEpochEvent era + , Event (EraRule "EPOCH" era) ~ BabelEpochEvent era + , Event (EraRule "NEWEPOCH" era) ~ BabelNewEpochEvent era + ) => + SpecWith (ImpTestState era) +spec = + describe "EPOCH" $ do + relevantDuringBootstrapSpec + dRepVotingSpec + treasurySpec + +relevantDuringBootstrapSpec :: + forall era. + ( BabelEraImp era + , InjectRuleEvent "TICK" BabelEpochEvent era + , Event (EraRule "EPOCH" era) ~ BabelEpochEvent era + , Event (EraRule "NEWEPOCH" era) ~ BabelNewEpochEvent era + ) => + SpecWith (ImpTestState era) +relevantDuringBootstrapSpec = do + proposalsSpec + dRepSpec + eventsSpec + +proposalsSpec :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +proposalsSpec = + describe "Proposals" $ do + it "Proposals survive multiple epochs without any activity" $ do + -- + 2 epochs to pass to get the desired effect + modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 4 + _tree <- + submitParameterChangeTree SNothing $ + Node + () + [ Node + () + [ Node () [] + , Node () [] + ] + , Node () [] + ] + + forest <- getProposals + passNEpochs 5 + forest' <- getProposals + forest' `shouldBe` forest + passEpoch + forest'' <- getProposals + forest'' `shouldBe` def + it "Expired proposal deposit refunded" $ do + let deposit = Coin 999 + modifyPParams $ \pp -> + pp + & ppGovActionLifetimeL + .~ EpochInterval 1 + & ppGovActionDepositL + .~ deposit + rewardAccount <- registerRewardAccount + + initialValue <- getsNES (nesEsL . curPParamsEpochStateL . ppMinFeeAL) + + policy <- + getsNES $ + nesEpochStateL . epochStateGovStateL . constitutionGovStateL . constitutionScriptL + govActionId <- + submitProposal $ + ProposalProcedure + { pProcDeposit = deposit + , pProcReturnAddr = rewardAccount + , pProcGovAction = + ParameterChange + SNothing + (def & ppuMinFeeAL .~ SJust (Coin 3000)) + policy + , pProcAnchor = def + } + expectPresentGovActionId govActionId + passEpoch + passEpoch + passEpoch + expectMissingGovActionId govActionId + + getsNES (nesEsL . curPParamsEpochStateL . ppMinFeeAL) `shouldReturn` initialValue + getRewardAccountAmount rewardAccount `shouldReturn` deposit + where + submitParameterChangeTree = submitGovActionTree $ submitGovAction . paramAction + paramAction p = + ParameterChange (GovPurposeId <$> p) (def & ppuMinFeeAL .~ SJust (Coin 10)) SNothing + +dRepSpec :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +dRepSpec = + describe "DRep" $ do + it "expiry is updated based on the number of dormant epochs" $ do + modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2 + (drep, _, _) <- setupSingleDRep 1_000_000 + + let submitParamChangeProposal = + submitParameterChange SNothing $ def & ppuMinFeeAL .~ SJust (Coin 3000) + expectNumDormantEpochs 0 + + -- epoch 0 + _ <- submitParamChangeProposal + expectCurrentProposals + expectNoPulserProposals + expectNumDormantEpochs 0 + expectExtraDRepExpiry drep 0 + + passEpoch + -- epoch 1 + expectCurrentProposals + expectPulserProposals + expectNumDormantEpochs 1 + expectExtraDRepExpiry drep 0 + + passEpoch + -- epoch 2 + expectCurrentProposals + expectPulserProposals + expectNumDormantEpochs 1 + expectExtraDRepExpiry drep 0 + + passEpoch + -- epoch 3 + expectCurrentProposals + expectPulserProposals + expectNumDormantEpochs 1 + expectExtraDRepExpiry drep 0 + + passEpoch + -- epoch 4, proposals expired + expectNoCurrentProposals + expectNoPulserProposals + expectNumDormantEpochs 1 + expectExtraDRepExpiry drep 0 + + passEpoch + -- epoch 5 + expectNoCurrentProposals + expectNoPulserProposals + expectNumDormantEpochs 2 + expectExtraDRepExpiry drep 0 + + _ <- submitParamChangeProposal + -- number of dormant epochs is added to the drep expiry and the reset + expectNumDormantEpochs 0 + expectExtraDRepExpiry drep 2 + + passEpoch + -- epoch 6 + expectCurrentProposals + expectPulserProposals + expectNumDormantEpochs 1 + expectExtraDRepExpiry drep 2 + it "DRep registration should succeed" $ do + logEntry "Stake distribution before DRep registration:" + logStakeDistr + _ <- registerDRep + logEntry "Stake distribution after DRep registration:" + logStakeDistr + passEpoch + +dRepVotingSpec :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +dRepVotingSpec = + describe "DRep" $ do + it "proposal is accepted after two epochs" $ do + modifyPParams $ \pp -> + pp + & ppDRepVotingThresholdsL + .~ def + { dvtPPEconomicGroup = 1 %! 1 + } + let getParamValue = getsNES (nesEsL . curPParamsEpochStateL . ppMinFeeAL) + initialParamValue <- getParamValue + + let proposedValue = initialParamValue <+> Coin 300 + let proposedUpdate = def & ppuMinFeeAL .~ SJust proposedValue + + -- Submit NewConstitution proposal two epoch too early to check that the action + -- doesn't expire prematurely (ppGovActionLifetimeL is set to two epochs) + logEntry "Submitting new minFee proposal" + gid <- submitParameterChange SNothing proposedUpdate + + (committeeHotCred :| _) <- registerInitialCommittee + (dRepCred, _, _) <- setupSingleDRep 1_000_000 + passEpoch + logRatificationChecks gid + do + isAccepted <- isDRepAccepted gid + assertBool "Gov action should not be accepted" $ not isAccepted + submitYesVote_ (DRepVoter dRepCred) gid + submitYesVote_ (CommitteeVoter committeeHotCred) gid + logAcceptedRatio gid + do + isAccepted <- isDRepAccepted gid + assertBool "Gov action should be accepted" isAccepted + + passEpoch + do + isAccepted <- isDRepAccepted gid + assertBool "Gov action should be accepted" isAccepted + logAcceptedRatio gid + logRatificationChecks gid + getParamValue `shouldReturn` initialParamValue + passEpoch + getParamValue `shouldReturn` proposedValue + +treasurySpec :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +treasurySpec = + describe "Treasury" $ do + it "TreasuryWithdrawal" $ do + treasuryWithdrawalExpectation [] + + it "TreasuryWithdrawalExtra" $ do + rewardAccount <- registerRewardAccount + rewardAccountOther <- registerRewardAccount + govPolicy <- getGovPolicy + treasuryWithdrawalExpectation + [ TreasuryWithdrawals (Map.singleton rewardAccount (Coin 667)) govPolicy + , TreasuryWithdrawals (Map.singleton rewardAccountOther (Coin 668)) govPolicy + ] + + it + "deposit is moved to treasury when the reward address is not registered" + depositMovesToTreasuryWhenStakingAddressUnregisters + +treasuryWithdrawalExpectation :: + forall era. + BabelEraImp era => + [GovAction era] -> + ImpTestM era () +treasuryWithdrawalExpectation extraWithdrawals = do + (committeeHotCred :| _) <- registerInitialCommittee + (dRepCred, _, _) <- setupSingleDRep 1_000_000 + treasuryStart <- getsNES $ nesEsL . esAccountStateL . asTreasuryL + rewardAccount <- registerRewardAccount + govPolicy <- getGovPolicy + let withdrawalAmount = Coin 666 + (govActionId NE.:| _) <- + submitGovActions $ + TreasuryWithdrawals (Map.singleton rewardAccount withdrawalAmount) govPolicy + NE.:| extraWithdrawals + submitYesVote_ (DRepVoter dRepCred) govActionId + submitYesVote_ (CommitteeVoter committeeHotCred) govActionId + passEpoch -- 1st epoch crossing starts DRep pulser + impAnn "Withdrawal should not be received yet" $ + lookupReward (raCredential rewardAccount) `shouldReturn` mempty + passEpoch -- 2nd epoch crossing enacts all the ratified actions + treasuryEnd <- getsNES $ nesEsL . esAccountStateL . asTreasuryL + impAnn "Withdrawal deducted from treasury" $ + treasuryStart <-> treasuryEnd `shouldBe` withdrawalAmount + impAnn "Withdrawal received by reward account" $ + lookupReward (raCredential rewardAccount) `shouldReturn` withdrawalAmount + expectMissingGovActionId govActionId + +depositMovesToTreasuryWhenStakingAddressUnregisters :: BabelEraImp era => ImpTestM era () +depositMovesToTreasuryWhenStakingAddressUnregisters = do + initialTreasury <- getsNES $ nesEsL . esAccountStateL . asTreasuryL + modifyPParams $ \pp -> + pp + & ppGovActionLifetimeL + .~ EpochInterval 8 + & ppGovActionDepositL + .~ Coin 100 + & ppCommitteeMaxTermLengthL + .~ EpochInterval 0 + returnAddr <- registerRewardAccount + govActionDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL + khCC <- KeyHashObj <$> freshKeyHash + committeeActionId <- + submitProposal + ProposalProcedure + { pProcReturnAddr = returnAddr + , pProcGovAction = + UpdateCommittee + SNothing + mempty + (Map.singleton khCC $ EpochNo 10) + (1 %! 2) + , pProcDeposit = govActionDeposit + , pProcAnchor = def + } + expectPresentGovActionId committeeActionId + replicateM_ 5 passEpoch + expectTreasury initialTreasury + expectRegisteredRewardAddress returnAddr + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton + (UnRegTxCert $ raCredential returnAddr) + expectNotRegisteredRewardAddress returnAddr + replicateM_ 5 passEpoch + expectMissingGovActionId committeeActionId + expectTreasury $ initialTreasury <> govActionDeposit + +eventsSpec :: + forall era. + ( BabelEraImp era + , InjectRuleEvent "TICK" BabelEpochEvent era + , Event (EraRule "NEWEPOCH" era) ~ BabelNewEpochEvent era + , Event (EraRule "EPOCH" era) ~ BabelEpochEvent era + ) => + SpecWith (ImpTestState era) +eventsSpec = describe "Events" $ do + describe "emits event" $ do + it "GovInfoEvent" $ do + (ccCred :| _) <- registerInitialCommittee + (spoCred, _, _) <- setupPoolWithStake $ Coin 42_000_000 + + let actionLifetime = 10 + modifyPParams $ \pp -> + pp + & ppGovActionLifetimeL + .~ EpochInterval actionLifetime + & ppDRepVotingThresholdsL + . dvtPPEconomicGroupL + .~ def + & ppPoolVotingThresholdsL + . pvtPPSecurityGroupL + .~ 1 + %! 1 + propDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL + let + proposeCostModel = do + newVal <- arbitrary + submitParameterChange SNothing $ def & ppuCoinsPerUTxOByteL .~ SJust newVal + proposalA <- impAnn "proposalA" proposeCostModel + proposalB <- impAnn "proposalB" proposeCostModel + rewardAccount@(RewardAccount _ rewardCred) <- registerRewardAccount + proposalC <- impAnn "proposalC" $ do + newVal <- arbitrary + submitProposal + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = + ParameterChange + SNothing + (def & ppuCoinsPerUTxOByteL .~ SJust newVal) + SNothing + , pProcDeposit = propDeposit + , pProcAnchor = def + } + let + isGovInfoEvent (SomeSTSEvent ev) + | Just (TickNewEpochEvent (EpochEvent (GovInfoEvent {})) :: ShelleyTickEvent era) <- cast ev = True + isGovInfoEvent _ = False + passEpochWithNoDroppedActions = do + (_, evs) <- listen passEpoch + filter isGovInfoEvent evs + `shouldBeExpr` [ SomeSTSEvent @era @"TICK" . injectEvent $ + GovInfoEvent mempty mempty mempty + ] + replicateM_ (fromIntegral actionLifetime) passEpochWithNoDroppedActions + logAcceptedRatio proposalA + submitYesVote_ (StakePoolVoter spoCred) proposalA + submitYesVote_ (CommitteeVoter ccCred) proposalA + gasA <- getGovActionState proposalA + gasB <- getGovActionState proposalB + gasC <- getGovActionState proposalC + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton (UnRegTxCert rewardCred) + passEpochWithNoDroppedActions + (_, evs) <- listen passEpoch + let + filteredEvs = filter isGovInfoEvent evs + filteredEvs + `shouldBeExpr` [ SomeSTSEvent @era @"TICK" . injectEvent $ + GovInfoEvent + (Set.singleton gasA) + (Set.fromList [gasB, gasC]) + (Set.singleton proposalC) + ] diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovCertSpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovCertSpec.hs new file mode 100644 index 00000000000..9cb8e5fc3b6 --- /dev/null +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovCertSpec.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Cardano.Ledger.Babel.Imp.GovCertSpec ( + spec, + relevantDuringBootstrapSpec, +) where + +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Babel.Core ( + EraGov (..), + InjectRuleFailure (..), + ppDRepDepositL, + ) +import Cardano.Ledger.Babel.Governance ( + BabelEraGov (..), + BabelGovState, + GovAction (..), + GovPurposeId (..), + Voter (..), + committeeMembersL, + ) +import Cardano.Ledger.Babel.Rules (BabelGovCertPredFailure (..)) +import Cardano.Ledger.Babel.TxCert ( + pattern AuthCommitteeHotKeyTxCert, + pattern RegDRepTxCert, + pattern ResignCommitteeColdTxCert, + pattern UnRegDRepTxCert, + ) +import Cardano.Ledger.Core (EraTx (..), EraTxBody (..)) +import Cardano.Ledger.Credential (Credential (..)) +import Cardano.Ledger.Shelley.LedgerState ( + curPParamsEpochStateL, + esLStateL, + lsUTxOStateL, + nesEsL, + utxosGovStateL, + ) +import Cardano.Ledger.Val (Val (..)) +import qualified Data.Map.Strict as Map +import Data.Maybe.Strict (StrictMaybe (..)) +import qualified Data.Sequence.Strict as SSeq +import qualified Data.Set as Set +import Lens.Micro ((&), (.~), (^.)) +import Test.Cardano.Ledger.Common hiding (assertBool, shouldBe) +import Test.Cardano.Ledger.Babel.Arbitrary () +import Test.Cardano.Ledger.Babel.ImpTest +import Test.Cardano.Ledger.Core.Rational (IsRatio (..)) +import Test.Cardano.Ledger.Imp.Common + +spec :: + forall era. + ( BabelEraImp era + , GovState era ~ BabelGovState era + , InjectRuleFailure "LEDGER" BabelGovCertPredFailure era + ) => + SpecWith (ImpTestState era) +spec = do + relevantDuringBootstrapSpec + describe "GOVCERT" + $ it + "A CC that has resigned will need to be first voted out and then voted in to be considered active" + $ do + (drepCred, _, _) <- setupSingleDRep 1_000_000 + passNEpochs 2 + -- Add a fresh CC + cc <- KeyHashObj <$> freshKeyHash + let addCCAction = UpdateCommittee SNothing mempty (Map.singleton cc 10) (1 %! 2) + addCCGaid <- submitGovAction addCCAction + submitYesVote_ (DRepVoter drepCred) addCCGaid + passNEpochs 2 + -- Confirm that they are added + SJust committee <- getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . committeeGovStateL + let assertCCMembership comm = + assertBool "Expected CC to be present in the committee" $ + Map.member cc (comm ^. committeeMembersL) + assertCCMissing comm = + assertBool "Expected CC to be absent in the committee" $ + Map.notMember cc (comm ^. committeeMembersL) + assertCCMembership committee + -- Confirm their hot key registration + _hotKey <- registerCommitteeHotKey cc + ccShouldNotBeResigned cc + -- Have them resign + resignCommitteeColdKey cc SNothing + ccShouldBeResigned cc + -- Re-add the same CC + let reAddCCAction = UpdateCommittee (SJust $ GovPurposeId addCCGaid) mempty (Map.singleton cc 20) (1 %! 2) + reAddCCGaid <- submitGovAction reAddCCAction + submitYesVote_ (DRepVoter drepCred) reAddCCGaid + passNEpochs 2 + -- Confirm that they are still resigned + ccShouldBeResigned cc + -- Remove them + let removeCCAction = UpdateCommittee (SJust $ GovPurposeId reAddCCGaid) (Set.singleton cc) mempty (1 %! 2) + removeCCGaid <- submitGovAction removeCCAction + submitYesVote_ (DRepVoter drepCred) removeCCGaid + passNEpochs 2 + -- Confirm that they have been removed + SJust committeeAfterRemove <- + getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . committeeGovStateL + assertCCMissing committeeAfterRemove + -- Add the same CC back a second time + let secondAddCCAction = UpdateCommittee (SJust $ GovPurposeId removeCCGaid) mempty (Map.singleton cc 20) (1 %! 2) + secondAddCCGaid <- submitGovAction secondAddCCAction + submitYesVote_ (DRepVoter drepCred) secondAddCCGaid + passNEpochs 2 + -- Confirm that they have been added + SJust committeeAfterRemoveAndAdd <- + getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . committeeGovStateL + assertCCMembership committeeAfterRemoveAndAdd + -- Confirm that after registering a hot key, they are active + _hotKey <- registerCommitteeHotKey cc + ccShouldNotBeResigned cc + +relevantDuringBootstrapSpec :: + forall era. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" BabelGovCertPredFailure era + ) => + SpecWith (ImpTestState era) +relevantDuringBootstrapSpec = do + describe "succeeds for" $ do + it "registering and unregistering a DRep" $ do + modifyPParams $ ppDRepDepositL .~ Coin 100 + drepCred <- KeyHashObj <$> freshKeyHash + drepDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppDRepDepositL + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton (RegDRepTxCert drepCred drepDeposit SNothing) + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton (UnRegDRepTxCert drepCred drepDeposit) + it "resigning a non-CC key" $ do + someCred <- KeyHashObj <$> freshKeyHash + submitTx_ + ( mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton (ResignCommitteeColdTxCert someCred SNothing) + ) + it "re-registering a CC hot key" $ do + void registerInitialCommittee + initialCommittee <- getCommitteeMembers + forM_ initialCommittee $ \kh -> + replicateM_ 10 $ do + ccHotCred <- KeyHashObj <$> freshKeyHash + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton (AuthCommitteeHotKeyTxCert kh ccHotCred) + describe "fails for" $ do + it "invalid deposit provided with DRep registration cert" $ do + modifyPParams $ ppDRepDepositL .~ Coin 100 + expectedDRepDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppDRepDepositL + let providedDRepDeposit = expectedDRepDeposit <+> Coin 10 + khDRep <- freshKeyHash + submitFailingTx + ( mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton + (RegDRepTxCert (KeyHashObj khDRep) providedDRepDeposit SNothing) + ) + ( pure . injectFailure $ + BabelDRepIncorrectDeposit providedDRepDeposit expectedDRepDeposit + ) + it "invalid refund provided with DRep deregistration cert" $ do + modifyPParams $ ppDRepDepositL .~ Coin 100 + drepDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppDRepDepositL + let refund = drepDeposit <+> Coin 10 + drepCred <- KeyHashObj <$> freshKeyHash + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton + (RegDRepTxCert drepCred drepDeposit SNothing) + submitFailingTx + ( mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton + (UnRegDRepTxCert drepCred refund) + ) + ( pure . injectFailure $ + BabelDRepIncorrectRefund refund drepDeposit + ) + it "DRep already registered" $ do + modifyPParams $ ppDRepDepositL .~ Coin 100 + drepDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppDRepDepositL + drepCred <- KeyHashObj <$> freshKeyHash + let + regTx = + mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton + (RegDRepTxCert drepCred drepDeposit SNothing) + submitTx_ regTx + submitFailingTx + regTx + (pure . injectFailure $ BabelDRepAlreadyRegistered drepCred) + it "unregistering a nonexistent DRep" $ do + modifyPParams $ ppDRepDepositL .~ Coin 100 + drepDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppDRepDepositL + drepCred <- KeyHashObj <$> freshKeyHash + submitFailingTx + ( mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton (UnRegDRepTxCert drepCred drepDeposit) + ) + (pure . injectFailure $ BabelDRepNotRegistered drepCred) + it "registering a resigned CC member hotkey" $ do + void registerInitialCommittee + initialCommittee <- getCommitteeMembers + forM_ initialCommittee $ \ccCred -> do + ccHotCred <- KeyHashObj <$> freshKeyHash + let + registerHotKeyTx = + mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton (AuthCommitteeHotKeyTxCert ccCred ccHotCred) + submitTx_ registerHotKeyTx + submitTx_ $ + mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton (ResignCommitteeColdTxCert ccCred SNothing) + submitFailingTx + registerHotKeyTx + (pure . injectFailure $ BabelCommitteeHasPreviouslyResigned ccCred) diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovSpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovSpec.hs new file mode 100644 index 00000000000..ff14f077950 --- /dev/null +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovSpec.hs @@ -0,0 +1,1408 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Test.Cardano.Ledger.Babel.Imp.GovSpec ( + spec, + relevantDuringBootstrapSpec, +) where + +import Cardano.Ledger.Address (RewardAccount (..)) +import Cardano.Ledger.Allegra.Scripts ( + pattern RequireAllOf, + pattern RequireAnyOf, + pattern RequireMOf, + pattern RequireSignature, + ) +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Governance +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Coin (Coin (Coin)) +import Cardano.Ledger.Conway.Governance (ConwayGovState) +import Cardano.Ledger.Conway.Rules (ConwayGovPredFailure (..)) +import Cardano.Ledger.Credential (Credential (KeyHashObj)) +import Cardano.Ledger.Plutus.CostModels (updateCostModels) +import qualified Cardano.Ledger.Shelley.HardForks as HF +import Cardano.Ledger.Shelley.LedgerState +import Cardano.Ledger.Val (zero, (<->)) +import Data.Default.Class (Default (..)) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust) +import qualified Data.OMap.Strict as OMap +import qualified Data.Sequence.Strict as SSeq +import qualified Data.Set as Set +import Data.Tree +import Lens.Micro +import Test.Cardano.Ledger.Babel.Arbitrary () +import Test.Cardano.Ledger.Babel.ImpTest +import Test.Cardano.Ledger.Core.Arbitrary (FlexibleCostModels (..)) +import Test.Cardano.Ledger.Core.Rational (IsRatio (..)) +import Test.Cardano.Ledger.Imp.Common hiding (Success) + +spec :: + forall era. + ( BabelEraImp era + , GovState era ~ ConwayGovState era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + ) => + SpecWith (ImpTestState era) +spec = + describe "GOV" $ do + relevantDuringBootstrapSpec + constitutionSpec + proposalsWithVotingSpec + votingSpec + policySpec + networkIdWithdrawalsSpec + predicateFailuresSpec + unknownCostModelsSpec + +relevantDuringBootstrapSpec :: + forall era. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + ) => + SpecWith (ImpTestState era) +relevantDuringBootstrapSpec = do + hardForkSpec + pparamUpdateSpec + proposalsSpec + networkIdSpec + bootstrapPhaseSpec + +unknownCostModelsSpec :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +unknownCostModelsSpec = + describe "Unknown CostModels" $ do + it "Are accepted" $ do + costModels <- getsPParams ppCostModelsL + FlexibleCostModels newCostModels <- arbitrary + (hotCommitteeC :| _) <- registerInitialCommittee + (drepC, _, _) <- setupSingleDRep 1_000_000 + gai <- + submitParameterChange SNothing $ + emptyPParamsUpdate + & ppuCostModelsL + .~ SJust newCostModels + submitYesVote_ (DRepVoter drepC) gai + submitYesVote_ (CommitteeVoter hotCommitteeC) gai + passNEpochs 2 + getLastEnactedParameterChange `shouldReturn` SJust (GovPurposeId gai) + getsPParams ppCostModelsL `shouldReturn` updateCostModels costModels newCostModels + +predicateFailuresSpec :: + forall era. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + ) => + SpecWith (ImpTestState era) +predicateFailuresSpec = + describe "Predicate failures" $ do + it "ExpirationEpochTooSmall" $ do + pp <- getsNES $ nesEsL . curPParamsEpochStateL + committeeC <- KeyHashObj <$> freshKeyHash + rewardAccount <- registerRewardAccount + let expiration = EpochNo 1 + action = + UpdateCommittee + SNothing + mempty + (Map.singleton committeeC expiration) + (0 %! 1) + passEpoch + submitFailingProposal + ( ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = action + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = def + } + ) + [injectFailure $ ExpirationEpochTooSmall $ Map.singleton committeeC expiration] + it "ProposalDepositIncorrect" $ do + committeeC <- KeyHashObj <$> freshKeyHash + rewardAccount <- registerRewardAccount + let expiration = EpochNo 1 + actionDeposit = Coin 2 + action = + UpdateCommittee + SNothing + mempty + (Map.singleton committeeC expiration) + (0 %! 1) + modifyPParams $ ppGovActionDepositL .~ actionDeposit + submitFailingProposal + ( ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = action + , pProcDeposit = actionDeposit <-> Coin 1 + , pProcAnchor = def + } + ) + [injectFailure $ ProposalDepositIncorrect (actionDeposit <-> Coin 1) actionDeposit] + it "ConflictingCommitteeUpdate" $ do + pp <- getsNES $ nesEsL . curPParamsEpochStateL + committeeC <- KeyHashObj <$> freshKeyHash + rewardAccount <- registerRewardAccount + let expiration = EpochNo 1 + action = + UpdateCommittee + SNothing + (Set.singleton committeeC) + (Map.singleton committeeC expiration) + (0 %! 1) + submitFailingProposal + ( ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = action + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = def + } + ) + [injectFailure $ ConflictingCommitteeUpdate $ Set.singleton committeeC] + +hardForkSpec :: + forall era. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + ) => + SpecWith (ImpTestState era) +hardForkSpec = + describe "HardFork" $ do + describe "Hardfork is the first one (doesn't have a GovPurposeId) " $ do + it "Hardfork minorFollow" (firstHardForkFollows minorFollow) + it "Hardfork majorFollow" (firstHardForkFollows majorFollow) + it "Hardfork cantFollow" firstHardForkCantFollow + describe "Hardfork is the second one (has a GovPurposeId)" $ do + it "Hardfork minorFollow" (secondHardForkFollows minorFollow) + it "Hardfork majorFollow" (secondHardForkFollows majorFollow) + it "Hardfork cantFollow" secondHardForkCantFollow + +pparamUpdateSpec :: + forall era. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + ) => + SpecWith (ImpTestState era) +pparamUpdateSpec = + describe "PParamUpdate" $ do + describe "PPU needs to be wellformed" $ do + let testMalformedProposal lbl lenz val = it lbl $ do + pp <- getsNES $ nesEsL . curPParamsEpochStateL + rew <- registerRewardAccount + let ppUpdate = + emptyPParamsUpdate + & lenz + .~ SJust val + ga = ParameterChange SNothing ppUpdate SNothing + submitFailingProposal + ( ProposalProcedure + { pProcReturnAddr = rew + , pProcGovAction = ga + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = def + } + ) + [injectFailure $ MalformedProposal ga] + testMalformedProposal + "ppuMaxBBSizeL cannot be 0" + ppuMaxBBSizeL + 0 + testMalformedProposal + "ppuMaxTxSizeL cannot be 0" + ppuMaxTxSizeL + 0 + testMalformedProposal + "ppuMaxBHSizeL cannot be 0" + ppuMaxBHSizeL + 0 + testMalformedProposal + "ppuMaxValSizeL cannot be 0" + ppuMaxValSizeL + 0 + testMalformedProposal + "ppuCollateralPercentageL cannot be 0" + ppuCollateralPercentageL + 0 + testMalformedProposal + "ppuCommitteeMaxTermLengthL cannot be 0" + ppuCommitteeMaxTermLengthL + $ EpochInterval 0 + testMalformedProposal + "ppuGovActionLifetimeL cannot be 0" + ppuGovActionLifetimeL + $ EpochInterval 0 + testMalformedProposal + "ppuPoolDepositL cannot be 0" + ppuPoolDepositL + zero + testMalformedProposal + "ppuGovActionDepositL cannot be 0" + ppuGovActionDepositL + zero + testMalformedProposal + "ppuDRepDepositL cannot be 0" + ppuDRepDepositL + zero + it "PPU cannot be empty" $ do + pp <- getsNES $ nesEsL . curPParamsEpochStateL + rew <- registerRewardAccount + let ga = ParameterChange SNothing emptyPParamsUpdate SNothing + submitFailingProposal + ( ProposalProcedure + { pProcReturnAddr = rew + , pProcGovAction = ga + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = def + } + ) + [injectFailure $ MalformedProposal ga] + +proposalsWithVotingSpec :: + forall era. + ( BabelEraImp era + , GovState era ~ BabelGovState era + ) => + SpecWith (ImpTestState era) +proposalsWithVotingSpec = + describe "Proposals" $ do + describe "Consistency" $ do + it "Subtrees are pruned when competing proposals are enacted" $ do + (dRep, committeeMember, GovPurposeId committeeGovActionId) <- electBasicCommittee + a@[ _ + , b@(Node p2 _) + ] <- + submitConstitutionForest + SNothing + [ Node + () + [ Node + () + [ Node () [] + , Node () [] + ] + ] + , Node + () + [ Node () [] + ] + ] + + getProposalsForest + `shouldReturn` [ Node SNothing [] + , Node SNothing [] + , Node (SJust committeeGovActionId) [] + , Node SNothing (fmap SJust <$> a) + ] + passEpoch + submitYesVote_ (DRepVoter dRep) p2 + submitYesVote_ (CommitteeVoter committeeMember) p2 + passNEpochs 2 + getProposalsForest + `shouldReturn` [ Node SNothing [] + , Node SNothing [] + , Node (SJust committeeGovActionId) [] + , SJust <$> b + ] + it "Subtrees are pruned when competing proposals are enacted over multiple rounds" $ do + (committeeMember :| _) <- registerInitialCommittee + (drepC, _, _) <- setupSingleDRep 1_000_000 + a@[ c + , Node + p2 + [ Node p21 [] + , Node p22 [] + ] + , Node p3 [] + ] <- + submitConstitutionForest + SNothing + [ Node + () + [ Node + () + [ Node () [] + , Node () [] + ] + ] + , Node + () + [ Node () [] + , Node () [] + ] + , Node () [] + ] + submitYesVote_ (DRepVoter drepC) p2 + submitYesVote_ (CommitteeVoter committeeMember) p2 + submitYesVote_ (DRepVoter drepC) p21 + submitYesVote_ (CommitteeVoter committeeMember) p21 + submitYesVote_ (DRepVoter drepC) p3 + submitYesVote_ (CommitteeVoter committeeMember) p3 -- Two competing proposals break the tie based on proposal order + fmap (!! 3) getProposalsForest + `shouldReturn` Node SNothing (fmap SJust <$> a) + passEpoch + p4 <- submitConstitutionGovAction SNothing + p31 <- submitConstitutionGovAction $ SJust p3 + p211 <- submitConstitutionGovAction $ SJust p21 + fmap (!! 3) getProposalsForest + `shouldReturn` Node + SNothing + [ SJust <$> c + , Node + (SJust p2) + [ Node (SJust p21) [Node (SJust p211) []] + , Node (SJust p22) [] + ] + , Node (SJust p3) [Node (SJust p31) []] + , Node (SJust p4) [] + ] + passEpoch + fmap (!! 3) getProposalsForest + `shouldReturn` Node + (SJust p2) + [ Node (SJust p21) [Node (SJust p211) []] + , Node (SJust p22) [] + ] + [ Node p212 [] + , Node p213 [] + , Node p214 [] + ] <- + submitConstitutionForest + (SJust p21) + [ Node () [] + , Node () [] + , Node () [] + ] + p2131 <- submitConstitutionGovAction $ SJust p213 + p2141 <- submitConstitutionGovAction $ SJust p214 + submitYesVote_ (DRepVoter drepC) p212 + submitYesVote_ (CommitteeVoter committeeMember) p212 + fmap (!! 3) getProposalsForest + `shouldReturn` Node + (SJust p2) + [ Node + (SJust p21) + [ Node (SJust p211) [] + , Node (SJust p212) [] + , Node (SJust p213) [Node (SJust p2131) []] + , Node (SJust p214) [Node (SJust p2141) []] + ] + , Node (SJust p22) [] + ] + passNEpochs 2 + fmap (!! 3) getProposalsForest + `shouldReturn` Node (SJust p212) [] + props <- getProposals + proposalsSize props `shouldBe` 0 + it "Votes from subsequent epochs are considered for ratification" $ do + modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 4 + (committeeMember :| _) <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep 1_000_000 + [Node p1 []] <- + submitConstitutionForest + SNothing + [Node () []] + fmap (!! 3) getProposalsForest + `shouldReturn` Node SNothing [Node (SJust p1) []] + passNEpochs 2 + submitYesVote_ (DRepVoter dRep) p1 + submitYesVote_ (CommitteeVoter committeeMember) p1 + passNEpochs 2 + fmap (!! 3) getProposalsForest + `shouldReturn` Node (SJust p1) [] + it "Subtrees are pruned for both enactment and expiry over multiple rounds" $ do + (committeeMember :| _) <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep 1_000_000 + modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 4 + [ a@( Node + p1 + [ b@( Node + p11 + [ Node _p111 [] + , Node _p112 [] + ] + ) + ] + ) + , Node + _p2 + [ Node _p21 [] + , Node _p22 [] + ] + , Node p3 [] + ] <- + submitConstitutionForest + SNothing + [ Node + () + [ Node + () + [ Node () [] + , Node () [] + ] + ] + , Node + () + [ Node () [] + , Node () [] + ] + , Node () [] + ] + passNEpochs 2 + submitYesVote_ (DRepVoter dRep) p1 + submitYesVote_ (CommitteeVoter committeeMember) p1 + submitYesVote_ (DRepVoter dRep) p11 + submitYesVote_ (CommitteeVoter committeeMember) p11 + submitYesVote_ (DRepVoter dRep) p3 + submitYesVote_ (CommitteeVoter committeeMember) p3 -- Two competing proposals break the tie based on proposal order + passNEpochs 2 + fmap (!! 3) getProposalsForest + `shouldReturn` SJust + <$> a + passEpoch -- ConstitutionPurpose is a delayed action + fmap (!! 3) getProposalsForest + `shouldReturn` SJust + <$> b + passNEpochs 2 + fmap (!! 3) getProposalsForest + `shouldReturn` Node (SJust p11) [] + c@[ Node _p113 [] + , Node _p114 [] + ] <- + submitConstitutionForest + (SJust p11) + [ Node () [] + , Node () [] + ] + fmap (!! 3) getProposalsForest + `shouldReturn` Node (SJust p11) (fmap SJust <$> c) + passNEpochs 4 + d@[ Node _p115 [] + , Node p116 [] + ] <- + submitConstitutionForest + (SJust p11) + [ Node () [] + , Node () [] + ] + fmap (!! 3) getProposalsForest + `shouldReturn` Node (SJust p11) (fmap SJust <$> (c <> d)) + passNEpochs 2 + fmap (!! 3) getProposalsForest + `shouldReturn` Node (SJust p11) (fmap SJust <$> d) + submitYesVote_ (DRepVoter dRep) p116 + submitYesVote_ (CommitteeVoter committeeMember) p116 + passNEpochs 3 + fmap (!! 3) getProposalsForest + `shouldReturn` Node (SJust p116) [] + it "Proposals are stored in the expected order" $ do + modifyPParams $ + ppMaxValSizeL .~ 1_000_000_000 + returnAddr <- registerRewardAccount + deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL + ens <- getEnactState + withdrawals <- arbitrary + let + mkProp name action = do + ProposalProcedure + { pProcReturnAddr = returnAddr + , pProcGovAction = action + , pProcDeposit = deposit + , pProcAnchor = Anchor (fromJust $ textToUrl 16 name) def + } + prop0 = mkProp "prop0" InfoAction + prop1 = mkProp "prop1" $ NoConfidence (ens ^. ensPrevCommitteeL) + prop2 = mkProp "prop2" InfoAction + prop3 = mkProp "prop3" $ TreasuryWithdrawals withdrawals SNothing + submitProposal_ prop0 + submitProposal_ prop1 + let + checkProps l = do + props <- + getsNES $ + nesEsL . epochStateGovStateL @era . cgsProposalsL . pPropsL + fmap (pProcAnchor . gasProposalProcedure . snd) (OMap.assocList props) + `shouldBe` fmap pProcAnchor l + checkProps [prop0, prop1] + submitProposal_ prop2 + submitProposal_ prop3 + checkProps [prop0, prop1, prop2, prop3] + where + submitConstitutionForest = submitGovActionForest submitConstitutionGovAction + +proposalsSpec :: + forall era. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + ) => + SpecWith (ImpTestState era) +proposalsSpec = + describe "Proposals" $ do + describe "Consistency" $ do + it "Proposals submitted without proper parent fail" $ do + let mkCorruptGovActionId :: GovActionId c -> GovActionId c + mkCorruptGovActionId (GovActionId txi (GovActionIx gaix)) = + GovActionId txi $ GovActionIx $ gaix + 999 + Node p1 [Node _p11 []] <- + submitParameterChangeTree + SNothing + $ Node + () + [ Node () [] + ] + pp <- getsNES $ nesEsL . curPParamsEpochStateL + khPropRwd <- freshKeyHash + let parameterChangeAction = + ParameterChange + (SJust $ GovPurposeId $ mkCorruptGovActionId p1) + (def & ppuMinFeeAL .~ SJust (Coin 3000)) + SNothing + parameterChangeProposal = + ProposalProcedure + { pProcDeposit = pp ^. ppGovActionDepositL + , pProcReturnAddr = RewardAccount Testnet (KeyHashObj khPropRwd) + , pProcGovAction = parameterChangeAction + , pProcAnchor = def + } + submitFailingProposal + parameterChangeProposal + [ injectFailure $ InvalidPrevGovActionId parameterChangeProposal + ] + it "Subtrees are pruned when proposals expire" $ do + modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 4 + p1 <- submitParameterChange SNothing (def & ppuMinFeeAL .~ SJust (Coin 3000)) + passNEpochs 3 + a <- + submitParameterChangeTree + (SJust p1) + $ Node + () + [ Node () [] + , Node () [] + ] + b <- + submitParameterChangeTree + SNothing + $ Node + () + [ Node () [] + ] + getProposalsForest + `shouldReturn` [ Node + SNothing + [ Node (SJust p1) [SJust <$> a] + , SJust <$> b + ] + , Node SNothing [] + , Node SNothing [] + , Node SNothing [] + ] + passNEpochs 3 + getProposalsForest + `shouldReturn` [ Node SNothing [SJust <$> b] + , Node SNothing [] + , Node SNothing [] + , Node SNothing [] + ] + it "Subtrees are pruned when proposals expire over multiple rounds" $ do + let ppupdate = def & ppuMinFeeAL .~ SJust (Coin 3000) + let submitInitialProposal = submitParameterChange SNothing ppupdate + let submitChildProposal parent = submitParameterChange (SJust parent) ppupdate + modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 4 + p1 <- submitInitialProposal + getProposalsForest + `shouldReturn` [ Node + SNothing + [ Node (SJust p1) [] + ] + , Node SNothing [] + , Node SNothing [] + , Node SNothing [] + ] + + passEpoch + p2 <- submitInitialProposal + p11 <- submitChildProposal p1 + getProposalsForest + `shouldReturn` [ Node + SNothing + [ Node (SJust p1) [Node (SJust p11) []] + , Node (SJust p2) [] + ] + , Node SNothing [] + , Node SNothing [] + , Node SNothing [] + ] + + passEpoch + p3 <- submitInitialProposal + p21 <- submitChildProposal p2 + a <- + submitParameterChangeForest + (SJust p11) + [ Node () [] + , Node () [] + ] + getProposalsForest + `shouldReturn` [ Node + SNothing + [ Node + (SJust p1) + [ Node + (SJust p11) + (fmap SJust <$> a) + ] + , Node (SJust p2) [Node (SJust p21) []] + , Node (SJust p3) [] + ] + , Node SNothing [] + , Node SNothing [] + , Node SNothing [] + ] + + passEpoch + p4 <- submitInitialProposal + p31 <- submitChildProposal p3 + p211 <- submitChildProposal p21 + getProposalsForest + `shouldReturn` [ Node + SNothing + [ Node + (SJust p1) + [ Node + (SJust p11) + (fmap SJust <$> a) + ] + , Node (SJust p2) [Node (SJust p21) [Node (SJust p211) []]] + , Node (SJust p3) [Node (SJust p31) []] + , Node (SJust p4) [] + ] + , Node SNothing [] + , Node SNothing [] + , Node SNothing [] + ] + passNEpochs 3 + getProposalsForest + `shouldReturn` [ Node + SNothing + [ Node (SJust p2) [Node (SJust p21) [Node (SJust p211) []]] + , Node (SJust p3) [Node (SJust p31) []] + , Node (SJust p4) [] + ] + , Node SNothing [] + , Node SNothing [] + , Node SNothing [] + ] + p5 <- submitInitialProposal + p41 <- submitChildProposal p4 + p311 <- submitChildProposal p31 + p212 <- submitChildProposal p21 + getProposalsForest + `shouldReturn` [ Node + SNothing + [ Node + (SJust p2) + [ Node + (SJust p21) + [ Node (SJust p211) [] + , Node (SJust p212) [] + ] + ] + , Node (SJust p3) [Node (SJust p31) [Node (SJust p311) []]] + , Node (SJust p4) [Node (SJust p41) []] + , Node (SJust p5) [] + ] + , Node SNothing [] + , Node SNothing [] + , Node SNothing [] + ] + passEpoch + p6 <- submitInitialProposal + p51 <- submitChildProposal p5 + p411 <- submitChildProposal p41 + p312 <- submitChildProposal p31 + getProposalsForest + `shouldReturn` [ Node + SNothing + [ Node + (SJust p3) + [ Node + (SJust p31) + [ Node (SJust p311) [] + , Node (SJust p312) [] + ] + ] + , Node (SJust p4) [Node (SJust p41) [Node (SJust p411) []]] + , Node (SJust p5) [Node (SJust p51) []] + , Node (SJust p6) [] + ] + , Node SNothing [] + , Node SNothing [] + , Node SNothing [] + ] + passEpoch + getProposalsForest + `shouldReturn` [ Node + SNothing + [ Node (SJust p4) [Node (SJust p41) [Node (SJust p411) []]] + , Node (SJust p5) [Node (SJust p51) []] + , Node (SJust p6) [] + ] + , Node SNothing [] + , Node SNothing [] + , Node SNothing [] + ] + passEpoch + getProposalsForest + `shouldReturn` [ Node + SNothing + [ Node (SJust p5) [Node (SJust p51) []] + , Node (SJust p6) [] + ] + , Node SNothing [] + , Node SNothing [] + , Node SNothing [] + ] + passNEpochs 3 + getProposalsForest + `shouldReturn` [ Node + SNothing + [ Node (SJust p6) [] + ] + , Node SNothing [] + , Node SNothing [] + , Node SNothing [] + ] + passEpoch + getProposalsForest + `shouldReturn` [ Node SNothing [] + , Node SNothing [] + , Node SNothing [] + , Node SNothing [] + ] + where + submitParameterChangeForest = submitGovActionForest $ submitGovAction . paramAction + submitParameterChangeTree = submitGovActionTree $ submitGovAction . paramAction + paramAction p = + ParameterChange (GovPurposeId <$> p) (def & ppuMinFeeAL .~ SJust (Coin 10)) SNothing + +votingSpec :: + forall era. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , GovState era ~ BabelGovState era + ) => + SpecWith (ImpTestState era) +votingSpec = + describe "Voting" $ do + describe "fails for" $ do + it "expired gov-actions" $ do + -- Voting after the 3rd epoch should fail + modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2 + (drep, _, _) <- setupSingleDRep 1_000_000 + (govActionId, _) <- submitConstitution SNothing + passEpoch + passEpoch + passEpoch + submitFailingVote + (DRepVoter drep) + govActionId + [ injectFailure $ VotingOnExpiredGovAction [(DRepVoter drep, govActionId)] + ] + it "non-existent gov-actions" $ do + (drep, _, _) <- setupSingleDRep 1_000_000 + (govActionId, _) <- submitConstitution SNothing + let dummyGaid = govActionId {gaidGovActionIx = GovActionIx 99} -- non-existent `GovActionId` + submitFailingVote + (DRepVoter drep) + dummyGaid + [injectFailure $ GovActionsDoNotExist $ pure dummyGaid] + it + "committee member voting on committee change" + committeeMemberVotingOnCommitteeChange + it "non-committee-member voting on committee change as a committee member" $ do + credCandidate <- KeyHashObj <$> freshKeyHash + credVoter <- KeyHashObj <$> freshKeyHash + committeeUpdateId <- + submitGovAction $ + UpdateCommittee + SNothing + mempty + (Map.singleton credCandidate $ EpochNo 28) + (3 %! 5) + let voter = CommitteeVoter credVoter + trySubmitVote VoteNo voter committeeUpdateId + `shouldReturn` Left + [ injectFailure $ DisallowedVoters [(voter, committeeUpdateId)] + ] + it + "committee member can't vote on committee update when sandwiched between other votes" + ccVoteOnConstitutionFailsWithMultipleVotes + it "CC cannot ratify if below threshold" $ do + modifyPParams $ \pp -> + pp + & ppGovActionLifetimeL + .~ EpochInterval 3 + & ppDRepVotingThresholdsL + .~ def + { dvtUpdateToConstitution = 1 %! 2 + } + & ppCommitteeMinSizeL + .~ 2 + (dRepCred, _, _) <- setupSingleDRep 1_000_000 + ccColdCred0 <- KeyHashObj <$> freshKeyHash + ccColdCred1 <- KeyHashObj <$> freshKeyHash + electionGovAction <- + submitGovAction $ + UpdateCommittee + SNothing + mempty + ( Map.fromList + [ (ccColdCred0, EpochNo 10) + , (ccColdCred1, EpochNo 10) + ] + ) + (3 %! 5) + submitYesVote_ (DRepVoter dRepCred) electionGovAction + logAcceptedRatio electionGovAction + passNEpochs 3 + expectNoCurrentProposals + ccHotKey0 <- registerCommitteeHotKey ccColdCred0 + ccHotKey1 <- registerCommitteeHotKey ccColdCred1 + anchor <- arbitrary + constitutionChangeId <- + submitGovAction $ + NewConstitution + SNothing + Constitution + { constitutionScript = SNothing + , constitutionAnchor = anchor + } + submitYesVote_ (DRepVoter dRepCred) constitutionChangeId + resignCommitteeColdKey ccColdCred0 SNothing + submitYesVote_ (CommitteeVoter ccHotKey0) constitutionChangeId + submitYesVote_ (CommitteeVoter ccHotKey1) constitutionChangeId + passEpoch + logAcceptedRatio constitutionChangeId + logToExpr =<< lookupGovActionState constitutionChangeId + passNEpochs 4 + conAnchor <- + getsNES $ + nesEsL + . esLStateL + . lsUTxOStateL + . utxosGovStateL + . cgsConstitutionL + . constitutionAnchorL + expectNoCurrentProposals + conAnchor `shouldNotBe` anchor + +constitutionSpec :: + forall era. + ( BabelEraImp era + , GovState era ~ BabelGovState era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + ) => + SpecWith (ImpTestState era) +constitutionSpec = + describe "Constitution proposals" $ do + describe "accepted for" $ do + it "empty PrevGovId before the first constitution is enacted" $ do + -- Initial proposal does not need a GovPurposeId but after it is enacted, the + -- following ones are not + _ <- submitConstitution SNothing + -- Until the first proposal is enacted all proposals with empty GovPurposeIds are valid + void $ submitConstitution SNothing + it "valid GovPurposeId" $ do + (committeeMember :| _) <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep 1_000_000 + constitution <- arbitrary + gaidConstitutionProp <- enactConstitution SNothing constitution dRep committeeMember + constitution1 <- arbitrary + void $ + enactConstitution + (SJust $ GovPurposeId gaidConstitutionProp) + constitution1 + dRep + committeeMember + + describe "rejected for" $ do + it "empty PrevGovId after the first constitution was enacted" $ do + (committeeMember :| _) <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep 1_000_000 + (govActionId, _constitution) <- submitConstitution SNothing + submitYesVote_ (DRepVoter dRep) govActionId + submitYesVote_ (CommitteeVoter committeeMember) govActionId + passNEpochs 2 + constitution <- arbitrary + let invalidNewConstitutionGovAction = + NewConstitution + SNothing + constitution + invalidNewConstitutionProposal <- proposalWithRewardAccount invalidNewConstitutionGovAction + submitFailingProposal + invalidNewConstitutionProposal + [ injectFailure $ InvalidPrevGovActionId invalidNewConstitutionProposal + ] + it "invalid index in GovPurposeId" $ do + (govActionId, _constitution) <- submitConstitution SNothing + passNEpochs 2 + constitution <- arbitrary + let invalidPrevGovActionId = + -- Expected Ix = 0 + GovPurposeId (govActionId {gaidGovActionIx = GovActionIx 1}) + invalidNewConstitutionGovAction = + NewConstitution + (SJust invalidPrevGovActionId) + constitution + invalidNewConstitutionProposal <- proposalWithRewardAccount invalidNewConstitutionGovAction + submitFailingProposal + invalidNewConstitutionProposal + [ injectFailure $ InvalidPrevGovActionId invalidNewConstitutionProposal + ] + it "valid GovPurposeId but invalid purpose" $ do + (govActionId, _constitution) <- submitConstitution SNothing + passNEpochs 2 + let invalidNoConfidenceAction = + NoConfidence $ SJust $ GovPurposeId govActionId + invalidNoConfidenceProposal <- proposalWithRewardAccount invalidNoConfidenceAction + + submitFailingProposal + invalidNoConfidenceProposal + [ injectFailure $ InvalidPrevGovActionId invalidNoConfidenceProposal + ] + it "submitted successfully with valid GovPurposeId" $ do + modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 1 + + curConstitution <- getsNES $ newEpochStateGovStateL . constitutionGovStateL + initialPulser <- getsNES $ newEpochStateGovStateL . drepPulsingStateGovStateL + initialEnactState <- getEnactState + + (govActionId, _) <- submitConstitution SNothing + curConstitution' <- getsNES $ newEpochStateGovStateL . constitutionGovStateL + impAnn "Constitution has not been enacted yet" $ + curConstitution' `shouldBe` curConstitution + + BabelGovState expectedProposals _ _ _ _ expectedPulser <- + getsNES newEpochStateGovStateL + expectedEnactState <- getEnactState + + impAnn "EnactState reflects the submitted governance action" $ do + expectedEnactState `shouldBe` initialEnactState + + impAnn "Proposals contain the submitted proposal" $ + expectedProposals `shouldSatisfy` \props -> govActionId `elem` proposalsIds props + + impAnn "Pulser has not changed" $ + expectedPulser `shouldBe` initialPulser + + passEpoch >> passEpoch + impAnn "Proposal gets removed after expiry" $ do + BabelGovState _ _ _ _ _ pulser <- getsNES newEpochStateGovStateL + let ratifyState = extractDRepPulsingState pulser + rsExpired ratifyState `shouldBe` Set.singleton govActionId + +policySpec :: + forall era. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + ) => + SpecWith (ImpTestState era) +policySpec = + describe "Policy" $ do + it "policy is respected by proposals" $ do + (committeeMember :| _) <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep 1_000_000 + keyHash <- freshKeyHash + scriptHash <- impAddNativeScript $ RequireAllOf (SSeq.singleton (RequireSignature keyHash)) + anchor <- arbitrary + _ <- + enactConstitution + SNothing + (Constitution anchor (SJust scriptHash)) + dRep + committeeMember + wrongScriptHash <- + impAddNativeScript $ + RequireMOf 1 $ + SSeq.fromList [RequireAnyOf mempty, RequireAllOf mempty] + pp <- getsNES $ nesEsL . curPParamsEpochStateL + impAnn "ParameterChange with correct policy succeeds" $ do + let + pparamsUpdate = + def + & ppuCommitteeMinSizeL + .~ SJust 1 + rewardAccount <- registerRewardAccount + submitProposal_ + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = ParameterChange SNothing pparamsUpdate (SJust scriptHash) + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = def + } + + impAnn "TreasuryWithdrawals with correct policy succeeds" $ do + rewardAccount <- registerRewardAccount + let + withdrawals = + Map.fromList + [ (rewardAccount, Coin 1000) + ] + submitProposal_ + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = TreasuryWithdrawals withdrawals (SJust scriptHash) + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = def + } + + impAnn "ParameterChange with invalid policy fails" $ do + rewardAccount <- registerRewardAccount + let + pparamsUpdate = + def + & ppuCommitteeMinSizeL + .~ SJust 2 + res <- + trySubmitProposal + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = ParameterChange SNothing pparamsUpdate (SJust wrongScriptHash) + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = def + } + res + `shouldBeLeft` [ injectFailure $ + InvalidPolicyHash (SJust wrongScriptHash) (SJust scriptHash) + ] + + impAnn "TreasuryWithdrawals with invalid policy fails" $ do + rewardAccount <- registerRewardAccount + let + withdrawals = + Map.fromList + [ (rewardAccount, Coin 1000) + ] + res <- + trySubmitProposal + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = TreasuryWithdrawals withdrawals (SJust wrongScriptHash) + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = def + } + res + `shouldBeLeft` [ injectFailure $ + InvalidPolicyHash (SJust wrongScriptHash) (SJust scriptHash) + ] + +networkIdSpec :: + forall era. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + ) => + SpecWith (ImpTestState era) +networkIdSpec = + describe "Network ID" $ do + it "Fails with invalid network ID in proposal return address" $ do + rewardCredential <- KeyHashObj <$> freshKeyHash + let badRewardAccount = + RewardAccount + { raNetwork = Mainnet -- Our network is Testnet + , raCredential = rewardCredential + } + propDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL + submitFailingProposal + ProposalProcedure + { pProcReturnAddr = badRewardAccount + , pProcGovAction = InfoAction + , pProcDeposit = propDeposit + , pProcAnchor = def + } + [ injectFailure $ + ProposalProcedureNetworkIdMismatch + badRewardAccount + Testnet + ] + +networkIdWithdrawalsSpec :: + forall era. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + ) => + SpecWith (ImpTestState era) +networkIdWithdrawalsSpec = + describe "Network ID" $ do + it "Fails with invalid network ID in withdrawal addresses" $ do + rewardAccount <- registerRewardAccount + rewardCredential <- KeyHashObj <$> freshKeyHash + let badRewardAccount = + RewardAccount + { raNetwork = Mainnet -- Our network is Testnet + , raCredential = rewardCredential + } + propDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL + submitFailingProposal + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = + TreasuryWithdrawals + (Map.singleton badRewardAccount $ Coin 100_000_000) + SNothing + , pProcDeposit = propDeposit + , pProcAnchor = def + } + [ injectFailure $ + TreasuryWithdrawalsNetworkIdMismatch + (Set.singleton badRewardAccount) + Testnet + ] + +proposalWithRewardAccount :: + forall era. + BabelEraImp era => + GovAction era -> + ImpTestM era (ProposalProcedure era) +proposalWithRewardAccount action = do + rewardAccount <- registerRewardAccount + govActionDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL + pure + ProposalProcedure + { pProcDeposit = govActionDeposit + , pProcReturnAddr = rewardAccount + , pProcGovAction = action + , pProcAnchor = def + } + +-- ========================================================= +-- Proposing a HardFork should always use a new ProtVer that +-- can follow the one installed in the previous HardFork action. + +-- | Tests the first hardfork in the Babel era where the PrevGovActionID is SNothing +firstHardForkFollows :: + forall era. + (ShelleyEraImp era, BabelEraTxBody era) => + (ProtVer -> ProtVer) -> + ImpTestM era () +firstHardForkFollows computeNewFromOld = do + protVer <- getProtVer + submitGovAction_ $ HardForkInitiation SNothing (computeNewFromOld protVer) + +-- | Negative (deliberatey failing) first hardfork in the Babel era where the PrevGovActionID is SNothing +firstHardForkCantFollow :: + forall era. + ( ShelleyEraImp era + , BabelEraTxBody era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + ) => + ImpTestM era () +firstHardForkCantFollow = do + rewardAccount <- registerRewardAccount + pp <- getsNES $ nesEsL . curPParamsEpochStateL + let protver0 = pp ^. ppProtocolVersionL + protver1 = minorFollow protver0 + protver2 = cantFollow protver1 + submitFailingProposal + ( ProposalProcedure + { pProcDeposit = pp ^. ppGovActionDepositL + , pProcReturnAddr = rewardAccount + , pProcGovAction = HardForkInitiation SNothing protver2 + , pProcAnchor = def + } + ) + [injectFailure $ ProposalCantFollow SNothing protver2 protver0] + +-- | Tests a second hardfork in the Babel era where the PrevGovActionID is SJust +secondHardForkFollows :: + forall era. + (ShelleyEraImp era, BabelEraTxBody era) => + (ProtVer -> ProtVer) -> + ImpTestM era () +secondHardForkFollows computeNewFromOld = do + protver0 <- getProtVer + let protver1 = minorFollow protver0 + protver2 = computeNewFromOld protver1 + gaid1 <- submitGovAction $ HardForkInitiation SNothing protver1 + submitGovAction_ $ HardForkInitiation (SJust (GovPurposeId gaid1)) protver2 + +-- | Negative (deliberatey failing) first hardfork in the Babel era where the PrevGovActionID is SJust +secondHardForkCantFollow :: + forall era. + ( ShelleyEraImp era + , BabelEraTxBody era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + ) => + ImpTestM era () +secondHardForkCantFollow = do + rewardAccount <- registerRewardAccount + pp <- getsNES $ nesEsL . curPParamsEpochStateL + let protver0 = pp ^. ppProtocolVersionL + protver1 = minorFollow protver0 + protver2 = cantFollow protver1 + gaid1 <- + submitProposal $ + ProposalProcedure + { pProcDeposit = pp ^. ppGovActionDepositL + , pProcReturnAddr = rewardAccount + , pProcGovAction = HardForkInitiation SNothing protver1 + , pProcAnchor = def + } + submitFailingProposal + ( ProposalProcedure + { pProcDeposit = pp ^. ppGovActionDepositL + , pProcReturnAddr = rewardAccount + , pProcGovAction = HardForkInitiation (SJust (GovPurposeId gaid1)) protver2 + , pProcAnchor = def + } + ) + [injectFailure $ ProposalCantFollow (SJust (GovPurposeId gaid1)) protver2 protver1] + +committeeMemberVotingOnCommitteeChange :: + forall era. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + ) => + ImpTestM era () +committeeMemberVotingOnCommitteeChange = do + (ccHot :| _) <- registerInitialCommittee + khCommittee <- KeyHashObj <$> freshKeyHash + committeeUpdateId <- + submitGovAction $ + UpdateCommittee + SNothing + mempty + (Map.singleton khCommittee $ EpochNo 28) + (3 %! 5) + let voter = CommitteeVoter ccHot + submitFailingVote + voter + committeeUpdateId + [ injectFailure $ DisallowedVoters [(voter, committeeUpdateId)] + ] + +ccVoteOnConstitutionFailsWithMultipleVotes :: + forall era. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + ) => + ImpTestM era () +ccVoteOnConstitutionFailsWithMultipleVotes = do + (ccCred :| _) <- registerInitialCommittee + (drepCred, _, _) <- setupSingleDRep 1_000_000 + drepCred2 <- KeyHashObj <$> registerDRep + newCommitteeMember <- KeyHashObj <$> freshKeyHash + committeeProposal <- + submitGovAction $ + UpdateCommittee + SNothing + mempty + (Map.singleton newCommitteeMember $ EpochNo 10) + (1 %! 2) + let + voteTx = + mkBasicTx $ + mkBasicTxBody + & votingProceduresTxBodyL + .~ VotingProcedures + ( Map.fromList + [ + ( DRepVoter drepCred2 + , Map.singleton committeeProposal $ VotingProcedure VoteYes SNothing + ) + , + ( CommitteeVoter ccCred + , Map.singleton committeeProposal $ VotingProcedure VoteNo SNothing + ) + , + ( DRepVoter drepCred + , Map.singleton committeeProposal $ VotingProcedure VoteYes SNothing + ) + ] + ) + impAnn "Try to vote as a committee member" $ + submitFailingTx + voteTx + [ injectFailure $ + DisallowedVoters [(CommitteeVoter ccCred, committeeProposal)] + ] + +bootstrapPhaseSpec :: + forall era. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" BabelGovPredFailure era + ) => + SpecWith (ImpTestState era) +bootstrapPhaseSpec = + describe "Proposing and voting during bootstrap phase" $ do + it "Parameter change" $ do + gid <- submitParameterChange SNothing (def & ppuMinFeeAL .~ SJust (Coin 3000)) + (committee :| _) <- registerInitialCommittee + (drep, _, _) <- setupSingleDRep 1_000_000 + (spo, _, _) <- setupPoolWithStake $ Coin 42_000_000 + checkVotingFailure (DRepVoter drep) gid + submitYesVote_ (StakePoolVoter spo) gid + submitYesVote_ (CommitteeVoter committee) gid + it "Hardfork initiation" $ do + curProtVer <- getProtVer + nextMajorVersion <- succVersion $ pvMajor curProtVer + gid <- + submitGovAction $ + HardForkInitiation SNothing (curProtVer {pvMajor = nextMajorVersion}) + (committee :| _) <- registerInitialCommittee + (drep, _, _) <- setupSingleDRep 1_000_000 + (spo, _, _) <- setupPoolWithStake $ Coin 42_000_000 + checkVotingFailure (DRepVoter drep) gid + submitYesVote_ (StakePoolVoter spo) gid + submitYesVote_ (CommitteeVoter committee) gid + it "Info action" $ do + gid <- submitGovAction InfoAction + (committee :| _) <- registerInitialCommittee + (drep, _, _) <- setupSingleDRep 1_000_000 + (spo, _, _) <- setupPoolWithStake $ Coin 42_000_000 + submitYesVote_ (DRepVoter drep) gid + submitYesVote_ (StakePoolVoter spo) gid + submitYesVote_ (CommitteeVoter committee) gid + it "Treasury withdrawal" $ do + rewardAccount <- registerRewardAccount + govActionDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL + let action = TreasuryWithdrawals [(rewardAccount, Coin 1000)] SNothing + let proposal = + ProposalProcedure + { pProcDeposit = govActionDeposit + , pProcReturnAddr = rewardAccount + , pProcGovAction = action + , pProcAnchor = def + } + checkProposalFailure proposal + it "NoConfidence" $ do + proposal <- proposalWithRewardAccount $ NoConfidence SNothing + checkProposalFailure proposal + it "UpdateCommittee" $ do + cCred <- KeyHashObj <$> freshKeyHash + let action = UpdateCommittee SNothing mempty [(cCred, EpochNo 30)] (1 %! 1) + proposal <- proposalWithRewardAccount action + checkProposalFailure proposal + it "NewConstitution" $ do + constitution <- arbitrary + proposal <- proposalWithRewardAccount $ NewConstitution SNothing constitution + checkProposalFailure proposal + where + checkProposalFailure proposal = do + curProtVer <- getProtVer + when (HF.bootstrapPhase curProtVer) $ + submitFailingProposal proposal [injectFailure $ DisallowedProposalDuringBootstrap proposal] + checkVotingFailure voter gid = do + curProtVer <- getProtVer + when (HF.bootstrapPhase curProtVer) $ + submitFailingVote voter gid [injectFailure $ DisallowedVotesDuringBootstrap [(voter, gid)]] diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/RatifySpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/RatifySpec.hs new file mode 100644 index 00000000000..a41c76618d9 --- /dev/null +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/RatifySpec.hs @@ -0,0 +1,994 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Cardano.Ledger.Babel.Imp.RatifySpec ( + spec, + relevantDuringBootstrapSpec, +) where + +import Cardano.Ledger.Address +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Governance +import Cardano.Ledger.Babel.PParams +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Coin +import Cardano.Ledger.Conway.Governance (ProposalProcedure (..)) +import Cardano.Ledger.Credential +import Cardano.Ledger.Keys +import Cardano.Ledger.Shelley.LedgerState +import qualified Cardano.Ledger.UMap as UM +import Cardano.Ledger.Val ((<->)) +import Data.Default.Class (def) +import Data.Foldable +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Lens.Micro +import Test.Cardano.Ledger.Babel.ImpTest +import Test.Cardano.Ledger.Core.KeyPair +import Test.Cardano.Ledger.Core.Rational ((%!)) +import Test.Cardano.Ledger.Imp.Common + +spec :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +spec = + describe "RATIFY" $ do + relevantDuringBootstrapSpec + votingSpec + delayingActionsSpec + spoVotesCommitteeUpdates + committeeMinSizeAffectsInFlightProposalsSpec + paramChangeAffectsProposalsSpec + committeeExpiryResignationDiscountSpec + +relevantDuringBootstrapSpec :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +relevantDuringBootstrapSpec = + spoVotesForHardForkInitiation + +committeeExpiryResignationDiscountSpec :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +committeeExpiryResignationDiscountSpec = + describe "Expired and resigned committee members are discounted from quorum" $ do + it "Expired" $ do + modifyPParams $ ppCommitteeMinSizeL .~ 2 + (drep, _, _) <- setupSingleDRep 1_000_000 + -- Elect a committee of 2 members + committeeColdC1 <- KeyHashObj <$> freshKeyHash + committeeColdC2 <- KeyHashObj <$> freshKeyHash + gaiCC <- + submitGovAction $ + UpdateCommittee + SNothing + mempty + (Map.fromList [(committeeColdC1, EpochNo 10), (committeeColdC2, EpochNo 2)]) + (1 %! 2) + submitYesVote_ (DRepVoter drep) gaiCC + passNEpochs 2 + getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gaiCC) + committeeHotC1 <- registerCommitteeHotKey committeeColdC1 + _committeeHotC2 <- registerCommitteeHotKey committeeColdC2 + -- Submit a constitution with a CC vote + (gaiConstitution, _constitution) <- submitConstitution SNothing + submitYesVote_ (CommitteeVoter committeeHotC1) gaiConstitution + -- Check for CC acceptance + ccShouldNotBeExpired committeeColdC2 + isCommitteeAccepted gaiConstitution `shouldReturn` True + -- expire the second CC + passNEpochs 2 + -- Check for CC acceptance should fail + ccShouldBeExpired committeeColdC2 + isCommitteeAccepted gaiConstitution `shouldReturn` False + it "Resigned" $ do + modifyPParams $ ppCommitteeMinSizeL .~ 2 + (drep, _, _) <- setupSingleDRep 1_000_000 + -- Elect a committee of 2 members + committeeColdC1 <- KeyHashObj <$> freshKeyHash + committeeColdC2 <- KeyHashObj <$> freshKeyHash + gaiCC <- + submitGovAction $ + UpdateCommittee + SNothing + mempty + (Map.fromList [(committeeColdC1, EpochNo 10), (committeeColdC2, EpochNo 10)]) + (1 %! 2) + submitYesVote_ (DRepVoter drep) gaiCC + passNEpochs 2 + getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gaiCC) + committeeHotC1 <- registerCommitteeHotKey committeeColdC1 + _committeeHotC2 <- registerCommitteeHotKey committeeColdC2 + -- Submit a constitution with a CC vote + (gaiConstitution, _constitution) <- submitConstitution SNothing + submitYesVote_ (CommitteeVoter committeeHotC1) gaiConstitution + -- Check for CC acceptance + ccShouldNotBeResigned committeeColdC2 + isCommitteeAccepted gaiConstitution `shouldReturn` True + -- Resign the second CC + resignCommitteeColdKey committeeColdC2 SNothing + -- Check for CC acceptance should fail + ccShouldBeResigned committeeColdC2 + isCommitteeAccepted gaiConstitution `shouldReturn` False + +paramChangeAffectsProposalsSpec :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +paramChangeAffectsProposalsSpec = + describe "ParameterChange affects existing proposals" $ do + let largerThreshold :: UnitInterval + largerThreshold = 51 %! 100 + smallerThreshold :: UnitInterval + smallerThreshold = 1 %! 2 + describe "DRep" $ do + let setThreshold :: UnitInterval -> ImpTestM era () + setThreshold threshold = do + drepVotingThresholds <- getsPParams ppDRepVotingThresholdsL + modifyPParams $ + ppDRepVotingThresholdsL + .~ (drepVotingThresholds & dvtCommitteeNormalL .~ threshold) + enactThreshold :: + UnitInterval -> + Credential 'DRepRole (EraCrypto era) -> + Credential 'HotCommitteeRole (EraCrypto era) -> + ImpTestM era () + enactThreshold threshold drepC hotCommitteeC = do + drepVotingThresholds <- getsPParams ppDRepVotingThresholdsL + let paramChange = + ParameterChange + SNothing + ( emptyPParamsUpdate + & ppuDRepVotingThresholdsL + .~ SJust (drepVotingThresholds & dvtCommitteeNormalL .~ threshold) + ) + SNothing + pcGai <- submitGovAction paramChange + submitYesVote_ (DRepVoter drepC) pcGai + submitYesVote_ (CommitteeVoter hotCommitteeC) pcGai + passNEpochs 2 + submitTwoExampleProposalsAndVoteOnTheChild :: + GovPurposeId 'CommitteePurpose era -> + Credential 'DRepRole (EraCrypto era) -> + ImpTestM era (GovActionId (EraCrypto era), GovActionId (EraCrypto era)) + submitTwoExampleProposalsAndVoteOnTheChild gpiCC drep = do + committeeC <- KeyHashObj <$> freshKeyHash + let updateCC parent = UpdateCommittee parent mempty (Map.singleton committeeC $ EpochNo 5) $ 1 %! 2 + gaiParent <- submitGovAction $ updateCC $ SJust gpiCC + -- We submit a descendent proposal so that even though it is sufficiently + -- voted on, it cannot be ratified before the ParameterChange proposal + -- is enacted. + gaiChild <- submitGovAction $ updateCC $ SJust $ GovPurposeId gaiParent + submitYesVote_ (DRepVoter drep) gaiChild + passEpoch -- Make the votes count + pure (gaiParent, gaiChild) + it "Increasing the threshold prevents a hitherto-ratifiable proposal from being ratified" $ do + (drepC, hotCommitteeC, gpiCC) <- electBasicCommittee + setThreshold smallerThreshold + (drep, _, _) <- setupSingleDRep 1_000_000 + (_gaiParent, gaiChild) <- submitTwoExampleProposalsAndVoteOnTheChild gpiCC drep + isDRepAccepted gaiChild `shouldReturn` True + enactThreshold largerThreshold drepC hotCommitteeC + isDRepAccepted gaiChild `shouldReturn` False + it "Decreasing the threshold ratifies a hitherto-unratifiable proposal" $ do + (drepC, hotCommitteeC, gpiCC) <- electBasicCommittee + setThreshold largerThreshold + (drep, _, _) <- setupSingleDRep 1_000_000 + (gaiParent, gaiChild) <- submitTwoExampleProposalsAndVoteOnTheChild gpiCC drep + isDRepAccepted gaiChild `shouldReturn` False + enactThreshold smallerThreshold drepC hotCommitteeC + isDRepAccepted gaiChild `shouldReturn` True + -- Not vote on the parent too to make sure both get enacted + submitYesVote_ (DRepVoter drep) gaiParent + passNEpochs 2 + getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gaiParent) + passEpoch -- UpdateCommittee is a delaying action + getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gaiChild) + describe "SPO" $ do + let setThreshold :: UnitInterval -> ImpTestM era () + setThreshold threshold = do + poolVotingThresholds <- getsPParams ppPoolVotingThresholdsL + modifyPParams $ + ppPoolVotingThresholdsL + .~ (poolVotingThresholds & pvtCommitteeNormalL .~ threshold) + enactThreshold :: + UnitInterval -> + Credential 'DRepRole (EraCrypto era) -> + Credential 'HotCommitteeRole (EraCrypto era) -> + ImpTestM era () + enactThreshold threshold drepC hotCommitteeC = do + poolVotingThresholds <- getsPParams ppPoolVotingThresholdsL + let paramChange = + ParameterChange + SNothing + ( emptyPParamsUpdate + & ppuPoolVotingThresholdsL + .~ SJust (poolVotingThresholds & pvtCommitteeNormalL .~ threshold) + ) + SNothing + pcGai <- submitGovAction paramChange + submitYesVote_ (DRepVoter drepC) pcGai + submitYesVote_ (CommitteeVoter hotCommitteeC) pcGai + passNEpochs 2 + submitTwoExampleProposalsAndVoteOnTheChild :: + GovPurposeId 'CommitteePurpose era -> + KeyHash 'StakePool (EraCrypto era) -> + KeyHash 'StakePool (EraCrypto era) -> + Credential 'DRepRole (EraCrypto era) -> + ImpTestM era (GovActionId (EraCrypto era), GovActionId (EraCrypto era)) + submitTwoExampleProposalsAndVoteOnTheChild gpiCC poolKH1 poolKH2 drepC = do + committeeC <- KeyHashObj <$> freshKeyHash + let updateCC parent = UpdateCommittee parent mempty (Map.singleton committeeC $ EpochNo 5) $ 1 %! 2 + gaiParent <- submitGovAction $ updateCC $ SJust gpiCC + -- We submit a descendent proposal so that even though it is sufficiently + -- voted on, it cannot be ratified before the ParameterChange proposal + -- is enacted. + gaiChild <- submitGovAction $ updateCC $ SJust $ GovPurposeId gaiParent + submitYesVote_ (DRepVoter drepC) gaiChild + submitYesVote_ (StakePoolVoter poolKH1) gaiChild + -- Abstained stake is not counted in the total stake in case of SPOs + submitVote_ VoteNo (StakePoolVoter poolKH2) gaiChild + passEpoch -- Make the votes count do + pure (gaiParent, gaiChild) + it "Increasing the threshold prevents a hitherto-ratifiable proposal from being ratified" $ do + (drepC, hotCommitteeC, gpiCC) <- electBasicCommittee + setThreshold smallerThreshold + (poolKH1, _paymentC1, _stakingC1) <- setupPoolWithStake $ Coin 1_000_000 + (poolKH2, _paymentC2, _stakingC2) <- setupPoolWithStake $ Coin 1_000_000 + passEpoch -- Make the new pool distribution count + (_gaiParent, gaiChild) <- submitTwoExampleProposalsAndVoteOnTheChild gpiCC poolKH1 poolKH2 drepC + isSpoAccepted gaiChild `shouldReturn` True + enactThreshold largerThreshold drepC hotCommitteeC + isSpoAccepted gaiChild `shouldReturn` False + it "Decreasing the threshold ratifies a hitherto-unratifiable proposal" $ do + (drepC, hotCommitteeC, gpiCC) <- electBasicCommittee + setThreshold largerThreshold + (poolKH1, _paymentC1, _stakingC1) <- setupPoolWithStake $ Coin 1_000_000 + (poolKH2, _paymentC2, _stakingC2) <- setupPoolWithStake $ Coin 1_000_000 + (gaiParent, gaiChild) <- submitTwoExampleProposalsAndVoteOnTheChild gpiCC poolKH1 poolKH2 drepC + isSpoAccepted gaiChild `shouldReturn` False + enactThreshold smallerThreshold drepC hotCommitteeC + isSpoAccepted gaiChild `shouldReturn` True + -- Not vote on the parent too to make sure both get enacted + submitYesVote_ (DRepVoter drepC) gaiParent + submitYesVote_ (StakePoolVoter poolKH1) gaiParent + logRatificationChecks gaiParent + logRatificationChecks gaiChild + passNEpochs 2 + getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gaiParent) + passEpoch -- UpdateCommittee is a delaying action + getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gaiChild) + it "A parent ParameterChange proposal can prevent its child from being enacted" $ do + (hotCommitteeC :| _) <- registerInitialCommittee + (drepC, _, _) <- setupSingleDRep 1_000_000 + -- Setup one other DRep with equal stake + _ <- setupSingleDRep 1_000_000 + -- Set a smaller DRep threshold + drepVotingThresholds <- getsPParams ppDRepVotingThresholdsL + modifyPParams $ + ppDRepVotingThresholdsL + .~ (drepVotingThresholds & dvtPPGovGroupL .~ smallerThreshold) + -- Submit a parent-child sequence of ParameterChange proposals and vote on + -- both equally, so that both may be ratified. But, the parent increases + -- the threshold, and it should prevent the child from being ratified. + let paramChange parent threshold = + ParameterChange + parent + ( emptyPParamsUpdate + & ppuDRepVotingThresholdsL + .~ SJust (drepVotingThresholds & dvtPPGovGroupL .~ threshold) + ) + SNothing + parentGai <- submitGovAction $ paramChange SNothing largerThreshold + childGai <- submitGovAction $ paramChange (SJust $ GovPurposeId parentGai) smallerThreshold + submitYesVote_ (DRepVoter drepC) parentGai + submitYesVote_ (CommitteeVoter hotCommitteeC) parentGai + submitYesVote_ (DRepVoter drepC) childGai + submitYesVote_ (CommitteeVoter hotCommitteeC) childGai + passEpoch + logRatificationChecks parentGai + logRatificationChecks childGai + isDRepAccepted parentGai `shouldReturn` True + isDRepAccepted childGai `shouldReturn` True + passEpoch + getLastEnactedParameterChange `shouldReturn` SJust (GovPurposeId parentGai) + Map.member (GovPurposeId childGai) <$> getParameterChangeProposals `shouldReturn` True + isDRepAccepted childGai `shouldReturn` False + +committeeMinSizeAffectsInFlightProposalsSpec :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +committeeMinSizeAffectsInFlightProposalsSpec = + describe "CommitteeMinSize affects in-flight proposals" $ do + let setCommitteeMinSize n = modifyPParams $ ppCommitteeMinSizeL .~ n + submitATreasuryWithdrawal = do + rewardAccount <- registerRewardAccount + submitTreasuryWithdrawals [(rewardAccount, Coin 1_000)] + it "TreasuryWithdrawal fails to ratify due to an increase in CommitteeMinSize" $ do + (hotCommitteeC :| _) <- registerInitialCommittee + (drepC, _, _) <- setupSingleDRep 1_000_000 + passEpoch + setCommitteeMinSize 1 + gaiTW <- submitATreasuryWithdrawal + submitYesVote_ (CommitteeVoter hotCommitteeC) gaiTW + submitYesVote_ (DRepVoter drepC) gaiTW + isCommitteeAccepted gaiTW `shouldReturn` True + gaiPC <- + submitParameterChange SNothing $ + emptyPParamsUpdate + & ppuCommitteeMinSizeL + .~ SJust 2 + submitYesVote_ (CommitteeVoter hotCommitteeC) gaiPC + submitYesVote_ (DRepVoter drepC) gaiPC + treasury <- getsNES $ nesEsL . esAccountStateL . asTreasuryL + passNEpochs 2 + -- The ParameterChange prevents the TreasuryWithdrawal from being enacted, + -- because it has higher priority. + getLastEnactedParameterChange `shouldReturn` SJust (GovPurposeId gaiPC) + isCommitteeAccepted gaiTW `shouldReturn` False + currentProposalsShouldContain gaiTW + getsNES (nesEsL . esAccountStateL . asTreasuryL) `shouldReturn` treasury + it "TreasuryWithdrawal ratifies due to a decrease in CommitteeMinSize" $ do + (drepC, hotCommitteeC, gpiCC) <- electBasicCommittee + treasury <- getsNES $ nesEsL . esAccountStateL . asTreasuryL + gaiTW <- submitATreasuryWithdrawal + submitYesVote_ (CommitteeVoter hotCommitteeC) gaiTW + submitYesVote_ (DRepVoter drepC) gaiTW + setCommitteeMinSize 2 + isCommitteeAccepted gaiTW `shouldReturn` False + passNEpochs 2 + getsNES (nesEsL . esAccountStateL . asTreasuryL) `shouldReturn` treasury + -- We do not enact the ParameterChange here because that does not pass + -- ratification as the CC size is smaller than MinSize. + -- We instead just add another Committee member to reach the CommitteeMinSize. + coldCommitteeC' <- KeyHashObj <$> freshKeyHash + gaiCC <- + submitGovAction $ + UpdateCommittee + (SJust gpiCC) + Set.empty + (Map.singleton coldCommitteeC' $ EpochNo 10) + (1 %! 2) + submitYesVote_ (DRepVoter drepC) gaiCC + passNEpochs 2 + _hotCommitteeC' <- registerCommitteeHotKey coldCommitteeC' + isCommitteeAccepted gaiTW `shouldReturn` True + passNEpochs 2 + getsNES (nesEsL . esAccountStateL . asTreasuryL) `shouldReturn` (treasury <-> Coin 1_000) + +spoVotesCommitteeUpdates :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +spoVotesCommitteeUpdates = + describe "Counting of SPO votes" $ do + describe "All gov action other than HardForkInitiation" $ do + it "NoConfidence" $ do + (spoK1, _, _) <- setupPoolWithStake $ Coin 1_000 + _ <- setupPoolWithStake $ Coin 1_000 + _ <- setupPoolWithStake $ Coin 1_000 + _ <- setupPoolWithStake $ Coin 1_000 + modifyPParams $ \pp -> + pp + & ppPoolVotingThresholdsL + . pvtMotionNoConfidenceL + .~ 1 + %! 2 + & ppDRepVotingThresholdsL + .~ def + gai <- submitGovAction $ NoConfidence SNothing + -- 1 % 4 stake yes; 3 % 4 stake abstain; yes / stake - abstain > 1 % 2 + submitYesVote_ (StakePoolVoter spoK1) gai + passNEpochs 2 + getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gai) + it "CommitteeUpdate" $ do + (spoK1, _, _) <- setupPoolWithStake $ Coin 1_000 + _ <- setupPoolWithStake $ Coin 1_000 + _ <- setupPoolWithStake $ Coin 1_000 + _ <- setupPoolWithStake $ Coin 1_000 + modifyPParams $ \pp -> + pp + & ppPoolVotingThresholdsL + . pvtCommitteeNormalL + .~ 1 + %! 2 + & ppDRepVotingThresholdsL + .~ def + + committeeC <- KeyHashObj <$> freshKeyHash + gai <- + submitGovAction $ + UpdateCommittee SNothing mempty (Map.singleton committeeC $ EpochNo 5) $ + 1 %! 2 + -- 1 % 4 stake yes; 3 % 4 stake abstain; yes / stake - abstain > 1 % 2 + submitYesVote_ (StakePoolVoter spoK1) gai + passNEpochs 2 + getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gai) + +spoVotesForHardForkInitiation :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +spoVotesForHardForkInitiation = + describe "Counting of SPO votes" $ do + it "HardForkInitiation" $ do + (hotCC :| _) <- registerInitialCommittee + (spoK1, _, _) <- setupPoolWithStake $ Coin 1_000 + (spoK2, _, _) <- setupPoolWithStake $ Coin 1_000 + _ <- setupPoolWithStake $ Coin 1_000 + _ <- setupPoolWithStake $ Coin 1_000 + modifyPParams $ ppPoolVotingThresholdsL . pvtHardForkInitiationL .~ 1 %! 2 + protVer <- getProtVer + gai <- submitGovAction $ HardForkInitiation SNothing (majorFollow protVer) + submitYesVote_ (CommitteeVoter hotCC) gai + -- 1 % 4 stake yes; 3 % 4 stake no; yes / stake - abstain < 1 % 2 + submitYesVote_ (StakePoolVoter spoK1) gai + passNEpochs 2 + logRatificationChecks gai + isSpoAccepted gai `shouldReturn` False + getLastEnactedHardForkInitiation `shouldReturn` SNothing + -- 1 % 2 stake yes; 1 % 2 stake no; yes / stake - abstain = 1 % 2 + submitYesVote_ (StakePoolVoter spoK2) gai + isSpoAccepted gai `shouldReturn` True + passNEpochs 2 + getLastEnactedHardForkInitiation `shouldReturn` SJust (GovPurposeId gai) + +votingSpec :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +votingSpec = + describe "Voting" $ do + it "SPO needs to vote on security-relevant parameter changes" $ do + (ccCred :| _) <- registerInitialCommittee + (drep, _, _) <- setupSingleDRep 1_000_000 + (khPool, _, _) <- setupPoolWithStake $ Coin 42_000_000 + initMinFeeA <- getsNES $ nesEsL . curPParamsEpochStateL . ppMinFeeAL + gaidThreshold <- impAnn "Update StakePool thresholds" $ do + pp <- getsNES $ nesEsL . curPParamsEpochStateL + (pp ^. ppPoolVotingThresholdsL . pvtPPSecurityGroupL) `shouldBe` minBound + rew <- registerRewardAccount + let ppUpdate = + emptyPParamsUpdate + & ppuPoolVotingThresholdsL + .~ SJust + PoolVotingThresholds + { pvtPPSecurityGroup = 1 %! 2 + , pvtMotionNoConfidence = 1 %! 2 + , pvtHardForkInitiation = 1 %! 2 + , pvtCommitteeNormal = 1 %! 2 + , pvtCommitteeNoConfidence = 1 %! 2 + } + & ppuGovActionLifetimeL + .~ SJust (EpochInterval 100) + gaidThreshold <- + submitProposal $ + ProposalProcedure + { pProcReturnAddr = rew + , pProcGovAction = ParameterChange SNothing ppUpdate SNothing + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = def + } + submitYesVote_ (DRepVoter drep) gaidThreshold + submitYesVote_ (CommitteeVoter ccCred) gaidThreshold + logAcceptedRatio gaidThreshold + pure gaidThreshold + passEpoch + logAcceptedRatio gaidThreshold + passEpoch + let newMinFeeA = Coin 12_345 + gaidMinFee <- do + pp <- getsNES $ nesEsL . curPParamsEpochStateL + impAnn "Security group threshold should be 1/2" $ + (pp ^. ppPoolVotingThresholdsL . pvtPPSecurityGroupL) `shouldBe` (1 %! 2) + rew <- registerRewardAccount + gaidMinFee <- + submitProposal $ + ProposalProcedure + { pProcReturnAddr = rew + , pProcGovAction = + ParameterChange + (SJust (GovPurposeId gaidThreshold)) + ( emptyPParamsUpdate + & ppuMinFeeAL + .~ SJust newMinFeeA + ) + SNothing + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = def + } + submitYesVote_ (DRepVoter drep) gaidMinFee + submitYesVote_ (CommitteeVoter ccCred) gaidMinFee + pure gaidMinFee + passEpoch + logAcceptedRatio gaidMinFee + passEpoch + do + pp <- getsNES $ nesEsL . curPParamsEpochStateL + (pp ^. ppMinFeeAL) `shouldBe` initMinFeeA + submitYesVote_ (StakePoolVoter khPool) gaidMinFee + passEpoch + logStakeDistr + logAcceptedRatio gaidMinFee + logRatificationChecks gaidMinFee + passEpoch + pp <- getsNES $ nesEsL . curPParamsEpochStateL + (pp ^. ppMinFeeAL) `shouldBe` newMinFeeA + describe "Active voting stake" $ do + describe "DRep" $ do + it "UTxOs contribute to active voting stake" $ do + -- Only modify the applicable thresholds + modifyPParams $ \pp -> + pp + & ppDRepVotingThresholdsL + .~ def + { dvtCommitteeNormal = 51 %! 100 + , dvtCommitteeNoConfidence = 51 %! 100 + } + -- Setup DRep delegation #1 + (drep1, KeyHashObj stakingKH1, paymentKP1) <- setupSingleDRep 1_000_000 + -- Setup DRep delegation #2 + _ <- setupSingleDRep 1_000_000 + -- Submit a committee proposal + cc <- KeyHashObj <$> freshKeyHash + let addCCAction = UpdateCommittee SNothing mempty (Map.singleton cc 10) (75 %! 100) + addCCGaid <- submitGovAction addCCAction + -- Submit the vote + submitVote_ VoteYes (DRepVoter drep1) addCCGaid + passNEpochs 2 + -- The vote should not result in a ratification + isDRepAccepted addCCGaid `shouldReturn` False + getLastEnactedCommittee `shouldReturn` SNothing + -- Bump up the UTxO delegated + -- to barely make the threshold (51 %! 100) + stakingKP1 <- lookupKeyPair stakingKH1 + _ <- sendCoinTo (mkAddr (paymentKP1, stakingKP1)) (inject $ Coin 200_000) + passNEpochs 2 + -- The same vote should now successfully ratify the proposal + getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid) + it "Rewards contribute to active voting stake" $ do + -- Only modify the applicable thresholds + modifyPParams $ \pp -> + pp + & ppDRepVotingThresholdsL + .~ def + { dvtCommitteeNormal = 51 %! 100 + , dvtCommitteeNoConfidence = 51 %! 100 + } + -- Setup DRep delegation #1 + (drep1, staking1, _) <- setupSingleDRep 1_000_000 + -- Setup DRep delegation #2 + _ <- setupSingleDRep 1_000_000 + -- Submit a committee proposal + cc <- KeyHashObj <$> freshKeyHash + let addCCAction = UpdateCommittee SNothing mempty (Map.singleton cc 10) (75 %! 100) + addCCGaid <- submitGovAction addCCAction + -- Submit the vote + submitVote_ VoteYes (DRepVoter drep1) addCCGaid + passNEpochs 2 + -- The vote should not result in a ratification + isDRepAccepted addCCGaid `shouldReturn` False + getLastEnactedCommittee `shouldReturn` SNothing + -- Add to the rewards of the delegator to this DRep + -- to barely make the threshold (51 %! 100) + modifyNES $ + nesEsL + . epochStateUMapL + %~ UM.adjust + (\(UM.RDPair r d) -> UM.RDPair (r <> UM.CompactCoin 200_000) d) + staking1 + . UM.RewDepUView + passNEpochs 2 + -- The same vote should now successfully ratify the proposal + getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid) + it "Rewards contribute to active voting stake even in the absence of StakeDistr" $ do + -- Only modify the applicable thresholds + modifyPParams $ \pp -> + pp + & ppDRepVotingThresholdsL + .~ def + { dvtCommitteeNormal = 51 %! 100 + , dvtCommitteeNoConfidence = 51 %! 100 + } + & ppGovActionDepositL + .~ Coin 1_000_000 + & ppPoolDepositL + .~ Coin 200_000 + & ppEMaxL + .~ EpochInterval 5 + & ppGovActionLifetimeL + .~ EpochInterval 5 + -- Setup DRep delegation #1 + (drepKH1, stakingKH1) <- setupDRepWithoutStake + -- Add rewards to delegation #1 + submitAndExpireProposalToMakeReward 1_000_000 $ KeyHashObj stakingKH1 + lookupReward (KeyHashObj stakingKH1) `shouldReturn` Coin 1_000_000 + -- Setup DRep delegation #2 + (_drepKH2, stakingKH2) <- setupDRepWithoutStake + -- Add rewards to delegation #2 + submitAndExpireProposalToMakeReward 1_000_000 $ KeyHashObj stakingKH2 + lookupReward (KeyHashObj stakingKH2) `shouldReturn` Coin 1_000_000 + -- Submit a committee proposal + cc <- KeyHashObj <$> freshKeyHash + let addCCAction = + UpdateCommittee + SNothing + mempty + (Map.singleton cc $ 10 + 2 * 5) -- some + 2 * GovActionLifetime + (75 %! 100) + addCCGaid <- submitGovAction addCCAction + -- Submit the vote + submitVote_ VoteYes (DRepVoter $ KeyHashObj drepKH1) addCCGaid + passNEpochs 2 + -- The vote should not result in a ratification + isDRepAccepted addCCGaid `shouldReturn` False + getLastEnactedCommittee `shouldReturn` SNothing + -- Increase the rewards of the delegator to this DRep + -- to barely make the threshold (51 %! 100) + registerAndRetirePoolToMakeReward $ KeyHashObj stakingKH1 + passEpoch + lookupReward (KeyHashObj stakingKH1) `shouldReturn` Coin 1_200_000 + isDRepAccepted addCCGaid `shouldReturn` True + -- The same vote should now successfully ratify the proposal + passEpoch + getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid) + describe "StakePool" $ do + it "UTxOs contribute to active voting stake" $ do + -- Only modify the applicable thresholds + modifyPParams $ \pp -> + pp + & ppPoolVotingThresholdsL + .~ def + { pvtCommitteeNormal = 51 %! 100 + , pvtCommitteeNoConfidence = 51 %! 100 + } + & ppDRepVotingThresholdsL + .~ def + -- Setup Pool delegation #1 + (poolKH1, delegatorCPayment1, delegatorCStaking1) <- setupPoolWithStake $ Coin 1_000_000 + -- Setup Pool delegation #2 + (poolKH2, _, _) <- setupPoolWithStake $ Coin 1_000_000 + passEpoch + -- Submit a committee proposal + cc <- KeyHashObj <$> freshKeyHash + let addCCAction = UpdateCommittee SNothing mempty (Map.singleton cc 10) (75 %! 100) + addCCGaid <- submitGovAction addCCAction + -- Submit the vote + submitVote_ VoteYes (StakePoolVoter poolKH1) addCCGaid + submitVote_ VoteNo (StakePoolVoter poolKH2) addCCGaid + passNEpochs 2 + -- The vote should not result in a ratification + logRatificationChecks addCCGaid + isSpoAccepted addCCGaid `shouldReturn` False + getLastEnactedCommittee `shouldReturn` SNothing + -- Bump up the UTxO delegated + -- to barely make the threshold (51 %! 100) + _ <- + sendCoinTo + (Addr Testnet delegatorCPayment1 (StakeRefBase delegatorCStaking1)) + (Coin 200_000) + passNEpochs 2 + -- The same vote should now successfully ratify the proposal + getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid) + it "Rewards contribute to active voting stake" $ do + -- Only modify the applicable thresholds + modifyPParams $ \pp -> + pp + & ppPoolVotingThresholdsL + .~ def + { pvtCommitteeNormal = 51 %! 100 + , pvtCommitteeNoConfidence = 51 %! 100 + } + & ppDRepVotingThresholdsL + .~ def + -- Setup Pool delegation #1 + (poolKH1, _, delegatorCStaking1) <- setupPoolWithStake $ Coin 1_000_000 + -- Setup Pool delegation #2 + (poolKH2, _, _) <- setupPoolWithStake $ Coin 1_000_000 + passEpoch + -- Submit a committee proposal + cc <- KeyHashObj <$> freshKeyHash + let addCCAction = UpdateCommittee SNothing mempty (Map.singleton cc 10) (75 %! 100) + addCCGaid <- submitGovAction addCCAction + -- Submit the vote + submitVote_ VoteYes (StakePoolVoter poolKH1) addCCGaid + submitVote_ VoteNo (StakePoolVoter poolKH2) addCCGaid + passNEpochs 2 + -- The vote should not result in a ratification + isSpoAccepted addCCGaid `shouldReturn` False + getLastEnactedCommittee `shouldReturn` SNothing + -- Add to the rewards of the delegator to this SPO + -- to barely make the threshold (51 %! 100) + modifyNES $ + nesEsL + . epochStateUMapL + %~ UM.adjust + (\(UM.RDPair r d) -> UM.RDPair (r <> UM.CompactCoin 200_000) d) + delegatorCStaking1 + . UM.RewDepUView + passNEpochs 2 + -- The same vote should now successfully ratify the proposal + getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid) + it "Rewards contribute to active voting stake even in the absence of StakeDistr" $ do + -- Only modify the applicable thresholds + modifyPParams $ \pp -> + pp + & ppPoolVotingThresholdsL + .~ def + { pvtCommitteeNormal = 51 %! 100 + , pvtCommitteeNoConfidence = 51 %! 100 + } + & ppGovActionDepositL + .~ Coin 1_000_000 + & ppPoolDepositL + .~ Coin 200_000 + & ppEMaxL + .~ EpochInterval 5 + & ppGovActionLifetimeL + .~ EpochInterval 5 + & ppDRepVotingThresholdsL + .~ def + -- Setup Pool delegation #1 + (poolKH1, delegatorCStaking1) <- setupPoolWithoutStake + -- Add rewards to delegation #1 + submitAndExpireProposalToMakeReward 1_000_000 delegatorCStaking1 + lookupReward delegatorCStaking1 `shouldReturn` Coin 1_000_000 + -- Setup Pool delegation #2 + (poolKH2, delegatorCStaking2) <- setupPoolWithoutStake + -- Add rewards to delegation #2 + submitAndExpireProposalToMakeReward 1_000_000 delegatorCStaking2 + lookupReward delegatorCStaking2 `shouldReturn` Coin 1_000_000 + -- Submit a committee proposal + cc <- KeyHashObj <$> freshKeyHash + let addCCAction = + UpdateCommittee + SNothing + mempty + (Map.singleton cc $ 10 + 2 * 5) -- some + 2 * GovActionLifetime + (75 %! 100) + addCCGaid <- submitGovAction addCCAction + -- Submit the vote + submitVote_ VoteYes (StakePoolVoter poolKH1) addCCGaid + submitVote_ VoteNo (StakePoolVoter poolKH2) addCCGaid + passNEpochs 2 + -- The vote should not result in a ratification + isSpoAccepted addCCGaid `shouldReturn` False + getLastEnactedCommittee `shouldReturn` SNothing + logRatificationChecks addCCGaid + -- Add to the rewards of the delegator to this SPO + -- to barely make the threshold (51 %! 100) + registerAndRetirePoolToMakeReward $ delegatorCStaking1 + passEpoch + lookupReward delegatorCStaking1 `shouldReturn` Coin 1_200_000 + -- The same vote should now successfully ratify the proposal + -- NOTE: It takes 2 epochs for SPO votes as opposed to 1 epoch + -- for DRep votes to ratify a proposal. + passNEpochs 2 + getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid) + +delayingActionsSpec :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +delayingActionsSpec = + describe "Delaying actions" $ do + it "A delaying action delays its child even when both ere proposed and ratified in the same epoch" $ do + (committeeMember :| _) <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep 1_000_000 + gai0 <- submitConstitutionGovAction SNothing + gai1 <- submitConstitutionGovAction $ SJust gai0 + gai2 <- submitConstitutionGovAction $ SJust gai1 + gai3 <- submitConstitutionGovAction $ SJust gai2 + submitYesVote_ (DRepVoter dRep) gai0 + submitYesVote_ (CommitteeVoter committeeMember) gai0 + submitYesVote_ (DRepVoter dRep) gai1 + submitYesVote_ (CommitteeVoter committeeMember) gai1 + submitYesVote_ (DRepVoter dRep) gai2 + submitYesVote_ (CommitteeVoter committeeMember) gai2 + submitYesVote_ (DRepVoter dRep) gai3 + submitYesVote_ (CommitteeVoter committeeMember) gai3 + passNEpochs 2 + getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId gai0) + passEpoch + getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId gai1) + passEpoch + getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId gai2) + passEpoch + getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId gai3) + getConstitutionProposals `shouldReturn` Map.empty + it + "A delaying action delays all other actions even when all of them may be ratified in the same epoch" + $ do + (committeeMember :| _) <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep 1_000_000 + pGai0 <- + submitParameterChange + SNothing + $ def & ppuDRepDepositL .~ SJust (Coin 1_000_000) + pGai1 <- + submitParameterChange + (SJust pGai0) + $ def & ppuDRepDepositL .~ SJust (Coin 1_000_001) + pGai2 <- + submitParameterChange + (SJust pGai1) + $ def & ppuDRepDepositL .~ SJust (Coin 1_000_002) + cGai0 <- submitConstitutionGovAction SNothing + cGai1 <- submitConstitutionGovAction $ SJust cGai0 + submitYesVote_ (DRepVoter dRep) cGai0 + submitYesVote_ (CommitteeVoter committeeMember) cGai0 + submitYesVote_ (DRepVoter dRep) cGai1 + submitYesVote_ (CommitteeVoter committeeMember) cGai1 + submitYesVote_ (DRepVoter dRep) pGai0 + submitYesVote_ (CommitteeVoter committeeMember) pGai0 + submitYesVote_ (DRepVoter dRep) pGai1 + submitYesVote_ (CommitteeVoter committeeMember) pGai1 + submitYesVote_ (DRepVoter dRep) pGai2 + submitYesVote_ (CommitteeVoter committeeMember) pGai2 + passNEpochs 2 + getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId cGai0) + getLastEnactedParameterChange `shouldReturn` SNothing + passEpoch + -- here 'ParameterChange' action does not get enacted even though + -- it is not related, since its priority is 4 while the priority + -- for 'NewConstitution' is 2, so it gets delayed a second time + getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId cGai1) + getConstitutionProposals `shouldReturn` Map.empty + getLastEnactedParameterChange `shouldReturn` SNothing + passEpoch + -- all three actions, pGai0, pGai1 and pGai2, are enacted one + -- after the other in the same epoch + getLastEnactedParameterChange `shouldReturn` SJust (GovPurposeId pGai2) + getParameterChangeProposals `shouldReturn` Map.empty + describe "An action expires when delayed enough even after being ratified" $ do + it "Same lineage" $ do + (committeeMember :| _) <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep 1_000_000 + modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2 + gai0 <- submitConstitutionGovAction SNothing + gai1 <- submitConstitutionGovAction $ SJust gai0 + gai2 <- submitConstitutionGovAction $ SJust gai1 + gai3 <- submitConstitutionGovAction $ SJust gai2 + submitYesVote_ (DRepVoter dRep) gai0 + submitYesVote_ (CommitteeVoter committeeMember) gai0 + submitYesVote_ (DRepVoter dRep) gai1 + submitYesVote_ (CommitteeVoter committeeMember) gai1 + submitYesVote_ (DRepVoter dRep) gai2 + submitYesVote_ (CommitteeVoter committeeMember) gai2 + submitYesVote_ (DRepVoter dRep) gai3 + submitYesVote_ (CommitteeVoter committeeMember) gai3 + passNEpochs 2 + getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId gai0) + passEpoch + getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId gai1) + passEpoch + getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId gai2) + getConstitutionProposals `shouldReturn` Map.empty + passEpoch + getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId gai2) + it "Other lineage" $ do + (committeeMember :| _) <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep 1_000_000 + modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2 + pGai0 <- + submitParameterChange + SNothing + $ def & ppuDRepDepositL .~ SJust (Coin 1_000_000) + pGai1 <- + submitParameterChange + (SJust pGai0) + $ def & ppuDRepDepositL .~ SJust (Coin 1_000_001) + pGai2 <- + submitParameterChange + (SJust pGai1) + $ def & ppuDRepDepositL .~ SJust (Coin 1_000_002) + cGai0 <- submitConstitutionGovAction SNothing + cGai1 <- submitConstitutionGovAction $ SJust cGai0 + cGai2 <- submitConstitutionGovAction $ SJust cGai1 + submitYesVote_ (DRepVoter dRep) cGai0 + submitYesVote_ (CommitteeVoter committeeMember) cGai0 + submitYesVote_ (DRepVoter dRep) cGai1 + submitYesVote_ (CommitteeVoter committeeMember) cGai1 + submitYesVote_ (DRepVoter dRep) cGai2 + submitYesVote_ (CommitteeVoter committeeMember) cGai2 + submitYesVote_ (DRepVoter dRep) pGai0 + submitYesVote_ (CommitteeVoter committeeMember) pGai0 + submitYesVote_ (DRepVoter dRep) pGai1 + submitYesVote_ (CommitteeVoter committeeMember) pGai1 + submitYesVote_ (DRepVoter dRep) pGai2 + submitYesVote_ (CommitteeVoter committeeMember) pGai2 + passNEpochs 2 + getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId cGai0) + getLastEnactedParameterChange `shouldReturn` SNothing + passEpoch + getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId cGai1) + getLastEnactedParameterChange `shouldReturn` SNothing + passEpoch + getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId cGai2) + getConstitutionProposals `shouldReturn` Map.empty + getLastEnactedParameterChange `shouldReturn` SNothing + passEpoch + -- all three actions, pGai0, pGai1 and pGai2, are expired here + -- and nothing gets enacted + getLastEnactedParameterChange `shouldReturn` SNothing + getParameterChangeProposals `shouldReturn` Map.empty + it "proposals to update the committee get delayed if the expiration exceeds the max term" $ do + let expectMembers :: + HasCallStack => Set.Set (Credential 'ColdCommitteeRole (EraCrypto era)) -> ImpTestM era () + expectMembers expKhs = do + committee <- + getsNES $ + nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . committeeGovStateL + let members = Map.keysSet $ foldMap' committeeMembers committee + impAnn "Expecting committee members" $ members `shouldBe` expKhs + (drep, _, _) <- setupSingleDRep 1_000_000 + maxTermLength <- + getsNES $ + nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . curPParamsGovStateL . ppCommitteeMaxTermLengthL + + void registerInitialCommittee + initialMembers <- getCommitteeMembers + + (membersExceedingExpiry, exceedingExpiry) <- + impAnn "Committee with members exceeding the maxTerm is not enacted" $ do + -- submit a proposal for adding two members to the committee, + -- one of which has a max term exceeding the maximum + c3 <- freshKeyHash + c4 <- freshKeyHash + currentEpoch <- getsNES nesELL + let exceedingExpiry = addEpochInterval (addEpochInterval currentEpoch maxTermLength) (EpochInterval 7) + let membersExceedingExpiry = [(KeyHashObj c3, exceedingExpiry), (KeyHashObj c4, addEpochInterval currentEpoch maxTermLength)] + _ <- + electCommittee + SNothing + drep + Set.empty + membersExceedingExpiry + passEpoch >> passEpoch + -- the new committee has not been enacted + expectMembers initialMembers + pure (Map.keysSet membersExceedingExpiry, exceedingExpiry) + + -- other actions get ratified and enacted + govIdConst1 <- impAnn "Other actions are ratified and enacted" $ do + (govIdConst1, constitution) <- submitConstitution SNothing + submitYesVote_ (DRepVoter drep) govIdConst1 + hks <- traverse registerCommitteeHotKey (Set.toList initialMembers) + traverse_ (\m -> submitYesVote_ (CommitteeVoter m) govIdConst1) hks + + passEpoch >> passEpoch + curConstitution <- getsNES $ newEpochStateGovStateL . constitutionGovStateL + curConstitution `shouldBe` constitution + pure govIdConst1 + + -- after enough epochs pass, the expiration of the new members becomes acceptable + -- and the new committee is enacted + impAnn "New committee is enacted" $ do + currentEpoch <- getsNES nesELL + let delta = + fromIntegral (unEpochNo exceedingExpiry) + - fromIntegral (unEpochNo (addEpochInterval currentEpoch maxTermLength)) + replicateM_ delta passEpoch + + -- pass one more epoch after ratification, in order to be enacted + passEpoch + expectMembers $ initialMembers <> membersExceedingExpiry + + impAnn "New committee can vote" $ do + (govIdConst2, constitution) <- submitConstitution $ SJust (GovPurposeId govIdConst1) + submitYesVote_ (DRepVoter drep) govIdConst2 + hks <- traverse registerCommitteeHotKey (Set.toList membersExceedingExpiry) + traverse_ (\m -> submitYesVote_ (CommitteeVoter m) govIdConst2) hks + + passEpoch >> passEpoch + curConstitution <- getsNES $ newEpochStateGovStateL . constitutionGovStateL + curConstitution `shouldBe` constitution diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxoSpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxoSpec.hs new file mode 100644 index 00000000000..f4d218d25a6 --- /dev/null +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxoSpec.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Cardano.Ledger.Babel.Imp.UtxoSpec (spec) where + +import Cardano.Ledger.Address +import Cardano.Ledger.Allegra.Scripts ( + pattern RequireAllOf, + pattern RequireSignature, + ) +import Cardano.Ledger.Alonzo.Scripts +import Cardano.Ledger.Babbage.TxBody (referenceInputsTxBodyL) +import Cardano.Ledger.Babbage.TxOut (referenceScriptTxOutL) +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Conway.PParams (ppMinFeeRefScriptCostPerByteL) +import Cardano.Ledger.MemoBytes (getMemoRawBytes) +import Cardano.Ledger.Plutus.Language (SLanguage (..), hashPlutusScript, plutusBinary) +import Cardano.Ledger.Shelley.Core +import Cardano.Ledger.Shelley.LedgerState +import Cardano.Ledger.Shelley.UTxO (getShelleyMinFeeTxUtxo) +import Cardano.Ledger.TxIn (TxIn (..)) +import Cardano.Ledger.UTxO (getMinFeeTxUtxo) +import Cardano.Ledger.Val +import qualified Data.ByteString.Short as SBS (length) +import Data.Functor ((<&>)) +import qualified Data.Map.Strict as Map +import qualified Data.Sequence.Strict as SSeq +import qualified Data.Set as Set +import Lens.Micro ((&), (.~), (^.)) +import Test.Cardano.Ledger.Babel.ImpTest +import Test.Cardano.Ledger.Core.KeyPair (mkScriptAddr) +import Test.Cardano.Ledger.Core.Rational ((%!)) +import Test.Cardano.Ledger.Core.Utils (txInAt) +import Test.Cardano.Ledger.Imp.Common +import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceeds3) + +spec :: + forall era. + BabelEraImp era => + SpecWith (ImpTestState era) +spec = describe "UTxO" $ do + describe "Reference scripts" $ do + it "required reference script counts towards the minFee calculation" $ do + spendingScript <- nativeScript + checkMinFee spendingScript [fromNativeScript spendingScript] + + it "reference scripts not required for spending the input count towards the minFee calculation" $ do + spendingScript <- nativeScript + extraScripts <- distinctScripts + checkMinFee spendingScript $ + fromNativeScript spendingScript : extraScripts + + it "a scripts referenced several times counts for each reference towards the minFee calculation" $ do + spendingScript <- nativeScript + extraScripts <- distinctScripts + checkMinFee spendingScript $ + [fromNativeScript spendingScript, fromNativeScript spendingScript] + ++ extraScripts + ++ extraScripts + where + checkMinFee :: NativeScript era -> [Script era] -> ImpTestM era () + checkMinFee scriptToSpend refScripts = do + refScriptFee <- setRefScriptFee + logEntry "lock an input with a script" + scriptSpendIn <- createScriptUtxo scriptToSpend + logEntry + "create outputs with reference scripts and the return them mapped to their corresponding inputs" + refScriptInToScripts <- createRefScriptsUtxos refScripts + logEntry "spend the initial input by passing the reference scripts" + tx <- spendScriptUsingRefScripts scriptSpendIn $ Map.keysSet refScriptInToScripts + logEntry + "compute the difference between the current-era minFee and that computed in pre-Babel eras" + minFeeDiff <- conwayDiffMinFee tx + logEntry "check that the difference is the sum of the sizes of the passed reference scripts" + minFeeDiff + `shouldBe` Coin + ( floor $ + fromIntegral @Int @Rational (sum $ scriptSize <$> refScriptInToScripts) + * unboundRational refScriptFee + ) + + distinctScripts :: ImpTestM era [Script era] + distinctScripts = do + nativeScripts <- + (fromNativeScript @era <$>) + <$> replicateM 3 nativeScript + let + psh1 = hashPlutusScript $ alwaysSucceeds3 SPlutusV3 + ps1 <- impAnn "Expecting Plutus script" . expectJust $ impLookupPlutusScriptMaybe psh1 + let + psh2 = hashPlutusScript $ alwaysSucceeds3 SPlutusV3 + ps2 <- impAnn "Expecting Plutus script" . expectJust $ impLookupPlutusScriptMaybe psh2 + let plutusScripts = [fromPlutusScript ps1, fromPlutusScript ps2] + pure $ nativeScripts ++ plutusScripts + + conwayDiffMinFee :: Tx era -> ImpTestM era Coin + conwayDiffMinFee tx = do + utxo <- getUTxO + pp <- getsNES $ nesEsL . curPParamsEpochStateL + pure $ getMinFeeTxUtxo pp tx utxo <-> getShelleyMinFeeTxUtxo pp tx + + createScriptUtxo :: NativeScript era -> ImpTestM era (TxIn (EraCrypto era)) + createScriptUtxo script = do + scriptAddr <- addScriptAddr script + tx <- + submitTx . mkBasicTx $ + mkBasicTxBody + & outputsTxBodyL @era + .~ SSeq.fromList [mkBasicTxOut @era scriptAddr (inject (Coin 1000))] + pure $ txInAt (0 :: Int) tx + + createRefScriptsUtxos :: [Script era] -> ImpTestM era (Map.Map (TxIn (EraCrypto era)) (Script era)) + createRefScriptsUtxos scripts = do + rootOut <- snd <$> lookupImpRootTxOut + let outs = + scripts + <&> ( \s -> + mkBasicTxOut @era (rootOut ^. addrTxOutL) (inject (Coin 100)) + & referenceScriptTxOutL @era + .~ SJust s + ) + tx <- + submitTx . mkBasicTx $ + mkBasicTxBody + & outputsTxBodyL @era + .~ SSeq.fromList outs + let refIns = (`txInAt` tx) <$> [0 .. length scripts - 1] + pure $ Map.fromList $ refIns `zip` scripts + + spendScriptUsingRefScripts :: + TxIn (EraCrypto era) -> Set.Set (TxIn (EraCrypto era)) -> ImpTestM era (Tx era) + spendScriptUsingRefScripts scriptIn refIns = + submitTxAnn "spendScriptUsingRefScripts" . mkBasicTx $ + mkBasicTxBody + & inputsTxBodyL @era + .~ Set.singleton scriptIn + & referenceInputsTxBodyL @era + .~ refIns + + nativeScript :: ImpTestM era (NativeScript era) + nativeScript = do + requiredKeyHash <- freshKeyHash + let script = RequireAllOf (SSeq.singleton (RequireSignature @era requiredKeyHash)) + _ <- impAddNativeScript script + pure script + + addScriptAddr :: NativeScript era -> ImpTestM era (Addr (EraCrypto era)) + addScriptAddr script = do + kpStaking1 <- lookupKeyPair =<< freshKeyHash + scriptHash <- impAddNativeScript script + pure $ mkScriptAddr scriptHash kpStaking1 + + scriptSize :: Script era -> Int + scriptSize = \case + TimelockScript tl -> SBS.length $ getMemoRawBytes tl + PlutusScript ps -> withPlutusScript ps (SBS.length . unPlutusBinary . plutusBinary) + + setRefScriptFee :: ImpTestM era NonNegativeInterval + setRefScriptFee = do + let refScriptFee = 10 %! 1 + modifyPParams $ ppMinFeeRefScriptCostPerByteL .~ refScriptFee + pure refScriptFee diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxosSpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxosSpec.hs new file mode 100644 index 00000000000..8ef755e1ac5 --- /dev/null +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxosSpec.hs @@ -0,0 +1,827 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Babel.Imp.UtxosSpec ( + spec, + relevantDuringBootstrapSpec, +) where + +import Cardano.Ledger.Address (Addr (..)) +import Cardano.Ledger.Allegra.Scripts ( + pattern RequireTimeStart, + ) +import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext (..)) +import Cardano.Ledger.Alonzo.Plutus.Evaluate (CollectError (..)) +import Cardano.Ledger.Alonzo.Rules (AlonzoUtxosPredFailure (..)) +import Cardano.Ledger.Alonzo.Tx (IsValid (..)) +import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure (..)) +import Cardano.Ledger.Babbage.TxInfo (BabbageContextError (..)) +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.TxCert +import Cardano.Ledger.Babel.TxInfo +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Conway.Core +import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Credential (Credential (..), StakeReference (..)) +import Cardano.Ledger.DRep +import Cardano.Ledger.Keys (KeyRole (..)) +import Cardano.Ledger.Mary.Value ( + MaryValue (..), + MultiAsset (..), + PolicyID (..), + ) +import Cardano.Ledger.Plutus +import Cardano.Ledger.Shelley.LedgerState +import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (..)) +import Cardano.Ledger.TxIn (TxId (..), mkTxInPartial) +import Data.Default.Class (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 SSeq +import qualified Data.Set as Set +import Lens.Micro +import qualified PlutusLedgerApi.V1 as P1 +import Test.Cardano.Ledger.Babel.ImpTest +import Test.Cardano.Ledger.Core.KeyPair (mkAddr) +import Test.Cardano.Ledger.Core.Utils +import Test.Cardano.Ledger.Imp.Common +import Test.Cardano.Ledger.Plutus (testingCostModels) +import Test.Cardano.Ledger.Plutus.Examples (alwaysFails2, alwaysSucceeds2, guessTheNumber3) + +spec :: + forall era. + ( BabelEraImp era + , Inject (BabbageContextError era) (ContextError era) + , Inject (BabelContextError era) (ContextError era) + , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era + , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era + , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era + ) => + SpecWith (ImpTestState era) +spec = + describe "UTXOS" $ do + relevantDuringBootstrapSpec + govPolicySpec + costModelsSpec + +relevantDuringBootstrapSpec :: + forall era. + ( BabelEraImp era + , Inject (BabbageContextError era) (ContextError era) + , Inject (BabelContextError era) (ContextError era) + , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era + , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era + ) => + SpecWith (ImpTestState era) +relevantDuringBootstrapSpec = do + datumAndReferenceInputsSpec + conwayFeaturesPlutusV1V2FailureSpec + +datumAndReferenceInputsSpec :: + forall era. + ( Inject (BabbageContextError era) (ContextError era) + , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era + , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era + , BabelEraImp era + ) => + SpecWith (ImpTestState era) +datumAndReferenceInputsSpec = do + it "can use reference scripts" $ do + producingTx <- setupRefTx + referringTx <- + submitTxAnn "Transaction that refers to the script" $ + mkBasicTx mkBasicTxBody + & bodyTxL + . inputsTxBodyL + .~ Set.singleton (mkTxInPartial producingTx 1) + & bodyTxL + . referenceInputsTxBodyL + .~ Set.singleton (mkTxInPartial producingTx 0) + (referringTx ^. witsTxL . scriptTxWitsL) `shouldBe` mempty + it "can use regular inputs for reference" $ do + producingTx <- setupRefTx + referringTx <- + submitTxAnn "Consuming transaction" $ + mkBasicTx mkBasicTxBody + & bodyTxL + . inputsTxBodyL + .~ Set.fromList + [ mkTxInPartial producingTx 0 + , mkTxInPartial producingTx 1 + ] + (referringTx ^. witsTxL . scriptTxWitsL) `shouldBe` mempty + it "fails with same txIn in regular inputs and reference inputs" $ do + producingTx <- setupRefTx + let + consumingTx = + mkBasicTx mkBasicTxBody + & bodyTxL + . inputsTxBodyL + .~ Set.fromList + [ mkTxInPartial producingTx 0 + , mkTxInPartial producingTx 1 + ] + & bodyTxL + . referenceInputsTxBodyL + .~ Set.singleton (mkTxInPartial producingTx 0) + _ <- + submitFailingTx + consumingTx + ( pure . injectFailure . BabbageNonDisjointRefInputs $ + mkTxInPartial producingTx 0 :| [] + ) + pure () + it "fails when using inline datums for PlutusV1" $ do + let shSpending = hashPlutusScript (guessTheNumber3 SPlutusV1) + refTxOut <- mkRefTxOut shSpending + let producingTx = + mkBasicTx mkBasicTxBody + & bodyTxL + . outputsTxBodyL + .~ SSeq.fromList + [ refTxOut + , scriptLockedTxOut shSpending & dataTxOutL .~ SJust (Data spendDatum) + ] + logToExpr producingTx + producingTxId <- txIdTx <$> submitTxAnn "Producing transaction" producingTx + let + lockedTxIn = mkTxInPartial producingTxId 1 + consumingTx = + mkBasicTx mkBasicTxBody + & bodyTxL + . inputsTxBodyL + .~ Set.singleton lockedTxIn + & bodyTxL + . referenceInputsTxBodyL + .~ Set.singleton (mkTxInPartial producingTxId 0) + impAnn "Consuming transaction" $ + submitFailingTx + consumingTx + ( pure . injectFailure $ + CollectErrors + [BadTranslation . inject . InlineDatumsNotSupported @era $ TxOutFromInput lockedTxIn] + ) + it "fails with same txIn in regular inputs and reference inputs" $ do + producingTx <- setupRefTx + let + consumingTx = + mkBasicTx mkBasicTxBody + & bodyTxL + . inputsTxBodyL + .~ Set.fromList + [ mkTxInPartial producingTx 0 + , mkTxInPartial producingTx 1 + ] + & bodyTxL + . referenceInputsTxBodyL + .~ Set.singleton (mkTxInPartial producingTx 0) + _ <- + submitFailingTx + consumingTx + ( pure . injectFailure . BabbageNonDisjointRefInputs $ + mkTxInPartial producingTx 0 :| [] + ) + pure () + it "fails when using inline datums for PlutusV1" $ do + let shSpending = hashPlutusScript $ guessTheNumber3 SPlutusV1 + refTxOut <- mkRefTxOut shSpending + producingTx <- + fmap txIdTx . submitTxAnn "Producing transaction" $ + mkBasicTx mkBasicTxBody + & bodyTxL + . outputsTxBodyL + .~ SSeq.fromList + [ refTxOut + , scriptLockedTxOut shSpending & dataTxOutL .~ SJust (Data spendDatum) + ] + let + lockedTxIn = mkTxInPartial producingTx 1 + consumingTx = + mkBasicTx mkBasicTxBody + & bodyTxL + . inputsTxBodyL + .~ Set.singleton lockedTxIn + & bodyTxL + . referenceInputsTxBodyL + .~ Set.singleton (mkTxInPartial producingTx 0) + impAnn "Consuming transaction" $ + submitFailingTx + consumingTx + ( pure . injectFailure $ + CollectErrors + [BadTranslation . inject . InlineDatumsNotSupported @era $ TxOutFromInput lockedTxIn] + ) + +conwayFeaturesPlutusV1V2FailureSpec :: + forall era. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era + , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era + , Inject (BabelContextError era) (ContextError era) + ) => + SpecWith (ImpTestState era) +conwayFeaturesPlutusV1V2FailureSpec = do + describe "Babel features fail in Plutusdescribe v1 and v2" $ do + describe "Unsupported Fields" $ do + describe "CurrentTreasuryValue" $ do + it "V1" + $ testPlutusV1V2Failure + (hashPlutusScript $ guessTheNumber3 SPlutusV1) + (SJust (Coin 10_000)) + currentTreasuryValueTxBodyL + $ inject + $ CurrentTreasuryFieldNotSupported @era + $ Coin 10_000 + it "V2" + $ testPlutusV1V2Failure + (hashPlutusScript $ guessTheNumber3 SPlutusV2) + (SJust (Coin 10_000)) + currentTreasuryValueTxBodyL + $ inject + $ CurrentTreasuryFieldNotSupported @era + $ Coin 10_000 + describe "VotingProcedures" $ do + let action = ParameterChange SNothing (def & ppuMinFeeAL .~ SJust (Coin 10)) SNothing + it "V1" $ do + (ccCred :| _) <- registerInitialCommittee + proposal <- submitGovAction action + let badField = + VotingProcedures + $ Map.singleton + (CommitteeVoter ccCred) + $ Map.singleton proposal + $ VotingProcedure VoteYes SNothing + testPlutusV1V2Failure + (hashPlutusScript $ guessTheNumber3 SPlutusV1) + badField + votingProceduresTxBodyL + $ inject + $ VotingProceduresFieldNotSupported badField + it "V2" $ do + (ccCred :| _) <- registerInitialCommittee + proposal <- submitGovAction action + let badField = + VotingProcedures + $ Map.singleton + (CommitteeVoter ccCred) + $ Map.singleton proposal + $ VotingProcedure VoteYes SNothing + testPlutusV1V2Failure + (hashPlutusScript $ guessTheNumber3 SPlutusV2) + badField + votingProceduresTxBodyL + $ inject + $ VotingProceduresFieldNotSupported badField + describe "ProposalProcedures" $ do + it "V1" $ do + deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL + rewardAccount <- registerRewardAccount + let badField = OSet.singleton $ ProposalProcedure deposit rewardAccount InfoAction def + testPlutusV1V2Failure + (hashPlutusScript $ guessTheNumber3 SPlutusV1) + badField + proposalProceduresTxBodyL + $ inject + $ ProposalProceduresFieldNotSupported badField + it "V2" $ do + deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL + rewardAccount <- registerRewardAccount + let badField = OSet.singleton $ ProposalProcedure deposit rewardAccount InfoAction def + testPlutusV1V2Failure + (hashPlutusScript $ guessTheNumber3 SPlutusV2) + badField + proposalProceduresTxBodyL + $ inject + $ ProposalProceduresFieldNotSupported badField + describe "TreasuryDonation" $ do + it "V1" + $ testPlutusV1V2Failure + (hashPlutusScript $ guessTheNumber3 SPlutusV1) + (Coin 10_000) + treasuryDonationTxBodyL + $ inject + $ TreasuryDonationFieldNotSupported @era + $ Coin 10_000 + it "V2" + $ testPlutusV1V2Failure + (hashPlutusScript $ guessTheNumber3 SPlutusV2) + (Coin 10_000) + treasuryDonationTxBodyL + $ inject + $ TreasuryDonationFieldNotSupported @era + $ Coin 10_000 + describe "Certificates" $ do + describe "Translated" $ do + let testCertificateTranslated okCert tx = do + submitTx_ + ( mkBasicTx mkBasicTxBody + & bodyTxL + . inputsTxBodyL + .~ Set.singleton (txInAt (0 :: Int) tx) + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton okCert + ) + describe "RegDepositTxCert" $ do + it "V1" $ do + stakingC <- KeyHashObj <$> freshKeyHash + let regDepositTxCert = RegDepositTxCert stakingC (Coin 0) + testCertificateTranslated regDepositTxCert + =<< txWithPlutus (hashPlutusScript $ guessTheNumber3 SPlutusV1) + it "V2" $ do + stakingC <- KeyHashObj <$> freshKeyHash + let regDepositTxCert = RegDepositTxCert stakingC (Coin 0) + testCertificateTranslated regDepositTxCert + =<< txWithPlutus (hashPlutusScript $ guessTheNumber3 SPlutusV2) + describe "UnRegDepositTxCert" $ do + it "V1" $ do + (_poolKH, _spendingC, stakingC) <- setupPoolWithStake $ Coin 1_000 + let unRegDepositTxCert = UnRegDepositTxCert stakingC (Coin 0) + testCertificateTranslated unRegDepositTxCert + =<< txWithPlutus (hashPlutusScript $ guessTheNumber3 SPlutusV1) + it "V2" $ do + (_poolKH, _spendingC, stakingC) <- setupPoolWithStake $ Coin 1_000 + let unRegDepositTxCert = UnRegDepositTxCert stakingC (Coin 0) + testCertificateTranslated unRegDepositTxCert + =<< txWithPlutus (hashPlutusScript $ guessTheNumber3 SPlutusV2) + describe "Unsupported" $ do + let testCertificateNotSupportedV1 badCert = + testCertificateNotSupported badCert + =<< txWithPlutus @era (hashPlutusScript $ guessTheNumber3 SPlutusV1) + testCertificateNotSupportedV2 badCert = + testCertificateNotSupported badCert + =<< txWithPlutus @era (hashPlutusScript $ guessTheNumber3 SPlutusV2) + testCertificateNotSupported badCert tx = do + submitFailingTx + ( mkBasicTx mkBasicTxBody + & bodyTxL + . inputsTxBodyL + .~ Set.singleton (txInAt (0 :: Int) tx) + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton badCert + ) + ( pure . injectFailure $ + CollectErrors + [ BadTranslation $ + inject $ + CertificateNotSupported badCert + ] + ) + describe "DelegTxCert" $ do + it "V1" $ do + (drep, delegator, _) <- setupSingleDRep 1_000 + let delegTxCert = + DelegTxCert @era + delegator + (DelegVote (DRepCredential drep)) + testCertificateNotSupportedV1 delegTxCert + it "V2" $ do + (drep, delegator, _) <- setupSingleDRep 1_000 + let delegTxCert = + DelegTxCert @era + delegator + (DelegVote (DRepCredential drep)) + testCertificateNotSupportedV2 delegTxCert + describe "RegDepositDelegTxCert" $ do + it "V1" $ do + (drep, _, _) <- setupSingleDRep 1_000 + unregisteredDelegatorKH <- freshKeyHash + let regDepositDelegTxCert = + RegDepositDelegTxCert @era + (KeyHashObj unregisteredDelegatorKH) + (DelegVote (DRepCredential drep)) + (Coin 0) + testCertificateNotSupportedV1 regDepositDelegTxCert + it "V2" $ do + (drep, _, _) <- setupSingleDRep 1_000 + unregisteredDelegatorKH <- freshKeyHash + let regDepositDelegTxCert = + RegDepositDelegTxCert @era + (KeyHashObj unregisteredDelegatorKH) + (DelegVote (DRepCredential drep)) + (Coin 0) + testCertificateNotSupportedV2 regDepositDelegTxCert + describe "AuthCommitteeHotKeyTxCert" $ do + it "V1" $ do + coldKey <- KeyHashObj <$> freshKeyHash + hotKey <- KeyHashObj <$> freshKeyHash + let authCommitteeHotKeyTxCert = AuthCommitteeHotKeyTxCert @era coldKey hotKey + testCertificateNotSupportedV1 authCommitteeHotKeyTxCert + it "V2" $ do + coldKey <- KeyHashObj <$> freshKeyHash + hotKey <- KeyHashObj <$> freshKeyHash + let authCommitteeHotKeyTxCert = AuthCommitteeHotKeyTxCert @era coldKey hotKey + testCertificateNotSupportedV2 authCommitteeHotKeyTxCert + describe "ResignCommitteeColdTxCert" $ do + it "V1" $ do + coldKey <- KeyHashObj <$> freshKeyHash + let resignCommitteeColdTxCert = ResignCommitteeColdTxCert @era coldKey SNothing + testCertificateNotSupportedV1 resignCommitteeColdTxCert + it "V2" $ do + coldKey <- KeyHashObj <$> freshKeyHash + let resignCommitteeColdTxCert = ResignCommitteeColdTxCert @era coldKey SNothing + testCertificateNotSupportedV2 resignCommitteeColdTxCert + describe "RegDRepTxCert" $ do + it "V1" $ do + unregisteredDRepKH <- freshKeyHash + let regDRepTxCert = RegDRepTxCert @era (KeyHashObj unregisteredDRepKH) (Coin 0) SNothing + testCertificateNotSupportedV1 regDRepTxCert + it "V2" $ do + unregisteredDRepKH <- freshKeyHash + let regDRepTxCert = RegDRepTxCert @era (KeyHashObj unregisteredDRepKH) (Coin 0) SNothing + testCertificateNotSupportedV2 regDRepTxCert + describe "UnRegDRepTxCert" $ do + it "V1" $ do + (drepKH, _, _) <- setupSingleDRep 1_000 + let unRegDRepTxCert = UnRegDRepTxCert @era drepKH (Coin 0) + testCertificateNotSupportedV1 unRegDRepTxCert + it "V1" $ do + (drepKH, _, _) <- setupSingleDRep 1_000 + let unRegDRepTxCert = UnRegDRepTxCert @era drepKH (Coin 0) + testCertificateNotSupportedV2 unRegDRepTxCert + describe "UpdateDRepTxCert" $ do + it "V1" $ do + (drepKH, _, _) <- setupSingleDRep 1_000 + let updateDRepTxCert = UpdateDRepTxCert @era drepKH SNothing + testCertificateNotSupportedV1 updateDRepTxCert + it "V2" $ do + (drepKH, _, _) <- setupSingleDRep 1_000 + let updateDRepTxCert = UpdateDRepTxCert @era drepKH SNothing + testCertificateNotSupportedV2 updateDRepTxCert + +govPolicySpec :: + forall era. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era + ) => + SpecWith (ImpTestState era) +govPolicySpec = do + describe "Gov policy scripts" $ do + it "failing native script govPolicy" $ do + (committeeMember :| _) <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep 1_000_000 + scriptHash <- impAddNativeScript $ RequireTimeStart (SlotNo 1) + anchor <- arbitrary + void $ + enactConstitution SNothing (Constitution anchor (SJust scriptHash)) dRep committeeMember + rewardAccount <- registerRewardAccount + pp <- getsNES $ nesEsL . curPParamsEpochStateL + impAnn "ParameterChange" $ do + let pparamsUpdate = def & ppuCommitteeMinSizeL .~ SJust 1 + let govAction = ParameterChange SNothing pparamsUpdate (SJust scriptHash) + let proposal = + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = govAction + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = anchor + } + let tx = + mkBasicTx mkBasicTxBody + & bodyTxL + . proposalProceduresTxBodyL + .~ [proposal] + & bodyTxL + . vldtTxBodyL + .~ ValidityInterval SNothing SNothing + submitFailingTx tx [injectFailure $ ScriptWitnessNotValidatingUTXOW [scriptHash]] + + impAnn "TreasuryWithdrawals" $ do + let withdrawals = Map.fromList [(rewardAccount, Coin 1000)] + let govAction = TreasuryWithdrawals withdrawals (SJust scriptHash) + + let proposal = + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = govAction + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = anchor + } + let tx = + mkBasicTx mkBasicTxBody + & bodyTxL + . proposalProceduresTxBodyL + .~ [proposal] + & bodyTxL + . vldtTxBodyL + .~ ValidityInterval SNothing SNothing + submitFailingTx tx [injectFailure $ ScriptWitnessNotValidatingUTXOW [scriptHash]] + + it "alwaysSucceeds Plutus govPolicy validates" $ do + let alwaysSucceedsSh = hashPlutusScript (alwaysSucceeds2 SPlutusV3) + (committeeMember :| _) <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep 1_000_000 + anchor <- arbitrary + pp <- getsNES $ nesEsL . curPParamsEpochStateL + void $ + enactConstitution + SNothing + (Constitution anchor (SJust alwaysSucceedsSh)) + dRep + committeeMember + rewardAccount <- registerRewardAccount + + impAnn "ParameterChange" $ do + let pparamsUpdate = def & ppuCommitteeMinSizeL .~ SJust 1 + let govAction = ParameterChange SNothing pparamsUpdate (SJust alwaysSucceedsSh) + let proposal = + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = govAction + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = anchor + } + submitProposal_ proposal + impAnn "TreasuryWithdrawals" $ do + let withdrawals = Map.fromList [(rewardAccount, Coin 1000)] + let govAction = TreasuryWithdrawals withdrawals (SJust alwaysSucceedsSh) + + let proposal = + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = govAction + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = anchor + } + submitProposal_ proposal + + it "alwaysFails Plutus govPolicy does not validate" $ do + let alwaysFailsSh = hashPlutusScript (alwaysFails2 SPlutusV3) + (committeeMember :| _) <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep 1_000_000 + anchor <- arbitrary + pp <- getsNES $ nesEsL . curPParamsEpochStateL + void $ + enactConstitution SNothing (Constitution anchor (SJust alwaysFailsSh)) dRep committeeMember + + rewardAccount <- registerRewardAccount + impAnn "ParameterChange" $ do + let pparamsUpdate = def & ppuCommitteeMinSizeL .~ SJust 1 + let govAction = ParameterChange SNothing pparamsUpdate (SJust alwaysFailsSh) + let proposal = + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = govAction + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = anchor + } + let tx = mkBasicTx mkBasicTxBody & bodyTxL . proposalProceduresTxBodyL .~ [proposal] + expectPhase2Invalid tx + + impAnn "TreasuryWithdrawals" $ do + let withdrawals = Map.fromList [(rewardAccount, Coin 1000)] + let govAction = TreasuryWithdrawals withdrawals (SJust alwaysFailsSh) + let proposal = + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = govAction + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = anchor + } + let tx = mkBasicTx mkBasicTxBody & bodyTxL . proposalProceduresTxBodyL .~ [proposal] + expectPhase2Invalid tx + +costModelsSpec :: + forall era. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era + , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era + ) => + SpecWith (ImpTestState era) +costModelsSpec = + describe "PlutusV3 Initialization" $ do + it "Updating CostModels with alwaysFails govPolicy does not validate" $ do + -- no initial PlutusV3 CostModels + modifyPParams $ ppCostModelsL .~ testingCostModels [PlutusV1 .. PlutusV2] + + (committeeMember :| _) <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep 1_000_000 + anchor <- arbitrary + govIdConstitution1 <- + enactConstitution SNothing (Constitution anchor SNothing) dRep committeeMember + -- propose and enact PlutusV3 Costmodels + govIdPPUpdate1 <- + enactCostModels SNothing (testingCostModels [PlutusV3]) dRep committeeMember + + let alwaysFailsSh = hashPlutusScript (alwaysFails2 SPlutusV3) + void $ + enactConstitution + (SJust (GovPurposeId govIdConstitution1)) + (Constitution anchor (SJust alwaysFailsSh)) + dRep + committeeMember + + impAnn "Fail to update V3 Costmodels" $ do + let pparamsUpdate = def & ppuCostModelsL .~ SJust (testingCostModels [PlutusV3]) + let govAction = ParameterChange (SJust govIdPPUpdate1) pparamsUpdate (SJust alwaysFailsSh) + rewardAccount <- registerRewardAccount + pp <- getsNES $ nesEsL . curPParamsEpochStateL + let proposal = + ProposalProcedure + { pProcReturnAddr = rewardAccount + , pProcGovAction = govAction + , pProcDeposit = pp ^. ppGovActionDepositL + , pProcAnchor = anchor + } + let tx = mkBasicTx mkBasicTxBody & bodyTxL . proposalProceduresTxBodyL .~ [proposal] + expectPhase2Invalid tx + + it "Updating CostModels with alwaysSucceeds govPolicy but no PlutusV3 CostModels fails" $ do + modifyPParams $ ppCostModelsL .~ testingCostModels [PlutusV1 .. PlutusV2] + + (committeeMember :| _) <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep 1_000_000 + anchor <- arbitrary + let alwaysSucceedsSh = hashPlutusScript (alwaysSucceeds2 SPlutusV3) + void $ + enactConstitution + SNothing + (Constitution anchor (SJust alwaysSucceedsSh)) + dRep + committeeMember + + let pparamsUpdate = def & ppuCostModelsL .~ SJust (testingCostModels [PlutusV3]) + let govAction = ParameterChange SNothing pparamsUpdate (SJust alwaysSucceedsSh) + + submitFailingGovAction govAction [injectFailure $ CollectErrors [NoCostModel PlutusV3]] + + it "Updating CostModels and setting the govPolicy afterwards succeeds" $ do + modifyPParams $ ppCostModelsL .~ testingCostModels [PlutusV1 .. PlutusV2] + + (committeeMember :| _) <- registerInitialCommittee + (dRep, _, _) <- setupSingleDRep 1_000_000 + anchor <- arbitrary + govIdConstitution1 <- + enactConstitution SNothing (Constitution anchor SNothing) dRep committeeMember + + let guessTheNumberSh = hashPlutusScript (guessTheNumber3 SPlutusV3) + + impAnn "Minting token fails" $ do + tx <- mintingTokenTx @era (mkBasicTx @era mkBasicTxBody) guessTheNumberSh + submitFailingTx tx [injectFailure $ CollectErrors [NoCostModel PlutusV3]] + + govIdPPUpdate1 <- + enactCostModels + SNothing + (testingCostModels [PlutusV3]) + dRep + committeeMember + + let alwaysSucceedsSh = hashPlutusScript (alwaysSucceeds2 SPlutusV3) + void $ + enactConstitution + (SJust (GovPurposeId govIdConstitution1)) + (Constitution anchor (SJust alwaysSucceedsSh)) + dRep + committeeMember + + impAnn "Minting token succeeds" $ do + tx <- mintingTokenTx @era (mkBasicTx @era mkBasicTxBody) guessTheNumberSh + submitTx_ tx + + impAnn "Updating CostModels succeeds" $ do + void $ + enactCostModels + (SJust govIdPPUpdate1) + (testingCostModels [PlutusV3]) + dRep + committeeMember + +txWithPlutus :: + forall era. + BabelEraImp era => + ScriptHash (EraCrypto era) -> + ImpTestM era (Tx era) +txWithPlutus sh = do + submitTxAnn "Submit a Plutus" $ + mkBasicTx mkBasicTxBody + & bodyTxL + . outputsTxBodyL + .~ SSeq.singleton (scriptLockedTxOut sh) + +scriptLockedTxOut :: + forall era. + AlonzoEraTxOut era => + ScriptHash (EraCrypto era) -> + TxOut era +scriptLockedTxOut shSpending = + mkBasicTxOut + (Addr Testnet (ScriptHashObj shSpending) StakeRefNull) + (inject $ Coin 1_000_000) + & dataHashTxOutL + .~ SJust (hashData @era $ Data spendDatum) + +mkRefTxOut :: + ( BabbageEraTxOut era + , AlonzoEraImp era + ) => + ScriptHash (EraCrypto era) -> + ImpTestM era (TxOut era) +mkRefTxOut sh = do + kpPayment <- lookupKeyPair =<< freshKeyHash + kpStaking <- lookupKeyPair =<< freshKeyHash + let mbyPlutusScript = impLookupPlutusScriptMaybe sh + pure $ + mkBasicTxOut (mkAddr (kpPayment, kpStaking)) (inject $ Coin 100) + & referenceScriptTxOutL + .~ maybeToStrictMaybe (fromPlutusScript <$> mbyPlutusScript) + +setupRefTx :: + forall era. + ( BabbageEraTxOut era + , AlonzoEraImp era + ) => + ImpTestM era (TxId (EraCrypto era)) +setupRefTx = do + let shSpending = hashPlutusScript (guessTheNumber3 SPlutusV1) + refTxOut <- mkRefTxOut shSpending + fmap txIdTx . submitTxAnn "Producing transaction" $ + mkBasicTx mkBasicTxBody + & bodyTxL + . outputsTxBodyL + .~ SSeq.fromList + [ refTxOut + , scriptLockedTxOut shSpending + , scriptLockedTxOut shSpending + ] + +testPlutusV1V2Failure :: + forall era a. + ( BabelEraImp era + , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era + , HasCallStack + ) => + ScriptHash (EraCrypto era) -> + a -> + Lens' (TxBody era) a -> + ContextError era -> + ImpTestM era () +testPlutusV1V2Failure sh badField lenz errorField = do + tx <- txWithPlutus @era sh + submitFailingTx + ( mkBasicTx mkBasicTxBody + & bodyTxL + . inputsTxBodyL + .~ Set.singleton (txInAt (0 :: Int) tx) + & bodyTxL + . lenz + .~ badField + ) + ( pure . injectFailure $ + CollectErrors [BadTranslation errorField] + ) + +expectPhase2Invalid :: BabelEraImp era => Tx era -> ImpTestM era () +expectPhase2Invalid tx = do + res <- trySubmitTx tx + -- TODO: find a way to check that this is a PlutusFailure + -- without comparing the entire PredicateFailure + void $ expectLeft res + submitTx_ $ tx & isValidTxL .~ IsValid False + +mintingTokenTx :: BabelEraImp era => Tx era -> ScriptHash (EraCrypto era) -> ImpTestM era (Tx era) +mintingTokenTx tx sh = do + name <- arbitrary + count <- choose (0, 10) + let policyId = PolicyID sh + let ma = MultiAsset $ Map.singleton policyId [(name, count)] + (_, addr) <- freshKeyAddr + pure $ + tx + & bodyTxL + . mintTxBodyL + .~ ma + & bodyTxL + . outputsTxBodyL + <>~ [mkBasicTxOut addr (MaryValue (Coin 12345) ma)] + +enactCostModels :: + BabelEraImp era => + StrictMaybe (GovPurposeId 'PParamUpdatePurpose era) -> + CostModels -> + Credential 'DRepRole (EraCrypto era) -> + Credential 'HotCommitteeRole (EraCrypto era) -> + ImpTestM era (GovPurposeId 'PParamUpdatePurpose era) +enactCostModels prevGovId cms dRep committeeMember = do + initialCms <- getsNES $ nesEsL . curPParamsEpochStateL . ppCostModelsL + let pparamsUpdate = def & ppuCostModelsL .~ SJust cms + govId <- submitParameterChange (unGovPurposeId <$> prevGovId) pparamsUpdate + submitYesVote_ (DRepVoter dRep) govId + submitYesVote_ (CommitteeVoter committeeMember) govId + passNEpochs 2 + enactedCms <- getsNES $ nesEsL . curPParamsEpochStateL . ppCostModelsL + enactedCms `shouldBe` (initialCms <> cms) + pure $ GovPurposeId govId + +spendDatum :: P1.Data +spendDatum = P1.I 3 diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/ImpTest.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/ImpTest.hs new file mode 100644 index 00000000000..b7fbc4a7e31 --- /dev/null +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/ImpTest.hs @@ -0,0 +1,1512 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Cardano.Ledger.Babel.ImpTest ( + module Test.Cardano.Ledger.Babbage.ImpTest, + BabelEraImp, + enactConstitution, + enactTreasuryWithdrawals, + submitGovAction, + submitGovAction_, + submitGovActions, + submitProposal, + submitAndExpireProposalToMakeReward, + submitProposal_, + submitProposals, + submitFailingProposal, + trySubmitGovAction, + trySubmitGovActions, + trySubmitProposal, + trySubmitProposals, + submitTreasuryWithdrawals, + submitVote, + submitVote_, + submitYesVote_, + submitFailingVote, + trySubmitVote, + registerDRep, + setupSingleDRep, + setupPoolWithStake, + setupPoolWithoutStake, + conwayModifyPParams, + getProposals, + getEnactState, + getGovActionState, + lookupGovActionState, + expectPresentGovActionId, + expectMissingGovActionId, + getRatifyEnv, + calculateDRepAcceptedRatio, + calculatePoolAcceptedRatio, + calculateCommitteeAcceptedRatio, + logAcceptedRatio, + isDRepAccepted, + isSpoAccepted, + isCommitteeAccepted, + getCommitteeMembers, + getConstitution, + registerInitialCommittee, + logRatificationChecks, + resignCommitteeColdKey, + registerCommitteeHotKey, + logCurPParams, + electCommittee, + electBasicCommittee, + proposalsShowDebug, + getGovPolicy, + submitFailingGovAction, + submitConstitutionGovAction, + submitGovActionForest, + submitGovActionTree, + getProposalsForest, + logProposalsForest, + logProposalsForestDiff, + constitutionShouldBe, + getCCExpiry, + ccShouldBeExpired, + ccShouldNotBeExpired, + ccShouldBeResigned, + ccShouldNotBeResigned, + getLastEnactedCommittee, + getLastEnactedConstitution, + submitParameterChange, + getLastEnactedParameterChange, + getLastEnactedHardForkInitiation, + getConstitutionProposals, + getParameterChangeProposals, + expectNumDormantEpochs, + submitConstitution, + expectExtraDRepExpiry, + expectCurrentProposals, + expectNoCurrentProposals, + expectPulserProposals, + expectNoPulserProposals, + minorFollow, + majorFollow, + cantFollow, + getsPParams, + currentProposalsShouldContain, + setupDRepWithoutStake, + withImpStateWithProtVer, + whenPostBootstrap, +) where + +import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), Ed25519DSIGN, Signable) +import Cardano.Crypto.Hash.Class (Hash) +import Cardano.Ledger.Address (Addr (..), RewardAccount (..)) +import Cardano.Ledger.Allegra.Scripts (Timelock) +import Cardano.Ledger.Alonzo.Scripts (AlonzoScript) +import Cardano.Ledger.Babel (BabelEra) +import Cardano.Ledger.Babel.Core hiding (proposals) +import Cardano.Ledger.Babel.TxCert ( + BabelEraTxCert, + Delegatee (..), + pattern AuthCommitteeHotKeyTxCert, + pattern RegDRepTxCert, + pattern RegDepositDelegTxCert, + pattern ResignCommitteeColdTxCert, + ) +import Cardano.Ledger.BaseTypes ( + EpochInterval (..), + EpochNo (..), + Network (..), + ProtVer (..), + ShelleyBase, + StrictMaybe (..), + Version, + addEpochInterval, + inject, + succVersion, + textToUrl, + ) +import Cardano.Ledger.CertState ( + CommitteeAuthorization (..), + csCommitteeCredsL, + vsNumDormantEpochsL, + ) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Conway.Core (ConwayEraPParams, ConwayEraTxBody (..)) +import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Conway.PParams (ConwayPParams (..)) +import Cardano.Ledger.Conway.Rules ( + ConwayGovEvent, + EnactSignal, + committeeAccepted, + committeeAcceptedRatio, + dRepAccepted, + dRepAcceptedRatio, + prevActionAsExpected, + spoAccepted, + spoAcceptedRatio, + validCommitteeTerm, + withdrawalCanWithdraw, + ) +import Cardano.Ledger.Conway.TxCert (ConwayEraTxCert (..)) +import Cardano.Ledger.Credential (Credential (..), StakeReference (..)) +import Cardano.Ledger.Crypto (Crypto (..)) +import Cardano.Ledger.DRep +import Cardano.Ledger.Keys (KeyHash, KeyRole (..)) +import Cardano.Ledger.Plutus.Language (SLanguage (..)) +import qualified Cardano.Ledger.Shelley.HardForks as HardForks (bootstrapPhase) +import Cardano.Ledger.Shelley.LedgerState ( + IncrementalStake (..), + asTreasuryL, + certVStateL, + curPParamsEpochStateL, + epochStateGovStateL, + esAccountStateL, + esLStateL, + lsCertStateL, + lsUTxOStateL, + nesELL, + nesEpochStateL, + nesEsL, + nesPdL, + newEpochStateGovStateL, + utxosGovStateL, + utxosStakeDistrL, + vsCommitteeStateL, + vsDRepsL, + ) +import Cardano.Ledger.TxIn (TxId (..)) +import Cardano.Ledger.Val (Val (..)) +import Control.Monad (forM) +import Control.State.Transition.Extended (STS (..)) +import Data.Default.Class (Default (..)) +import Data.Foldable (Foldable (..)) +import Data.Functor.Identity +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust, isJust) +import Data.Sequence.Strict (StrictSeq (..)) +import qualified Data.Sequence.Strict as SSeq +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Tree +import qualified GHC.Exts as GHC (fromList) +import Lens.Micro +import Lens.Micro.Mtl ((%=)) +import Test.Cardano.Ledger.Babbage.ImpTest +import Test.Cardano.Ledger.Babel.Arbitrary () +import Test.Cardano.Ledger.Babel.TreeDiff () +import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkAddr) +import Test.Cardano.Ledger.Core.Rational (IsRatio (..)) +import Test.Cardano.Ledger.Imp.Common + +-- | Modify the PParams in the current state with the given function +conwayModifyPParams :: + ConwayEraGov era => + (PParams era -> PParams era) -> + ImpTestM era () +conwayModifyPParams f = modifyNES $ \nes -> + nes + & nesEsL + . curPParamsEpochStateL + %~ f + & newEpochStateGovStateL + . drepPulsingStateGovStateL + %~ modifyDRepPulser + where + modifyDRepPulser pulser = + case finishDRepPulser pulser of + (snapshot, ratifyState) -> + DRComplete snapshot (ratifyState & rsEnactStateL . ensCurPParamsL %~ f) + +withImpStateWithProtVer :: + forall era. + ( BabelEraImp era + , GovState era ~ ConwayGovState era + , PParamsHKD Identity era ~ ConwayPParams Identity era + ) => + Version -> + SpecWith (ImpTestState era) -> + Spec +withImpStateWithProtVer ver = do + withImpStateModified $ + impNESL + . nesEsL + . esLStateL + . lsUTxOStateL + . (utxosGovStateL @era) + . cgsCurPParamsL + %~ ( \(PParams pp) -> + PParams (pp {cppProtocolVersion = ProtVer ver 0}) + ) + +instance + ( Crypto c + , NFData (SigDSIGN (DSIGN c)) + , NFData (VerKeyDSIGN (DSIGN c)) + , DSIGN c ~ Ed25519DSIGN + , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody) + , Eq (ConwayGovEvent (BabelEra c)) + ) => + ShelleyEraImp (BabelEra c) + where + initImpTestState = do + kh <- fst <$> freshKeyPair + let committee = Committee [(KeyHashObj kh, EpochNo 15)] (1 %! 1) + anchor <- arbitrary + let constitution = Constitution anchor SNothing + impNESL %= initBabelNES committee constitution + where + initBabelNES committee constitution nes = + let newNes = + (initAlonzoImpNES nes) + & nesEsL + . curPParamsEpochStateL + . ppDRepActivityL + .~ EpochInterval 100 + & nesEsL + . curPParamsEpochStateL + . ppGovActionLifetimeL + .~ EpochInterval 30 + & nesEsL + . curPParamsEpochStateL + . ppGovActionDepositL + .~ Coin 123 + & nesEsL + . curPParamsEpochStateL + . ppCommitteeMaxTermLengthL + .~ EpochInterval 20 + & nesEsL + . curPParamsEpochStateL + . ppCommitteeMinSizeL + .~ 1 + & nesEsL + . curPParamsEpochStateL + . ppDRepVotingThresholdsL + %~ ( \dvt -> + dvt + { dvtCommitteeNormal = 1 %! 1 + , dvtCommitteeNoConfidence = 1 %! 2 + , dvtUpdateToConstitution = 1 %! 2 + } + ) + & nesEsL + . epochStateGovStateL + . committeeGovStateL + .~ SJust committee + & nesEsL + . epochStateGovStateL + . constitutionGovStateL + .~ constitution + epochState = newNes ^. nesEsL + ratifyState = + def + & rsEnactStateL + .~ mkEnactState (epochState ^. epochStateGovStateL) + in newNes & nesEsL .~ setCompleteDRepPulsingState def ratifyState epochState + + impSatisfyNativeScript = impAllegraSatisfyNativeScript + + modifyPParams = conwayModifyPParams + + fixupTx = alonzoFixupTx + +instance + ( Crypto c + , NFData (SigDSIGN (DSIGN c)) + , NFData (VerKeyDSIGN (DSIGN c)) + , DSIGN c ~ Ed25519DSIGN + , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody) + ) => + MaryEraImp (BabelEra c) + +instance ShelleyEraImp (BabelEra c) => AlonzoEraImp (BabelEra c) where + scriptTestContexts = + plutusTestScripts SPlutusV1 + <> plutusTestScripts SPlutusV2 + <> plutusTestScripts SPlutusV3 + +class + ( AlonzoEraImp era + , ConwayEraGov era + , BabelEraTxBody era + , STS (EraRule "ENACT" era) + , BaseM (EraRule "ENACT" era) ~ ShelleyBase + , State (EraRule "ENACT" era) ~ EnactState era + , Signal (EraRule "ENACT" era) ~ EnactSignal era + , Environment (EraRule "ENACT" era) ~ () + , NativeScript era ~ Timelock era + , Script era ~ AlonzoScript era + ) => + BabelEraImp era + +instance + ( Crypto c + , NFData (SigDSIGN (DSIGN c)) + , NFData (VerKeyDSIGN (DSIGN c)) + , DSIGN c ~ Ed25519DSIGN + , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody) + ) => + BabelEraImp (BabelEra c) + +registerInitialCommittee :: + (HasCallStack, BabelEraImp era) => + ImpTestM era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))) +registerInitialCommittee = do + committeeMembers <- Set.toList <$> getCommitteeMembers + case committeeMembers of + x : xs -> traverse registerCommitteeHotKey $ x NE.:| xs + _ -> error "Expected an initial committee" + +-- | Submit a transaction that registers a new DRep and return the keyhash +-- belonging to that DRep +registerDRep :: + forall era. + ( ShelleyEraImp era + , BabelEraTxCert era + ) => + ImpTestM era (KeyHash 'DRepRole (EraCrypto era)) +registerDRep = do + -- Register a DRep + khDRep <- freshKeyHash + submitTxAnn_ "Register DRep" $ + mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton + ( RegDRepTxCert + (KeyHashObj khDRep) + zero + SNothing + ) + dreps <- getsNES @era $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsDRepsL + dreps `shouldSatisfy` Map.member (KeyHashObj khDRep) + pure khDRep + +-- | In contrast to `setupSingleDRep`, this function does not make a UTxO entry +-- that could count as delegated stake to the DRep, so that we can test that +-- rewards are also calculated nonetheless. +setupDRepWithoutStake :: + forall era. + ( BabelEraTxCert era + , ShelleyEraImp era + ) => + ImpTestM + era + ( KeyHash 'DRepRole (EraCrypto era) + , KeyHash 'Staking (EraCrypto era) + ) +setupDRepWithoutStake = do + drepKH <- registerDRep + delegatorKH <- freshKeyHash + deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL + submitTxAnn_ "Delegate to DRep" $ + mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.fromList + [ mkRegDepositDelegTxCert @era + (KeyHashObj delegatorKH) + (DelegVote (DRepCredential $ KeyHashObj drepKH)) + deposit + ] + pure (drepKH, delegatorKH) + +-- | Registers a new DRep and delegates the specified amount of ADA to it. +setupSingleDRep :: + forall era. + ( BabelEraTxCert era + , ShelleyEraImp era + ) => + Integer -> + ImpTestM + era + ( Credential 'DRepRole (EraCrypto era) + , Credential 'Staking (EraCrypto era) + , KeyPair 'Payment (EraCrypto era) + ) +setupSingleDRep stake = do + drepKH <- registerDRep + (delegatorKH, delegatorKP) <- freshKeyPair + (_, spendingKP) <- freshKeyPair + submitTxAnn_ "Delegate to DRep" $ + mkBasicTx mkBasicTxBody + & bodyTxL + . outputsTxBodyL + .~ SSeq.singleton + ( mkBasicTxOut + (mkAddr (spendingKP, delegatorKP)) + (inject $ Coin stake) + ) + & bodyTxL + . certsTxBodyL + .~ SSeq.fromList + [ mkRegDepositDelegTxCert @era + (KeyHashObj delegatorKH) + (DelegVote (DRepCredential $ KeyHashObj drepKH)) + zero + ] + pure (KeyHashObj drepKH, KeyHashObj delegatorKH, spendingKP) + +getsPParams :: EraGov era => Lens' (PParams era) a -> ImpTestM era a +getsPParams f = getsNES $ nesEsL . curPParamsEpochStateL . f + +-- | Sets up a stake pool with coin delegated to it. +-- +-- NOTE: This uses the `RegDepositDelegTxCert` for delegating, so it has to be +-- in Babel. The Shelley version of this function would have to separately +-- register the staking credential and then delegate it. +setupPoolWithStake :: + (ShelleyEraImp era, BabelEraTxCert era) => + Coin -> + ImpTestM + era + ( KeyHash 'StakePool (EraCrypto era) + , Credential 'Payment (EraCrypto era) + , Credential 'Staking (EraCrypto era) + ) +setupPoolWithStake delegCoin = do + khPool <- registerPool + credDelegatorPayment <- KeyHashObj <$> freshKeyHash + credDelegatorStaking <- KeyHashObj <$> freshKeyHash + void $ + sendCoinTo + (Addr Testnet credDelegatorPayment (StakeRefBase credDelegatorStaking)) + delegCoin + pp <- getsNES $ nesEsL . curPParamsEpochStateL + submitTxAnn_ "Delegate to stake pool" $ + mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.fromList + [ RegDepositDelegTxCert + credDelegatorStaking + (DelegStake khPool) + (pp ^. ppKeyDepositL) + ] + pure (khPool, credDelegatorPayment, credDelegatorStaking) + +setupPoolWithoutStake :: + (ShelleyEraImp era, BabelEraTxCert era) => + ImpTestM + era + ( KeyHash 'StakePool (EraCrypto era) + , Credential 'Staking (EraCrypto era) + ) +setupPoolWithoutStake = do + khPool <- registerPool + credDelegatorStaking <- KeyHashObj <$> freshKeyHash + deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL + submitTxAnn_ "Delegate to stake pool" $ + mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.fromList + [ RegDepositDelegTxCert + credDelegatorStaking + (DelegStake khPool) + deposit + ] + pure (khPool, credDelegatorStaking) + +-- | Submits a transaction with a Vote for the given governance action as +-- some voter +submitVote :: + ( ShelleyEraImp era + , BabelEraTxBody era + , HasCallStack + ) => + Vote -> + Voter (EraCrypto era) -> + GovActionId (EraCrypto era) -> + ImpTestM era (TxId (EraCrypto era)) +submitVote vote voter gaId = trySubmitVote vote voter gaId >>= expectRightDeep + +-- | Submits a transaction that votes "Yes" for the given governance action as +-- some voter +submitYesVote_ :: + ( ShelleyEraImp era + , BabelEraTxBody era + , HasCallStack + ) => + Voter (EraCrypto era) -> + GovActionId (EraCrypto era) -> + ImpTestM era () +submitYesVote_ voter gaId = void $ submitVote VoteYes voter gaId + +submitVote_ :: + ( ShelleyEraImp era + , BabelEraTxBody era + , HasCallStack + ) => + Vote -> + Voter (EraCrypto era) -> + GovActionId (EraCrypto era) -> + ImpTestM era () +submitVote_ vote voter gaId = void $ submitVote vote voter gaId + +submitFailingVote :: + ( ShelleyEraImp era + , BabelEraTxBody era + , HasCallStack + ) => + Voter (EraCrypto era) -> + GovActionId (EraCrypto era) -> + NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> + ImpTestM era () +submitFailingVote voter gaId expectedFailure = + trySubmitVote VoteYes voter gaId >>= (`shouldBeLeftExpr` expectedFailure) + +-- | Submits a transaction that votes "Yes" for the given governance action as +-- some voter, and expects an `Either` result. +trySubmitVote :: + ( ShelleyEraImp era + , BabelEraTxBody era + ) => + Vote -> + Voter (EraCrypto era) -> + GovActionId (EraCrypto era) -> + ImpTestM + era + ( Either + (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) + (TxId (EraCrypto era)) + ) +trySubmitVote vote voter gaId = + fmap (fmap txIdTx) $ + trySubmitTx $ + mkBasicTx mkBasicTxBody + & bodyTxL + . votingProceduresTxBodyL + .~ VotingProcedures + ( Map.singleton + voter + ( Map.singleton + gaId + ( VotingProcedure + { vProcVote = vote + , vProcAnchor = SNothing + } + ) + ) + ) + +submitProposal_ :: + (ShelleyEraImp era, BabelEraTxBody era, HasCallStack) => + ProposalProcedure era -> + ImpTestM era () +submitProposal_ = void . submitProposal + +submitProposal :: + (ShelleyEraImp era, BabelEraTxBody era, HasCallStack) => + ProposalProcedure era -> + ImpTestM era (GovActionId (EraCrypto era)) +submitProposal proposal = trySubmitProposal proposal >>= expectRightExpr + +submitProposals :: + (ShelleyEraImp era, ConwayEraGov era, BabelEraTxBody era, HasCallStack) => + NE.NonEmpty (ProposalProcedure era) -> + ImpTestM era (NE.NonEmpty (GovActionId (EraCrypto era))) +submitProposals proposals = do + curEpochNo <- getsNES nesELL + pp <- getsNES $ nesEsL . curPParamsEpochStateL + tx <- trySubmitProposals proposals >>= expectRightExpr + let txId = txIdTx tx + proposalsWithGovActionId = + NE.zipWith (\idx p -> (GovActionId txId (GovActionIx idx), p)) (0 NE.:| [1 ..]) proposals + forM proposalsWithGovActionId $ \(govActionId, proposal) -> do + govActionState <- getGovActionState govActionId + govActionState + `shouldBeExpr` GovActionState + { gasId = govActionId + , gasCommitteeVotes = mempty + , gasDRepVotes = mempty + , gasStakePoolVotes = mempty + , gasProposalProcedure = proposal + , gasProposedIn = curEpochNo + , gasExpiresAfter = addEpochInterval curEpochNo (pp ^. ppGovActionLifetimeL) + } + pure govActionId + +-- | Submits a transaction that proposes the given proposal +trySubmitProposal :: + ( ShelleyEraImp era + , BabelEraTxBody era + ) => + ProposalProcedure era -> + ImpTestM + era + ( Either + (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) + (GovActionId (EraCrypto era)) + ) +trySubmitProposal proposal = do + res <- trySubmitProposals (pure proposal) + pure $ case res of + Right tx -> + Right + GovActionId + { gaidTxId = txIdTx tx + , gaidGovActionIx = GovActionIx 0 + } + Left err -> Left err + +trySubmitProposals :: + ( ShelleyEraImp era + , BabelEraTxBody era + ) => + NE.NonEmpty (ProposalProcedure era) -> + ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) (Tx era)) +trySubmitProposals proposals = do + trySubmitTx $ + mkBasicTx mkBasicTxBody + & bodyTxL + . proposalProceduresTxBodyL + .~ GHC.fromList (toList proposals) + +submitFailingProposal :: + ( ShelleyEraImp era + , BabelEraTxBody era + , HasCallStack + ) => + ProposalProcedure era -> + NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> + ImpTestM era () +submitFailingProposal proposal expectedFailure = + trySubmitProposal proposal >>= (`shouldBeLeftExpr` expectedFailure) + +-- | Submits a transaction that proposes the given governance action. For proposing +-- multiple actions in the same transaciton use `trySubmitGovActions` instead. +trySubmitGovAction :: + ( ShelleyEraImp era + , BabelEraTxBody era + ) => + GovAction era -> + ImpTestM + era + ( Either + (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) + (GovActionId (EraCrypto era)) + ) +trySubmitGovAction ga = do + let mkGovActionId tx = GovActionId (txIdTx tx) (GovActionIx 0) + fmap mkGovActionId <$> trySubmitGovActions (pure ga) + +submitAndExpireProposalToMakeReward :: + BabelEraImp era => + Int -> + Credential 'Staking (EraCrypto era) -> + ImpTestM era () +submitAndExpireProposalToMakeReward expectedReward stakingC = do + rewardAccount <- getRewardAccountFor stakingC + EpochInterval lifetime <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionLifetimeL + gai <- + submitProposal $ + ProposalProcedure + { pProcDeposit = Coin $ fromIntegral expectedReward + , pProcReturnAddr = rewardAccount + , pProcGovAction = TreasuryWithdrawals mempty def + , pProcAnchor = def + } + passNEpochs $ 2 + fromIntegral lifetime + expectMissingGovActionId gai + +-- | Submits a transaction that proposes the given governance action +trySubmitGovActions :: + (ShelleyEraImp era, BabelEraTxBody era) => + NE.NonEmpty (GovAction era) -> + ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) (Tx era)) +trySubmitGovActions gas = do + deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL + rewardAccount <- registerRewardAccount + proposals <- forM gas $ \ga -> do + pure + ProposalProcedure + { pProcDeposit = deposit + , pProcReturnAddr = rewardAccount + , pProcGovAction = ga + , pProcAnchor = def + } + trySubmitProposals proposals + +submitGovAction :: + forall era. + ( ShelleyEraImp era + , BabelEraTxBody era + , HasCallStack + ) => + GovAction era -> + ImpTestM era (GovActionId (EraCrypto era)) +submitGovAction ga = do + gaId NE.:| _ <- submitGovActions (pure ga) + pure gaId + +submitGovAction_ :: + forall era. + ( ShelleyEraImp era + , BabelEraTxBody era + , HasCallStack + ) => + GovAction era -> + ImpTestM era () +submitGovAction_ = void . submitGovAction + +submitGovActions :: + forall era. + ( ShelleyEraImp era + , BabelEraTxBody era + , HasCallStack + ) => + NE.NonEmpty (GovAction era) -> + ImpTestM era (NE.NonEmpty (GovActionId (EraCrypto era))) +submitGovActions gas = do + tx <- trySubmitGovActions gas >>= expectRightExpr + let txId = txIdTx tx + pure $ NE.zipWith (\idx _ -> GovActionId txId (GovActionIx idx)) (0 NE.:| [1 ..]) gas + +submitTreasuryWithdrawals :: + ( ShelleyEraImp era + , BabelEraTxBody era + , ConwayEraGov era + ) => + [(RewardAccount (EraCrypto era), Coin)] -> + ImpTestM era (GovActionId (EraCrypto era)) +submitTreasuryWithdrawals wdrls = do + policy <- getGovPolicy + submitGovAction $ TreasuryWithdrawals (Map.fromList wdrls) policy + +enactTreasuryWithdrawals :: + BabelEraImp era => + [(RewardAccount (EraCrypto era), Coin)] -> + Credential 'DRepRole (EraCrypto era) -> + Credential 'HotCommitteeRole (EraCrypto era) -> + ImpTestM era (GovActionId (EraCrypto era)) +enactTreasuryWithdrawals withdrawals dRep cm = do + gaId <- submitTreasuryWithdrawals withdrawals + submitYesVote_ (DRepVoter dRep) gaId + submitYesVote_ (CommitteeVoter cm) gaId + passNEpochs 2 + pure gaId + +submitParameterChange :: + BabelEraImp era => + StrictMaybe (GovActionId (EraCrypto era)) -> + PParamsUpdate era -> + ImpTestM era (GovActionId (EraCrypto era)) +submitParameterChange parent ppu = do + policy <- getGovPolicy + submitGovAction $ ParameterChange (GovPurposeId <$> parent) ppu policy + +getGovPolicy :: ConwayEraGov era => ImpTestM era (StrictMaybe (ScriptHash (EraCrypto era))) +getGovPolicy = + getsNES $ + nesEpochStateL . epochStateGovStateL . constitutionGovStateL . constitutionScriptL + +submitFailingGovAction :: + forall era. + ( ShelleyEraImp era + , BabelEraTxBody era + , HasCallStack + ) => + GovAction era -> + NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> + ImpTestM era () +submitFailingGovAction ga expectedFailure = trySubmitGovAction ga >>= (`shouldBeLeftExpr` expectedFailure) + +getEnactState :: ConwayEraGov era => ImpTestM era (EnactState era) +getEnactState = mkEnactState <$> getsNES (nesEsL . epochStateGovStateL) + +getProposals :: ConwayEraGov era => ImpTestM era (Proposals era) +getProposals = getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . proposalsGovStateL + +logProposalsForest :: ConwayEraGov era => ImpTestM era () +logProposalsForest = do + proposals <- getProposals + logEntry $ proposalsShowDebug proposals True + +getCommitteeMembers :: + BabelEraImp era => + ImpTestM era (Set.Set (Credential 'ColdCommitteeRole (EraCrypto era))) +getCommitteeMembers = do + committee <- + getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . committeeGovStateL + pure $ Map.keysSet $ foldMap' committeeMembers committee + +getLastEnactedCommittee :: + ConwayEraGov era => ImpTestM era (StrictMaybe (GovPurposeId 'CommitteePurpose era)) +getLastEnactedCommittee = do + ps <- getProposals + pure $ ps ^. pRootsL . grCommitteeL . prRootL + +getConstitution :: + BabelEraImp era => + ImpTestM era (Constitution era) +getConstitution = + getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . constitutionGovStateL + +getLastEnactedConstitution :: + ConwayEraGov era => ImpTestM era (StrictMaybe (GovPurposeId 'ConstitutionPurpose era)) +getLastEnactedConstitution = do + ps <- getProposals + pure $ ps ^. pRootsL . grConstitutionL . prRootL + +getLastEnactedParameterChange :: + ConwayEraGov era => ImpTestM era (StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)) +getLastEnactedParameterChange = do + ps <- getProposals + pure $ ps ^. pRootsL . grPParamUpdateL . prRootL + +getLastEnactedHardForkInitiation :: + ConwayEraGov era => ImpTestM era (StrictMaybe (GovPurposeId 'HardForkPurpose era)) +getLastEnactedHardForkInitiation = do + ps <- getProposals + pure $ ps ^. pRootsL . grHardForkL . prRootL + +getConstitutionProposals :: + ConwayEraGov era => + ImpTestM + era + ( Map.Map + (GovPurposeId 'ConstitutionPurpose era) + (PEdges (GovPurposeId 'ConstitutionPurpose era)) + ) +getConstitutionProposals = do + ps <- getProposals + pure $ ps ^. pGraphL . grConstitutionL . pGraphNodesL + +getParameterChangeProposals :: + ConwayEraGov era => + ImpTestM + era + ( Map.Map + (GovPurposeId 'PParamUpdatePurpose era) + (PEdges (GovPurposeId 'PParamUpdatePurpose era)) + ) +getParameterChangeProposals = do + ps <- getProposals + pure $ ps ^. pGraphL . grPParamUpdateL . pGraphNodesL + +logProposalsForestDiff :: + (Era era, ToExpr (PParamsHKD StrictMaybe era)) => + Proposals era -> + Proposals era -> + ImpTestM era () +logProposalsForestDiff pf1 pf2 = logEntry $ unlines ["Proposals Forest Diff:", diffExpr pf1 pf2] + +-- | Looks up the governance action state corresponding to the governance action id +lookupGovActionState :: + ConwayEraGov era => + GovActionId (EraCrypto era) -> + ImpTestM era (Maybe (GovActionState era)) +lookupGovActionState aId = proposalsLookupId aId <$> getProposals + +-- | Looks up the governance action state corresponding to the governance action id +getGovActionState :: + (HasCallStack, ConwayEraGov era) => + GovActionId (EraCrypto era) -> + ImpTestM era (GovActionState era) +getGovActionState govActionId = + impAnn "Expecting an action state" $ do + lookupGovActionState govActionId >>= \case + Nothing -> + assertFailure $ "Could not find action state for govActionId: " <> show govActionId + Just govActionState -> pure govActionState + +expectPresentGovActionId :: + (HasCallStack, ConwayEraGov era) => + GovActionId (EraCrypto era) -> + ImpTestM era () +expectPresentGovActionId govActionId = void $ getGovActionState govActionId + +expectMissingGovActionId :: + (HasCallStack, ConwayEraGov era) => + GovActionId (EraCrypto era) -> + ImpTestM era () +expectMissingGovActionId govActionId = + impAnn "Expecting for gov action state to be missing" $ do + lookupGovActionState govActionId >>= \case + Just _ -> + expectationFailure $ "Found gov action state for govActionId: " <> show govActionId + Nothing -> pure () + +-- | Builds a RatifyEnv from the current state +getRatifyEnv :: ConwayEraGov era => ImpTestM era (RatifyEnv era) +getRatifyEnv = do + eNo <- getsNES nesELL + stakeDistr <- getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosStakeDistrL + poolDistr <- getsNES nesPdL + drepDistr <- getsNES $ nesEsL . epochStateDRepPulsingStateL . psDRepDistrG + drepState <- getsNES $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsDRepsL + committeeState <- getsNES $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsCommitteeStateL + pure + RatifyEnv + { reStakePoolDistr = poolDistr + , reStakeDistr = credMap stakeDistr + , reDRepState = drepState + , reDRepDistr = drepDistr + , reCurrentEpoch = eNo - 1 + , reCommitteeState = committeeState + } + +ccShouldNotBeExpired :: + (HasCallStack, ConwayEraGov era) => + Credential 'ColdCommitteeRole (EraCrypto era) -> + ImpTestM era () +ccShouldNotBeExpired coldC = do + curEpochNo <- getsNES nesELL + ccExpiryEpochNo <- getCCExpiry coldC + curEpochNo `shouldSatisfy` (<= ccExpiryEpochNo) + +ccShouldBeExpired :: + (HasCallStack, ConwayEraGov era) => + Credential 'ColdCommitteeRole (EraCrypto era) -> + ImpTestM era () +ccShouldBeExpired coldC = do + curEpochNo <- getsNES nesELL + ccExpiryEpochNo <- getCCExpiry coldC + curEpochNo `shouldSatisfy` (> ccExpiryEpochNo) + +getCCExpiry :: + (HasCallStack, ConwayEraGov era) => + Credential 'ColdCommitteeRole (EraCrypto era) -> + ImpTestM era EpochNo +getCCExpiry coldC = do + committee <- getsNES $ nesEsL . epochStateGovStateL . committeeGovStateL + case committee of + SNothing -> assertFailure "There is no committee" + SJust Committee {committeeMembers} -> + case Map.lookup coldC committeeMembers of + Nothing -> assertFailure $ "Committee not found for cold credential: " <> show coldC + Just epochNo -> pure epochNo + +-- | Test the resignation status for a CC cold key to be resigned +ccShouldBeResigned :: + HasCallStack => Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era () +ccShouldBeResigned coldK = do + committeeCreds <- + getsNES $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsCommitteeStateL . csCommitteeCredsL + authHk <$> Map.lookup coldK committeeCreds `shouldBe` Just Nothing + +-- | Test the resignation status for a CC cold key to not be resigned +ccShouldNotBeResigned :: + HasCallStack => Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era () +ccShouldNotBeResigned coldK = do + committeeCreds <- + getsNES $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsCommitteeStateL . csCommitteeCredsL + (Map.lookup coldK committeeCreds >>= authHk) `shouldSatisfy` isJust + +authHk :: CommitteeAuthorization c -> Maybe (Credential 'HotCommitteeRole c) +authHk (CommitteeHotCredential hk) = Just hk +authHk _ = Nothing + +-- | Calculates the ratio of DReps that have voted for the governance action +calculateDRepAcceptedRatio :: + forall era. + (HasCallStack, ConwayEraGov era) => + GovActionId (EraCrypto era) -> + ImpTestM era Rational +calculateDRepAcceptedRatio gaId = do + ratEnv <- getRatifyEnv + gas <- getGovActionState gaId + pure $ + dRepAcceptedRatio @era + ratEnv + (gas ^. gasDRepVotesL) + (gasAction gas) + +-- | Calculates the ratio of Committee members that have voted for the governance +-- action +calculateCommitteeAcceptedRatio :: + forall era. + (HasCallStack, ConwayEraGov era) => + GovActionId (EraCrypto era) -> + ImpTestM era Rational +calculateCommitteeAcceptedRatio gaId = do + eNo <- getsNES nesELL + RatifyEnv {reCommitteeState} <- getRatifyEnv + GovActionState {gasCommitteeVotes} <- getGovActionState gaId + committee <- getsNES $ nesEsL . epochStateGovStateL . committeeGovStateL + let + members = foldMap' (committeeMembers @era) committee + pure $ + committeeAcceptedRatio + members + gasCommitteeVotes + reCommitteeState + eNo + +calculatePoolAcceptedRatio :: + ConwayEraGov era => GovActionId (EraCrypto era) -> ImpTestM era Rational +calculatePoolAcceptedRatio gaId = do + ratEnv <- getRatifyEnv + gas <- getGovActionState gaId + pure $ spoAcceptedRatio ratEnv gas + +-- | Logs the ratios of accepted votes per category +logAcceptedRatio :: + (HasCallStack, ConwayEraGov era) => GovActionId (EraCrypto era) -> ImpTestM era () +logAcceptedRatio aId = do + dRepRatio <- calculateDRepAcceptedRatio aId + committeeRatio <- calculateCommitteeAcceptedRatio aId + spoRatio <- calculatePoolAcceptedRatio aId + logEntry $ + unlines + [ "" + , "----- ACCEPTED RATIOS -----" + , "DRep accepted ratio:\t\t" <> show dRepRatio + , "Committee accepted ratio:\t" <> show committeeRatio + , "SPO accepted ratio:\t\t" <> show spoRatio + ] + +getRatifyEnvAndState :: ConwayEraGov era => ImpTestM era (RatifyEnv era, RatifyState era) +getRatifyEnvAndState = do + ratifyEnv <- getRatifyEnv + enactState <- getEnactState + let ratifyState = + RatifyState + { rsEnactState = enactState + , rsEnacted = mempty + , rsExpired = mempty + , rsDelayed = False + } + pure (ratifyEnv, ratifyState) + +-- | Checks whether the governance action has enough DRep votes to be accepted in the next +-- epoch. (Note that no other checks except DRep votes are used) +isDRepAccepted :: + (HasCallStack, ConwayEraGov era, ConwayEraPParams era) => + GovActionId (EraCrypto era) -> + ImpTestM era Bool +isDRepAccepted gaId = do + (ratifyEnv, ratifyState) <- getRatifyEnvAndState + action <- getGovActionState gaId + pure $ dRepAccepted ratifyEnv ratifyState action + +isSpoAccepted :: + (HasCallStack, ConwayEraGov era, ConwayEraPParams era) => + GovActionId (EraCrypto era) -> + ImpTestM era Bool +isSpoAccepted gaId = do + (ratifyEnv, ratifyState) <- getRatifyEnvAndState + action <- getGovActionState gaId + pure $ spoAccepted ratifyEnv ratifyState action + +isCommitteeAccepted :: + (HasCallStack, ConwayEraGov era, ConwayEraPParams era) => + GovActionId (EraCrypto era) -> + ImpTestM era Bool +isCommitteeAccepted gaId = do + (ratifyEnv, ratifyState) <- getRatifyEnvAndState + action <- getGovActionState gaId + pure $ committeeAccepted ratifyEnv ratifyState action + +-- | Logs the results of each check required to make the governance action pass +logRatificationChecks :: + (ConwayEraGov era, ConwayEraPParams era) => + GovActionId (EraCrypto era) -> + ImpTestM era () +logRatificationChecks gaId = do + gas@GovActionState {gasCommitteeVotes, gasDRepVotes} <- getGovActionState gaId + let govAction = gasAction gas + ens@EnactState {..} <- getEnactState + committee <- getsNES $ nesEsL . epochStateGovStateL . committeeGovStateL + ratEnv@RatifyEnv {reCurrentEpoch} <- getRatifyEnv + let ratSt = RatifyState ens mempty mempty False + curTreasury <- getsNES $ nesEsL . esAccountStateL . asTreasuryL + currentEpoch <- getsNES nesELL + let + members = foldMap' committeeMembers committee + committeeState = reCommitteeState ratEnv + curPParams <- getsNES $ nesEsL . epochStateGovStateL . curPParamsGovStateL + logEntry $ + unlines + [ "----- RATIFICATION CHECKS -----" + , "prevActionAsExpected:\t" <> show (prevActionAsExpected gas ensPrevGovActionIds) + , "validCommitteeTerm:\t" <> show (validCommitteeTerm govAction curPParams currentEpoch) + , "notDelayed:\t\t??" + , "withdrawalCanWithdraw:\t" <> show (withdrawalCanWithdraw govAction curTreasury) + , "committeeAccepted:\t" + <> show (committeeAccepted ratEnv ratSt gas) + <> " [ To Pass: " + <> show (committeeAcceptedRatio members gasCommitteeVotes committeeState currentEpoch) + <> " >= " + <> show (votingCommitteeThreshold reCurrentEpoch ratSt committeeState (gasAction gas)) + <> " ]" + , "spoAccepted:\t\t" + <> show (spoAccepted ratEnv ratSt gas) + <> " [ To Pass: " + <> show (spoAcceptedRatio ratEnv gas) + <> " >= " + <> show (votingStakePoolThreshold ratSt (gasAction gas)) + <> " ]" + , "dRepAccepted:\t\t" + <> show (dRepAccepted ratEnv ratSt gas) + <> " [ To Pass: " + <> show (dRepAcceptedRatio ratEnv gasDRepVotes (gasAction gas)) + <> " >= " + <> show (votingDRepThreshold ratSt (gasAction gas)) + <> " ]" + , "" + ] + +-- | Submits a transaction that registers a hot key for the given cold key. +-- Returns the hot key hash. +registerCommitteeHotKey :: + (ShelleyEraImp era, BabelEraTxCert era) => + Credential 'ColdCommitteeRole (EraCrypto era) -> + ImpTestM era (Credential 'HotCommitteeRole (EraCrypto era)) +registerCommitteeHotKey coldKey = do + hotKey <- KeyHashObj <$> freshKeyHash + submitTxAnn_ "Registering Committee Hot key" $ + mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton (AuthCommitteeHotKeyTxCert coldKey hotKey) + pure hotKey + +-- | Submits a transaction that resigns the cold key +resignCommitteeColdKey :: + (ShelleyEraImp era, BabelEraTxCert era) => + Credential 'ColdCommitteeRole (EraCrypto era) -> + StrictMaybe (Anchor (EraCrypto era)) -> + ImpTestM era () +resignCommitteeColdKey coldKey anchor = do + submitTxAnn_ "Resigning Committee Cold key" $ + mkBasicTx mkBasicTxBody + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton (ResignCommitteeColdTxCert coldKey anchor) + +electCommittee :: + forall era. + ( HasCallStack + , BabelEraImp era + ) => + StrictMaybe (GovPurposeId 'CommitteePurpose era) -> + Credential 'DRepRole (EraCrypto era) -> + Set.Set (Credential 'ColdCommitteeRole (EraCrypto era)) -> + Map.Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo -> + ImpTestM era (GovPurposeId 'CommitteePurpose era) +electCommittee prevGovId drep toRemove toAdd = impAnn "Electing committee" $ do + let + committeeAction = + UpdateCommittee + prevGovId + toRemove + toAdd + (1 %! 2) + gaidCommitteeProp <- submitGovAction committeeAction + submitYesVote_ (DRepVoter drep) gaidCommitteeProp + pure (GovPurposeId gaidCommitteeProp) + +electBasicCommittee :: + forall era. + ( HasCallStack + , BabelEraImp era + ) => + ImpTestM + era + ( Credential 'DRepRole (EraCrypto era) + , Credential 'HotCommitteeRole (EraCrypto era) + , GovPurposeId 'CommitteePurpose era + ) +electBasicCommittee = do + logEntry "Setting up a DRep" + (drep, _, _) <- setupSingleDRep 1_000_000 + + logEntry "Registering committee member" + coldCommitteeC <- KeyHashObj <$> freshKeyHash + let + committeeAction = + UpdateCommittee + SNothing + mempty + (Map.singleton coldCommitteeC 20) + (1 %! 2) + (gaidCommitteeProp NE.:| _) <- + submitGovActions + [ committeeAction + , UpdateCommittee SNothing mempty mempty (1 %! 10) + ] + submitYesVote_ (DRepVoter drep) gaidCommitteeProp + passEpoch + passEpoch + hotCommitteeC <- registerCommitteeHotKey coldCommitteeC + pure (drep, hotCommitteeC, GovPurposeId gaidCommitteeProp) + +logCurPParams :: (EraGov era, ToExpr (PParamsHKD Identity era)) => ImpTestM era () +logCurPParams = do + pp <- getsNES $ nesEsL . curPParamsEpochStateL + logEntry $ + unlines + [ "" + , "----- Current PParams -----" + , showExpr pp + , "---------------------------" + , "" + ] + +proposalsShowDebug :: Era era => Proposals era -> Bool -> String +proposalsShowDebug ps showRoots = + unlines $ + [ "" + , "----- Proposals -----" + , "Size" + , show $ proposalsSize ps + , "OMap" + , show $ proposalsIds ps + , "" + , "Roots" + , "> PParamUpdate" + , show $ ps ^. pRootsL . grPParamUpdateL + , "> HardFork" + , show $ ps ^. pRootsL . grHardForkL + , "> Committee" + , show $ ps ^. pRootsL . grCommitteeL + , "> Constitution" + , show $ ps ^. pRootsL . grConstitutionL + ] + <> ( if showRoots + then + [ "Hierarchy" + , ">> PParamUpdate" + , show $ ps ^. pGraphL . grPParamUpdateL . pGraphNodesL + , ">> HardFork" + , show $ ps ^. pGraphL . grHardForkL . pGraphNodesL + , ">> Committee" + , show $ ps ^. pGraphL . grCommitteeL . pGraphNodesL + , ">> Constitution" + , show $ ps ^. pGraphL . grConstitutionL . pGraphNodesL + ] + else mempty + ) + <> ["----- Proposals End -----"] + +submitConstitutionGovAction :: + (ShelleyEraImp era, BabelEraTxBody era) => + StrictMaybe (GovActionId (EraCrypto era)) -> + ImpTestM era (GovActionId (EraCrypto era)) +submitConstitutionGovAction gid = do + constitutionHash <- freshSafeHash + let constitutionAction = + NewConstitution + (GovPurposeId <$> gid) + ( Constitution + ( Anchor + (fromJust $ textToUrl 64 "constitution.dummy.0") + constitutionHash + ) + SNothing + ) + submitGovAction constitutionAction + +getProposalsForest :: + ConwayEraGov era => + ImpTestM era (Forest (StrictMaybe (GovActionId (EraCrypto era)))) +getProposalsForest = do + ps <- getProposals + pure + [ Node (mkRoot grPParamUpdateL ps) $ mkForest grPParamUpdateL ps + , Node (mkRoot grHardForkL ps) $ mkForest grHardForkL ps + , Node (mkRoot grCommitteeL ps) $ mkForest grCommitteeL ps + , Node (mkRoot grConstitutionL ps) $ mkForest grConstitutionL ps + ] + where + mkRoot :: + Lens' (GovRelation PRoot era) (PRoot (GovPurposeId p era)) -> + Proposals era -> + StrictMaybe (GovActionId (EraCrypto era)) + mkRoot rootL ps = fmap unGovPurposeId $ ps ^. pRootsL . rootL . prRootL + mkForest :: + (forall f. Lens' (GovRelation f era) (f (GovPurposeId p era))) -> + Proposals era -> + Forest (StrictMaybe (GovActionId (EraCrypto era))) + mkForest forestL ps = + let h = ps ^. pGraphL . forestL . pGraphNodesL + s = toList $ proposalsIds ps + getOrderedChildren cs = filter (`Set.member` Set.map unGovPurposeId cs) s + go c = (SJust c, getOrderedChildren $ h Map.! GovPurposeId c ^. peChildrenL) + in unfoldForest go (getOrderedChildren $ ps ^. pRootsL . forestL . prChildrenL) + +submitGovActionTree :: + (StrictMaybe (GovActionId (EraCrypto era)) -> ImpTestM era (GovActionId (EraCrypto era))) -> + StrictMaybe (GovActionId (EraCrypto era)) -> + Tree () -> + ImpTestM era (Tree (GovActionId (EraCrypto era))) +submitGovActionTree submitAction p tree = + unfoldTreeM go $ fmap (const p) tree + where + go (Node parent children) = do + n <- submitAction parent + pure (n, fmap (\(Node _child subtree) -> Node (SJust n) subtree) children) + +submitGovActionForest :: + (StrictMaybe (GovActionId (EraCrypto era)) -> ImpTestM era (GovActionId (EraCrypto era))) -> + StrictMaybe (GovActionId (EraCrypto era)) -> + Forest () -> + ImpTestM era (Forest (GovActionId (EraCrypto era))) +submitGovActionForest submitAction p forest = + unfoldForestM go $ fmap (fmap $ const p) forest + where + go (Node parent children) = do + n <- submitAction parent + pure (n, fmap (\(Node _child subtree) -> Node (SJust n) subtree) children) + +enactConstitution :: + forall era. + ( BabelEraImp era + , HasCallStack + ) => + StrictMaybe (GovPurposeId 'ConstitutionPurpose era) -> + Constitution era -> + Credential 'DRepRole (EraCrypto era) -> + Credential 'HotCommitteeRole (EraCrypto era) -> + ImpTestM era (GovActionId (EraCrypto era)) +enactConstitution prevGovId constitution dRep committeeMember = impAnn "Enacting constitution" $ do + let action = NewConstitution prevGovId constitution + govId <- submitGovAction action + submitYesVote_ (DRepVoter dRep) govId + submitYesVote_ (CommitteeVoter committeeMember) govId + logRatificationChecks govId + passNEpochs 2 + enactedConstitution <- + getsNES $ + nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . constitutionGovStateL + enactedConstitution `shouldBe` constitution + pure govId + +-- | Asserts that the URL of the current constitution is equal to the given +-- string +constitutionShouldBe :: (HasCallStack, ConwayEraGov era) => String -> ImpTestM era () +constitutionShouldBe cUrl = do + Constitution {constitutionAnchor = Anchor {anchorUrl}} <- + getsNES $ + nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . constitutionGovStateL + anchorUrl `shouldBe` fromJust (textToUrl 64 $ T.pack cUrl) + +expectNumDormantEpochs :: HasCallStack => EpochNo -> ImpTestM era () +expectNumDormantEpochs expected = do + nd <- + getsNES $ + nesEsL . esLStateL . lsCertStateL . certVStateL . vsNumDormantEpochsL + nd `shouldBeExpr` expected + +submitConstitution :: + forall era. + BabelEraImp era => + StrictMaybe (GovPurposeId 'ConstitutionPurpose era) -> + ImpTestM era (GovActionId (EraCrypto era), Constitution era) +submitConstitution prevGovId = do + constitution <- arbitrary + let constitutionAction = + NewConstitution + prevGovId + constitution + govActionId <- submitGovAction constitutionAction + pure (govActionId, constitution) + +expectExtraDRepExpiry :: + (HasCallStack, EraGov era, ConwayEraPParams era) => + Credential 'DRepRole (EraCrypto era) -> + EpochNo -> + ImpTestM era () +expectExtraDRepExpiry drep expected = do + drepActivity <- + getsNES $ + nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . curPParamsGovStateL . ppDRepActivityL + dsMap <- + getsNES $ + nesEsL . esLStateL . lsCertStateL . certVStateL . vsDRepsL + let ds = Map.lookup drep dsMap + (^. drepExpiryL) + <$> ds + `shouldBe` Just (addEpochInterval expected drepActivity) + +currentProposalsShouldContain :: + ( HasCallStack + , ConwayEraGov era + ) => + GovActionId (EraCrypto era) -> + ImpTestM era () +currentProposalsShouldContain gai = + currentProposalIds >>= flip shouldContain [gai] . toList + +expectCurrentProposals :: (HasCallStack, ConwayEraGov era) => ImpTestM era () +expectCurrentProposals = do + props <- currentProposalIds + assertBool "Expected proposals in current gov state" (not (SSeq.null props)) + +expectNoCurrentProposals :: (HasCallStack, BabelEraImp era) => ImpTestM era () +expectNoCurrentProposals = do + proposals <- getProposals + case proposalsActions proposals of + Empty -> pure () + xs -> assertFailure $ "Expected no active proposals, but got:\n" <> show (toExpr xs) + +expectPulserProposals :: (HasCallStack, ConwayEraGov era) => ImpTestM era () +expectPulserProposals = do + props <- lastEpochProposals + assertBool "Expected proposals in the pulser" (not (SSeq.null props)) + +expectNoPulserProposals :: (HasCallStack, ConwayEraGov era) => ImpTestM era () +expectNoPulserProposals = do + props <- lastEpochProposals + assertBool "Expected no proposals in the pulser" (SSeq.null props) + +currentProposalIds :: + ConwayEraGov era => ImpTestM era (SSeq.StrictSeq (GovActionId (EraCrypto era))) +currentProposalIds = + proposalsIds + <$> getsNES (nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . proposalsGovStateL) + +lastEpochProposals :: + forall era. + ConwayEraGov era => + ImpTestM era (SSeq.StrictSeq (GovActionId (EraCrypto era))) +lastEpochProposals = + fmap (gasId @era) . psProposals + <$> getsNES + ( nesEsL + . esLStateL + . lsUTxOStateL + . utxosGovStateL + . drepPulsingStateGovStateL + . pulsingStateSnapshotL + ) + +pulsingStateSnapshotL :: Lens' (DRepPulsingState era) (PulsingSnapshot era) +pulsingStateSnapshotL = lens getter setter + where + getter (DRComplete x _) = x + getter state = fst (finishDRepPulser state) + setter (DRComplete _ y) snap = DRComplete snap y + setter state snap = DRComplete snap $ snd $ finishDRepPulser state + +-- | A legal ProtVer that differs in the minor Version +minorFollow :: ProtVer -> ProtVer +minorFollow (ProtVer x y) = ProtVer x (y + 1) + +-- | A legal ProtVer that moves to the next major Version +majorFollow :: ProtVer -> ProtVer +majorFollow pv@(ProtVer x _) = case succVersion x of + Just x' -> ProtVer x' 0 + Nothing -> error ("The last major version can't be incremented. " ++ show pv) + +-- | An illegal ProtVer that skips 3 minor versions +cantFollow :: ProtVer -> ProtVer +cantFollow (ProtVer x y) = ProtVer x (y + 3) + +whenPostBootstrap :: EraGov era => ImpTestM era () -> ImpTestM era () +whenPostBootstrap a = do + pv <- getProtVer + unless (HardForks.bootstrapPhase pv) a diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Proposals.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Proposals.hs new file mode 100644 index 00000000000..1b4ad210008 --- /dev/null +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Proposals.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Cardano.Ledger.Babel.Proposals where + +import Cardano.Ledger.Babel +import Cardano.Ledger.Conway.Governance ( + GovActionState (..), + Proposals, + Vote, + Voter, + proposalsActionsMap, + proposalsAddAction, + proposalsAddVote, + proposalsApplyEnactment, + proposalsIds, + proposalsRemoveWithDescendants, + proposalsSize, + toGovRelationTreeEither, + ) +import Control.DeepSeq (force) +import Control.Exception (AssertionFailed (..), evaluate) +import Data.Either (isRight) +import Data.Foldable (foldl', toList) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Sequence (fromList) +import qualified Data.Sequence as Seq +import qualified Data.Sequence.Strict as SSeq +import qualified Data.Set as Set +import Test.Cardano.Ledger.Babel.Arbitrary ( + ProposalsForEnactment (..), + ProposalsNewActions (..), + ) +import Test.Cardano.Ledger.Common + +spec :: Spec +spec = do + describe "Proposals" $ do + describe "Construction" $ do + prop "Adding new nodes keeps Proposals consistent" $ + \(ProposalsNewActions ps actions :: ProposalsNewActions Babel) -> + let ps' = + foldl' + (\p action -> fromMaybe (error "Unable to add action") $ proposalsAddAction action p) + ps + actions + actionsMap = foldl' (\accum gas -> Map.insert (gasId gas) gas accum) Map.empty actions + in actionsMap `shouldBe` (actionsMap `Map.intersection` proposalsActionsMap ps') + describe "Removal" $ do + prop "Removing leaf nodes keeps Proposals consistent" $ + \(ps :: Proposals Babel) -> do + let gais = Set.fromList $ toList $ SSeq.takeLast 4 $ proposalsIds ps + ps' = fst $ proposalsRemoveWithDescendants gais ps + proposalsSize ps' `shouldBe` proposalsSize ps - Set.size gais + prop "Removing root nodes keeps Proposals consistent" $ + \(ps :: Proposals Babel) -> do + let gais = Set.fromList $ toList $ SSeq.take 4 $ proposalsIds ps + ps' = fst $ proposalsRemoveWithDescendants gais ps + proposalsSize ps' `shouldSatisfy` (<= proposalsSize ps) + prop "Removing non-member nodes throws an AssertionFailure" $ + \(ProposalsNewActions ps actions :: ProposalsNewActions Babel) -> + (evaluate . force) (proposalsRemoveWithDescendants (Set.fromList $ gasId <$> actions) ps) + `shouldThrow` \AssertionFailed {} -> True + describe "Enactment" $ do + prop "Adding votes preserves consistency" $ + \(ProposalsForEnactment ps gass _ :: ProposalsForEnactment Babel, voter :: Voter era, vote :: Vote) -> do + case gass of + gas Seq.:<| _gass -> isRight . toGovRelationTreeEither $ proposalsAddVote voter vote (gasId gas) ps + _ -> True + prop "Enacting exhaustive lineages reduces Proposals to their roots" $ + \(ProposalsForEnactment ps gass _ :: ProposalsForEnactment Babel) -> do + let toEnact = Set.fromList $ toList gass + (_ps', enactedRemoved, expiredRemoved) = proposalsApplyEnactment gass Set.empty ps + expiredRemoved `shouldSatisfy` Map.null + toEnact `shouldSatisfy` (`Set.isSubsetOf` Set.fromList (Map.elems enactedRemoved)) + prop "Enacting non-member nodes throws an AssertionFailure" $ + \(ProposalsNewActions ps actions :: ProposalsNewActions Babel) -> + (evaluate . force) (proposalsApplyEnactment (fromList actions) Set.empty ps) + `shouldThrow` \AssertionFailed {} -> True + prop "Expiring compliments of exhaustive lineages keeps proposals consistent" $ + \(ProposalsForEnactment ps _ gais :: ProposalsForEnactment Babel) -> do + let (_ps', enactedRemoved, expiredRemoved) = proposalsApplyEnactment Seq.Empty gais ps + enactedRemoved `shouldSatisfy` Map.null + gais `shouldSatisfy` (`Set.isSubsetOf` Map.keysSet expiredRemoved) + prop "Expiring non-member nodes throws an AssertionFailure" $ + \(ProposalsNewActions ps actions :: ProposalsNewActions Babel) -> + (evaluate . force) (proposalsApplyEnactment Seq.Empty (Set.fromList $ gasId <$> actions) ps) + `shouldThrow` \AssertionFailed {} -> True + prop "Enacting and expiring exhaustive lineages reduces Proposals to their roots" $ + \(ProposalsForEnactment ps toEnact toExpire :: ProposalsForEnactment Babel) -> do + let (ps', enactedRemoved, expiredRemoved) = proposalsApplyEnactment toEnact toExpire ps + Set.fromList (toList toEnact) + `shouldSatisfy` (`Set.isSubsetOf` Set.fromList (Map.elems enactedRemoved)) + Set.fromList (toList toExpire) `shouldSatisfy` (`Set.isSubsetOf` Map.keysSet expiredRemoved) + proposalsSize ps' `shouldBe` 0 diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/TreeDiff.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/TreeDiff.hs new file mode 100644 index 00000000000..75399078504 --- /dev/null +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/TreeDiff.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Cardano.Ledger.Babel.TreeDiff ( + module Test.Cardano.Ledger.Babbage.TreeDiff, +) where + +import Cardano.Ledger.Alonzo.Plutus.Context (ContextError) +import Cardano.Ledger.Babel (BabelEra) +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Rules +import Cardano.Ledger.Babel.Scripts +import Cardano.Ledger.Babel.TxBody +import Cardano.Ledger.Babel.TxCert +import Cardano.Ledger.Babel.TxInfo (BabelContextError) +import Cardano.Ledger.BaseTypes +import Control.State.Transition.Extended (STS (..)) +import Test.Cardano.Data.TreeDiff () +import Test.Cardano.Ledger.Babbage.TreeDiff +import Test.Cardano.Ledger.Conway.TreeDiff () + +-- Scripts +instance ToExpr (PlutusScript (BabelEra c)) + +instance ToExpr (BabelPlutusPurpose AsIx era) + +instance + ( Era era + , ToExpr (TxCert era) + , ToExpr (PParamsHKD StrictMaybe era) + ) => + ToExpr (BabelPlutusPurpose AsItem era) + +-- PlutusContext +instance + ( Era era + , ToExpr (PParamsHKD StrictMaybe era) + , ToExpr (TxCert era) + , ToExpr (PlutusPurpose AsIx era) + , ToExpr (PlutusPurpose AsItem era) + ) => + ToExpr (BabelContextError era) + +-- TxCert + +instance ToExpr (BabelDelegCert c) + +instance ToExpr (BabelGovCert c) + +-- Rules +instance + ( ToExpr (PlutusPurpose AsItem era) + , ToExpr (ContextError era) + , ToExpr (TxCert era) + ) => + ToExpr (BabelUtxosPredFailure era) + +-- TxBody +instance + (EraPParams era, ToExpr (PParamsHKD StrictMaybe era), ToExpr (TxOut era)) => + ToExpr (BabelTxBodyRaw era) + +instance + (EraPParams era, ToExpr (PParamsHKD StrictMaybe era), ToExpr (TxOut era)) => + ToExpr (BabelTxBody era) + +-- Rules/Ledger +instance + ( ToExpr (PredicateFailure (EraRule "UTXOW" era)) + , ToExpr (PredicateFailure (EraRule "GOV" era)) + , ToExpr (PredicateFailure (EraRule "CERTS" era)) + ) => + ToExpr (BabelLedgerPredFailure era) + +instance + ( ToExpr (Event (EraRule "CERTS" era)) + , ToExpr (Event (EraRule "UTXOW" era)) + , ToExpr (Event (EraRule "GOV" era)) + ) => + ToExpr (BabelLedgerEvent era) + +instance ToExpr (TxOut era) => ToExpr (BabelUtxosEvent era) + +instance + ( ToExpr (Value era) + , ToExpr (TxOut era) + , ToExpr (PredicateFailure (EraRule "UTXOS" era)) + ) => + ToExpr (BabelUtxoPredFailure era) + +instance + ( Era era + , ToExpr (PredicateFailure (EraRule "UTXO" era)) + , ToExpr (PlutusPurpose AsIx era) + , ToExpr (PlutusPurpose AsItem era) + , ToExpr (TxCert era) + ) => + ToExpr (BabelUtxowPredFailure era) diff --git a/eras/babel/test-suite/.ghcid b/eras/babel/test-suite/.ghcid new file mode 100644 index 00000000000..6f24637ea18 --- /dev/null +++ b/eras/babel/test-suite/.ghcid @@ -0,0 +1 @@ +--command="cabal repl --repl-options='-isrc -fwarn-unused-binds -fwarn-unused-imports -fno-code -fobject-code -g2 -fno-break-on-exception -fno-break-on-error -ferror-spans -j -Wno-unused-packages'" --clear --no-height-limit --reverse-errors --reload=../../../ --outputfile=/tmp/cardano-ledger-babel-test-ghcid.txt \ No newline at end of file diff --git a/eras/babel/test-suite/CHANGELOG.md b/eras/babel/test-suite/CHANGELOG.md new file mode 100644 index 00000000000..db817db75e6 --- /dev/null +++ b/eras/babel/test-suite/CHANGELOG.md @@ -0,0 +1,46 @@ +# Version history for `cardano-ledger-conway-test` + +## 1.2.1.5 + +* + +## 1.2.1.4 + +* + +## 1.2.1.3 + +* + +## 1.2.1.2 + +* Move `cddl-files` to `cardano-ledger-alonzo` + +## 1.2.1.1 + +* Update CDDL files to reflect the change in header structure in + cardano-protocol-praos. + +## 1.2.1.0 + +* Add `Crypto c` constraint to `exampleBabelGenesis` + +## 1.2.0.5 + +* + +## 1.2.0.4 + +* + +## 1.2.0.3 + +* + +## 1.2.0.2 + +* + +## 1.2.0.1 + +* diff --git a/eras/babel/test-suite/cardano-ledger-babel-test.cabal b/eras/babel/test-suite/cardano-ledger-babel-test.cabal new file mode 100644 index 00000000000..22dfb00442f --- /dev/null +++ b/eras/babel/test-suite/cardano-ledger-babel-test.cabal @@ -0,0 +1,108 @@ +cabal-version: 3.0 +name: cardano-ledger-babel-test +version: 1.2.1.4 +license: Apache-2.0 +maintainer: operations@iohk.io +author: IOHK +bug-reports: https://github.com/intersectmbo/cardano-ledger/issues +synopsis: Tests for Cardano ledger Babel era +description: This package builds upon the Alonzo ledger +category: Network +build-type: Simple +data-files: golden/*.cbor + +source-repository head + type: git + location: https://github.com/intersectmbo/cardano-ledger + subdir: eras/babel/test-suite + +library + exposed-modules: + Test.Cardano.Ledger.Babel.Examples + Test.Cardano.Ledger.Babel.Examples.Combinators + Test.Cardano.Ledger.Babel.Examples.Consensus + Test.Cardano.Ledger.Babel.Examples.Prototype + Test.Cardano.Ledger.Babel.Rules.Chain + Test.Cardano.Ledger.Babel.RulesTests + Test.Cardano.Ledger.Babel.Translation.TranslatableGen + Test.Cardano.Ledger.Babel.Utils + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -Wunused-packages + + build-depends: + base >=4.14 && <5, + cardano-data, + cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib} >=1.6, + cardano-ledger-alonzo-test, + cardano-ledger-babbage >=1.3 && <1.9, + cardano-ledger-babbage-test >=1.1.1, + cardano-ledger-binary >=1.0, + cardano-ledger-babel:{cardano-ledger-babel, testlib} >=1.13 && <1.15, + cardano-ledger-core:{cardano-ledger-core, testlib} >=1.11, + cardano-ledger-allegra >=1.2, + cardano-ledger-mary >=1.4, + cardano-ledger-shelley-ma-test >=1.1, + cardano-ledger-shelley-test >=1.1, + cardano-ledger-shelley:{cardano-ledger-shelley, testlib} >=1.6, + cardano-strict-containers, + cardano-slotting, + containers, + data-default-class, + small-steps:{small-steps, testlib} >=1.1, + plutus-ledger-api, + microlens, + tasty-hunit, + cardano-protocol-tpraos:{cardano-protocol-tpraos, testlib}, + cardano-crypto-class, + tasty-quickcheck, + tasty, + mtl, + transformers, + cardano-data:{testlib}, + cardano-ledger-mary:{testlib}, + nothunks, + deepseq, + + +executable gen-golden + main-is: GenerateGoldenFileMain.hs + hs-source-dirs: test + other-modules: Paths_cardano_ledger_babel_test + default-language: Haskell2010 + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -Wunused-packages + + build-depends: + base, + cardano-ledger-babel:{cardano-ledger-babel, testlib}, + cardano-ledger-babel-test, + cardano-ledger-alonzo-test + +test-suite cardano-ledger-babel-test + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: test + other-modules: + Test.Cardano.Ledger.Babel.TxInfo + Paths_cardano_ledger_babel_test + + default-language: Haskell2010 + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + -Wunused-packages -threaded -rtsopts -with-rtsopts=-N + "-with-rtsopts=-K4m -M250m" + + build-depends: + base, + cardano-ledger-babbage-test, + cardano-ledger-babel, + tasty, + cardano-ledger-babel-test, \ No newline at end of file diff --git a/eras/babel/test-suite/golden/translations.cbor b/eras/babel/test-suite/golden/translations.cbor new file mode 100644 index 0000000000000000000000000000000000000000..b7854d16260f07b59cb4fc3cc0f904a6f231da0b GIT binary patch literal 68526 zcma%jcOcdO_y4s=W{7*QoxQJpv+uR8z3)ZVb?tety=RD)oslgfB$*XTMUrS)DI#Ts zNRjxxF7^KYKL1pI)$Mg&_dL$yd7fuIpSRL8m$@MzGL;qxh*l9v&q@aYk)Y{;4^4s) z5H2;A13J!~2=x=+xW)J}q#g<)J0Dy1C>{j-BgaoLDIWNfi36NS!w9^=KM4U*lOf6y ziEl8!h@Q>t%^-n-s31R4=Rw3bph`(sT;2(oH$c<-Pm-Vg1Og>O5xGS_9*=m{L7^H;3IIdOX&|7>dGWvp4mA#3`Y*|t($mM_M9EJttC@(BVA6mi^ia|#Vs~e?i_btQ z*X?az+&lsbNP<;npDGbwk-D@xa)_Q}L|?>u_e>|0ex|LZ26re4VUqAGg>XG}J5tYH zH~}GnNgj%W7@Vo!Y*V5Ce{t{`EpVUNAyVO6E{CEV5NZgh=-LZ#{aL_3bSwm9?ch$@ zmWbh{FtWrN`#LZSZ@DI#MJqbZE$_w8af_X}QEtdGnRgWi0R^p_SAj5anM;E0mhD{q z##6X%s+JS?22Gqo*zSE+ZcGcFs(mc&lRu%|9!@oxa^_sj!p&FRx8_v0s5$FA|Ur$R`C8_ie9a6jTjqoE`$^VJ;)`veSU z^fNvieN%T+x&B+-qk)!l+LEKswI=p`CRdz1%XK3qLSyXfX3bRGeB7Z---?;`w8}1&_$aIWYW*AV8Fp6`ne*x(9Bt+Nref zuBCj;bH;YynWIH**?_k#z#~l%vwP;yEm&B>l@m(_YDzw(R7o18^V0?E-%Au)>i}n0 z^i!$?c!Z682PtqhD%yN_-DcCW-Z^M*=-8!qtikt+zPNJ>zuecnIZCmfQW@?V&B|Nh+*9{nMcK73s=$>53m&yPQEu|F%Hrp!60H-Uc@?92y%P3XqYNigP!?w*nR9dGwjaltqAvWw?f4!DNMSgH zXdRym=;yb-fqQ{x*k9~^;UP<=^>vg@2E}WW2|Ts*BHUbC{q*7{@)}`o=EfqXq2a5p zBeEQ#jP?alFL3V304Tsc(Ym_lge9Eet1fQzg)ZV zSYs0Ol+^95MAgXi08HIP(63bx{v^X^^Nm{NgxCE+Do=Xt?bCBr!HeBzmU+%}J;Pb1 zKtSCE2Sl9AMa4#{-fS&pO}8zxD&!c8Gaq)vk5_S*E#71rD-jOrVEW#|aGqODlG7jw z^SaTpRr2-CieYp7QvfH{ESI$VpzRK@3Lu`5j!gAiuFX4>p9V%ZMvs;1et5Ac>vw+i zWln`bO4T>2gL>4WO*E8|wL~I(X|CP+r*e8%(pJwE@m#dxjetmq>I0$ZK`29k)~QMN zaB>VMlifvVD^7cGC`IX9E&?*VEbGJA9;}X1?~r~~p``@1*Jf0vCG)yv(=EuvZSCn@ z+<-qbJkuy;L0wu*Cc_1#?1Qk|ZN8WxO(X$!pwf6$sg}%mOeqqh{wRJtqLhLRQ81x- zFdkW|4by7>a#FjVy}kVKqE>G1mSSZ%q;lV99-0NInf0eUOx7z8ExO zpEw_p|1iMEC&9^9qhh{7O9raV`LocZ_(LX!>xnF@SjXL$xa=42?YV2Q^ADRqRwg&h zH4>kG%u9u`)_3!5oc60cBtT0OutZXO?Qt{tjgXzBCaO7O56^Y~u*|gGj&ls$E04Yz z5KJK;iKj3iP;&)_`x5MnL((=K9={pEFcS zZ&?w3+Pn7<7jir@{xE`&>gteyKtdz{%+ubaGT$y$Y~lkq^q(`>e;N%nPFj?$Xd1Q* z>kdK4M?gSs@*rY9;l*;l>(;z{fjRPp05Y~Ks~Qy*g7W}(l6~J?GT?Pe>+c@^ux*|R zh9!3{2^)`U#L>2so^H&@hX5uRBrBeI5>G;0%7vffQ{J5F*ioQ97NgDbv*dI;M6qIC7y>%~)|%*aGUu(j z*vGM!XzQ2Uc7(6Y>q@EXU(c@!$ZK6jYs8!h3TpE&}aLDNqVgPbWfeiP|z57bI8`uixMVp`xh@MesBK) zO(9+1v4%Q}S-E7mbQ)qflPnu1X|Dggv*?j6ItaeNa6F5R{LC2iW*PeKb_E7vVw4{0 z!bjoiHKFgVj&xm@&5rj{zUwj6k_<)Gc7muq48rt_PB4D)1RJJ7{px=Ze0#*@4>E#2qlFc%l; zZ4gLKsbtxzg>qVsmuy0CZ!nw}b-`Bq(j5Dr0@ail>~Te(u*-8Kgu~mKu8;3q z@%ZananTOq^SflFxdDbU(x=+?q7ARhnN@3U8GMH%XMv5M-~X5QF|%!G4ofHkrOWh? za(IJr9k!bgdGXt6+UEF=e|?`c>8~OH#MValQ;oGBKx|R(4C{Ud*q05XZNEL$BH3e+ zw)*S)@NhK)PsE?88g^X~oqu43@DX(-IeJkmp-gtgE^b?`1^9E40+r)UKz65ReUDB$04X=fk2G8JC^i!^ZS}1TvE{ zqi!&NKUcjaQJ6clLe1T}+gn{O?PhB>sN6&{xv%cpsXEjYl~w#)DpX1@&W_~}|sZ)tT=|@}>#ZpnWr0FFZ;^z9l`lz*ib)8GatKj}N z+r5jLn!S#wz2WWr%ksN2Rxpu-$)^wyzTfgNsl!TcHa*LT0ih$-ppo}T)=`DAMe99q zR-3nw>Ve9S7tr#|^>s5Eh{D_=+i8^7Ed~OIgtODzRKP4>e)4p?O^`YeJN^^_h)JD! z!Y|)R6u+VM6$*ca{~^kr4fHGz6Q@r~ee(~`{zi^iTrVqE<$uAGYiPJwBXQ5NT- zIzqSn;RR2_Uu#AI6rc18z?!vgArkYJhTobEWsTSJXYf7tcpmPX$EPcp9Z6em)gA=_ zo&MxXG!Ay!Lwu5I<611v^>!XBX*j1&%E-_0aK7e!5B%4xyQ*6*WBXBz?tSj2C);VA z_`x4>w-Wnxek3;l#>qLl;CIOomcW{!E)Ch^=d9mjM(S1BjR(<1KPB>-G^cbTmc|^) zF+8NtcGKMg2d7a7AAIGikC9V2o^5bcRKp@Zt$91RK7)D=>(EHJ^l<#28N2Q`05jT} zp7jW+I&GQZ49n@Rsv;1y>{+)|QWk_3_oX{Op7wx%t}U1x?)9xvm4F*Rt+%1KTLYhV z7-`77HGfDDmJ$6zW`3Z^ckS|{pFR4q57a2}?}YSb(qFxa!Q~#<8cJ9IW(X?Rh_7-^ zNf6_EhZcQak@xGiynM3$*dAYPN=P-QgYR;c8~S~@p;7Roiv#pj$;MMk(17fSxJrVJ1#Y|e&dqQCz`qOg7=f56$+gV#LJrC89(hBXX_)tvq&wRkC!Xl8y9`_Ii6WG z35=ho`Oj#5Ina+WYa?f@ z8A(Bu066>87mot^Jw_Q`nqi@>7phl{Hr1KR3vWQ<@FN;m9y?^wu|@;Nc#v&7-pTx= z1Q^rQ^=wE_ovC-D-uoM3EP65fQhBuF@dC@QrdNe4Fi=qrKG9clg6H<=CQ@AujjaZ0 z4)AsQFJFAP=nVCIPhI0%*f|OK2RCw~o6}_Y^P#z<<+{EX9 ztiVVTi6U2Z^$ags!Gzc-+wKRwpz60NG--S6gP1lDwV(wGxdfujAFCh?@622+j)wo^ zwC{wmVY=bs+9RI81wNyB^DWI!rXx3US|Om35=Y`1le~~K*wt+@>*+Jgsr!-;IdfkO z&V=?B+wv`3SZ$o4bQyhdjlUpO`IdI7`K?+}w~v0Nn6PxEWgcLSg~iUQ^U$$}0lQm} zdLy5GX zx^W<}`@mLy4;`v#YW*G0GJ& z8-1mKK}C4iI5n<#R$(~%w(?7-1>;UXmgMNm{b^QWXH$=Z-F1yXf7B1Euol3q&ef9{ zSxLFHEKMeBC+*I5ki3G1>yn)qE70o0@YX(c82kL7b0fs(j^>0m!xsZHdn<>*%cEyI z%T#?29=Aa8e4j5ieCOu{cv?u;0jK-6+`i&W`HU~{)z|=MUyXrh__xoN#8-XJT^vQ}bi^ zWTwdMr!?pI1Gg5a5ZcsC{zoJ|hEwYJ!})?43n)ucP-ge)as7%p7j`8|?B|fo3>#wG zLk8N|_vM%xI&_nnOBF&9l6v26c=mj1b&JCXy8Adh?l`f3Q^YEWbwF<5|8o=mrcuVk zyO&L_Uj6nlM|f$GcdjYC1Psqi$<9p&%wN%X{|wYB@@%2lfN^O-!03XXW!&xXs)}*r zcr>f#lm-MehMOR6AXqrF+2yF1f^WN)Q}Bg3gQsVsv90#q5gpA%6ri`2JiY^G*5VeE zK97< z&IjJ=O|{nnlHTa)Q!jml9~P2g)XTi4TKj51iGo!5{vJpui)O7LF6aj^iu_}SHOYRm zIUV?cCSx|JxIwuT>Ww?*Ya=2Vc1T-7SB-$Jb}O{u>Vdt|$EryBvt_ntHec(S8Z0;O z`W$@z|7iQu?n-V35vlv9Q9dB|Ph(I(?w`hxfZRXL*Z{eInqUEP|1>@UA*Aj-{wY5La{m;DNX`-S6|ASddW!r(0)5Be7r|0`b)H>1(Jx9T zAbS0N4ZGMMkFMZsihf2&oGZADzDtsRAHz|{9b|B}{KNzhh}uk8`rLcTl)Sa|io zXP+|L0XQ2fVGQHKy>D6;qZO#0ZwD>k$cQYZoA^ z0hp7=l8(kD(xt$#q=GLV`7ZGkFyla!4IXHz5~m};2V_f#46i1FKtpzb)XbeaCzzabPQ{e=3nx!&aE^ILI{du<8GYJy~1$FVR*(s z!qaR&)j9P(8fUxZ*$bG=nwuhMga+^Y-DxEQ7d)=s(SmOI9oPMa+OD3e#}(IamF%?V z$^ig{F3E7`CRWe@0RNcGw3MN7OfIF8oSDZkoUfwH+NR&lZ%L(E?pG|F|M4vAy{7-Y z5VUbx6>m9)H?yF#FOOE7=iUvU$L)B56!m>o5gq;4rSkTV2ZU%znJ)6**6QsRq>q4yNwNnB~bhnwOta)4X@;TL4!ddsO6( zgNjh%2QJK|J5%2?2Fi0_-UPujx+uV2#%FJT?m{rf0iS8y*%8Ty&v90NyJKO0($sx8 z*=AmLY9+}3o|##>mONDEyPbf%{GE@7`MOtTP{bwyD~7YHjp}f7vR_?Ndn#~lS@m{R z+<0yVssV5rRO0W0fJ2a<-6u4;NZy^FE7lLb5m$up9_o*bXdxGEL%`ykwGvj78gHL? zGu<7f`nf?ra6rE7L1C4NfqkkY0MhQJN&Dkc0}cS>pK951Q=t#nEee-|7WOQs7|VaK zLk*x(oMYNN)`yUzznq*TVKf?TlK|!EbqieFvdJG|W8;|Pn1oz5v-tM<5Hctc7(Z=) zcOycU;jxtOJgB&B9mXYTaBef@c8m-?X*b?pjDOq{;Ur^}OdsDep(AcF60yu2S+8xB zHuJKd%g8!r7l3SLi#UzV4j!r{Jky!sn-P~3!Zad9PH zvTYQKvy$XitV+6@*U8qN3)te7v(vh~;t>GQpW17$T2=XOQ*-L^P0|BHrViUhvl0iW zKVA4n4e+=}I0Z|pehMqO8M6SJDdW+UhMiJ#V@jNVNnnCX2*!(jBR~ufks?cZk3jy9 zkBl%TZscEoy*w*3_bie5&AH4Kqf+**193L$d6B@^zD5p|8K$Q)S5AlX4^cP9JCRvk z(rIS%Zsr6)Dm;Tm$fYoG`u)#GC_Gu6dalObW^w@a21Bt9}n zLp?eRg0eG(PhvP#T}zp=uQ8IDYol4n7~@%H3V z)Ph>X=YJd~0nh(-$nv-6e>`L%J(EO6aR~EoU-QRF1OW3-Y!J=-;|KzH{>QNkIeiit z*&)n7O*@Ec{`UNDZ2yt1zrj2jApMPrzd`&X699xinLvymBxlJ(Z~eSr`jp8j+JZvS zj?61Je@d!;ulIW{NLP!Hn0e>B7r!ps#T=35ymCLaGYk*lW^Cv+2rV%d%1jyMyt|MD z#KQWSVLxdwCJ!=2SPKNP{0JL*gHR#QKr9emJi{`yRij}2ljnkKzF#0)a&S0Z) zUVtST`eKUxsb>2<+O==6O+6^JugG_4;X0$k;A2*Syf^b&J6XH?V|*z>1VxNQwj?i! z2bN^XhfYCqIN|!^Ani!xPrUuw(trFGfcn3U`~LWxBtDS>n5ZWK*Lsr3$p0xe{LPjA zwyFO1{vYuIgMV^5Adn>{Qcweb91chSM$q4U`%l}8=)171I|RxSNTz}u%)Uj<@xhI^ z3tHXfR4-A>4^1J*dlPoFwO3m2P-rYnNbh$(JSV3^n>ISSz=`$)e3$;ysMO^rb&7!R z{_%c=eiXHPivS0U9n?0Cq~X@-5p{erp2 z$}JzvJxXvqWG7shb33>FS7&HKR3}szp+^%pK!fZ>~As zd15?4vc^7CUrvJI2ikFZ`9fFnf;v{*ru=KwAjDKr3cEFfw6r!>V&VR|y9f}(Y3>yc zuwU?$iBrt%PvQ{$Pxe<>!6aR&le!z%hlj?}E;_RXV%CCdq3W=3u;YmWFi-!{`LQH2 zKp5E9e{<_Ux$VEa|2KR881nz&SmJMq33&b|N`XThaywTt67utjjEN)|&fQD4)lUnS zsY=QRTIB6r;%^PweL$$Z;Ci{93QYno$~Br9ey}N3GqO^qW*geB$*q6C@p|;eqOllf zl|2Lm&HtK2Lu7@Jf{tOyA<%tbbMK$D1G~Q0+d4;@6ky)BG}1>@vrl`y>7}*6Ma=^T zqjRH%x;2lZSO?A(cCP$ri8un{|16D4;)(Uv$XHC#<*4*7R1)p#icfx)kijK^BnIMl zn051q#t9(<*&veD1NeurtW5R&>Iu4*_vO*8L=4|(eZ_Q4UP_pRgyCJ&XDXdiOT@x< z7cPG*GZrP9(*9ykseQxPPJ!Ed@8yH4K8an@Me%u^4XqA4;6k;Aoj5Qc0KVqb7jeep zzLY2IHd!@}z34zs4$WkKI8F*1yG#!>1MY5j3$pS^j&0vwtW>ysF3she=gIMx*$v$i z!xxE4mR)2uan;HP*L~FJNd-w*nK**7>JxiZ=@5)n5Ku>kU@|Sy7K&KVmq9JhYM%M0 zHmep{6lx~>=jn`Alqha0`(Zf!?m6OvzwKZ5dD=rU)0g@9PA+~g%WA`V;yivXfh?U2 zxNvNA%SAe>z-B8nl7?{+FPFzgNQzAlcf6;h?+y%F&k#QU43qMSX{e$e?6|Fd;&Iop z8l{?9Hstl_<#CQ6;CB0$4d9yktGkDnuu0W{ThvtLycn+8v+9r6?XPh5+vJekWN*zN z#8hAOt;@AyD&XdMbqT{sPA>H-$CLXw+2tue)K!e9*Qp$(Rh7B*l@3wBDBACa)Xbkd zip7#}uS-?0r%!yS_bbD^FAE5r$-;2*y7`q%r5YPw##>#C6JK?y`w;V!MAdJIt2q@Y z>qYl^Qe=~a=&UmG2$q8Krysox+4D+rq4dm*>z7)~9D3B%=3`&x0|++zz#y?&GJqKZ#Ysu=Q$B4G@tz7FdN=1{K~$ntq^ zu}Gt3KNQ)SUh868YTuKdK$_=*%%U&eGaI*{f;VB$n3ruYK}8FlyhENgzLAva}bj) ze5$NMT8~v?tO7`CRsG?r#Y|EXOXEGKYU`cvoAZ(JWF=BcUF%IEU^we!#h$b~JJ`%F zocbosm0l4)6cBq^MNP8iocTU5_81pY6lcw+zj)X27WHmM(d{6vY*e7=vG`*r=P;bB zh~t?oY^CGP3|~b~;Zuf|UVKez;l*9uYcLg0Pb76m21vOE_$88t%NXkWN$Pn>VS-H* zj9myy9uaPaZjvZ{J%n3?j1}GmA7JVVH}Kb!#me}~{(6TmLI!35H@0zA^t5pe3kx>3 za}5a5304Y`H+0AO{1TGT^9eT5xAF4`SJajXQig@PTI2A(0TuziN|H7(%Wy*_d6=88 zA;II9yohV0r!gwr-9pkBhxf46mm%1MOQGbw^}~X&ve?it6BBu3C8BH+2{=?eT-jeP z0_*8zYlrm@cJ~f~S)i3o2q-VSak!bOi;S#{fxIOiZ)FmImee;>vea*rCPUOuyZ^+3_eSqz%+(HaD zow8rOHuSo6HEpD(J<|p#q1NZAHJb}_l^KhHn~X7{q(|S?Hd{6ExzA%fT(El%L(l5F zswd~HxR9w1^R=r062gc&MI(l5{nTjTou{|ok!$i8Pp`_4G*I>E#9Z-XI^)l-Z3O{Q zPQ(B*E(b=-QwH&sZjtAWX4B-W*VM#3vf)ei_iv2*a9z9#G;B)kTCM3a@>?*NhM zZZC#w=H`3SA8J`H2ZX4_qz=tjrN^)zpq>}eue{);kAPo^1nvPcpERC7f`qY(c>cWj zv%>>A#{Gji=Otq1t7rov0vuWw^G|Bdf&IkI=?HxJN zfUeI0fK0<6OIhg!)zzYl*b~BaW-TeoDkka8*%Z^4!>$3kmTQ4P%+yvvkvz$}mx+$5 zZf}}omZpy%Cj7kR$M>x*8nA2G8IU1pF3&da2{;sQVoAGjrX*f**7x2Iv@LIzHw^&4 zMB26kWO5UsQ6FVqIQnxH)Z7ZLU|1DMKcPlL}51=+pkW zwYkn@aHK8u$8##?jq6lhc%TkvpL$B&LpHZnkxEcB(tU`19nO)!Y&{7a;84#vMFYsStTXGkjjZ zlX1#R`xs2KRfjK&r+W#*X>sN?{BpL}Tf47Z8>iVjyeeYN)2sGRe|y(SpM&9a4&Fh5 z+o`YV@~6Ie@!4g*+e~#5+Bm|zRwPsn{K}_=HGS?-9ELM{O^+_mjPr)vyGxw+67SvK ziG0x193*0itv^?W;mjXc9W{(8apAgFs7<*@??~0!=9%!k4cw6;cM8KrI7@ybO3d>JukbI@%XqobOiBdU5Sqj71 z1ux1Dj*jBc`H}}Gw^JI=`cTOt@x5c_!d)Xu4CfTzwGLSl@6K70pA;}3+ZFvJ{zp?+ z-tc{%{b-Ki+}nmcGWOA4reF8Pe!@7hc9{2PH5XNJ-48%|5U1*Y>LSW9&_*R>+HKRq zHFKYmp_^i_e5rz;X>G5?ei+AGh5D)cKSe}c?f>&N?{Xazim%NVR0z^w3PsiomSe#2 zt%2VIXk|Zd=x{S*rruX@lw{uW+mDW=+Pe?ci_Wo^GlE#!h=Gv%@x~nMYr*5(FJ4l$ z5^g*y?d0aQkmJvd5-;fM0gl2>R198IH4e*LK2UavNR0c*(RIh{&ajLMmm=&eq#!FE z%+?5u^TIrXg9C$3NlP1qVuQSNBWxpZk;G_=;cXu}bw1v%!nqV?`6K>a#K7&T)1P#8 zV&*pX{SCx=+AjerASUDxZJ2dgKQi_b+BRmaw7ct0Uc$s0*gz+dG%;M@ zw+>kwGpv-YhmD=9i?XYfBq7ifYlE=#cRy0-*68$d;Wnk@d&cfEw(sz|CVfI>cls8ftR&vw^uWu7G^WQ3H2Hg=8HUZMZlKJhpqEB6lg7)v7QHXz8q zCSKMr{^MPmpC$W!djXV6#hmQR>jOg|=I3pV9xC6!tcS>Wej^K(4<(q`$$Lfm;cb)+ z{9F`#eu3haTlURZkd41ioh5u<|M5=EK`sg1nB_iGFbT# z(LSHBprt00_cfz1%^SyWQ}5E#u7k09L>Az`bt#%_2N+pen84uZNIP>sx6mL0UM~oX z^hd!FwrE4Vi@u+$w{Ij8W~K|bIilv%t>pKd8smf@8M^fIEG1Mg9pozS4zFKb%A2PW z>+xj)P>7AzAd@au#ZvpYw_Mlo4i@{SYqA?j0XMqTg(qD(rvNt9O9Tw1auE0Nl{uX#K)N^#dbqjU{16P|UME(nT+Y zxSmnATsrsO<8?rj)Yr1`xt`*PwC{<14+8)VN+BZoN&TY=peyH9qQ@)5ZIWa_b~cRe z*B&Z<5v!fQ4h|AbBuNaH`K1Y>?~v zK6p&v9k#^y+}ud84=Yo(FUT7#1axMJ;VQqC8bh2f6TN~U*wE$*ju)*7sQSoj&&GUr`2Q8g74pUyu9(~SR*SNPewplm$- z{VlvBObNP@IzBe0#u4UnI{xMeL{Kmiqoj{Q+3DNqxQ7vNhs7vxLBg)*%j*-$mttOw z$`q36B}i;c#?q4MKz=^I{Z(cQ%nYD#{$w77+W=izRsFb?l@X7*u~sO-w=y%Gm!Igi8vxb zhHEJElEa&#b$aGyr0+{Z$^DaOe&(M*3%#kaD$a=02h@88S!{#&klrNvi*7sO$slXw zey>iaNbQYcIHh|xHWn-hgtEkNrQhnq?4)G;Eu{S2z5L{DOm%S>t#B6+`uC0Fabmu;a#Q>+qz!FM%| zb`Q(P!BM_KBsBwy$Y7NcC-^CKf}WxXPiSj2E^4TtkLzOpX&xs zC5wBoDTK|CFYAYb$rp&wB!5HmQiS77;0SDpzJHLF7tTB~!YCvXhL;TvFh-zdEq%~O z5HVL1-@LZmi5lQs@BLO@*f76zwNg)3nam&K@pSWqWHbOVzE#eM%1TkA_!5jQUe}N? z7r$&Bv?vIvD6N|xyQ_r;Yn)CbAqI<5@7~Hr=8`_#GuzH7Ic>eSQ_Gj{csr`s(38JA zE|~TX?CeThK>6PgF?vz~u3iRcT_a!H;84Se5Eq;RLC?fB&^6LTQPSJm0~2DZVB`AB zgRY{6+BW%49AmZ_)_wn4fFT~JQ3vl-DbRypyZUg^5CA~)DXPVmoej*pmE59-ikrdA zf~B%1_!6YU?z2ldD4|BM*()MPyuShH8U%$02iV$0y27Lke(ZE zk_yYOC+YO(XldnUu)M#%lAp};VIte=m?xmDC06d)JJx)|nRi7eXUNmi$_H{_WM}Wc zp%yCs?4%*41%?4P3;w^|g4Wf8D+S6}$lKatJe9ozwct{bQWhA5yquxCtUNpr22+MB z86T-1o}`OR-Uu4^^ZoT9q(Jm5ymWEkdDRSIKz*BU6;62%vW2|oo;;8X z6zZ;zGtp!8yqla^BUUGhl)wDcQ@2UAfGpKolMlkoZYEF|8JsCG)6 zZk%@if<{lKfD{x)GviuVKR_>9G|Te7>nlDOOgRO3^?#+2mW^zfm6;LN&FWVWSZi(^ z2wMr-FM9Do;_QgJ%Cw2lW6BTyujiT{#W!FF7XTGcN2GCrZguajSmZd%!6y6Zj&(=h zr974eb7XLv)zyjw^T!i64(D%cO}&+{h7oXAYhxKxPbo>$BU(T0$U+1LE{qFg9`mBk zR7>UBU9)rAOws)TlGX0Ci0A+mJwLxTHx6;WuFZ7D4OO3+^zuhX%BS;vNSCK3JiXfc z=fS$7#5}|CTai8rC+Vl`kMwj84?R*MS39OBf_ByE*qIaRl*X2HE@{rs;;*tZK7O8$ zU&}uSD4De8Dn$=S+Og?8=QT+T4CiiQVz!Q!5N0~r&4_rrf12Y1(U||LDJjE9Q%iR@ zBVDw)qL+z+myLqaktz!xTNP&u<m3=D3v@H9T_E@1S@NqwU`QZQ*MDxJ6RZ%TtK(r~ps#DEByTPU z_cS%N@r^L`w~)26F+l{%xVsnxOZo-+MA`<+nuVLm%O63}d4DldCqv*0ZZohZWGtvN zD2EPJiF8=px#ev0a9$e&Kv@aevaE@dV-Xa~C9#C;m#uk`Ym>NN;9$vqz&+QFQ& zL@56yPitAYk10&jEJ!9S0vo2NU>k;y@WSF1y-j7zbo7+ao`&*v?!T(*Iok>IhYz`? zcBWFNd%GpSpqn1-4QYS>X{q_Jr67gB7Er&ngl7EkENAe7g>S-Xt{iS7^@q!!jC}i> zcBeCQ&>9S2m8zpW@?*Vp{vPt4^{vLu7+x>OwO2_UEIQu7Rg7QcXKR8!HiJ*H0MYz_ z*fco3Zx9TgOp!rre}yP2kbbq)P1Wp^zmR$>p+A)P!wvW%D_LDWEu7q8$k!#TH&vUG z^c}>^$|@&YVrKvDO9^n`ec~on{_Rb=#>O)K5kZD-;RM3~S0z1f17mM5C4{~eCfE{- zHbvV8OA@5)%=Pqa-GA*JyBBI#!?TB@LuFj%1H-p7mquERHLwfwsU=T~f_ABhysL(E zD~zw}oy!W?|3Mz(VksXH>uYToZN`(-WR^QQ^aX5nhv?FxzdmImob?>DC+q59Es>+%!u~S zJF024Feq8ge9dO)Gp*1NPOw8X(JlT9prLrP5J@E?L_mlMRskCpY-(mEuV`yz;es~~ zkPZGtOZ)&QAMfKU9ioicTP6G&1ei`aA!e{%gX#wrDUILzApoFLeh{ar-GDzu#L4_S z<(s{f=5Z9G1-WmM71i$zznqK*2kip1g#2bD#NX0S4ryr(Kk|3H$cfqt@=hw|!mTgW zogVjgAR6{xBjaW1D=%kY>#l7Q3=Bw3e2k3)!;~%M!jX9MNMkQA9e8*k9%E}}U>oMC z<9~$W<-HY+uF~O_Jh2GbsH+F&H6~}pi=|FYWu3benv6cJ3!q3yT_*bu8HH0S-~L!i z$`N#$oC8G3Q(V--Ut7@~9kdOOyiRn%{|b1N4;lfix<#OJ1i>N{?XT;HRYIdILV_*K zeS$2EQF?(`DOo+ZImRH|4Xubc!m;9JkSj_b97D?bte8osiePe@jNz`-yvImikD3;( z7jY{j^9XkkG8f|LmX@BoW|9pLI?9fWIZ>qK2jk9sfExB z#Uqsc!Ys74Ljn+TuE7{A!UW;r7iy%1#>k+KwCg?R;CS*FRL&HTZ4zL_A-!fT*30@R zWo-E}`!VNJPB1`wwxCLdbKC9xgeM8DW~DL)Gyca7FNB}Xe0!D9HwY&aJw1HI~OIZff~SN!TzJjcL~?S1P^mrn3cPf zqK>bN8O#kCAgAkz)-y#Kco>E$xj_ji=q3#E#pV^f-sc^k{0 z3EOdpsD5X+Ta4GHJ$?_s&@py{p>j0*>-aWx_enYDoy=RuN822pEA8@BhS)?)RD#)d zi5R4QFHoSOg^L0_%oZ-Cs25_3Fjl|?+Xd?C>L?f*M7a0`8llaPcxuRRx%9&R!6MA5 zVTQ0cMQ>lGqLmdjL1bw9LBR~#HjCKVoD zdGw?jOx<(DQ@1dk6jJfx-Cpgd>(Z|eqN1#Y-3<#om;|g_`*TZ5MZh{Yj|3l1v)ncQ zIk9URb!T|+5he3B%^N|U0goZ6&Qb-AjY%&s4IO)OLgd@r(08tlKsktFU%o>grdO76LUgIc^CTfu22sxaAl!^7W`_u=8lyXK6n-#;8lct`GM(_=P^7 z&q?$Gv@S%us0Z?hP6S9|^5q7a`rVJiTOSCsnb6Y`ysx4i+QQ^Pj(kDB1+udRQvqlob38EKRkP^(^eX zwUpr&9^oPK1Pf0BMqVz`-34Wa`4xY+*~x_bA3P$hhWc?^q)Z2%DZgq!K1k<0WLsW$ zT1-R@0J|&|Zuz~@te2q}tBIGFGnS2?9r&(%nVfCP^WZ@O1_ne42x>wC(UdI|W#cG&8u1BB!j1&N~Y#(K( z&*)d*@t5B|J*{tX`X~ME)pn2Lo~_B#$@Y(=@_Fj=e8FUHM5e&M9mzc~Qp+M#31%Vd z74CKfr(QVA>r=dhQH_QU>iXWj%?c!V@$yz*clUD{#4+ziVq3ObdcWdyeq`Crslv#( zT!+%Ks4U5j)a$t6p_k`p^y^r_%8>sF(g;O2e}4sUJ0CZbP!nApSERfZ%tXN>1Z^az zXkctXzyzXjUalrKo-W3UN**ppIKC<7?{>d*+aJ?yJCN>TY!+7(8#&p*z0qhM9a^n@ zNe95OhpbaMcChf(!gkBkMd*MkH+5B*##IQP9h37a^1+h`uvZvyP5$edq%bCM3!gws zYh6zi^4D<9RPSX>OQH~nv+X<6C$dyG`HaQ-oQOMMsunG+InaFzV%-!u|KxqUHW=AG zahHJ!tN!)i@z93Llnds{tgm<*fCKbRo~!81>puTGWLw=zugq7;F>3Yu5YaN=eD< zD9QwR2YI3Wu`as5ih+)vPJ)WBJyV8A@%5!U1z8C#a!!J##a~l9kDa$qu2)LuTi(<+@hf>-otBg`_`|gI^Xzp#nyP_n1fWfgkg!@^T~oU$ zK^{P%xKaBQ%sM;l_e^tLpkco%95;jc9+r&~z39Ag8PX_CR z>Y3;%5Ol)=^(?%-{dKHiy1I6j;XZn<{(&f|BbR#ny7$q=jOpoJx_6AW^c4NgZy%cN zgXkG)w^BNsxFp;FD6ZM-QT!CXm4hk_nUBj4KCZNo!`bVQk5KOoQ+HsRLSWldL@57F zWrCDlLVb|tJ~H95ZkP~HNi!rS&>E?Q(bZM-K^a-XeziWLZD-F2c}&GfU$%IDbrydj za_8Ol_@m(XtA0-ix(s_`faXXB=BnL|yH_4iXYU6z-0dJ`W@ekeQyRvbIjPCTuk!+| z7Jrm1GBBLQ_xv{*PfI)cL4HJzKAO1msy*7-WwS8EH?F#8# zr9nb(UBm{TQaw$S_X{=$@)H(9iC@98Pl&esmsKL&EhY8wesC$goe{#++Q(QcTrVI@ z7KaIzl9xAB@-=eT#_9z93YlaGEgOljw=Wb5NY^4hT_V_3Mv62Fm^mhH3C#pt9Zd!- zYPFc-H{ad5)M#!j-#+PFNJ=NK_-S%H$|hqyNxJSz2RH&v)DQjbM8-&MTLKRz?VPa@2gVvR_Gea2# zhKGeH%G=7K=DK6F!f$wR?Ut58ly8g$lJoK!6 zBkerGB_+-M>@0j0ef&&a@CrUCe^(_fZC52ixQDeu7~D$VJw#Cs<>4n~;sHOr+JNCb zxX=;DKpI?!wga;VK>Q1VXphxE})!8VjzNieP`0O z7;M)-wE4e@uQ>sx->*~Zw-*o9;l?1q`kY*bPz-Agx>bQ4`fx=2Z)=q{HeT~H}16{QPZey_c)eLuf{ z;CasLobx=-$GN^jxgq3KaSS6)MO3p?P`&>>ta@)W?@Q~{SH!;viZQZur0Hr$ZJ68L z0lC*5R|gmaWZ4V|U6#?3ZEp%Ncj^>v_)Y~y zi9&?+yIlXYYQPo6v2 z`ysZq2S9Egs^nX&%?-Rbvo_lFg{bx<*XbQ#E!BzB>7PB3JqT2+fGr>rLO5vwsz4Z+ z@j#08>CY1pi;_H?*<2=T9b_bVG7wayW`Obof-15wI$qAG0I_@&P zU~!Q&6MqmNwfOskGar99MF381 zDI<*o?ah#>H@^TY|BG=w|H%YGNF)d$Npfgvs+8{^Ec6diiU}$bJI#Z~k|H=B9IXCj zIu)7u?#UB~rgQEEqY0R0p~8Y0Wyc(HAN+0l(x-U+QkS2Nsd%I{?*Afw+H1*tuf10y z`b{nC^}4z}wMnwM|B1;sz@!v3^SFPc^%b`>g~-)6=ZvYnc!7Pk+O|$x=$;WpTJ{s? z9dNvO@6Z_vc<}Pedq*0>a~gjAh$s%-REKOFfAVfQXFdMm#Y1^6z^*w!kS}e*=?y_U6r> z#*WI;B(Fb!*&^K)LjU_Z3PmYY^VJkeG>1<^2l&G{^dKz`snJT);;~e9VjNcuNk9dP z!mp|)QjthIpZShW^St_Ty+>&bGhOCe*eo?bb#&!{rm;V_=PQ(3e8Cc zb9Nykf8~|GdC+9sCuy_xyfzCkx z7P9Ct6;_`>l9qb~6xn^FcdXuM@nJdp#?X`29l!VcK02PbDuc7zSO?&`HG=*et!&=G zn8C4yxTBk0#|>(JZ06KWE3|(Q)Ue|v;50*L#HfE?ufzsWLvZS(P=-b#)`V&ZF~P|^ zA|0*f@Kb`4G=gXvT^qv;@zbN(>FsaJx3=)V{~VKgD|%Xg-gTQ~rxgx|&Nn&Nyhu74 zQ?9#b6}gu`q#kXLd$11~9G8lE*_?1v9XmMZ7UcN1iKjpo%~Gl)$iP+>eF$fMU4H!Q z*y>9U9ZFkrF6KMGHd$7G1^`pxAd3dePmp8qK|E+QM;aibfv;vPj;}$IWyol}h#wQm z;vh(Rc=G;jQjOeg)|OY?BPSP|FhBF}O@ht*EKs(xekDAD9DfbcwhbRYqma7XRutJz za@jFA{!zJy;OTe&Mf1Z@Gm(qhH9*i2opBgK>7X!#EEGXzCxl4wVMMBui$OCHa$%Cc zP{or&Gyz1oM1_x&LjC?dGCjmo)zh>6Mp<&codrM@IBx(ZFOY~@th zpRW|}>ZQCN(k@?kWXbg3>vU^Be2j;#%~`lR!+iX%`)c+Z)8}D1+Eh3~;lJiX_#Ptc z8{nO))1>P^a_T^00$<5i2TL(zH7ivqiH4{>2p-VXK$hMSB!*3pe|3+knS<~@v;R76 zoyD@WWm%U3x4am-`dR(>R69sC%motKwl8O6{Dp>-;r@Ku)BTLsv-Y<)|6Rj?fB*1= z1kfJnzR?h(!1;**c!C;EMGGO)7z~Cd#bJW93Vv_^MuZ><_SUZ#@ zB=_G0oPBiH+E8tZjbXyc+8{Px9^*0U=hiw7p5A4O82WbTb!kX_+L7bbs0EFcrB`bC zoa&RFDZ1)({HiKH&-X?|_E*o&fwBXZVHI&LJJXtc9o7ruj1HX30)!jE&olUD(&)jf z&N@vfHkv{cpSs=fW5m|R=(UWN84_Vsl-8J0K6%q@@ZikhTz&#RnQr>JAwS~P9-rzJ z^>2kjNWx~#+NB$;&EkMyf=*e6q8yhJ0FMtqrcje(;mjaGh@Q~R(?2YNDvAb>l8KPZ zr>AFyGs(e^#$y=bpaYKMc3XmkO8k*+7dvX;R=C8%A!}ck1@9fk2d>+(DsUUL;{r5` z3xxict}+zN5)sf)Kekd#VuT_Bkzu4*w!WAN9JEA?6;By-v-hPeV|dsYn>JMxIC)Z) z9d4aKCUFW#t8U9ZyGaW~9j5gYc0U@n9VoO;v{`xo)I{9tho93D6vlwbAgB^UF;f#m zMB|vLm_V++5)}?$FusB@U!S&!A0W1WSU(j4=clxETVI>kw}oNa{$A(Ls<;WWy&|9r z=lQD0OeW2{uKq}NOI_CHo`u;5b?Fb2z~mRd@jFeq8T$NS=z+cqJqU0UpOj6Mj=qWDAdx zYscRZm1ikSd1g#L{n}U0=WdsC1TVHc%RL0lP1mW)fJFRb$w(xO6NjMDWYOs0WSTf8 zkvFO@E76|R$BCw0YhQiJODN7ZTKb~q^RHHi8)F`}pJ244oB{cFM2hD))P20%PCtYz zUHL#ofjsb@g1sHn92ghYd6+Q>Ob0`@|1oPnNGKwh%)m;-DcDgWC%YCF9GkO+;MF{* z;N!lzSp|zw2R2}x?#K?Ln6-By(?BAwCm#S|d-k$px9=L7cdKM)eKn&cII<=xa&V6C z_2L0%VD?SWtdswF3cmmq4g%Ha9ec)&CdY*@wL_<6CKFO9kJJ(TgP|psRab}+_0NIt zx2fRyu&?f2J4&-@VVP}XmM^qPMIs*kQi$EMJ0Ux6?moFC2hi=a(|O;(KUiSHqb6F= z#ElvI4uzdK8MST#gLePUsu{52Am8c6fP+f+wT2WSgRF^1$%)a31Wc-G^mAF`u87MQ zuB$|9)+A0__GEJV#apPCFcIbhx_8yjs_3U6l^}%UUo(1q+nJ`wd%rhgHl!{(@+6(S zVaMfHo@^%{*AyUJIhwHyJ6~f}_p6-DnmE<^0d6JTDMCvO$;&c2;xW-?$AL8|K-hVm zstqk3Frt!>9HWQm%uO*Zp5rA=eK0&geU}DPVXS zqw?H^$Z*E2SKclsvsXZMmqm^0%*gwbD?aQ!{o{2_%e1kK&;EDDENOj^OhH#h9oY|9 zf#^)9C$NK_{UY_RPg2J2x%Jq;z-O;#s}Waj22b&PUW+~F`3YEJqI2_xdR(x-kV+K_ z@N_?@B#6aJh+(22Nh}X;iXu)DL{RVqp2Io@o*PiA zEQ+*FNhh0uxw_Pj>ff#5ry@c*dLzAm;r7iFCR?|fj4!Xh`z7x7VQRJXSBJ5<8$H9# z=l=X)@btX57PZIB`W&ads_W5`#-eK=r&@NLL$_NjuwLQ+I?sJ<9cpuM@c9`b$@f>IWfiY}wVsHA)UaRP8qE2s3ucdypDmoYvFP*9%n9zn zZMW8bH}4ERwgK`=`ObCaOYaE_0q?mw;TdYhe6CbQCB%}&LN*5yq?Vx*Nn*Jyjm$ua zgiN76+PpD1Lv?b0Z9ErvMq zN!wlUgx=+Df3B&k*0m?c13q!d00s;R|0nSVP2(p7d3Xd0QWUAw1oWtO9>Dhftsct! z9U@D=3TFPDBz?2<$*Swx8SDNgY_?64gLK*>73tBRQrM=XDVa;{whayCo;-M)b!%zE z;lrWcKbJ28rVanEcBBFoO(`BdoxW;n*GJ!ZyDu8$)*g5-i8kMFNm%wS$-J$6dyg!J zxE4IU8}GSqU2_r0dmi$ zk08mfNx~X44k0spd$CjTuxWykYva*S+VzsWPpwf_Yqns4`Tvzq3>nK9sE8aE9SuW= zz_?&3arDzROwwR%9hbkI%pK&8h1lnjgQr<9CZ6ejoPry-g85e$CVpS|Iu3e_`Re(E z7e0q%WjCunT}%8aSu(Di`A1f^v3fV40UyGwG@pN;#tYnZo zb35tH@z)MdKPH2`{JQ4+IkA8H;Iz!+VQU=swZK--n{eMW@u+D^IBsLny465DU*~5G zyl~?rG-+aJGF*b76O)6KykHE4sZuJ@Se%?DkM&oIDFIp-jRcY6{IS#k6cwWH!pIxg z^EUIxJNe6~nqh@Qz~_agg}2?k7xh37S(F_si)QMe#x-ZZA4jyX$1LIIWrKwG&rv(4 ze`d-|W?#9RW2|dyAIqITBbIIZ&VF3eL*F;mxYcKBd;)&a9@V|7k1H;%{sx$3k9yBZ zDYBPdBaAPv$9ghyesTB27GD;XQM)kI%@zh4Iq6(vs zUtCgrhVeGZ@Z5%3BeqrApRQAZ#8Tbo841%GUZtJ(>7YQNoCgdI!>nlh)E* zk8UD-b2vnKc&+F6BD-s!%#F7cH)lHz#*}`l1lUV;rZD@TDG=oGDbdmde+*4TgK-0e zdS8lf;ur1g&kh(G?i~AKMvny(`aas2iTW7d}l>8JBTWNO&HX>kdvPmS| zp#-7XIeQVObKb2DldRUp!2!yD-N1$ig@;81Q&fu7*aQv+O-ZESLj=Kz!T^~{#tMc8 zX)qXZFjf8Dxr*Fuk8stKZ zzPWbJ+G{T#x%D^CZNC15UG-)1aY0G`TKh@%wzC)S0W5n*aY`((_R#JSEF?R6*%$JZ zrTa|U=X@#*^HB<|Rrfxbf3XETVLHVaa0*X@SEGbzSQrk8;f~%!L3y7l?$_%_!B5j# zN8-1zExnGt`nn~-D=Z_fxc<*B-4h_$ci}Gq7Al&AAHRCjHBqIz%TLLZ3vCAv^Y&(% z^R{Y$sfD2U4Q)04WI8dJice&Z5=gvv<4s!42j=m7hIX0fa6@e4vyUrz1XOuY_{XJX zy*kJdzxqsS=059~nhMvS_H$1NJaEwujMMImj_p2PleTYf7clLx?lTNghcreeSNhRl zv7xFYzKHYRj2+k%^|iKt>%g?abV|^kc*Yz>!I-ZBJ(SL8#Nj8ZRqcCDfP|Fk=-Wo# z$H&Uzhqp&)y;$w49Oy-B35PQ+q%FYb&N6`bU(30{UDASM2zWY@9i2uAio;0pXiNxE z%#uXQ^;pJ>h)p}^aQ8zf^)!aC?b3en-NNvvl+7J^JZCJWLbMztnM&+=&Gnh0GO7-l zYJV|lf}qNC&G)%8N=)OXyRCRoE(HV%o$VUFEtMalOw|ZsOlTTUn@H40IftU-xBg9_4td z?XprR#O(?ZK=^<{G^Ev{75eBV<$a6&+$hHjs~l$K7duy>*4cQiSu@9dX>?Z?1ieJ5 zE4!_^u{~~)Tk|-}#2fDmf$LXKD8-TQ`)xZj1}&gN+6pBQ)}n)ihG31O^`NrpidZ!P zf&t5%BqTzQH!i>aZn4YlfDn^Dz4EG=v1MiXll%>j_qowFDJSjTCqE0)TKAr|{`*Ya z=`0kQiK$2)AbQNG^7cx3880glr56Z)0w!^zw!iIMpfCNfG`GBL)kE)lnbzk-)b2T7 zqsxrsxen=HQs98O_o$mY&G@&#P||aKHDR}ajkvGa?)pr+jx_l!}j+&0LYMz zdqcZaus>A73nuZzDkO`EgsQk9C^;uNS*Swr(n7Er5fw!VBFPeP${+zo6rgV%I&@1} zdm)FM&C(fhJ!k?Y!{(2^Do*SN1VlA4PcpOYmOCV>}<7(r^&JUa0_#%Drw2gy@e&nC|p8l0J9y>pgKQM@yBwR7rw}ibxHGrqU>SB(oBmdpF{9{0cZD zevyksyQO-l!W`9C@4MG|t>?t+JM%#vZXH9O{yXb1<;NQnyLS;pQ=Ig*Kc9Kg8w7 z3?ZL>i6$*e4tsy7<5mAaKr!U)wxkETHnQ6*8`np496#;<^HqJF-ILg((qn7WqmqX! zqMxp=*>LPPATQN@yVt+BMJ$fyP*FUDm?5D+lLRydHH;D)3XZ`9ODR;8On?y5_%X3e zZ32mdq6*mjAN$%f!PzEHCryMkR#m-SxNWsDwmJR9UKDL=9V@^@L*c+^LuJ(t5$Eq+bi zgO1&`pxUwo@S39&uOTgkOcN#I6-ZokK%%}}amnb_^ysn0gElUQDmF|QIX+`=OWPWT zi_^Jx&BLeyDi)pG(@4h_}+L+nl49wf5lcgag z5vK@|5-?#RN+3@YNJ2m)glLpL?6O|y^7?yz24695y+sZAW;}O{669xG5{Mm>Hxa)qPIaX4{Zu& z3(8kq{61vT^R)4sef$9PNS*!RJ)SdxaFy=cm;94#Y;da7PZG)wB`N6)nqN?;A{2@w z5Sg+xv@l4EA%?J&(ZT-8cx^nHhEXNKN0p#}4h%NZ_P-)`r81;#Ewcya93m|1qLpm` ze>IR-iv9(1{PESMeQ)v_;Gd15L7k+UFOOYftM_Dny16@Galh=w@iraB?{=gqfI!`OKGSSU^nK%i zd-J`Tj=!Zemu3LbQ*=(vkl<7$i_`&x0C<1^Nl>biF+pOXfKNfkLFG`ARDk5^!O0%U zC~cIm?r<{OvggR9oZZ>|0~?L>VR z;Iv)Gq9JQR^kYh*$s7dBj~EY6ixvxlX@pVH#y$RpI`%L$NK5?qVoA{htf}=4#g(_| zr1$IBwyA3?bWh_KO7Eo1aE6zq_Dk}J++1|$UfF@q8z+|lzF?b^?wLei znaTFJYj;(6_vw|xq;VV0R>zOKxrob3VK0rE`=g!-5Wyzq|0yhxIa~}&#*wBb$^+DN zE>eNyiW1Yp#4HAl4~y{!6WPj9Ce2=RA|Iu1BW>KfLUZ@Tg7*9KPIYdC8D%Wo`BpS# z{9hfq^g3No`g~@@AW-qAqr7YQR$zUWTkQt-?hCJ?%mj9JNI@$)MY2#r?mOPG} z$WY)o9$F1DiK|W`PzX#YnNOw)0yU$Qo7Qf%9XesGd18L?`z~e5qr;O=k*_RV{D2x- z)aQDAxh~a&pHgO)t{B#AwW=i4uldoj#0;Tb|FqI6roWZVS~7V6a3bh*VE{f*HQGNW zG?m6mWv*) zUG_jnGIGL{o^f;9E!)u(E_QUapR4}-qG88DrSz zgjNbMFnmBaCTyV~LM+?RV81b6jc3u@iqhIs+$?e-_vgpC(GF22_ZEOZ!k z5aF@!euU4nn3w-fc>N9fLs!oS={h5rqB8rp5ra5yZM&q-7#O9W{mt{lndg>rfFB$$+!KtTEvQo>Sb8UZpD z1R#M#tt2iXC`=zQI+6EIsTsCjJN!C6I!4?)?+*?+YteG<`z4s(o?OR2;h-Fj^HsTF zOV7T2+j>3t>E)iqW>erd79O%4%V>Z-j*g2po3RAcy#c<1om#9Qh@VtFYFr;J0xdH+ z>`SmA#df3H3#Z*Qb<5jvd2)i<`NOsOW&v98{L@vg#~uK#zn-V3IswH{+#c70k9mt_ zN!G6}RK4u$-vdmYpwqPBZIO!5TC4=Zkh4AX(7n6>wUOw1d+ckMkfmtxqy15s$J#%t zHe9!FrMJ_zeBIw;t`x~4kqgDg)?_73Kfx{vzxnxO`|>$Y>ANT2)oK)Z`S@rH#5@+f7_=Iq{eY# z(5?%+Q!Kx_M7jZ1bvj>Vz=U)X#zR73!0{?2C&*6(WrtvswA6SWl%`Iji22|^41y4( z<&w}EeTm#WuYqygyZ&WQ+KD@D_lK;}c|O@)r(*IeS5(X5fAw`U+X&- zKN9n>y7uLd@hLqU(X86e>9jFhDgd{9orn#cRM<2$9|MnL(Mee0;pRW6F}^K)_vJ! z;FIt3$}5kuVnX!T(=S|Rwy(1ST>k@T3;ux=DuEe5m!?VuOg2S^kHbL|d1MVlj_3R1 za6&y~n|pL~`jPd`_b>8m*Sij6`k@%^IN63v`!-D(u>+oN)0HcGPucUqU(hE0>EOSL zk?qR+F-ESaag2vAI#M51K{@XXOnW)%`aVh4g8xsQDX|WD^ZnYSl4c5J(Ggak@22VN zR>XgFJ)HxPj_K^dkOLCqLWse11}7jaNW|pF#j!|44`B#8IL0F&B$<_jR?r1Bc96cV z`o#Ryr_j=z=fgj&b_@K@yY?JG`7OZAIbXgULmx}&*QMY-FU^a5lQLaY@+j2GqKR_H zf5w`<{LQB=&je%1>%UY@1Tw%WKHUTVC)3uhl=-!|b1bfW`}LIl8)i6{y;}(|kSa}m znjd{F5DSj^|4%kPBp`{+Rmxbnm@pbSK`LeQ$g1GbWEBUiB*qZ^J%kAw5#>chl77OrQa&)|CGe*LrX|)uv7fJ-0-!I^Npj&o zO~Zl+C^DAI(2BGqjQ|oID-RRF{L^3r5uKeR4ARE{h_BgZxf#?4lXJH?-k)ju+O_Gp z&GU>P?4;t5V^y9Gr66JJceMhh@9uL}5xWTQ`k23Sx#5%7UhHwB&xJjI{(Jp5z-|DP zjPf5{GEJqg8jXX65q=b%u$b3nmSaETVd}R&uQ5xHAGP&aEj9BQxunBiQ^)?*-pa8$ zKY*FhpAqG}F1%u68#lSHHSnyb^;0ve{XlT;sCwrAdiUgDDhAoz<^k+%B{vE_q@V2? z<0yGmRd77{y6qwWT?hI`LorsHsv#g)=-4>Ue`}z?LL{`XZ{ZC-iXQC}-q$J3tvI#i zncaZ`-=NNCR>-1j&LA()b;gCBBXIAO6$SIgY>f2wY(4AW-RQ=BJ;XVcV*i*8m|xWi z*l>M=Az}_MBvz%;FtIQ)nSzEUs`w~8c!%}SF0b^&OKj1LF=eNw?&yi1+kA98H{jic zZLr^%*clft_v)G|yjZWiQP#mVgjYloW5?|mw^ov+smQ_cP+EN3TFahE0NPJS)6mUB zNRq|y!FJ&kRctI3rbq`Xt|W^!z(%4LaiFwOhUS zk&b_N%!1nCZR7k5Moy4j00g!si#^^gQlnb;Rhi;?!CKiuP7tC1y>9=&EtYe=| zX32Xm012klboX-k7)SV&aGRON+485^mbtQ`yX7Coo7fw#n%RCw`N(b;5Dd|=X+Q~Z zTq4>dHW1H^mFufXHIuH6opz#a-G|;|V@+EQm1q~3L$}B}PRj?59oUl>>8&GD^zglD z%B`O8o>@a~J0aJHCvo4d-szF~roY4ewQF+^;CVv#_#0jftu%p>#t@W=1to=`(MkTIFb}*k zn5FkHyW<=l2VmTdH;ovZ_PjvJeOPCH{c4S!?`i!&WA0RWT1RW}7E6KY-9#yz@%yZw zePwt)ebS@CMS|>F_ejOPU z#Knkt^0*Lis{&OWh#N%};*2traQgqQW||)tDh`cjdkEBYd29+s zLB+#GWC|wi-$=+lv+jlUdl&Ss;N7MkHcRL4s}_>RNDoynD^E`$*m+zAX+EIewY^$t zlJ`9^xun{mua4E&*Zo7>Nb9;$3AXYcb_T2tj>_vnrTheH*{s>X-UmtR@FQzyXi`fc zdtgkP13S`p->t*~Q6Om7nerp`%HHpp^vTcn5I%A>ho4u4dp2Fj;$1d3kD9d^F%kku zG@~cB-MxU%{Bg;*B75k5&4L*=pU)$nYR;Zr_UGfiY5fgH5P%lkB%nL73(b47#csos zrCoVpMV%FkEq7FQKc=3}AxGKFV$ZpH0a%O&<&yNzHFG4ISRO&|A{L}QJbva!cTcP9 zr9U(zm2gG$#AV(^OVU;BYlmkyOLTef?yjSvx2NLof8Y91ycqu3!fK1#!goz;`+`Q+ zbydH$nhi|t)0w9s2@Qt|Ve%MWQZ!c+6rv#LO9c+@9;gx;XtH_e<7o_y`p^2fzb1Gn+)cYn&aSb2@Rs?x|JhJytB=jjL; zdZWooYD@?pp{Am+Nh~~thwz8NlSDL}hUFIu4`Ok67#v$Jfa>Re(z5BFbEUbwlI`J@ zVUjgFT?Fd&2kc9Go*Hj@GmD*}>j57UzrC>Oy!<+>Hcgd}o$U~{+V1EuqYfnw-)@zV zc{TuWJD@W#1B~JkkzgH8hz7BLoGet9mg+$hih`&jLL9>noSOa*EpLg!u83^Qx&QO& z(pt*)F@IAqnTI5Y)A0RsU_~=_FV;mTL)GNj?(;J1I%=D9boe9QH%I~-Oh-)cHDAit=CfP$qnZQZ*1MIMP2J>plAFYV=`n3SUH0NGVB&Y zYWzY({zO%X-aXX6Qg3{J=7uXX#_RKA{u|6~BG*e-j7PJj%|wUh_k;__6B?Q7|1Nf@w|=Cx$zUKBVzH1xQ)F<6C%1B+rtyq zW=|U2{?YUb5O1ebk^$QDAw-fi2u5L%!Okc=Di{q_$VGlBfsjOoio#44bAl2$ST;hP z%F{Q1n$z9}EE{meIX_S0nbR%}Wop?E<2FExZ#IIX9@+^89p$v z_PD6DA=xhfs?(6Fw&qZoQFshs{SI_F208d?g5wfZfhwxL$u)7tHShZB!(S#RJP_voQDXQQe=yNl+YT>fO>SabM> z7oPw~kj@gY|L&ARO5mh=ka2-wF)XRn1Ivr$a^OU%T8PBP;sT(du_9q=Xe>!U5yn8G*lU?{+nT#y9=_%A9<(bBxUaHyr@Yb=`lA2W`1%SzJHmVO@1w zN&BQwo-6-|s`PD*u3yFEQPDS3s_*xOR#BPtf)^1^l~uP6&iZ()q!ChXZWh)8xb}dO zF+ea`ES8KU1|vgK^qp3xGe4GBbjIOGoZ^pencT|(dFd}ReA@B@89#HaevjzF3bXdj z%B?2zs~Z3I-hyaBA`QFW+h5W%VAq7!NpsIR~BNvy@$){qd@m@*yFixna`& zx#K?tT9}`%yL^2{x^VKkzN>&7%+X|}E&8V=A{CqzMJB0(=}<(fMoJQAP*$GZ69ozjKa4iGP(U2nvmIcD1sqj#} zy?;FR`W3LtN$7(TdIR9dCs?&ydNGZ#KfOWI$Z7; zZ<;&pzJ+^fgrt7Mai@kG064G>-Z?|~giGP$&>C^ zcpfY|mK&|rJLXcOs#X3A-ge#~x#zQe(b%|BpJVqF<0BkX=06)c(B%oz_b;};=XoIX zzURChcUyNQZYuIEz+La_*Jd5b*zJZqTLYLX{=YjgQ!dtoT(3S89f<7DW~t{=>;W?Q62B@n(vk=s`hxap?CX{FG^~{ zKpp~33r510cK^*_3Oy^|)#R>SIrY_L;@gMYtRnWgX`;Mv zpeDqJLTHdM36_oJB$L=NP(nOT5}KflOB6^UIHF&yz90Gb?Xi)Juz0awhC2H?{YODv zq;KksBRh&#Y){>WEquBOO9Um84bi?}&_6?|{T+FzSa*!2T4FkAmW)6A)IDn6By zASUAQqLh#Xnp761NJ^#z@gz`xbqGU?ptBgGmsn^rW|!Ua_s3dC@&(HBhKj(haYnJF z4TVP@o;G4{+z|zGx%}hKE31=7>PDV2X-lRhkIaB4>xn4BL(*6Mc4)ns)29ta_B#9-IyWn9ul=cCHk zc|8sDo2PHB9MdvzY2@SAM>zlv%o6-hE*BG%q#*Oia=&OMl`c-EC}orcO1wxJ8-$A! z;8^HHmV}1GYsvZ?5Ile%wowpp(z)uCFM_UNYEq16b0blZRnR8It5jL9wMG99I#K6VfRH zNeD|6j~D50Ot@EwFgX>*g@2el_i`VhCBeAWYg2K`O|zBbm)j1U(sd1AuW89G-m!SD z%*5XM#rj#hTJ1{mj9KVS-Z7z@XZ49{%nQ%`d;g9n?a}pfPn*uP4Uz%TSDms905>|2 z!UYjaJW2_nvSa=9__A-q0sJJh3uWc_{4#{|%~g&{e-n zo~KUw)I7Us96v8>g-Yp_(D$IdzBhH5>3+J>86dA2^&XS6r)bMt+Q|K8sGpu$IN}WR z(0-HhXtS|@KEtLTJk|p6&gwWa08vFEQ6Od#_y`!&4;g@DNzsW63Al4UkP-w}>+ea@ z5V%&V^yi_7DaNZ@pfmrreo`QxKR1cnFE%p|{b*|h@@IQ6bV>E}0qZ?kMJ11H|CaRZ zSaRsIbyNeg|3+EB)4G?yR1Y0l!`zHaDnsDJ40H@k1CQl|X*98TQXoBnFNfix`6;08 z6tYn*ZSp%;TGVN`ba7!a-~@ZtdnxHzL(ajh`7Qnrx4{^xF(7TbaL1Jj*$a8ZiRDXd z4x^tfzdOG1WaB|>3vlk&v$GbFz&J3_`kzS;S}-?|FQqDZF-!%RYU6oOgDD7t6osR~ z_5GDEqipGK#{1ug&FW1Vp1yg_vIm7y@8741jRXAF#05nqAW_)Llh2Nx?xlX~>bT6m z(C(3JLAu-5P^nQd`oDC#`)mQ|H+3Ius4`+9DG-m85U4+e4+%))CI^b3`bL;>^v#|* z&#~&lfUH*f&S_;s!P_6YA}XIPm2|r-Up1&}R)t+X>|XR~c+ExiH8RO`uhhK&7A@~R z10Oeg_NH|&7uEm~x@Oq_L(c3#f-(gblN`uI1^GeHJRwGtB2V=Y;N#&iG)P}82~nY? z;I;)neO=As@fUWG-OB0T0uNTaK6h1A+qZA*^El5%r0FYePdvcYHA;A2dl>&Xi|;F{ zT=*J2(Q^EGX4`vvmz9rJXKR{vZU5~C*sRk@*-%8}snHTzG!_n1u;>Cx0xT^I9ZgP? zr62@Kf0jU*s;{T9e6N+C7>=MnKI(T3{%mQ@+V%I&7@da^8v6RtUuwlqK+3dhJ0sJZ z+ii!VRzZ|vQ~l)9#8Eps z@F7kceM>wPy?^>qe&MT=M$L9R12R|8Gd?ZojLnndbac9wRFkBYXM{oD7IYl+*f3FH zS5cIocf06ANxKPC{0K+{OXUBvG&eLUE<_oMMkn~gvC(K{EH^cg4bGwJCtWQ=g(m~M zIrpBYEjLPNR?o30HorPM@nVidYjSaThD8lXFe0gAx0iIJ3jTw&v0_%TJ1xR`OUi$4^NtSxZf?cAuYhm$+`jd6 zc76&cE2BCrIA#-~&|~^9d`{kg8ejvUHVw_&beI;&)mOz2Xk$J1owT%0U%l;{1NB*2 z{U$}#lxZDNoveOy#kb`-;OSd?rDF=}ckDSnfBcv?K4ErumR~yT{SMgsCKQW%G_dR@ zAULkGSHl~I5<=u@^aOQ`R+&T~V|WQ^C@q%^PxY6eLW8M6(P$=A5=`=g6S*<^oX=|* zfFE?0Voqll_Vk9e!^{-u;yXnz&Sp)zcQg!r;}gil-g8qcx4PP#EJYStU3<<_UV{`o zuX7%XySwa#cmMFY)qqIXVPhCp(r=&p;QDeYtgD%DVd~_Hg>Q`tw^&2=6xUyfYO%h5 zF^b-{20Zxmp7fnkN=Qj2B}^4$#IBYQjyk@r!!BC1mVcWDtN8^eEJxK=vwNHK_A}Vo zR~%~_%UtgT*FpDb`fR1*Sr6e8=}j|}fshwEgECwhq>Rc6B2(ppXk-jb9tytXDx`uU zrw96_5tv9dPH)N+KgK)Wle~^NXNRsSpP@OwdARaI&vO3-J53t;&#$|yt0Xl)ssGlT zo0ve;w449x{_eVd9lhcmugmm=Y|iOB5X@6uRR>gn;Sp6O2*Mz#iZDEpt_cX@FhWs* zf;1^TUKE2yfJ-!mF0O!K;*@i}Ti<}Bs(KYj2D->TIBZ-q_@ zh8!i0%;s@%N>PeGHw;SVu~I_ys+oWBV)zP2Q~Qk0j&~k@p=E&Glj5xN$j4=~qg}U@ zT-puNdLm17Z#+OPV4J^d$oq}lHAOzr{8;||rJt5ZH`|53f&(7lGxb0{crEP)<~gd#*tN*X^-5JRBE zz=UubnXlg{#C3|_Bfhj`*MZPb={(zw1F~$E>pjOo^sjUL{+k~xH-e1xt~_oLt3L89 z`Bq|IWnT8-&Dg)W9fC(q+~xu7Z(jKl0LKCuG2A144N&RCnf-Em^T^_^(JO0W% z&pvGw7j2;IdAw`$%_dzg=5PDGRaeQy(;vSzU$6bq2vP3%IfU8wgm`oj!70Esq#aP6 z`~SXBj!H>^3V6{f6cvd{mI!e$3_nn-rqg8Fb&nC^6Z_2NE7eH1`o;<~UXoyH$w`0aN%b7(<1uE={x}nQ24$m%bUm;kj2Am6Y zkDo!~C|PKL1SRLwG5?bJl4C6!8hrXHV`gvoxql#gPklqx#eBbkzd4vU!B>;a7lTCX zT|#W@zC8lAw*MSI^?A$LCBLZ~9dE2sOcAFoxwH1CEfDeF?6G0-0Y8DR2!r!5%;aEo z2#x50PkT`AqMY1B_y=TJq`OkS{ccSmmfid}B>6?XO zkQGGf*Kw)uyB@8)Tsw8<3HQUPrbY)g=LTderUH!@ejTv{lJVfxGrU`JworgYj3R&# zR$tZZyIaRty+oZ}}TX z$JpC^A|&vJ6Rz&HO{+OT)t&x-i^PNkTo{H!XNM)g2~t8_tOq|e1jA>F=wiG~E|)Na z6-qtvYWtdP){q$Zee++zwbc$T%a$DsE!cY1h7GBIp8sNruAav7m^_flZK^tye|c;8 zzAGfnZx42B;GYYZmW3odlHR%nSR4hVY`ACoD5maqWZ8n(jEQi&^%#*;a^qFim}RCt zJ9mF6!TYdE@V?-|VYD@v3C1Bmc4^cv>v0!)($2t8c|D(^Zx#)X4OrpH1+dS+gX90D zx>EExjk6JH2evJ_Hzq*q1SwX1x!l@{5|`fJaF=B=s3l%{rpxF>ww9CMGkP}B7D z=>FK=*T8>nu_1CTB^%8*Ip|pzt1eXrN!JkQt95gBv?A5=I(cq~KGK zL2)ny6@nB&Q3wK@$dQtg^kW)bEr*|5;S<;Lu856xy02JRdu-LuS3BljVfO9oySw_9 z1;|BI^}#>S``FIAx^7x(Yjdqn+&6!LChK}qIVW2=FNMiC~aVQ~|04~f^QVA4xPG!UDHWd#r|1(>;0~$5TFJ3)%E;pq#sRTw+eNDjUIP=GAL2M0 z%#lxYb0wQyS_CT?Q>M;2N}y~}9r3cyqubi$c3)!h&1W4Q$!Y?U{u7%47brMPRcId}-1fkJ~kp<6GAKUo##UrbCt-QQxkK;7;U1-_jcdrPX zCE$_(-g=Poj!<~OQ0ZsPOF^nlm0VuUzLxLI^Qv0$?A}gk=*DpC86tAmv^UCLZ=lZ@JquQ&-);ig9rCM@i2)H z2eXe_;Q=w``E{wn%a*Uc-o0n9ScEDTj8f0;OqLDU1gq&lBjoFA863zTbK z+BxGkY>3UseE;hRYqEzUn+E*S71r*2Sm$Vwbt)-)*vqc>Mp}=1lCrS7xpwX#DzfKj z;mR+-Qb*994gCb6;xOr`2S8kT&&g@w?XD=Znw2g}`Rci&L~B!6`INalLSmH75P)Yt zm}I=D(>)4bayO;4#Pv?nHtIF^p^3g%HqQ2#Z}RZCBf!qqS+t=CUP+Sjl@y)|#7)vb z5{i$dBA|G@Sl_etY@M`XXJ+BJDeYg^cRLABTA;12d~&$>4N4-6dl-J_B}ni|Q&qnG zkwnGy@kj;n(fZPTH5WE-xB#~{dvoc{q6rccK>0(b5krS$LIBGHNbP+FqIj}jzS z;8UVQ@Jx>0{9?>Loi&SP|CuDje0+2K?+lVFWP-pn!;=OhLhY=lbQ&j3|onAG-K%12E;5?i&pqk_lihY9cy0Iy4C)O%TLj39&eE z|5Q*ws*Fwwi3$nWFzK@U61gRspGkMRX2CjqzP|EobEUC9|e+pgi4 zDBHHPW8Pz*iQVs#+nVO(933~(dJ>-JK5wZ@Zz_29+euQJ?B8zG?Cb=umoK%qm?u8G z{jw#s;lN9Z&#{!MV!*xuJp2EqVuMs6Dse~%xb{lT05>x!5CU#;EGZQ&MUu%$azr#$ zmK26zkCL}l?)eyH9Zj;%xL|3X>2S6`Irw8)ZW77fZ(@+3@=7{L{&&`}b;#I#g3_D~ zd3#n%R$T2_wJm0^*TA8Nlb!oa)7}GV(ErbX0>Msw1Ya8%BNu2>Q=)Za9&A4XOW%5+ zuHQDN>YA}Fp<@@loABJKjoU9YN?azH4K%*kYE?_uVV4gsgj>Rb>>aP-rO_clf{}-- zImw5vD{pM39f~~yazyYd|Ku(-3H@?x{ju+ZD+ae_rZAf)-HF?~JavPW(e?%ab``WR z!)=t1kcoVbo_^t-iu;#^+pXoz!v|zJ#;tOPNr&qvqnfe(#zIGvZq-no= zg%eD`oGW(`;jaYWUijYZi*cATyH`z^2+RYwmVDDO`f<|SdGjZ?-#%HpI&9A6vn@ZL z6|X!$CQFpwdbU-UOq*Z6$x7^5aBc_twh_G__HBO1ws(opEWxqR_CFb0`$7N$*ifRw zBd!o_e`wW`w1%2{-L@Db@AOq)N0uxa2|#%dVWfTcD9;{~g*xe3Z5+{~Ygk zYZKOA>b-N{;#^OlX;1K*Un6G=fBx9r$=eYT8ZgK@4%mWAc>gCEj87s5L!ih+ z93C1YmeAESl9nw}&_ndt`*X*k?bPc;<9X+r$GV*H;njLvo%`#_24?)mPqqhPgStp# z0nz411f${pK*qwf)%hC>S(@bzDz{y07Oz1Uv;gcDz#g16_@Bv!Bmo&ipodbz*g>i! zaa>5SI9aXFY0bYf9C0!Dt&0ugOJHo^3=K49*91aI`q(RO;nN-;n(qu!bFY1pwsJvw z)y6O5@3{%u&dWWw`&Q&3HEa8x5z0(_j{s_;Q3Wi@A}DAsV-MZ0E>>LhtvlIzeC@}3 znMDClanl+WXJ>x}Xy8vHb(&hzL;Kmb`^S_)57F~`@J9|Z^s)Y_@GXn?p!zaT-m{Da zQgp3fhAD21SePL8@X&`4J8y+=YP=PNU9g?>=i+JXm89I#ohhY877smb?nrO6>Ta9Q zw1?ly(zD(6wz|34*I#^g&+QifTcPom++B0pDsvipbww3WK8DS&e$gU{Fg7eYFdC`) ze`I}mJkx*txH}{g$=j7gMaYaDQJ6V)AJ}GHHZx;mW0#F2SCOPrLQ*-PBMb%Rf-Q-%`PzIam8R38lx;{NF!f#9%_SEtTJ%H!N>fAEQO1J5#)%gKa&t99&& z7eCKh04$rKlJOe-IfV(M@x#-68B7t#<&77wM-PihU>o}DaLbnwDI7@~|HxrlNdYwy{ zWe!a1P#q9WilG1+Pf1gVJlI5uG|`s|O>Aw0EV(e4XJP)k ztxWTt6r1(>y;XkcC`bIkATo6ysjltiA3k)p9tn(C+4Xt2{i@{KVo&W;8McGa+n*b* zn0BNk1B-oBe4q()dIocnXo(0h+BcL>;s%M45^0cc2swo8E08hyOb7!Exg&hl$XZX6B;wl}(l_>3Yw77VE-{zp{(R0kvETAuJ`v9%-t)T& z;vw7c?O|j^O;*_oNR4OntJa^-r-t3t&Rp2#XstVySZNH*`rFY|GbIgMqu+Gx$n|d#a{ahihWoc*dYK< zN7iw;UB>*e>q`4J{N91n+zk7LrnNxCa@AIAtYn`QPZ$v^NW?H9QDA8$TF&GqCNtGm z^7TJ=jw4U&VOaY0Xw)uj~LzTsO$Z*3Wy^j5s&+CfsYwhj| zvRGfF?PS?j@w)1$LMNQ4EV=q({~Hj<39R)J?x7W{Pb8$DdX_w2mOt8XATtVT08XV^UEP@L2~htQYiMfp zkkaH-z8D5g!!m-B5fDT;NfDt=3yy9w#`}6X=9RyEq1=p;Z}B;nHI|BK*%6pUvR-)Q z{C5yq3#HHa&V|?l^a^F0!|Av3)o#x+b?>)3*LJixC{`Tb1%w%>Xs2n%oa`GdLWGfV z^zh^)54jgJNUao{K0`F(Wh0e=a z5Z0t$U?U&jVb79&c^MgbVhQd^(P&%bURk@g}amV`XIMp zRl%7xFOD03I(rmEmFs ziB6Ko(jwu(Xr4@nPK*^`;X;oDWV}$C`VZ0fnN5*Xq%*pF1GktC=~x`Upf|Se!k^lh z+RY0Vvn9|55dNEPMS8_bcNe|I_CuK)#3D&aus>IN=4#l!15dMG;YI<2&nkY?P|TO( z9gzluM^X{7Y0+dn%PRp9kxb$Xl%n`BNhFvaf`ErJx!_O}bnK=9weM;b2iO{R&X!=uBv-qCV!{4WuqmeP- zO0GEnbUWq0yT@|xu4_~KS z4T5GXIGc8Y-FWzVXm5Bg91Gi=b)&Z)1Z^|q)4$Mr@O9KrVE_K^bt$)hY(D*%uDO=a$Bu6zX-Lz1bzR(AzopSwN2HCcQ1*q9G;^^)E5t!6~kK0ADNdvfE$ z`O}TSx4UC)N@y0yEY8xFQ}7f@)%y(tH0!xW$)y*`w$jycBtU;u#r_)aJ{KnDak;cG z8bRSB@D)OET(xOu*tz^;;}yxFCebZ}S#5hPte~Qmm7^@J(XlnWn2gtXAS}<0-7XIa z7loMpveJO+<7I0GOE`EAe~wRN#f__Rb;?YtU^jNGeH_JPYxppJXoGWa#{jU5TC+PcoJ})@hobnI-GZS z-QD0_F6AAZ!(aMEJMg0srF*`>wY>2$lc-!0HQgqNNT`ioV<&a?#lt z_XH4`lrG6$`@lz*D-r?euT>{Y69e}`iQ~A62vx(kP@z19?-LK|c;SQuv?2@<8-z>~ zu+)Chd;a^ruAJfI^j>fI%gT>2Zw+5HSBw*PNnfFy)BZOh_ih4mFuhu}F-7oA=3e#*M^1Q(r}&smUvGVL zpX0$qljr!nqByr(e%}D{XBCMwMRL+G7+jtx_U6%1VTnWpEJ=z7(`uwdj5j+B69J0` zn>Q!1Lbzcfwa>E8A}+f6TEn->-rbw`eW=VUjm^?8Fpm%CmBs2C!D{4B3Zzs3wcEEV0mnU+H&i)4cTz!$Y)Di ziz_0-eeWK;J9g*{W!FhZg7*`X1!0RZAj|_PQ{+-Q)A>)n1GM+tsruR%mg}maONKAK zEA2Q`s5>7({$C|fkwi%)O3;i*2#LWGL&ab-fsp7py3i9EBuh>UrH9CwA-E&~Nkrm@ zK)@bhfA65fiHyGauiVVfY`M>MJM1n(noJZ-S=(u|>hs(+X!ISGui>^oGVJZLxORA6 zO=#+Zeh;G+Yh%u5xE^m_=7pfoIdcnOz*YOJ$-@>AJ$$`5ibPma3Oy1oWs|(YelH>{ zF_adjpmIE7L&6}0R7s>d*l1>cB<{tVrNUVoZl1ZyIlG9<91FCo>muqi`Kzbp1*oQ_ zyrA@q3Fe7EZS$}74A>4|`fgC4?_s2)m4jA3s_kA83=sbk;(wJUvIH9;0-Ldmgbb!9 zRqf}2J|BS>E=)R+)MaKGuP+ltO|{>+XhV84FVcD7W<`(#om}_>;AlU zRhgC9qbgZ~=bMS(7fZj4bM5Q^(QK700_AgJiFr|TTItL?&n;&y*!*&>mhK%LgvH>g zUxi&}s)|S8gENLw{bEKDcdz-KbM_hO==zm6eD^rOEU61C7Vu30UYLqsG~VE785@!! z@d%DciV9*tskBri1}E^4c&EWVBwUCGN$p6L=GttVI(*`q&1@^%z4;URf%+dU9l8Vc z0@_&UrsU0oe$uErJhAy|Am;q5As)>+jfvWf9RgFx1}rT_I4oT@4yO84qd!V4ribeSa^m94o4E9 z!J$BrNZ*KXwN7Rf)cR}NG^y1e(`O5!1lEn;e?(siC@SCMnm)9}Hif4eK!iNt;VXTx z{QDjWqi%UGrU6He(@WZDVk7qMk)=!sgMfM0{>dZ1y~LFs?-iHeqZ?hN&o8cDpC9Pd zGLevdw>CY*-g{Rafa?5rqXbVqQtG%3a+P~6OM9~gv!ArYq2OzIp6$>4?f5$rr4Ios z%l{+Wl?*NowAmw~f-rn3R?72b;)q^Kxi~&C*u#gMNX97DNy0T>0$qQtb-2rNpYkN} z7xwH)p+VVQ^zj?BQFo8ocUC5XUlYuXUrz8`q%(2SY%}6_?53i7_Y}_~p*BPLa-U*z zWCI{Rsk+TH?t>^KI5A0_m`spM88~=wctnB_1*%F^LK;Px1`S6LeLQ_=O0+`2Qs9`} zXiubCjd4O_kFRa!vv}mVQxGZuC3QLCVl_pYtd*<-hh;Q}= zWPM#b@fk4QucDX6MJI@krbcs=k;Et@D>RnNfhXWe=u{R75sgiaAgjHRRJZiX0NbKW zqsYf@Nns*q2R(xx4jl<@|8K#NsUJ zIj{Ap&uV@cV0-2tf|;!k*05dVAJe`Qst5RttuypQKa{DPPg<6D4h0u2#RIUv?c_9` zBfKaK$AEapg7*OfB7=lOc}k*Gq)b!@Lr`&Gl>k%(_xL9!4{ZCBeWKYiGNNC*IFeF$ zcyQ)D*ZC+tpL6hdkNE~>n?WoKQ+_eGP{CiC;HA!l!{+iCRB7b|m(8?`N?Sgz!K zTBw)1wJ3qs9;q5%THbGv_iJNrb=3jvl7-L1f0#~u5nLX?B*GNml?@gwCC;#Nv1Ee01sWnveh`Tf(|~U|Vq7?Ce`7P5usSJ#bx#{Bdl>{s42f!xCJa%cC-jsh7Z37n{bSckSZv zfasEcUwrk1dCh39!am@~72(GdRz>R?ZI2ze0Gz4W(ifc<*L6!3a|gdzb6Jbfv^XA= z90BGGhAO!7s3Zx6;F&~Z6VYlzEiT6WiY#W&L6caC7mouE-~H{2h9H4_DCZSsXizKEd<31 zVW5a2x-SM2<;jbd1&P%bK65iLC(~`1k)ty&Z2aAR*!%^DL>tTvfUgGf!Q0kTRgK-= zdFAvNEb#H%S(`5*;kI8gxzN;79-2)N_03!PW6GTo0M)MgN{xFAt%#6wlYJt26uGYl zM@|Y&l5x|((RoA+5$Xvcusy&&1z-^9-*!yzPCB}2>q+x<+wM1TE*;opI9c04zVPI7 z?br7`W(9I9)gAbqCToV=whX((n(U8d91*Ka@KywH#CMssQgG@84m;>2g#)2$wX?hSCU#U zY|bIx{oX$(#<%Dwig395frHb=@f$1mKK-=7qSowV^f>r-j}cfk4{wd1wxfZ~SY-85 zDO$=st84#h)kD0Jmwqb}(6;_}DS2Kz`J?!c?We(6?S^$b!g}$=k$L^8Nlkl!vaGRr zKRtmcPZcpVq6yAp2_+Fwx^HM$A{~ka8&Pt@gcwpZ7eZDTFO~;nR^98@cmv396 z@32JLd}tu+`Y+5SGxBWsIBAbtO!xsAh$YM!XP199bYkyb=Ix&8BfYO@+%|aLQvRal zhubkT-%B%rRVopn39dp@gz|rEAXn5`9dZlTb)4L_s-()+uk7Z7Zw0Gvc(_*I*=rR) zqEZBw_P&@1{Wj#X)VDT$eszSIwS{ZZmdJ>4s|IO-udwbgkaA1)VH#H&R!jgJdx=tm z!6ENyL{R zoAPItgMd-BS8i|3i!AX2%Ynf^ugm@EjpK2 z1FoaGU2&ApWublsRd4kZ^QPH-`IThc-woK$R~-}$=_BL36EF}|WCYARguw}>#v-7~ z86KY;oQsD97tyFC~R{HgMpa z5i<6L)lYOgw&3P37{RysAU0G1DV6`E+lm|ci_?zZ(=Tl2ZWzBd*7z;>bd9L=Y$P7v za29aC1qBv4sx$`;!TC{fWCR884MRdj-Z)yCAc%wJ5aHgbI8Uq?fl!OMy&Gdp9Cw^! zUTN%1N$M~Zuita;UEZctf^p1+B;Kg6E{I{wJV9a4>m&IAw~O^Q{s>AbV|d<@QZ0u| zCdFwVx5{<^6rcY}cPhpQAC3OUN6)7?k}A4&3Us`EsZA003}+5dyp4kMU5h$DLz_=7 zrGRf|Exn>WF*5U%YqFU;FPhXeM6U zZA@5O{Poz0%@IWz%gXQXjo+v<_dxqovh$A_hN^<NAI0LVC*>zyu_Q|acCxx+h z0-L^MUHQ=U|=D)DhX z(BYFc#jhoe!LnX_cz`^kI+tah#ZUSo{s?(xzbTj#4rN~D&SA_`gRNmMx*}Ch~p2I(|!4Ho8K%4^MNlUcEo|f~b z0PjoTZVy&sT&R%Yle=e|9l|R`z#JPDJdIn90*xh7#DaKa1YPXS1q=8I5-7lcL7o zEi+za^%F!yN%-g%(zpLga76Ut(DL&=p=-`nI~D@Hc2AmCze(x83()gbd!R8(SSSxM zTR# zW_9>o5QR-|%ddYQRHEnl)pf*ofOF{jrdzp)j>b6++%K(Be%%9zMpfcQqX`H?C3Ko7 zI@Kcx84(#7nh2)IDt%~PSn9t`-rMU_xTnZud(P)qXO7<4v!mh^FXqoNf9%~{%Yc!` zZaYATN9@by_l^e`f4;vW{A$Y0GZnMI$#f-Td$M2W+~e~H#Q^Bj{#zh1g2`MxIyDkikBxMNeFl>Csl|}3gX34J)^{; zXcCnY#luAVDty?GAVl~-G@n+Q@cmXo-EuxH^IcY$(BV`*IJ0BY|KjND`OfKQcm37h zwDd=(zx~p2pwyUHCE0BMx$gJd&C#2-ewu!@Sx3j$7U0%{(EqoSk&qm%uCN*-zO_nI z-WkwYoN{I*q%WV7 znmh6%^3~(yZ=OjG0c*Fde&lE|4Y2&HIchwq#PAUBRHO$B8%j-;(c>bxqy!&ovQ(K! zOctq~+V1FlLH&^-61qS3vaMnbUq}7WJMx9P2YR zeCrGNUGKT0UAl3kykwiD+DKZYtdiEEc7*d1+z6 zOtgAi#^YO;u*aL?LcT93d>X=u${w%hNeYOMyQ_Wc`dG(ICbRVzcJA!AUp@EP!&|3v zKb$C4%#0K6szVK2JGjzUf4m7qOncp#2PaQ{N_;@{yQHfKd_;e}!SR}*(BTHxV$&MK z@f5(zR&^>gW-SlvNkI@$!DtbOA5MZ(qLo~lw?r64;>Hq*1jWDoI`OHZ^;`qGneR85 z`|}lI**cF!(`I@vFp3!9ANXCdzXXK4u)cYv$q3?WsBBGu@kgVv#W#j@zAV=*yS)8v zNhGdiKH&66B`7p~-EgclXlxQf00l=fu#lt_t`9WL3oH!{^`^wfQZcktTsTqSlN9Q! zfC;?9;ZdPPwEA$$H_jm+Vqf}{g8Fr_q4TY9zUOG1dxkBl-SW=l;-*Yh{+&nYv$+uo z?ib-n%!N~9^K^ip~LFDi}LW5EX z%8*oA8QdSzY^uW)S8%{AI#E72B+%h%#o=*#cSSGZVbshUbUxq%kRsFK+q9G*b^fC zmbqBP_#?)Mf2JF!$wpwX?D59xnfZUnqkqWz&+dg47@a*N24)_aty-sbVaPfkr2S!44`p z6?6dqJBh&u59PkB?UOboR5K6TEnrx2T8v4_JtHsPI$`(%ogffZe(nBX17YI^C-Z|k zWD)yAaHAh)PijG+?XkO8RvC4g1M`=HRMLbGB132pl5bp!S|>1U{JMSBgdF*GNrroX zWcYq8&eL_{XFub|t#ck^^){$X;jAq4&yh6W<^>yG}tjgey;ekBWlD? zr_eg(pJdK^x#9H9Me&E5E6VHkKSc?q00zv<$bqkUY#X*E> ziKBg2XWPx01y2$N-3RiBYrJBgZ$CeEO(ENg)lhMYovY%8;un2~2F@6`$5oWG=CkE_ zw|3m?*1PF(5_mU_uy<&;Ip9iGaf7B=2iBV+Q;K~tK~ivjwhu}X4GTsG<8e|v-Iq*= zz%f##NeCp9lO|%RkNu``hmK#5=UH0r`1973)ON+m?pAJb3-4Cd`4x+r7d?Fr;&4Jf z5H&pl`qsc@>PlG;+<#^6G91c9w8b#kuy7cxUI47*s%uh%g9j%T7fno*iNN9F)F`S* zmZXGWWSj_Dq&yjtpp3&OD8sxsl;mis*T4P7H}ZuWx>Cm9B~&f=)3af6Lyj}5;(8@* z)l%r@m}#$7T6oKt9({Jb)30W8QSQ)`0;}*PX%4v+vm~$Gk4`WB(E1i|-loDqleYkl zn;?OGsgaRbg_7y3z=Hu}oLV)>&DX~ceY>HfyL@zaLDB35+*Jp7FCLH_mRI%^WO<`i zuA!$d&+@*srT@6+HZ&5f1LLp8G|Q3W1CQlHMpJ8TCzkN%~!nWOQnLihHnZ6K^ady`>d3&@L2 zjv;b?cUNwYE2#CK$=z|KV3z00kRkCa08Uh$B~9D`9v`pp3?`D&$RrAmjtof+gCpZ; z$$TN5Nr_KWc&O|DxoMkOb&3u^xagWe4031TCsR|*pC?RP+_mb?B3VM5>YBy2BEFyU zd^4+MPp$ri=~J!@6VJaIoo)FZ(V?HJ5{BAXN<;JG$8u5AaS>_R^Pe**qy0BMPhq`I zRFYTO@GJo-O@*4qZsk(a;511x0YaA}l+iM8CY%uzLZHy-7-^_VP5QUnJqAxaHnt}^ zN6lRwH{)jBtkqj1R*dG=jg7T(>`=DV;nVgv#7nLUDi&7P7iU@^I zO1L_YYS?5}+kKeZdc?jJ5xx_dC4$T5m@pt<0(+?98y;_B0)75s^(i$Lg|`LKon7O%IQ~!H%wHI|d&Qf#=hOVo-~Ppa z@!P=Ql+MDV>ydzI#y_{m{LMEH)%&z97)p;MEHKVfuYPru@xnv?Nu*PiNs9a*W zTJmoD1(=y>^QqCux1R;hD3@OF>mbgh(|$ZL;_-xkh0=56G<%dJN z29QIt49C60g^tew>=4NNnwyP54hFYW@IR#vokOfQSZ9U&=@Z`(k6#}xI)mgp9~fK_ zC54ly)&_@5K>$lp27}RXSBLga+x{<|O?al`ISceo<!Px4%$`uw}M~q zC>S~#vRG^DN4K!2{2)Y5>I10}?Y&coc!aS2;vRqm{ihD(uRmF^EgK>GJz*7^a5Qv1 zEB3+EmMi)fTy|de-moF_DZu!9L1%EW!O8 z9`4vP?FqKn#1#zdhaV2num5v0uE8*@hb>iwzqTYVDlRkf++F(7wc=tBYuo-MgVJ)_ zs%ggGe*G9(-;)7E8LPyD#zn&C(L}xyC?0Iq%|S)WnLG)@+b4uXi)3Sh(#RDa z@f>_eY=RI;i^au9MWUl2%xG@`RVGVS$95!(3&M=*ZnxnV%fzUP*>$MljKwgD_hpMF z3w%dJ))5e9gH6z!*&%mggJ&Lx7DT?N2)Ud8d1_9}5z<2cmgnJ-2>>{27Tg34Oiu!w zrj&CMU~$oMQ7la^NEHc?XrzooR_B>B<98~Y@Jp^OSm!Uq%db~jUE06?d|ctC<;Q+q zF`F|w48lAyZ|kd{EA^jGjfE~LfzO_*{BXO@0-3?_KYtm)GkS0dpmnL}?fpMlBj{)n zg_VR)PVf%p;T66xA)FS+;zUOWdsCwc(Y~=k-Y`}o=bxZnv_XFp$A12SZ%(2hGU5n) z=J&6mqJ|kc=QkT!79K}G0l}YHapQ=&S%q|G`n!M`FlCv`otP}~+3s&+r-`N?S7vwt z+C?fdYs^lz2cPC8h>E4fF^Cj?Fg1xQVk4Dd_(+a0g)UG#TK5N0a%XOj4Qn;*3CpYx zMekZ>e6r|>Xbbewr{vNuo~nete^*>06ip;rA0;0kjsR-SFS z(dd#h)1d{q{lzND_)BfPabe}2?rsp_2j$DQwGyAv>k15lnvT5KCES1K$H`mq_vZ=4 zy)W~fBY`xPK-WYs5^*$jd)LN#Ilok!B-A8N*VXq z)bPT?>M7rp2LE29vs&qVPQ}3vKaFmu#NCut@wB{jocZZ4JL@%m6 z2?BA)6l|+^Ti!kAdWakQ9r?_uxYg^yL`9hRr7Bni5J zszk;wuW0&@&lN9V4~|B?_~iQP`qw2V3`o!ns9PE48X@*1z%fxVg62kzVtY{%_B$`|e-Kg`h(<}~TEuN!LI>YIXl}N);vx|- zf8ihQOx-ccii)Vm??uuBpTGAkcvL1j1fb5V2&gHBl(HoF*bs&y6>Q@fo5b-zaU_UX zIZB-rkSRVk%K}Uxm_r^+aeJTt2wu14#(wAl@%_bLd|;nGs5HEL_xf4Z5o-kld3icI zD~P?TLMxf8x3ukDlVY%LZKh=l;KNV>)ad3c`=QKN zvsx~^0*dpvuHSErr)C^lTdQ01mV*XNkt)C%H)jw!5+)7;eF|bGIxT_8BM`)NSUiO0 zqeS4;VM!&ktyoy|$s=Rd@mVIgvumCyODb;cwk!&QR$gWg7e<3nM=A*2Ok&K|y~n?= zYsxofIDSrlGiVrj_uAsZyl(F^=_+gEuiN8G1}6GBPL65sYr5EE3z4Sox_ESD>gBC< z>k=Pq@I`z8)=c|9S6+0IGK?cgi}GS4`H38lR2~*W$e6XLF{>c-ySVu=Do2J3YPvwA(7;YI-d~l%5T6HuW~xDPHt8WQ#I5?y_SeZN(<6TM=sJ$LyZBMZ{VT*wCIX+5RZ zR69)Op?M&_&iTtvMl?2>R_K&JY?-5bj&OX`kB#d$AGB6wRHdMRAzI0 z)0mJj7B3hP#;1jFlNk~?CoNIo8J$bHQ2zLHDlbG%eoPK-w7Dd7{+LpI(jpv>~IqTbh?JsI@@^S>+!9mXd$-VGE zGf)&kLRgAaicz4$rQ*bJG$$_3m#9=gc(|Y-oPrQXm8nxh%dn2~DiIZ0)W-QH&=SKV zy1`yImB&IKt>#9Ne5%QzAp9)>hcd<#X}a>Xv6-YJ$3j0buQ~r7dKEr9jOey&gUAYq z`5ScCG+AbnQ=k|shsS2Ju{35ZN6j(q=oIDDlRe3=99Q6;JqZ9%ohs*)7*JI&+=oOy?hZfUthLX#cVX~J<&W-5CokB zArjQd=C$@@hm_wKN^J?ftv5 zbJ{wg0DHndwKVoohUtciosR7oKp*TZ{U80C6HF$g&=V!`(ohtH>IIHBk&qLjLU~aH zD&H3#XjLf_AfC-?CiO4v;#!qCS!Xrd`+gZiS(qlgEzagug$~+mb1uf+k1@m zdXJ>jz|t!!YG|^^P$>yy30@Eu#_)u(8Q@rs2oW+~oh`aTw|7U^p0m^J`-hx%pX}sq zKIL>TrQ*XPr$-{4jFB%DAh-e6z_+(I#YgMUufn@HN4)&ee$Xy(%a$ZfMX+h%ttVP^`i%6FkF9EJ2F(9jvKp5en1qaB^XNW7 z1XKhTBEw)f@L+ZGmKV&H?4s637sUPFceF!SBBtYW7OZ`8F!WZT->W^@U&=tV9t@$k z?R3gs_J~Ww*IJBC2;HYfeC=IXcWLb9Sa;HkBY?ZAiI!z?u8r1IRwBdxqtKbQWd%@s zs|Z&rW+H1JZkmOv44{?i+J+bI%~2UwYb9}^=eM8N+wyKZQjnNcGu%PEe$LfcZ?J9( zFCTZ=0T8Up{?CDha3QgDC@Vo6B8!luq0vkpRUDKQ%$Etm=wK8)60Qu6Oo{OPCot06 zT#x32tbDxr=;Wbj_m~+ku3g4YKbLVbe(d$NUHE1F3_B_*xi|XAe)NGa;nq5r?G4!56)CJpwA`Ea@5L+1L<F=Q;XVHBXr>bf!UuVx|hW*p-_m+D9k<2lqZI$<}FR*pH=~ z3vYGgX`edd8mqHn`?;R##JsH>y-R4b4e2jzv=# z*F0@xSBJ$uI`p#gT3;XPin1QgNRYjjeSWx=!?n>ez1hOBAF{T;Ewt+-O&&}3e>MB^ z*yfdwi3UFjs_Ghuj~4-4vxE;iEg!Do2DWaW6|;wVvuHW){DoT&yosj9$85Ar zE|I`BiSm_Ks5D&7$gtzC_E=KNTL=2N>*&S00e8|HL45FVa7{sWfA)i`NkNBGA>_4q zOWwAaU__v#= z;?5xnI;>r`6&um#A1jMCYR`=a zcXZbmaLw9Lk@Qi55bbC><;s??4HXUvbMq(5UI!ONLqZtybScCmSA z^J`1F$tyyG(@H_nXUq3)&LAwa5O7WXhO6iAL|xf-pxCb9GH`hC);qjmg~2ULR7OIm zjh4}zmmv4dQhq!!_ps@~`w5NP6Acepobx)i1+LNe2iI&h$$Ado^gXF2 z<@0OYHOdt8^f^ZM;|SBys;i^mp2ji3HKk{wXR8E*uk(j<+xHAy#K z+uCRuD4oDH^>@}W;4kxQO7O`>ioAChBYrCUKH*L490S6zp(l3H7{LBH(fhrsp;G0=shzaB+qF`FnP!c%OtmJBjjtdQY!pP&SBSuo$Ip$kCN``Mv!^Q z0}6-IG5B7_V^=z3Fg`=)w9JjVTV~RNn2yNN`qr!kzCZJnHu!hTh_1Dbo`pWhuETlyVA6^+C*$vY#XrD)7;>xc(#?5HINJb6fg(?=1*6>Lwnceti|c= zI9uH`kE0{^{=OK{z6wmau3BbQ4a^R-wkcGt)J4qp>NA-)=f5j$v@B19`!~;JH@L#a zoN%tzR!d7u+fDz|Uj((ZP_H_v_~W)(+854HV*^$Hv{~_ANFId9c{E0E-L!pWF3h5qAAv{e5hS$cc-VS^b76y^W%HO=(?@sDUAD9UJX|- zoZ6ZTRDJ}H$j~jPBoXk+|J9G8vSr!3zb`Y4g%@Y0DpzjrM| zRDL)kReW=pl3kb6zF{Tp?|r5$e(mz|?2>tqrZ}_xPN!);SVTGh3!Xt=q0hts+hJ^gj6z+q~TLSBB zGm!(2UdDIaUfVXauFAC-KhQnt*;A8k0M`b;a#}_Tc-Ai8DIsA81}iSyp>NCIGe>~4 zV$QW*^6khFrgCPk9!UA~E=?Y*h#o)c{zw^BAI6(0`%c=(g=qf;@j zzt_a(vZBTVVnS8V8Om3g$@e|P)mWMD!4?Aj+1$e(sM^aZPnY7Zsh)F$JgYIIr;|dX z&7$!aMh-9Y4Pr}M;kiafT?19mD{kRk8fff7m!2)M&<|%K2lt+PbO&IGn}FG1nKi@i z7#C)4dT>P!?DVRx>kX~`j$cz|TAVuBbgI}6?9;-qYned|%rtoY#c3@6wB1!y?7(Mz zFMDP{0O#0~#j5A6Ys@w{%^Gnp{wUL))4I%degAC7xlNAV2fm1>s#+T3KQ3D{v5L!0 zpWU_Na>_p-13mQm}H1%g*|zOJ}fZaRgm zdY2G~omUE@-W6}5YRVVIt>W=PyNEJE^k&myJd7snY*Z7Fx-OgfE~5b+Gh>A!5MakH`X+G zX6)HHqf%yCY}v>5J)&5@3I5@s;oVDBHd;5Y7N{20L2E^LiyYg}OP9}H?eWg{Xx$V? z@|l-G-a%8r`wF*-q+0aAusMC+=E_I%gy_=JEKZ{h*fEru?FW98&kd3 zd;MrUUXeI)DQ!5uee2rra(Mw7%w14vhTRl%X?OE$kCq6c6O1tT9ke-T9!Ig%!w>a* zIk5aQ_>QL+?tTm7FQE65lc})N-#+i5PtOjHnnAsgazhO28B1>bx3w~n8zC1(CK83R zq!2kC73GUjM=;vS`$u1|9_d(3vz8Zy1oQ{8K<%E9vcIG+8lBw@NlnwiOKpE=x z8FStDS!Lkgz88X(@j?ab)@E7$GtlF|xyw{5$+x(UZ}r#2c_beAOF zh_x+doXGz8iZTh{`?IyJZU2*kg%3}Q4~^q6C`tr}&Sel`C~2BkP@;e-$H9Fu$T&DJ zl%t?w#2kV+AuSA^0Edy(SqY&Nr_5~D{eB(FXs|r}EsJpO8(jytH!A1V%r*G?dpERz zSnG6GgII5e{jmStF}=rmf`~i!^Ctuvv&!5SQyp0&3bW1uix0JC{(rhnHXHH1VPVUB z`{=y!@rS3I4!p=@q)x~Ux_s?k zZTj&2)1PDEg(}?!)M^Z=?{%#m^k#rsjqa&115nM;{W!%&%RT>_p}}7T2l!ZcrtRzs z@F?MNfhy$&2sQ(?m_3f5E~C$AHV1#`!CmPX-#tstWHv? z6tlu*!z#4^xU%LiT=nxc`!>urS3TdH``QiE5DcyDrdrPi&6XvlDh0teYxRG^M@%}A zE`Y*NiF7s_E`efkVhD+j@Cc4Zs0&N5dhf@3c_n*V7d3t^^O9lL&q9<=TXEAvCk9G9 zdj5SoNK);bl^{v~_&@8e|3f+Lc2kr5MkZMW1tb^-gja5I!1fJ`?ScVE)ROAq{=?lcJ0Z{rc-{Le(AzZu0sE~Ow_!IEXCKb9p%mgc4g4-ARLn+ zKaemX_!kHH{oAa+e0#IV`KooR)zaFCvBzyw?~?vN{}Lu9XIiRj?w?EPhoOCIzKPdB zSJ&iKZK|W6I8;q-9@x4BurSFsnD(EDiH{fG8xEz0Gs7@G|LkM^{if%AI%!Ye-#kk@ zSb92TF}KFbk3Y}i$rtRLp)O<^h|IJ%FUQmox_?aXaR@F7GOv(fIuA z`uJ@ksug&;l$e8BIiSA6KFguo%zyj7>T}bd21Dzk`JL`NF5?MHZpj{2H_^OjFakY( zn@t+Hvo`8!dmu{^Y=W_aByfNhjgMvB8M#|`d9ZW-rdb=aW}3%1va(MQ_xUx8ZoHf9 z8a$@3c#FJtBcBWc=~_ekez|qi=0EYv0c+Z>S2=G2S2>#HH3HT?dhG=y1|#tL<=XOr z1xb?33o`=CYSIpl=yMTvJMJ|ZGuT|yaL<-ts2?`|a@NItFEZN%I*39xM%kk`l$nf} zzH0T&f|dCokYdS(_3uabPW*{SM)ldaLL>_#8a^)$p&q@M#{Z=}Az}pDc#*Tuj;(*T zFAj76xYXD5y4J02Pj|%x1Ifo{^;i6PgCd+t3UVy}Rk5ISVe+mv(TzUO59yy%?ek_F zw92BMiP6c;1-m~4E}KmZ#5t8imBz8EDx?$KDd z;MT9nX2Y8y5%*&+UW{~kvNhWBNhA03L2}{3nKM5tT`gCE@COE0gucrm#(eqg&{*eO zZcR#hbM~#dM{W%;>SDWI7{CZLvNM{<`M&UQHj-r9+;A20)k!)(W9v6_D@DW6*qOd{ z2Nv2~thjTpsqKt)eUC>N)PLY(!-}1Xk~zn>_{~;cI~q*aE~Ujt_e}(l^mYq21;oDf z_uT#D<<+voks$o)jo0mdMa=nsrJZ*?)!+ZXFRm>k`(BYv$SPSG_sX7GH)JKUvMMvK zYZOIxR<_9Al#rE@5wb_hh_Yu9_xHYTczho{9{D^TzrWtzkN0`K&Urmwuh%)}eeQAI zeK3yTrl|bQ8e$QnRd14xhIORX+ZJJaFhcHjM)PT%GmHjZNLNLwurf~5Mz->t40aHs6qji2XF4gdJIP1L=GT+&b7XAU?3 zeXuFCU_6%KVXo^p^UV>nn1%%Q-|H@BZgmB(@23+c;?NV-D>L_J7B6oYD7+cYsVw~% z!DrAnC|E{QVoR@I!5e4Iqpa)`_EHJ2L~E92_hHWOPY5O_uzV6nUw=|QxpDiO;_LjK zX|oi!U9vam-I;IVM5DkEkcAT;3O4|SPl=ftmD(F@E)b~A7D(rtUtBH+Ms zVt(0qCIAld3VZ)1n0d4k1NGuDP$n=TN!N7S&ftXTtc&V{YYC?jNRlj}I3PiQD zdPxOSjXbGyC-1-RH3=%b~-rK{*Re7(HV4nYrL;xNRu=^IlG?_yq9Dllb+wB#2 z;kv!-@BX|YZ33h**qew`9w-w4fJNa3qQI0Wd@u^13}AgA_OIq))czAPFtyN%xsUO& zb@&nrxI4FPh`Ersv0yGlI5-DY5&)F}UIhpJL4K0CC%Htmo7*kY$6L?G(9Um_viFst zXya;o^4QJ9?~(?XHviKmtk>_&5{{k|exK3IZP5#dFxcsnHM4Ff4-Mq<@dAfL{+sxT zRRHoAVFl&SHIPlwxLl_!n`^x8oa<3-2r_+bBTB@K0u!LXmH+n6@+ZR&Sq?Bgw1N3PMWGpq<uT-RbIvU?U5Lm%O zLG5>i>55&)^`Oop=cWbVdnp^h87PsU)BsQb2&nWdzPhfZhQoC#?u{ELZ67hSsUN?Q zQ_Sb+O48M+N8+9fLqKjTIzgDiIG8p@a8~P9pJ~$=wW=p9r)zB2G`maNxFlZm@Xly1 z(7Rv@y%)59I;>FbK{yf|^!R@3!lI)2m|zRvzJNv-@C!5wlnQi#a(^yRvHRB6w814j z=!1UI%S%7T4~ERdflG+ysJq$W6m)TfxMfpCv7@CEa^IqTExi-Rv%s~gntnn6W>$9-nSj17$61 zEz!1$`W|Q9DFuO^UismD`;i5+TiALOz4&?G4eCO9Fw!>(Zx8y|2XVXw%ctD}>qMX43@l|oHG~e6*e*X4 zc)E7q^N>6TasPekf=uB7*)%Jmgfu@*fta$7wT=uyNv~Ycwa5nGy{GH$0eOt0m@Ghh z+s*G9orCE6cGg(%0!bW9MFK%c1w4*U-6Qh0u4T)MbA4s-7p_y2CG&{F!c9ei<=#ns zFoDQl;E>GdL&hXmm->$IXkkO3Jcfi6|7276m{h z&)06Cq`kt>Xn*W@a#5%w@!ML64%Le!FI)zV!8ctwFfBTfK?$AG!9!cQ=Y&`dwuz+Z zY@6B%Z=F)uGMUP{GhZL{gC*!yx0P-%1XQ1ZK8~`aWOZpf+VZsGTHUA&QHtcq)>p`( zEatTNGRi@Wtp`9-xZP?ff0mPnF<%y7QVl>16zNt943uSb>9}C_IR0;xS!&1P)}yOl zV{HYoe5{F-skl-4Yh>N_$jGBtwzSncwcpvDRm;v{&s6@XHMdQM7a{abd)g)Tu|lSSvR5~U{N37vrw zG(+f(*83)b$ip4-PL&rLx}OS1$h<`kd8Xpy!4ih$&_J>)2+LQmu`A@$SEnD`ZvD92 z#0ru_qveb7(8xmv@J_O+C$sZ}UkacMyXvA7A@HN_peE zkP%;KB=PKD4j`pzTdDFS9o@R-TEUNQc+yf|0em(1| ziDM=PmE4ih0t(CTOTi^~e+3j1PHEWOTDk2W`EaM^F*)EnsP+Q~20u4+mG{ zBwo%AtF`m;D@3FUer801lsQxC(i)@wD80L}_kRo6s?#eHHsQEcPi$@kO)v#m(bPGp_3-(^m+eGuWGlr9&j-mwz4MNM(4C{aeHB6`= zAe!o-_bgcPZ`cki+sVLhtcXM-ZN=+sI?4l~@Z6UmA{$kApqz3N9mU!$Mzx1f$NXJa zhX%e2M}3&v4ty+V^bRkFh!!K`3nM8(1edNfNzaS4mF~_%=9SfpD`%u^6PmVY8=uI@ zy)jk!-L>^J{=$xso-mL9NGAm3(x!XNTsWnyxckw4kfG-?)T#_=1FTV+u=y%!WrH`h@DriNGv!CC- z?Ge2VhRv^}rAxE*vBavW&FAnp>i$vi9IEfBnBE$GOYMkM5Zx!r`Td&s-JzSv{oV`r ze7C_{S3O4KY{*sb9+BFBq2j)GO=x#S4dt>uVtsGZ>){Z`s>m7bMUt*p?F|8$%-uL9 zWn#lOLb&?E*Xl-X91X4q)0NNf#>V)~ zsshz^WjCrqn5g+rV={4F7llJ)IiseSHczz$e{wIQ1 zaJzRxZ#uV+tDt8bM6*f3_@*I+rec>ZVROrN*Kc$~Z*^TE=C^2IIO0&YL4Y)Uw*Nto zSEf*dSmBqahAu_C0R8;u@iCr54h=y{nlbg~KZtlIWCCBI<6`V3(NB?pB^8-mR4N_( znhF7}*~%Yt(2~8mSe3LK_;$u_?7|z#ENz)jDla>$Zx9N;tUltfind}4U$KapDzTH z=cWv(huhj_P~6HzY)&DS=z#{+h%0yhpaaf2vZno7kv3G=O!w;gF4xeqcDrDaCh^WQ zsF2Kio<_X}io>bX%Uy#3&QLz77+Oo?4_fiQffCz08JP~rwUMjIiz%FHfRP9$RxNY2 z;45I<(D^lI#ljINQQ?RCUJe_sLtdE2BPgZ)0XTTtOL*xz@bou8NSIp=0tF?HrcqtxnrvYsQbZ-D7qBBE*` z9G_(X-!(2kyGzh_N%2n3-Y-1Xm@fT1~dPdmlP zAm2*3?uMt~H)Y_!)Koy1J_llPDj!c>@4Q9%_mMz_fSoTjIQ>u$MLfE}1o>u6ZD(^k zuMaM@yj;C&|5|QXfqYF>+gR^a z{6wj+FjSf31;Y7+XmfV&i}Mie`c$(vL}%ZARAtRHQICb8<5}D;0+V&Tmt9Eu$#`nw zN)J@1Cz`rg&=87Mk)`tE<^?OhpFeL&_{>C}@>mfFQ2k)N_ie9&9@yE7;VFL+>d51d zf4h*A>?qf-j$MXV^(vaiQ6_&gs)E#;CZ7qFPM$@FN^TzIy7L|Vj@>G_)$S@O$Vaj~tc-P+__27Axs8VD%VDD#*Vo3TA99j8QBi`ee7rP-^w#fs-jZukbrfg1Fl z9fhQ%razS;-OsWJrIM|3t*Ys1Z|1FERjue|fkOPhSh=X|exw}r*ufeq;HtwT=lD+K z$DJ1E#CH7CDoN7b^pmH2%4T~?|FA0l-o(tH!^iWckRvcSlX@c;%A`A#vJSBt!>afX z1B@tC{~SZXx&=Y+5i5I3VNd=@iiT@LEZsA2!!Hej{SjSzg-^~*@@^caZysqLONK^Z zX<{lPo}S8zG~cJoeHV%0RCHUz=GdWwA(BveU4w{?z-PFN5 zl-J?;3b}Fbj^ZkmH_Nv*g6&~)_9VHkFV8stlN@+h`GQ_F!DHYH^H`JR{#>AzlAO5_ z&EZ{GLs5^k)PPtcFDl{YB%xJ6H(>!zr)JOr~{%(z)%@%@p;p zfY_E#7Lvo^qEL}bB|Yt9p^KOqTxKeA$Qy|s@=2A)O;_+Vy+)3g&5k372akPs3m14o{AL1dd3!OddF-l< z9x11iJ^d|cZKZQ(jk>JRgifm~w-E0do(}rRRbs3!;@|EyDEqctCUE)8r8F7ZKX%_L z7JW^PAM@eDgETyH6{mO(-y+i}|DUj~kv|oeWH(S1_Y|+qx4}Vy0Fupg-Qh>pO~bEP zK{fR|Z=bw7MHr|tdI{t0E&E)b9qyBHoI{=u!& zkG>dnDV$nRpu5&v?L#d>!PqB0fP0R8_7HKmdDlaSk~_9bQpHBP9Hm*xW8)&Bo<$4a z`JiJ_Kb>%aWhA#V2Z#YS2&R=Pf?v7AuVRw-5L2#jZJY#e4#w!YHJgM}zbTFo3!NqI z;@aqwey+YQLz$jf0`+tGDEsXF^(ZnLpT7{>;BA?{j-0!MrBwW?yF*Ea^37_#-8O8{ zXFfV2-N*EFg6^i)bM8Oc0Oe(1ceEgei_`wY|4ZU_^v`e1yr@omd=FnSTiE;bi1 z@ttpL;QsO!OGoqvXYg~RU%XprV}L>S)6&F4YLipBR>W-I#vO(=)I!zfm*28D&$6md z>uku)X?-k-sf2(&rkEa6>l0PoQ7qSPXx5I&Tl4ptY&s`FX=rzD!y$2Y@rYW{B!NXw z-wU>c2jUe94|FPWd2fDm)Izw2Ui!iE7d7s4Au=pv^zK+{oJ6a>8BPnyp;NB-J<`qR zqc662N928NV8#7KjisiVZtRyp5GxeBd!P;Y-kxb^MAWU?(u%~kXv$OYN2-JnXI?%8Bj zitn==>fw&MezhK18ABRKLmIhJSqNy*YWO(AJ*c$fz3(S%@92(7%ucCxhWJ=k8rOT) zlqTV0mV>YhfD@T44)21N{pJIfdT?9Da&puBuGMINkj|RO!+enGe>42@8f^)AHhUlz z2D5y~@RT5H=A5gG>Zt8tOsrpv-?eGyiZ>68ulxx=#vT*NPxjociMR-vG~3b2<{S`; zlkn+n8#t6&E|=5FZTHV;fAWM^Gy22&xbqD0qc3jBh2p7DJ1bHL10DhQL(2ZIayYIj zR6+}%qm3_p%knxEl6Ea_*Q#I{toT;Z|Sa!&G z*DldPl-e8%caG3m?!J9yWstPz$^SSZ-mnfQv;1!YZM+C&T*oBg8Lv7wKTx2!2-K$dW(e?E)w=`x&0`4eWC-m z$y7^d-!DS# literal 0 HcmV?d00001 diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples.hs new file mode 100644 index 00000000000..7fcebb2f7df --- /dev/null +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Cardano.Ledger.Babel.Examples ( + CHAINExample (..), + testCHAINExample, +) +where + +import Cardano.Ledger.Block (Block) +import Cardano.Ledger.Babel (BabelEra) +import Cardano.Ledger.Babel.Era (BabelBBODY) +import Cardano.Ledger.Babel.Rules +import Cardano.Protocol.TPraos.BHeader (BHeader) +import Control.State.Transition.Extended hiding (Assertion) +import Data.List.NonEmpty (NonEmpty) +import Test.Cardano.Ledger.Babel.Rules.Chain ( + CHAIN, + ChainEvent (BbodyEvent), + ChainState, + TestChainPredicateFailure (BbodyFailure), + totalAda, + ) +import Test.Cardano.Ledger.Babel.TreeDiff (expectExprEqual) +import Test.Cardano.Ledger.Babel.Utils (applySTSTest, maxLLSupply, runShelleyBase) +import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (StandardCrypto, TestCrypto) +import Test.Control.State.Transition.Trace (checkTrace, (.-), (.->>)) +import Test.Tasty.HUnit (Assertion, (@?=)) + +type A = BabelEra TestCrypto + +instance Embed (BabelBBODY A) (CHAIN A) where + wrapFailed = BbodyFailure + wrapEvent = BbodyEvent + +data CHAINExample h era = CHAINExample + { startState :: ChainState era + -- ^ State to start testing with + , newBlock :: Block h era + -- ^ Block to run chain state transition system on + , intendedResult :: Either (NonEmpty (PredicateFailure (CHAIN era))) (ChainState era) + -- ^ type of fatal error, if failure expected and final chain state if success expected + } + +-- | Runs example, applies chain state transition system rule (STS), +-- and checks that trace ends with expected state or expected error. +testCHAINExample :: CHAINExample (BHeader StandardCrypto) (BabelEra StandardCrypto) -> Assertion +testCHAINExample (CHAINExample initSt block (Right expectedSt)) = do + ( checkTrace @(CHAIN (BabelEra StandardCrypto)) + runShelleyBase + () + (pure initSt .- block .->> expectedSt) + ) + >> expectExprEqual (totalAda expectedSt) maxLLSupply +testCHAINExample (CHAINExample initSt block predicateFailure@(Left _)) = do + let st = runShelleyBase $ applySTSTest @(CHAIN (BabelEra StandardCrypto)) (TRC ((), initSt, block)) + st @?= predicateFailure \ No newline at end of file diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Combinators.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Combinators.hs new file mode 100644 index 00000000000..f00414ad6b2 --- /dev/null +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Combinators.hs @@ -0,0 +1,834 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Test.Cardano.Ledger.Shelley.Examples.Combinators +-- Description : Chain State Combinators +-- +-- A collection of combinators for manipulating Chain State. +-- The idea is to provide a clear way of describing the +-- changes to the chain state when a block is processed. +module Test.Cardano.Ledger.Babel.Examples.Combinators ( + evolveNonceFrozen, + evolveNonceUnfrozen, + newLab, + feesAndKeyRefund, + feesAndDeposits, + newUTxO, + newStakeCred, + deregStakeCred, + delegation, + newPool, + reregPool, + updatePoolParams, + stageRetirement, + reapPool, + mir, + applyMIR, + rewardUpdate, + pulserUpdate, + applyRewardUpdate, + setPoolDistr, + setOCertCounter, + newSnapshot, + incrBlockCount, + -- newEpoch, + setCurrentProposals, + setFutureProposals, + setPParams, + setPrevPParams, + setFutureGenDeleg, + adoptFutureGenDeleg, +) +where + +import Cardano.Ledger.Address (RewardAccount (..)) +import Cardano.Ledger.BaseTypes ( + BlocksMade (..), + Nonce (..), + StrictMaybe (..), + (⭒), + ) +import Cardano.Ledger.Block ( + Block (..), + bheader, + ) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Credential ( + Credential (..), + Ptr, + ) +import Cardano.Ledger.EpochBoundary (SnapShot, SnapShots (..), calculatePoolDistr) +import Cardano.Ledger.Keys ( + GenDelegPair, + GenDelegs (..), + KeyHash, + KeyRole (..), + ) +import Cardano.Ledger.PoolDistr (PoolDistr (..)) +import Cardano.Ledger.PoolParams (PoolParams (..)) +import Cardano.Ledger.Shelley.Core +import Cardano.Ledger.Shelley.LedgerState ( + AccountState (..), + CertState (..), + DState (..), + EpochState (..), + FutureGenDeleg (..), + InstantaneousRewards (..), + LedgerState (..), + NewEpochState (..), + PState (..), + PulsingRewUpdate (..), + RewardUpdate (..), + UTxOState (..), + applyRUpd, + curPParamsEpochStateL, + delegations, + prevPParamsEpochStateL, + rewards, + updateStakeDistribution, + ) +import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates) +import Cardano.Ledger.Shelley.Rules (emptyInstantaneousRewards) +import Cardano.Ledger.UMap ( + RDPair (..), + UView (PtrUView, RewDepUView, SPoolUView), + fromCompact, + unUView, + ) +import qualified Cardano.Ledger.UMap as UM +import Cardano.Ledger.UTxO (UTxO (..), txins, txouts) +import Cardano.Ledger.Val ((<+>), (<->), (<×>)) +import Cardano.Protocol.TPraos.BHeader ( + BHBody (..), + BHeader, + LastAppliedBlock (..), + bhHash, + bhbody, + -- lastAppliedHash, + -- prevHashToNonce, + ) +import Cardano.Slotting.Slot (EpochNo, WithOrigin (..)) +import Data.Default.Class (Default (..)) +import Data.Foldable (fold, foldl') +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Word (Word64) +import Lens.Micro ((&), (.~), (^.)) +import Test.Cardano.Ledger.Babel.Rules.Chain (ChainState (..)) + +-- import Lens.Micro.Extras (view) + +-- import Test.Cardano.Ledger.Shelley.Utils (epochFromSlotNo, getBlockNonce) + +-- ====================================================== + +-- | = Evolve Nonces - Frozen +-- +-- Evolve the appropriate nonces under the assumption +-- that the candidate nonce is now frozen. +evolveNonceFrozen :: forall era. Nonce -> ChainState era -> ChainState era +evolveNonceFrozen n cs = cs {chainEvolvingNonce = chainEvolvingNonce cs ⭒ n} + +-- | = Evolve Nonces - Unfrozen +-- +-- Evolve the appropriate nonces under the assumption +-- that the candidate nonce is not frozen. +-- Note: do not use this function when crossing the epoch boundary, +-- instead use 'newEpoch'. +evolveNonceUnfrozen :: forall era. Nonce -> ChainState era -> ChainState era +evolveNonceUnfrozen n cs = + cs + { chainCandidateNonce = chainCandidateNonce cs ⭒ n + , chainEvolvingNonce = chainEvolvingNonce cs ⭒ n + } + +-- | = New 'LastAppliedBlock' (*NOT* on epoch boundaries) +-- +-- Update the chain state with the details of 'LastAppliedBlock' +-- that occur when a new block is processed. +-- Note: do not use this function when crossing the epoch boundary, +-- instead use 'newEpoch'. +newLab :: + forall era. + Era era => + Block (BHeader (EraCrypto era)) era -> + ChainState era -> + ChainState era +newLab b cs = + cs {chainLastAppliedBlock = At $ LastAppliedBlock bn sn (bhHash bh)} + where + bh = bheader b + bn = bheaderBlockNo . bhbody $ bh + sn = bheaderSlotNo . bhbody $ bh + +-- | = Update Fees and Deposits +-- +-- Update the fee pot and deposit pot with the new fees and deposits +-- adjust the deposit tables in the UTxOState and the CertState. +-- Notes +-- 1) do not give this function duplicates in the 'stakes' or 'pools' inputs. +-- 2) do not use this function when crossing the epoch boundary, +-- instead use 'newEpoch'. +feesAndDeposits :: + forall era. + EraPParams era => + PParams era -> + Coin -> + [Credential 'Staking (EraCrypto era)] -> + [PoolParams (EraCrypto era)] -> + ChainState era -> + ChainState era +feesAndDeposits ppEx newFees stakes pools cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + ls = esLState es + CertState vstate pstate dstate = lsCertState ls + utxoSt = lsUTxOState ls + utxoSt' = + utxoSt + { utxosDeposited = + utxosDeposited utxoSt + <+> (length stakes <×> ppEx ^. ppKeyDepositL) + <+> (newcount <×> ppEx ^. ppPoolDepositL) + , utxosFees = utxosFees utxoSt <+> newFees + } + ls' = ls {lsUTxOState = utxoSt', lsCertState = dpstate'} + -- Count the number of new pools, because we don't take a deposit for existing pools + -- This strategy DOES NOT WORK if there are duplicate PoolParams in one call + newcount = foldl' accum 0 pools + accum n x = if Map.member (ppId x) (psDeposits pstate) then (n :: Integer) else n + 1 + newDeposits = + Map.fromList (map (\cred -> (cred, UM.compactCoinOrError (ppEx ^. ppKeyDepositL))) stakes) + newPools = Map.fromList (map (\p -> (ppId p, ppEx ^. ppPoolDepositL)) pools) + dpstate' = + CertState + vstate + pstate {psDeposits = Map.unionWith (\old _new -> old) newPools (psDeposits pstate)} + dstate {dsUnified = UM.unionKeyDeposits (RewDepUView (dsUnified dstate)) newDeposits} + es' = es {esLState = ls'} + nes' = nes {nesEs = es'} + +feesAndKeyRefund :: + forall era. + Coin -> + Credential 'Staking (EraCrypto era) -> + ChainState era -> + ChainState era +feesAndKeyRefund newFees key cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + ls = esLState es + CertState _vstate pstate dstate = lsCertState ls + refund = case UM.lookup key (RewDepUView (dsUnified dstate)) of + Nothing -> Coin 0 + Just (RDPair _ ccoin) -> fromCompact ccoin + utxoSt = lsUTxOState ls + utxoSt' = + utxoSt + { utxosDeposited = utxosDeposited utxoSt <-> refund + , utxosFees = utxosFees utxoSt <+> newFees + } + ls' = ls {lsUTxOState = utxoSt', lsCertState = dpstate'} + es' = es {esLState = ls'} + nes' = nes {nesEs = es'} + dpstate' = CertState def pstate dstate {dsUnified = UM.adjust zeroD key (RewDepUView (dsUnified dstate))} + zeroD (RDPair x _) = RDPair x (UM.CompactCoin 0) + +-- | = Update the UTxO +-- +-- Update the UTxO for given transaction body. +newUTxO :: + forall era. + (EraTx era, EraGov era) => + TxBody era -> + ChainState era -> + ChainState era +newUTxO txb cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + ls = esLState es + utxoSt = lsUTxOState ls + utxo = unUTxO $ utxosUtxo utxoSt + utxoAdd = txouts @era txb + utxoToDel = Map.restrictKeys utxo (txins @era txb) + utxoWithout = Map.withoutKeys utxo (txins @era txb) + utxoDel = UTxO utxoToDel + utxo' = UTxO (utxoWithout `Map.union` unUTxO utxoAdd) + sd' = + updateStakeDistribution @era (es ^. curPParamsEpochStateL) (utxosStakeDistr utxoSt) utxoDel utxoAdd + utxoSt' = utxoSt {utxosUtxo = utxo', utxosStakeDistr = sd'} + ls' = ls {lsUTxOState = utxoSt'} + es' = es {esLState = ls'} + nes' = nes {nesEs = es'} + +-- | = New Stake Credential +-- +-- Add a newly registered stake credential, initialize the rdRewards component of the RDPair. +-- The rdDeposit component of the RDPair is set by 'feesAndDeposits' +newStakeCred :: + forall era. + Credential 'Staking (EraCrypto era) -> + Ptr -> + ChainState era -> + ChainState era +newStakeCred cred ptr cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + ls = esLState es + dps = lsCertState ls + ds = certDState dps + ds' = + ds + { dsUnified = + let um0 = dsUnified ds + um1 = UM.insert cred (UM.RDPair (UM.CompactCoin 0) (UM.CompactCoin 0)) (RewDepUView um0) + um2 = (PtrUView um1 UM.∪ (ptr, cred)) + in um2 + } + dps' = dps {certDState = ds'} + ls' = ls {lsCertState = dps'} + es' = es {esLState = ls'} + nes' = nes {nesEs = es'} + +-- | = De-Register Stake Credential +-- +-- De-register a stake credential and all associated data. +-- Be sure to run 'feesAndKeyRefund' before you run this +-- because this throws away the stored refund, which then +-- can't be used to balance the utxosDeposited field in 'feesAndKeyRefund' +deregStakeCred :: + forall era. + Credential 'Staking (EraCrypto era) -> + ChainState era -> + ChainState era +deregStakeCred cred cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + ls = esLState es + dps = lsCertState ls + ds = certDState dps + ds' = + ds + { dsUnified = + let um0 = dsUnified ds + um1 = UM.delete cred (RewDepUView um0) + um2 = PtrUView um1 UM.⋫ Set.singleton cred + um3 = UM.delete cred (SPoolUView um2) + in um3 + } + dps' = dps {certDState = ds'} + ls' = ls {lsCertState = dps'} + es' = es {esLState = ls'} + nes' = nes {nesEs = es'} + +-- | = New Delegation +-- +-- Create a delegation from the given stake credential to the given +-- stake pool. +delegation :: + forall era. + Credential 'Staking (EraCrypto era) -> + KeyHash 'StakePool (EraCrypto era) -> + ChainState era -> + ChainState era +delegation cred pool cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + ls = esLState es + dps = lsCertState ls + ds = certDState dps + ds' = + ds + { dsUnified = UM.insert cred pool (delegations ds) + } + dps' = dps {certDState = ds'} + ls' = ls {lsCertState = dps'} + es' = es {esLState = ls'} + nes' = nes {nesEs = es'} + +-- | = New Stake Pool +-- +-- Add a newly registered stake pool +newPool :: + forall era. + PoolParams (EraCrypto era) -> + ChainState era -> + ChainState era +newPool pool cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + ls = esLState es + dps = lsCertState ls + ps = certPState dps + ps' = + ps + { psStakePoolParams = Map.insert (ppId pool) pool (psStakePoolParams ps) + } + dps' = dps {certPState = ps'} + ls' = ls {lsCertState = dps'} + es' = es {esLState = ls'} + nes' = nes {nesEs = es'} + +-- | = Re-Register Stake Pool +reregPool :: + forall era. + PoolParams (EraCrypto era) -> + ChainState era -> + ChainState era +reregPool pool cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + ls = esLState es + dps = lsCertState ls + ps = certPState dps + ps' = + ps + { psFutureStakePoolParams = Map.insert (ppId pool) pool (psStakePoolParams ps) + } + dps' = dps {certPState = ps'} + ls' = ls {lsCertState = dps'} + es' = es {esLState = ls'} + nes' = nes {nesEs = es'} + +-- | = Re-Register Stake Pool +updatePoolParams :: + forall era. + PoolParams (EraCrypto era) -> + ChainState era -> + ChainState era +updatePoolParams pool cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + ls = esLState es + dps = lsCertState ls + ps = certPState dps + ps' = + ps + { psStakePoolParams = Map.insert (ppId pool) pool (psStakePoolParams ps) + , psFutureStakePoolParams = Map.delete (ppId pool) (psStakePoolParams ps) + } + dps' = dps {certPState = ps'} + ls' = ls {lsCertState = dps'} + es' = es {esLState = ls'} + nes' = nes {nesEs = es'} + +-- | = Pool Retirement +-- +-- Stage a stake pool for retirement. +stageRetirement :: + forall era. + KeyHash 'StakePool (EraCrypto era) -> + EpochNo -> + ChainState era -> + ChainState era +stageRetirement kh e cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + ls = esLState es + dps = lsCertState ls + ps = certPState dps + ps' = ps {psRetiring = Map.insert kh e (psRetiring ps)} + dps' = dps {certPState = ps'} + ls' = ls {lsCertState = dps'} + es' = es {esLState = ls'} + nes' = nes {nesEs = es'} + +-- | = Reap Pool +-- +-- Remove a stake pool. +reapPool :: + forall era. + EraGov era => + PoolParams (EraCrypto era) -> + ChainState era -> + ChainState era +reapPool pool cs = cs {chainNes = nes'} + where + kh = ppId pool + nes = chainNes cs + es = nesEs nes + ls = esLState es + dps = lsCertState ls + ps = certPState dps + ps' = + ps + { psRetiring = Map.delete kh (psRetiring ps) + , psStakePoolParams = Map.delete kh (psStakePoolParams ps) + , psDeposits = Map.delete kh (psDeposits ps) + } + pp = es ^. curPParamsEpochStateL + ds = certDState dps + RewardAccount _ rewardAddr = ppRewardAccount pool + (rewards', unclaimed) = + case UM.lookup rewardAddr (rewards ds) of + Nothing -> (rewards ds, pp ^. ppPoolDepositL) + Just (UM.RDPair ccoin dep) -> + ( UM.insert' + rewardAddr + (UM.RDPair (UM.addCompact ccoin (UM.compactCoinOrError (pp ^. ppPoolDepositL))) dep) + (rewards ds) + , Coin 0 + ) + -- FIXME shouldn't we look up the pooldeposit here? + umap1 = unUView rewards' + umap2 = UM.SPoolUView umap1 UM.⋫ Set.singleton kh + ds' = ds {dsUnified = umap2} + as = esAccountState es + as' = as {asTreasury = asTreasury as <+> unclaimed} + utxoSt = lsUTxOState ls + utxoSt' = utxoSt {utxosDeposited = utxosDeposited utxoSt <-> (pp ^. ppPoolDepositL)} + dps' = dps {certPState = ps', certDState = ds'} + ls' = ls {lsCertState = dps', lsUTxOState = utxoSt'} + es' = es {esLState = ls', esAccountState = as'} + nes' = nes {nesEs = es'} + +-- | = MIR +-- +-- Add a credential to the MIR mapping for the given pot (reserves or treasury) +mir :: + forall era. + Credential 'Staking (EraCrypto era) -> + MIRPot -> + Coin -> + ChainState era -> + ChainState era +mir cred pot amnt cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + ls = esLState es + dps = lsCertState ls + ds = certDState dps + InstantaneousRewards + { iRReserves = ir + , iRTreasury = it + , deltaReserves = dr + , deltaTreasury = dt + } = dsIRewards ds + irwd' = case pot of + ReservesMIR -> InstantaneousRewards (Map.insert cred amnt ir) it dr dt + TreasuryMIR -> InstantaneousRewards ir (Map.insert cred amnt it) dr dt + ds' = ds {dsIRewards = irwd'} + dps' = dps {certDState = ds'} + ls' = ls {lsCertState = dps'} + es' = es {esLState = ls'} + nes' = nes {nesEs = es'} + +-- | = Apply MIR +-- +-- On the epoch boundary, reset the MIR mappings and augment the rewards. +applyMIR :: + forall era. + MIRPot -> + Map (Credential 'Staking (EraCrypto era)) Coin -> + ChainState era -> + ChainState era +applyMIR pot newrewards cs = cs {chainNes = nes'} + where + tot = fold newrewards + nes = chainNes cs + es = nesEs nes + ls = esLState es + dps = lsCertState ls + ds = certDState dps + ds' = + ds + { dsUnified = rewards ds UM.∪+ Map.map UM.compactCoinOrError newrewards + , dsIRewards = emptyInstantaneousRewards + } + dps' = dps {certDState = ds'} + ls' = ls {lsCertState = dps'} + as = esAccountState es + as' = + if pot == ReservesMIR + then as {asReserves = asReserves as <-> tot} + else as {asTreasury = asTreasury as <-> tot} + es' = es {esAccountState = as', esLState = ls'} + nes' = nes {nesEs = es'} + +-- | = Reward Update +-- +-- Update the chain state with the given reward update +rewardUpdate :: + forall era. + RewardUpdate (EraCrypto era) -> + ChainState era -> + ChainState era +rewardUpdate ru cs = cs {chainNes = nes'} + where + nes' = (chainNes cs) {nesRu = SJust (Complete ru)} + +-- | = Pulser +-- +-- Update the chain state with the given reward update pulser +pulserUpdate :: + forall era. + PulsingRewUpdate (EraCrypto era) -> + ChainState era -> + ChainState era +pulserUpdate p cs = cs {chainNes = nes'} + where + nes' = (chainNes cs) {nesRu = SJust p} + +-- | = Apply a Reward Update +-- +-- Apply the given reward update to the chain state +applyRewardUpdate :: + forall era. + EraGov era => + RewardUpdate (EraCrypto era) -> + ChainState era -> + ChainState era +applyRewardUpdate ru cs = cs {chainNes = nes'} + where + nes = chainNes cs + es' = applyRUpd ru (nesEs nes) + nes' = (chainNes cs) {nesEs = es', nesRu = SNothing} + +-- | = New Snapshot +-- +-- Add a new snapshot and rotate the others +newSnapshot :: + forall era. + SnapShot (EraCrypto era) -> + Coin -> + ChainState era -> + ChainState era +newSnapshot snap fee cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + SnapShots + { ssStakeMark = ssMark + , ssStakeSet = ssSet + } = esSnapshots es + snaps = + SnapShots + { ssStakeMark = snap + , ssStakeMarkPoolDistr = calculatePoolDistr snap + , ssStakeSet = ssMark + , ssStakeGo = ssSet + , ssFee = fee + } + es' = es {esSnapshots = snaps} + nes' = nes {nesEs = es'} + +-- | = Set Pool Distribution +-- +-- Set the stake pool distribution to the given one. +setPoolDistr :: + forall era. + PoolDistr (EraCrypto era) -> + ChainState era -> + ChainState era +setPoolDistr pd cs = cs {chainNes = nes'} + where + nes' = (chainNes cs) {nesPd = pd} + +-- | = Set Operation Certificate Counter +-- +-- Set the operational certificates counter for a given stake pool. +setOCertCounter :: + forall era. + KeyHash 'BlockIssuer (EraCrypto era) -> + Word64 -> + ChainState era -> + ChainState era +setOCertCounter kh n cs = cs {chainOCertIssue = counters} + where + counters = Map.insert kh n (chainOCertIssue cs) + +-- | = Increase Block Count +-- +-- Record that the given stake pool (non-core node) produced a block. +incrBlockCount :: + forall era. + KeyHash 'StakePool (EraCrypto era) -> + ChainState era -> + ChainState era +incrBlockCount kh cs = cs {chainNes = nes'} + where + nes = chainNes cs + BlocksMade bs = nesBcur nes + n = 1 + Map.findWithDefault 0 kh bs + bs' = BlocksMade $ Map.insert kh n bs + nes' = nes {nesBcur = bs'} + +-- | = New Epoch +-- +-- Update the new epoch number, set the nonces, set the last applied block, +-- and reset blocks made. +-- Note: This function subsumes the manipulations done by +-- 'newLab', 'evolveNonceUnfrozen', and 'evolveNonceFrozen'. +-- newEpoch :: +-- forall era. +-- (ProtVerAtMost era 6, EraGov era) => +-- Block (BHeader (EraCrypto era)) era -> +-- ChainState era -> +-- ChainState era +-- newEpoch b cs = cs' +-- where +-- ChainState +-- { chainNes = nes +-- , chainEvolvingNonce = evNonce +-- , chainCandidateNonce = cNonce +-- , chainPrevEpochNonce = pNonce +-- , chainLastAppliedBlock = lab +-- } = cs +-- bh = bheader b +-- bn = bheaderBlockNo . bhbody $ bh +-- sn = bheaderSlotNo . bhbody $ bh +-- pp = view curPParamsEpochStateL . nesEs $ nes +-- e = epochFromSlotNo . bheaderSlotNo . bhbody . bheader $ b +-- nes' = +-- nes +-- { nesEL = e +-- , nesBprev = nesBcur nes +-- , nesBcur = BlocksMade Map.empty +-- } +-- n = getBlockNonce b +-- cs' = +-- cs +-- { chainNes = nes' +-- , chainEpochNonce = cNonce ⭒ pNonce ⭒ (pp ^. ppExtraEntropyL) +-- , chainEvolvingNonce = evNonce ⭒ n +-- , chainCandidateNonce = evNonce ⭒ n +-- , chainPrevEpochNonce = prevHashToNonce . lastAppliedHash $ lab +-- , chainLastAppliedBlock = At $ LastAppliedBlock bn sn (bhHash bh) +-- } + +-- | = Set Current Proposals +-- +-- Set the current protocol parameter proposals. +setCurrentProposals :: + forall era. + GovState era ~ ShelleyGovState era => + ProposedPPUpdates era -> + ChainState era -> + ChainState era +setCurrentProposals ps cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + ls = esLState es + utxoSt = lsUTxOState ls + ppupSt = utxosGovState utxoSt + ppupSt' = ppupSt {sgsCurProposals = ps} + utxoSt' = utxoSt {utxosGovState = ppupSt'} + ls' = ls {lsUTxOState = utxoSt'} + es' = es {esLState = ls'} + nes' = nes {nesEs = es'} + +-- | = Set Future Proposals +-- +-- Set the future protocol parameter proposals. +setFutureProposals :: + forall era. + GovState era ~ ShelleyGovState era => + ProposedPPUpdates era -> + ChainState era -> + ChainState era +setFutureProposals ps cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + ls = esLState es + utxoSt = lsUTxOState ls + ppupSt = utxosGovState utxoSt + ppupSt' = ppupSt {sgsFutureProposals = ps} + utxoSt' = utxoSt {utxosGovState = ppupSt'} + ls' = ls {lsUTxOState = utxoSt'} + es' = es {esLState = ls'} + nes' = nes {nesEs = es'} + +-- | = Set the Protocol Proposals +-- +-- Set the protocol parameters. +setPParams :: + forall era. + EraGov era => + PParams era -> + ChainState era -> + ChainState era +setPParams pp cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + es' = es & curPParamsEpochStateL .~ pp + nes' = nes {nesEs = es'} + +-- | = Set the Previous Protocol Proposals +-- +-- Set the previous protocol parameters. +setPrevPParams :: + forall era. + EraGov era => + PParams era -> + ChainState era -> + ChainState era +setPrevPParams pp cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + es' = es & prevPParamsEpochStateL .~ pp + nes' = nes {nesEs = es'} + +-- | = Set a future genesis delegation. +setFutureGenDeleg :: + forall era. + (FutureGenDeleg (EraCrypto era), GenDelegPair (EraCrypto era)) -> + ChainState era -> + ChainState era +setFutureGenDeleg (fg, gd) cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + ls = esLState es + dps = lsCertState ls + ds = certDState dps + ds' = ds {dsFutureGenDelegs = Map.insert fg gd (dsFutureGenDelegs ds)} + dps' = dps {certDState = ds'} + ls' = ls {lsCertState = dps'} + es' = es {esLState = ls'} + nes' = nes {nesEs = es'} + +-- | = Set a future genesis delegation. +adoptFutureGenDeleg :: + forall era. + (FutureGenDeleg (EraCrypto era), GenDelegPair (EraCrypto era)) -> + ChainState era -> + ChainState era +adoptFutureGenDeleg (fg, gd) cs = cs {chainNes = nes'} + where + nes = chainNes cs + es = nesEs nes + ls = esLState es + dps = lsCertState ls + ds = certDState dps + gds = GenDelegs $ Map.insert (fGenDelegGenKeyHash fg) gd (unGenDelegs (dsGenDelegs ds)) + ds' = + ds + { dsFutureGenDelegs = Map.delete fg (dsFutureGenDelegs ds) + , dsGenDelegs = gds + } + dps' = dps {certDState = ds'} + ls' = ls {lsCertState = dps'} + es' = es {esLState = ls'} + nes' = nes {nesEs = es'} diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Consensus.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Consensus.hs new file mode 100644 index 00000000000..5e189ffea48 --- /dev/null +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Consensus.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Cardano.Ledger.Babel.Examples.Consensus where + +import Cardano.Ledger.Allegra.Scripts (Timelock (..)) +import Cardano.Ledger.Alonzo.Scripts (AlonzoScript (..), ExUnits (..)) +import Cardano.Ledger.Alonzo.Tx (IsValid (..)) +import Cardano.Ledger.Alonzo.TxAuxData ( + AuxiliaryDataHash (..), + mkAlonzoTxAuxData, + ) +import Cardano.Ledger.Alonzo.TxWits (Redeemers (..), TxDats (..)) +import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..)) +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Binary (mkSized) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Babel (Babel) +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Genesis (BabelGenesis (..)) +import Cardano.Ledger.Babel.Governance (VotingProcedures (..)) +import Cardano.Ledger.Babel.Rules (BabelCERTS, BabelCertsPredFailure (..), BabelLEDGER) +import Cardano.Ledger.Babel.Scripts (BabelPlutusPurpose (..)) +import Cardano.Ledger.Babel.Translation () +import Cardano.Ledger.Babel.Tx (AlonzoTx (..)) +import Cardano.Ledger.Babel.TxBody (BabelTxBody (..)) +import Cardano.Ledger.Babel.TxCert +import Cardano.Ledger.Babel.TxWits (AlonzoTxWits (..)) +import Cardano.Ledger.Credential (Credential (KeyHashObj, ScriptHashObj)) +import Cardano.Ledger.Crypto (StandardCrypto) +import Cardano.Ledger.Keys (asWitness) +import Cardano.Ledger.Mary.Value (MaryValue (..)) +import Cardano.Ledger.Plutus.Data ( + Data (..), + Datum (..), + dataToBinaryData, + hashData, + ) +import Cardano.Ledger.Plutus.Language (Language (..)) +import Cardano.Ledger.SafeHash (hashAnnotated) +import Cardano.Ledger.Shelley.API ( + ApplyTxError (..), + NewEpochState (..), + ProposedPPUpdates (..), + RewardAccount (..), + TxId (..), + ) +import Cardano.Ledger.Shelley.Tx (ShelleyTx (..)) +import Cardano.Ledger.TxIn (mkTxInPartial) +import Control.State.Transition.Extended (Embed (..)) +import Data.Default.Class (Default (def)) +import qualified Data.Map.Strict as Map +import qualified Data.OSet.Strict as OSet +import Data.Proxy (Proxy (..)) +import qualified Data.Sequence.Strict as StrictSeq +import qualified Data.Set as Set +import Lens.Micro +import qualified PlutusLedgerApi.Common as P +import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysFails, alwaysSucceeds) +import Test.Cardano.Ledger.Babel.Genesis (expectedBabelGenesis) +import Test.Cardano.Ledger.Core.KeyPair (mkAddr, mkWitnessesVKey) +import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash) +import qualified Test.Cardano.Ledger.Mary.Examples.Consensus as MarySLE +import Test.Cardano.Ledger.Shelley.Examples.Consensus (examplePoolParams) +import qualified Test.Cardano.Ledger.Shelley.Examples.Consensus as SLE + +-- ============================================================== + +-- | ShelleyLedgerExamples for Babel era +ledgerExamplesBabel :: + SLE.ShelleyLedgerExamples Babel +ledgerExamplesBabel = + SLE.ShelleyLedgerExamples + { SLE.sleBlock = SLE.exampleShelleyLedgerBlock exampleTransactionInBlock + , SLE.sleHashHeader = SLE.exampleHashHeader (Proxy @Babel) + , SLE.sleTx = exampleTransactionInBlock + , SLE.sleApplyTxError = + ApplyTxError $ + pure $ + wrapFailed @(BabelCERTS Babel) @(BabelLEDGER Babel) $ + DelegateeNotRegisteredDELEG @Babel (SLE.mkKeyHash 1) + , SLE.sleRewardsCredentials = + Set.fromList + [ Left (Coin 100) + , Right (ScriptHashObj (SLE.mkScriptHash 1)) + , Right (KeyHashObj (SLE.mkKeyHash 2)) + ] + , SLE.sleResultExamples = resultExamples + , SLE.sleNewEpochState = exampleBabelNewEpochState + , SLE.sleChainDepState = SLE.exampleLedgerChainDepState 1 + , SLE.sleTranslationContext = exampleBabelGenesis + } + where + resultExamples = + SLE.ShelleyResultExamples + { SLE.srePParams = def + , SLE.sreProposedPPUpdates = examplePPPU + , SLE.srePoolDistr = SLE.examplePoolDistr + , SLE.sreNonMyopicRewards = SLE.exampleNonMyopicRewards + , SLE.sreShelleyGenesis = SLE.testShelleyGenesis + } + examplePPPU = + ProposedPPUpdates $ + Map.singleton + (SLE.mkKeyHash 0) + (emptyPParamsUpdate & ppuCollateralPercentageL .~ SJust 150) + +collateralOutput :: BabbageTxOut Babel +collateralOutput = + BabbageTxOut + (mkAddr (SLE.examplePayKey, SLE.exampleStakeKey)) + (MaryValue (Coin 8675309) mempty) + NoDatum + SNothing + +exampleBabelCerts :: Era era => OSet.OSet (BabelTxCert era) +exampleBabelCerts = + OSet.fromList -- TODO should I add the new certs here? + [ BabelTxCertPool (RegPool examplePoolParams) + ] + +exampleTxBodyBabel :: TxBody Babel +exampleTxBodyBabel = + BabelTxBody + (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 1)) 0]) -- spending inputs + (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 2)) 1]) -- collateral inputs + (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 1)) 3]) -- reference inputs + ( StrictSeq.fromList + [ mkSized (eraProtVerHigh @Babel) $ + BabbageTxOut + (mkAddr (SLE.examplePayKey, SLE.exampleStakeKey)) + (MarySLE.exampleMultiAssetValue 2) + (Datum $ dataToBinaryData datumExample) -- inline datum + (SJust $ alwaysSucceeds @'PlutusV2 3) -- reference script + ] + ) + (SJust $ mkSized (eraProtVerHigh @Babel) collateralOutput) -- collateral return + (SJust $ Coin 8675309) -- collateral tot + exampleBabelCerts -- txcerts + ( Withdrawals $ + Map.singleton + (RewardAccount Testnet (SLE.keyToCredential SLE.exampleStakeKey)) + (Coin 100) -- txwdrls + ) + (Coin 999) -- txfee + (ValidityInterval (SJust (SlotNo 2)) (SJust (SlotNo 4))) -- txvldt + (Set.singleton $ SLE.mkKeyHash 212) -- reqSignerHashes + exampleMultiAsset -- mint + (SJust $ mkDummySafeHash (Proxy @StandardCrypto) 42) -- scriptIntegrityHash + (SJust . AuxiliaryDataHash $ mkDummySafeHash (Proxy @StandardCrypto) 42) -- adHash + (SJust Mainnet) -- txnetworkid + (VotingProcedures mempty) + mempty + (SJust $ Coin 867530900000) -- current treasury value + mempty + mempty + mempty + mempty + where + MaryValue _ exampleMultiAsset = MarySLE.exampleMultiAssetValue 3 + +datumExample :: Data Babel +datumExample = Data (P.I 191) + +redeemerExample :: Data Babel +redeemerExample = Data (P.I 919) + +exampleTx :: ShelleyTx Babel +exampleTx = + ShelleyTx + exampleTxBodyBabel + ( AlonzoTxWits + (mkWitnessesVKey (hashAnnotated exampleTxBodyBabel) [asWitness SLE.examplePayKey]) -- vkey + mempty -- bootstrap + ( Map.singleton + (hashScript @Babel $ alwaysSucceeds @'PlutusV1 3) + (alwaysSucceeds @'PlutusV1 3) -- txscripts + ) + (TxDats $ Map.singleton (hashData datumExample) datumExample) + ( Redeemers $ + Map.singleton (BabelSpending $ AsIx 0) (redeemerExample, ExUnits 5000 5000) + ) -- redeemers + ) + ( SJust $ + mkAlonzoTxAuxData + SLE.exampleAuxDataMap -- metadata + [alwaysFails @'PlutusV1 2, TimelockScript $ RequireAllOf mempty] -- Scripts + ) + +exampleTransactionInBlock :: AlonzoTx Babel +exampleTransactionInBlock = AlonzoTx b w (IsValid True) a -- mempty + where + ShelleyTx b w a = exampleTx + +exampleBabelNewEpochState :: NewEpochState Babel +exampleBabelNewEpochState = + SLE.exampleNewEpochState + (MarySLE.exampleMultiAssetValue 1) + emptyPParams + (emptyPParams & ppCoinsPerUTxOByteL .~ CoinPerByte (Coin 1)) + +exampleBabelGenesis :: BabelGenesis StandardCrypto +exampleBabelGenesis = expectedBabelGenesis diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Prototype.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Prototype.hs new file mode 100644 index 00000000000..f7648cf8a63 --- /dev/null +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Prototype.hs @@ -0,0 +1,463 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +-- | +-- Module : Test.Cardano.Ledger.Shelley.Examples.Updates +-- Description : Protocol Parameter Update Example +-- +-- Example demonstrating using the protocol parameter update system. +module Test.Cardano.Ledger.Babel.Examples.Prototype where + +import Cardano.Ledger.Allegra.Scripts (Timelock (RequireAllOf)) +import Cardano.Ledger.Alonzo.Data ( + AuxiliaryDataHash (AuxiliaryDataHash), + Datum (NoDatum), + mkAlonzoTxAuxData, + ) +import Cardano.Ledger.Alonzo.Tx (IsValid (IsValid)) +import Cardano.Ledger.Alonzo.TxWits (Redeemers (Redeemers), TxDats (TxDats)) +import Cardano.Ledger.Babbage +import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..)) +import Cardano.Ledger.BaseTypes ( + EpochInterval (EpochInterval), + Network (Mainnet), + Nonce, + StrictMaybe (..), + WithOrigin (At), + ) +import Cardano.Ledger.Binary (mkSized) +import Cardano.Ledger.Block (Block) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Babel (Babel, BabelEra) +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Genesis (BabelGenesis) +import Cardano.Ledger.Babel.Governance (VotingProcedures (VotingProcedures)) +import Cardano.Ledger.Babel.Scripts ( + AlonzoScript (TimelockScript), + BabelPlutusPurpose (BabelSpending), + ) +import Cardano.Ledger.Babel.Tx (AlonzoTx (AlonzoTx)) +import Cardano.Ledger.Babel.TxBody +import Cardano.Ledger.Babel.TxWits (AlonzoTxWits (AlonzoTxWits)) +import Cardano.Ledger.Crypto +import Cardano.Ledger.Keys ( + GenDelegPair (GenDelegPair), + Hash, + KeyPair (KeyPair), + KeyRole (GenesisDelegate), + VerKeyVRF, + asWitness, + hashKey, + vKey, + ) +import Cardano.Ledger.Mary.Value (MaryValue (MaryValue)) +import Cardano.Ledger.Plutus (Datum (Datum), Language (PlutusV1), dataToBinaryData) +import Cardano.Ledger.Plutus.Data (Data (Data), hashData) +import Cardano.Ledger.Plutus.ExUnits (ExUnits (ExUnits)) +import Cardano.Ledger.Plutus.Language (Language (PlutusV2)) +import Cardano.Ledger.SafeHash (hashAnnotated) +import Cardano.Ledger.Shelley.API (hashVerKeyVRF) +import Cardano.Ledger.Shelley.API.Types (Network (Testnet)) +import Cardano.Ledger.Shelley.LedgerState ( + FutureGenDeleg (FutureGenDeleg), + NewEpochState, + StashedAVVMAddresses, + ) +import Cardano.Ledger.Shelley.Tx (ShelleyTx (ShelleyTx)) +import Cardano.Ledger.Shelley.TxBody (RewardAccount (RewardAccount)) +import Cardano.Ledger.Slot ( + BlockNo (..), + EpochNo (..), + SlotNo (..), + ) +import Cardano.Ledger.TxIn (TxId (TxId), mkTxInPartial) +import Cardano.Ledger.UTxO (UTxO (..), balance) +import Cardano.Ledger.Val ((<->)) +import qualified Cardano.Ledger.Val as Val +import Cardano.Protocol.TPraos.API (PraosCrypto) +import Cardano.Protocol.TPraos.BHeader ( + BHeader, + HashHeader (HashHeader), + LastAppliedBlock (LastAppliedBlock), + hashHeaderToNonce, + ) +import Cardano.Protocol.TPraos.OCert (KESPeriod (..)) +import Data.Default.Class (Default) +import qualified Data.Map.Strict as Map +import Data.Proxy (Proxy (Proxy)) +import qualified Data.Sequence.Strict as StrictSeq +import qualified Data.Set as Set +import GHC.Stack (HasCallStack) +import Lens.Micro ((&), (.~)) +import qualified PlutusLedgerApi.Common as P +import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysFails) +import Test.Cardano.Ledger.Alonzo.Scripts (alwaysSucceeds) +import Test.Cardano.Ledger.Babel.Examples +import Test.Cardano.Ledger.Babel.Examples.Combinators (evolveNonceUnfrozen, newLab) +import qualified Test.Cardano.Ledger.Babel.Examples.Combinators as C +import Test.Cardano.Ledger.Babel.Examples.Consensus (exampleBabelCerts) +import Test.Cardano.Ledger.Babel.Genesis (expectedBabelGenesis) +import Test.Cardano.Ledger.Babel.Rules.Chain (ChainState, initialBabelState) +import Test.Cardano.Ledger.Core.KeyPair (mkAddr, mkWitnessesVKey) +import Test.Cardano.Ledger.Core.Utils (unsafeBoundRational) +import qualified Test.Cardano.Ledger.Mary.Examples.Consensus as MarySLE +import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (ExMock) +import qualified Test.Cardano.Ledger.Shelley.Examples.Cast as Cast +import qualified Test.Cardano.Ledger.Shelley.Examples.Consensus as SLE +import Test.Cardano.Ledger.Shelley.Examples.Federation ( + coreNodeKeysBySchedule, + coreNodeVK, + genDelegs, + ) +import Test.Cardano.Ledger.Shelley.Generator.Core ( + NatNonce (..), + RawSeed (RawSeed), + VRFKeyPair (vrfVerKey), + genesisCoins, + mkBlockFakeVRF, + mkOCert, + ) +import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId) +import Test.Cardano.Ledger.Shelley.Generator.ShelleyEraGen () +import Test.Cardano.Ledger.Shelley.Generator.Trace.Chain () +import Test.Cardano.Ledger.Shelley.Utils ( + getBlockNonce, + maxLLSupply, + mkDummySafeHash, + mkHash, + mkKeyPair, + mkVRFKeyPair, + ) + +------------------ + +initUTxO :: EraTxOut era => UTxO era +initUTxO = + genesisCoins + genesisId + [ mkBasicTxOut Cast.aliceAddr aliceInitCoin + , mkBasicTxOut Cast.bobAddr bobInitCoin + ] + where + aliceInitCoin = Val.inject $ Coin $ 10 * 1000 * 1000 * 1000 * 1000 * 1000 + bobInitCoin = Val.inject $ Coin $ 1 * 1000 * 1000 * 1000 * 1000 * 1000 + +initStEx1 :: + ( EraTxOut era + , Default (StashedAVVMAddresses era) + , EraGov era + ) => + ChainState era +initStEx1 = initSt (UTxO mempty) -- initUTxO + +blockEx1 :: + forall era. + ( EraSegWits era + , Tx era ~ AlonzoTx Babel + , PraosCrypto (EraCrypto era) + ) => + Block (BHeader (EraCrypto era)) era +blockEx1 = SLE.exampleShelleyLedgerBlockTxs mempty -- exampleTransactionInBlock + +exampleTransactionInBlock :: AlonzoTx Babel +exampleTransactionInBlock = AlonzoTx b w (IsValid True) a + where + ShelleyTx b w a = exampleTx + +blockNonce :: + forall era. + ( EraSegWits era + , Tx era ~ AlonzoTx Babel + , PraosCrypto (EraCrypto era) + ) => + Nonce +blockNonce = getBlockNonce (blockEx1 @era) + +expectedStEx1 :: + forall era. + ( EraSegWits era + , EraGov era + , Default (StashedAVVMAddresses era) + , Tx era ~ AlonzoTx Babel + , PraosCrypto (EraCrypto era) + ) => + ChainState era +expectedStEx1 = evolveNonceUnfrozen (blockNonce @era) . newLab blockEx1 $ initStEx1 + +-- | = Empty Block Example +-- +-- This is the most minimal example of using the CHAIN STS transition. +-- It applies an empty block to an initial shelley chain state. +-- +-- The only things that change in the chain state are the +-- evolving and candidate nonces, and the last applied block. +exEmptyBlock :: + ( EraSegWits era + , Default (StashedAVVMAddresses era) + , EraGov era + , Tx era ~ AlonzoTx Babel + , PraosCrypto (EraCrypto era) + ) => + CHAINExample (BHeader (EraCrypto era)) era +exEmptyBlock = CHAINExample initStEx1 blockEx1 (Right expectedStEx1) + +-- ------------------ +-- initUTxO :: EraTxOut era => UTxO era +-- initUTxO = +-- genesisCoins +-- genesisId +-- [ mkBasicTxOut Cast.aliceAddr aliceInitCoin +-- , mkBasicTxOut Cast.bobAddr bobInitCoin +-- ] +-- where +-- aliceInitCoin = Val.inject $ Coin $ 10 * 1000 * 1000 * 1000 * 1000 * 1000 +-- bobInitCoin = Val.inject $ Coin $ 1 * 1000 * 1000 * 1000 * 1000 * 1000 + +-- initStGenesisDeleg :: +-- ( EraTxOut era +-- , EraGov era +-- , Default (StashedAVVMAddresses era) +-- ) => +-- ChainState era +-- initStGenesisDeleg = initSt initUTxO + +-- -- +-- -- Block 1, Slot 10, Epoch 0 +-- -- + +-- newGenDelegate :: +-- Crypto c => +-- KeyPair 'GenesisDelegate c +-- newGenDelegate = KeyPair vkCold skCold +-- where +-- (skCold, vkCold) = mkKeyPair (RawSeed 108 0 0 0 1) + +-- newGenesisVrfKH :: forall c. Crypto c => Hash c (VerKeyVRF c) +-- newGenesisVrfKH = hashVerKeyVRF (vrfVerKey (mkVRFKeyPair @c (RawSeed 9 8 7 6 5))) + +-- feeTx1 :: Coin +-- feeTx1 = Coin 1 + +-- blockEx1 :: +-- forall c. +-- ExMock (EraCrypto (BabelEra c)) => +-- Block (BHeader c) (BabelEra c) +-- blockEx1 = +-- mkBlockFakeVRF @(BabelEra c) +-- lastByronHeaderHash +-- (coreNodeKeysBySchedule @(BabelEra c) ppEx 10) +-- [txEx1] +-- (SlotNo 10) +-- (BlockNo 1) +-- (nonce0 @c) +-- (NatNonce 1) +-- minBound +-- 0 +-- 0 +-- (mkOCert @c (coreNodeKeysBySchedule @(BabelEra c) ppEx 10) 0 (KESPeriod 0)) + +-- txEx1 :: forall c. ExMock (EraCrypto (BabelEra c)) => AlonzoTx (BabelEra c) +-- txEx1 = +-- AlonzoTx +-- exampleTxBodyBabel +-- ( AlonzoTxWits +-- (mkWitnessesVKey (hashAnnotated exampleTxBodyBabel) [asWitness SLE.examplePayKey]) -- vkey +-- mempty -- bootstrap +-- ( Map.singleton +-- (hashScript @(BabelEra c) $ alwaysSucceeds @'PlutusV1 3) +-- (alwaysSucceeds @'PlutusV1 3) -- txscripts +-- ) +-- (TxDats $ Map.singleton (hashData datumExample) datumExample) +-- ( Redeemers $ +-- Map.singleton (BabelSpending $ AsIx 0) (redeemerExample, ExUnits 5000 5000) +-- ) -- redeemers +-- ) +-- (IsValid True) +-- SNothing + +-- newGenDeleg :: +-- forall c. +-- Crypto c => +-- (FutureGenDeleg c, GenDelegPair c) +-- newGenDeleg = +-- ( FutureGenDeleg (SlotNo 43) (hashKey $ coreNodeVK 0) +-- , GenDelegPair (hashKey . vKey $ newGenDelegate) (newGenesisVrfKH @c) +-- ) + +-- expectedStEx1 :: +-- forall c. +-- ExMock (EraCrypto (BabelEra c)) => +-- ChainState (BabelEra c) +-- expectedStEx1 = +-- C.evolveNonceUnfrozen (getBlockNonce @(BabelEra c) blockEx1) +-- . C.newLab blockEx1 +-- . C.feesAndDeposits ppEx feeTx1 [] [] +-- . C.newUTxO exampleTxBodyBabel +-- . C.setFutureGenDeleg newGenDeleg +-- $ initStGenesisDeleg + +-- -- === Block 1, Slot 10, Epoch 0 +-- -- +-- -- In the first block, stage a new future genesis delegate +-- genesisDelegation1 :: +-- ExMock (EraCrypto (BabelEra c)) => +-- CHAINExample (BHeader c) (BabelEra c) +-- genesisDelegation1 = CHAINExample initStGenesisDeleg blockEx1 (Right expectedStEx1) + +collateralOutput :: Crypto c => BabbageTxOut (BabelEra c) +collateralOutput = + BabbageTxOut + (mkAddr (SLE.examplePayKey, SLE.exampleStakeKey)) + (MaryValue (Coin 8675309) mempty) + NoDatum + SNothing + +testOutput :: Crypto c => BabbageTxOut (BabelEra c) +testOutput = + BabbageTxOut + (mkAddr (SLE.examplePayKey, SLE.exampleStakeKey)) + (MarySLE.exampleMultiAssetValue 2) + (Datum $ dataToBinaryData datumExample) -- inline datum + (SJust $ alwaysSucceeds @'PlutusV2 3) -- reference script + +exampleTxBodyBabel :: forall c. Crypto c => BabelTxBody (BabelEra c) +exampleTxBodyBabel = + BabelTxBody + (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 1)) 0]) -- spending inputs + (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 2)) 1]) -- collateral inputs + (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 1)) 3]) -- reference inputs + ( StrictSeq.fromList + [ mkSized (eraProtVerHigh @Babel) testOutput + -- BabbageTxOut + -- (mkAddr @c (SLE.examplePayKey, SLE.exampleStakeKey)) + -- (MarySLE.exampleMultiAssetValue 2) + -- (Datum $ dataToBinaryData datumExample) -- inline datum + -- (SJust $ alwaysSucceeds @'PlutusV2 3) -- reference script + ] + ) + (SJust $ mkSized (eraProtVerHigh @Babel) collateralOutput) -- collateral return + (SJust $ Coin 8675309) -- collateral tot + exampleBabelCerts -- txcerts + ( Withdrawals $ + Map.singleton + (RewardAccount Testnet (SLE.keyToCredential SLE.exampleStakeKey)) + (Coin 100) -- txwdrls + ) + (Coin 999) -- txfee + (ValidityInterval (SJust (SlotNo 2)) (SJust (SlotNo 4))) -- txvldt + (Set.singleton $ SLE.mkKeyHash 212) -- reqSignerHashes + exampleMultiAsset -- mint + (SJust $ mkDummySafeHash (Proxy @c) 42) -- scriptIntegrityHash + (SJust . AuxiliaryDataHash $ mkDummySafeHash (Proxy @c) 42) -- adHash + (SJust Mainnet) -- txnetworkid + (VotingProcedures mempty) + mempty + (SJust $ Coin 867530900000) -- current treasury value + mempty + mempty + mempty + mempty + where + MaryValue _ exampleMultiAsset = MarySLE.exampleMultiAssetValue 3 + +datumExample :: Crypto c => Data (BabelEra c) +datumExample = Data (P.I 191) + +redeemerExample :: Crypto c => Data (BabelEra c) +redeemerExample = Data (P.I 919) + +exampleTx :: ShelleyTx Babel +exampleTx = + ShelleyTx + exampleTxBodyBabel + ( AlonzoTxWits + (mkWitnessesVKey (hashAnnotated exampleTxBodyBabel) [asWitness SLE.examplePayKey]) -- vkey + mempty -- bootstrap + ( Map.singleton + (hashScript @Babel $ alwaysSucceeds @'PlutusV1 3) + (alwaysSucceeds @'PlutusV1 3) -- txscripts + ) + (TxDats $ Map.singleton (hashData datumExample) datumExample) + ( Redeemers $ + Map.singleton (BabelSpending $ AsIx 0) (redeemerExample, ExUnits 5000 5000) + ) -- redeemers + ) + ( SJust $ + mkAlonzoTxAuxData + SLE.exampleAuxDataMap -- metadata + [alwaysFails @'PlutusV1 2, TimelockScript $ RequireAllOf mempty] -- Scripts + ) + +-- ------ + +-- | Initial Protocol Parameters +ppEx :: EraPParams era => PParams era +ppEx = + emptyPParams + & ppMaxBBSizeL + .~ 50000 + & ppMaxBHSizeL + .~ 10000 + & ppMaxTxSizeL + .~ 10000 + & ppEMaxL + .~ EpochInterval 10000 + & ppKeyDepositL + .~ Coin 7 + & ppPoolDepositL + .~ Coin 250 + & ppTauL + .~ unsafeBoundRational 0.2 + & ppRhoL + .~ unsafeBoundRational 0.0021 + +-- | === The hash of the last Bryon Header +-- +-- The first block of the Shelley era will point back to the +-- last block of the Byron era. +-- For our purposes in the examples we can bootstrap the chain +-- by just coercing the value. +-- When this transition actually occurs, +-- the consensus layer will do the work of making +-- sure that the hash gets translated across the fork. +lastByronHeaderHash :: + forall c. + Crypto c => + HashHeader c +lastByronHeaderHash = HashHeader $ mkHash 0 + +-- | === Initial Nonce +nonce0 :: + forall c. + Crypto c => + Nonce +nonce0 = hashHeaderToNonce (lastByronHeaderHash @c) + +-- | === Initial Chain State +-- +-- The initial state for the examples uses the function +-- 'initialShelleyState' with the genesis delegation +-- 'genDelegs' and any given starting 'UTxO' set. +initSt :: + forall era. + ( EraTxOut era + , Default (StashedAVVMAddresses era) + , EraGov era + ) => + UTxO era -> + ChainState era +initSt utxo = + initialBabelState + (At $ LastAppliedBlock (BlockNo 0) (SlotNo 0) lastByronHeaderHash) + (EpochNo 0) + utxo + (maxLLSupply <-> Val.coin (balance utxo)) + genDelegs + (ppEx @era) + (nonce0 @(EraCrypto era)) \ No newline at end of file diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Rules/Chain.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Rules/Chain.hs new file mode 100644 index 00000000000..5e7d0fbbee1 --- /dev/null +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Rules/Chain.hs @@ -0,0 +1,470 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Cardano.Ledger.Babel.Rules.Chain ( + CHAIN, + ChainState (..), + TestChainPredicateFailure (..), + ChainEvent (..), + PredicateFailure, + AdaPots (..), + initialBabelState, + totalAda, + totalAdaPots, +) where + +import Cardano.Ledger.BHeaderView (BHeaderView) +import Cardano.Ledger.BaseTypes ( + BlocksMade (..), + Globals (..), + Nonce (..), + ShelleyBase, + StrictMaybe (..), + ) +import Cardano.Ledger.Binary (EncCBORGroup) +import Cardano.Ledger.Block (Block (..)) +import Cardano.Ledger.CertState (VState (..)) +import Cardano.Ledger.Chain ( + ChainPredicateFailure (..), + chainChecks, + pparamsToChainChecksPParams, + ) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Babel.Era (BabelBBODY, BabelEra) +import Cardano.Ledger.Babel.Rules.Bbody (BabelBbodyPredFailure, BabelBbodyState (..)) +import qualified Cardano.Ledger.Core as Core +import Cardano.Ledger.EpochBoundary (emptySnapShots) +import Cardano.Ledger.Keys ( + GenDelegPair (..), + GenDelegs (..), + KeyHash, + KeyRole (..), + coerceKeyRole, + ) +import Cardano.Ledger.PoolDistr (PoolDistr (..)) +import Cardano.Ledger.Shelley.AdaPots ( + AdaPots (..), + totalAdaES, + totalAdaPotsES, + ) +import Cardano.Ledger.Shelley.Core +import Cardano.Ledger.Shelley.LedgerState ( + AccountState (..), + CertState (..), + DState (..), + EpochState (..), + LedgerState (..), + NewEpochState (..), + PState (..), + StashedAVVMAddresses, + curPParamsEpochStateL, + dsGenDelegs, + nesEpochStateL, + prevPParamsEpochStateL, + smartUTxOState, + updateNES, + ) +import Cardano.Ledger.Shelley.Rules ( + BbodyEnv (BbodyEnv), + ShelleyTICK, + ShelleyTickEvent, + ShelleyTickPredFailure, + ) +import Cardano.Ledger.Slot (EpochNo) +import qualified Cardano.Ledger.UMap as UM +import Cardano.Ledger.UTxO (UTxO (..)) +import Cardano.Protocol.TPraos.BHeader ( + BHeader, + HashHeader, + LastAppliedBlock (..), + bhHash, + bhbody, + bheaderBlockNo, + bheaderSlotNo, + lastAppliedHash, + makeHeaderView, + prevHashToNonce, + ) +import Cardano.Protocol.TPraos.Rules.Prtcl ( + PRTCL, + PrtclEnv (..), + PrtclState (..), + PrtlSeqFailure, + prtlSeqChecks, + ) +import Cardano.Protocol.TPraos.Rules.Tickn +import Cardano.Slotting.Slot (SlotNo, WithOrigin (..)) +import Control.DeepSeq (NFData) +import Control.Monad.Trans.Reader (asks) +import Control.State.Transition ( + Embed (..), + STS (..), + TRC (..), + TransitionRule, + failBecause, + judgmentContext, + liftSTS, + trans, + ) +import Data.Default.Class (Default, def) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Void (Void) +import Data.Word (Word64) +import GHC.Generics (Generic) +import Lens.Micro ((&), (.~), (^.)) +import NoThunks.Class (NoThunks (..)) +import Test.Cardano.Ledger.Core.Rational (unsafeBoundRational) +import Test.Cardano.Ledger.Shelley.TreeDiff () +import Test.Cardano.Ledger.TreeDiff (ToExpr (toExpr), defaultExprViaShow) + +type instance EraRule "TICKN" (BabelEra c) = TICKN + +data CHAIN era + +data ChainState era = ChainState + { chainNes :: NewEpochState era + , chainOCertIssue :: Map.Map (KeyHash 'BlockIssuer (EraCrypto era)) Word64 + , chainEpochNonce :: Nonce + , chainEvolvingNonce :: Nonce + , chainCandidateNonce :: Nonce + , chainPrevEpochNonce :: Nonce + , chainLastAppliedBlock :: WithOrigin (LastAppliedBlock (EraCrypto era)) + } + deriving (Generic) + +deriving stock instance Show (NewEpochState era) => Show (ChainState era) + +deriving stock instance Eq (NewEpochState era) => Eq (ChainState era) + +instance NFData (NewEpochState era) => NFData (ChainState era) + +data TestChainPredicateFailure era + = RealChainPredicateFailure !ChainPredicateFailure + | BbodyFailure !(PredicateFailure (EraRule "BBODY" era)) -- Subtransition Failures + | TickFailure !(PredicateFailure (EraRule "TICK" era)) -- Subtransition Failures + | TicknFailure !(PredicateFailure (EraRule "TICKN" era)) -- Subtransition Failures + | PrtclFailure !(PredicateFailure (PRTCL (EraCrypto era))) -- Subtransition Failures + | PrtclSeqFailure !(PrtlSeqFailure (EraCrypto era)) -- Subtransition Failures + deriving (Generic) + +data ChainEvent era + = BbodyEvent !(Event (EraRule "BBODY" era)) + | TickEvent !(Event (EraRule "TICK" era)) + | TicknEvent !(Event (EraRule "TICKN" era)) + | PrtclEvent !(Event (PRTCL (EraCrypto era))) + +deriving stock instance + ( Era era + , Show (PredicateFailure (EraRule "BBODY" era)) + , Show (PredicateFailure (EraRule "TICK" era)) + , Show (PredicateFailure (EraRule "TICKN" era)) + ) => + Show (TestChainPredicateFailure era) + +deriving stock instance + ( Era era + , Eq (PredicateFailure (EraRule "BBODY" era)) + , Eq (PredicateFailure (EraRule "TICK" era)) + , Eq (PredicateFailure (EraRule "TICKN" era)) + ) => + Eq (TestChainPredicateFailure era) + +instance + ( Era era + , NoThunks (PredicateFailure (EraRule "BBODY" era)) + , NoThunks (PredicateFailure (EraRule "TICK" era)) + , NoThunks (PredicateFailure (EraRule "TICKN" era)) + ) => + NoThunks (TestChainPredicateFailure era) + +-- | Creates a valid initial chain state +initialBabelState :: + forall era. + ( EraTxOut era + , EraGov era + , Default (StashedAVVMAddresses era) + ) => + WithOrigin (LastAppliedBlock (EraCrypto era)) -> + EpochNo -> + UTxO era -> + Coin -> + Map (KeyHash 'Genesis (EraCrypto era)) (GenDelegPair (EraCrypto era)) -> + PParams era -> + Nonce -> + ChainState era +initialBabelState lab e utxo reserves genDelegs pp initNonce = + ChainState + ( NewEpochState + e + (BlocksMade Map.empty) + (BlocksMade Map.empty) + ( EpochState + (AccountState (Coin 0) reserves) + ( LedgerState + ( smartUTxOState + pp + utxo + (Coin 0) + (Coin 0) + emptyGovState + mempty + ) + (CertState def def dState) + ) + emptySnapShots + def + & curPParamsEpochStateL + .~ pp + & prevPParamsEpochStateL + .~ pp + ) + SNothing + (PoolDistr Map.empty) + def + ) + cs + initNonce + initNonce + initNonce + NeutralNonce + lab + where + cs = + Map.fromList + ( fmap + (\(GenDelegPair hk _) -> (coerceKeyRole hk, 0)) + (Map.elems genDelegs) + ) + + dState :: DState era + dState = + DState + { dsUnified = UM.empty + , dsFutureGenDelegs = Map.empty + , dsGenDelegs = GenDelegs genDelegs + , dsIRewards = def + } + +instance + ( EraGov era + , Embed (EraRule "BBODY" era) (CHAIN era) + , Environment (EraRule "BBODY" era) ~ BbodyEnv era + , State (EraRule "BBODY" era) ~ BabelBbodyState era + , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era + , Embed (EraRule "TICKN" era) (CHAIN era) + , Environment (EraRule "TICKN" era) ~ TicknEnv + , State (EraRule "TICKN" era) ~ TicknState + , Signal (EraRule "TICKN" era) ~ Bool + , Embed (EraRule "TICK" era) (CHAIN era) + , Environment (EraRule "TICK" era) ~ () + , State (EraRule "TICK" era) ~ NewEpochState era + , Signal (EraRule "TICK" era) ~ SlotNo + , Embed (PRTCL (EraCrypto era)) (CHAIN era) + , EncCBORGroup (TxZones era) + , ProtVerAtMost era 10 + , State (EraRule "ZONES" era) ~ LedgerState era + , State (Core.EraRule "LEDGERS" era) ~ LedgerState era + ) => + STS (CHAIN era) + where + type + State (CHAIN era) = + ChainState era + + type + Signal (CHAIN era) = + Block (BHeader (EraCrypto era)) era + + type Environment (CHAIN era) = () + type BaseM (CHAIN era) = ShelleyBase + + type PredicateFailure (CHAIN era) = TestChainPredicateFailure era + type Event (CHAIN era) = ChainEvent era + + initialRules = [] + transitionRules = [chainTransition] + +chainTransition :: + forall era. + ( STS (CHAIN era) + , Embed (EraRule "BBODY" era) (CHAIN era) + , Environment (EraRule "BBODY" era) ~ BbodyEnv era + , State (EraRule "BBODY" era) ~ BabelBbodyState era + , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era + , Embed (EraRule "TICKN" era) (CHAIN era) + , Environment (EraRule "TICKN" era) ~ TicknEnv + , State (EraRule "TICKN" era) ~ TicknState + , Signal (EraRule "TICKN" era) ~ Bool + , Embed (EraRule "TICK" era) (CHAIN era) + , Environment (EraRule "TICK" era) ~ () + , State (EraRule "TICK" era) ~ NewEpochState era + , Signal (EraRule "TICK" era) ~ SlotNo + , Embed (PRTCL (EraCrypto era)) (CHAIN era) + , EncCBORGroup (TxZones era) + , State (EraRule "ZONES" era) ~ LedgerState era + , EraGov era + ) => + TransitionRule (CHAIN era) +chainTransition = + judgmentContext + >>= \( TRC + ( _ + , ChainState + nes + cs + eta0 + etaV + etaC + etaH + lab + , Block bh txs + ) + ) -> do + case prtlSeqChecks lab bh of + Right () -> pure () + Left e -> failBecause $ PrtclSeqFailure e + + let pp = nes ^. nesEpochStateL . curPParamsEpochStateL + chainChecksData = pparamsToChainChecksPParams pp + bhView = makeHeaderView bh + + maxpv <- liftSTS $ asks maxMajorPV + case chainChecks maxpv chainChecksData bhView of + Right () -> pure () + Left e -> failBecause (RealChainPredicateFailure e) + + let s = bheaderSlotNo $ bhbody bh + + nes' <- trans @(EraRule "TICK" era) $ TRC ((), nes, s) + + let NewEpochState e1 _ _ _ _ _ _ = nes + NewEpochState e2 _ bcur es _ _pd _ = nes' + let EpochState account ls _ _ = es + pp' = es ^. curPParamsEpochStateL + let LedgerState _ (CertState VState {} PState {} DState {dsGenDelegs = genDelegs}) = ls + let ph = lastAppliedHash lab + etaPH = prevHashToNonce ph + + TicknState eta0' etaH' <- + trans @(EraRule "TICKN" era) $ + TRC + ( TicknEnv + NeutralNonce -- (pp' ^. ppExtraEntropyL) + etaC + etaPH + , TicknState eta0 etaH + , e1 /= e2 + ) + + PrtclState cs' etaV' etaC' <- + trans @(PRTCL (EraCrypto era)) $ + TRC + ( PrtclEnv + (unsafeBoundRational 0.5) -- minBound -- (pp' ^. ppDL) + _pd + genDelegs + eta0' + , PrtclState cs etaV etaC + , bh + ) + + let thouShaltNot = error "A block with a header view should never be hashed" + BbodyState ls' bcur' <- + trans @(EraRule "BBODY" era) $ + TRC (BbodyEnv pp' account, BbodyState ls bcur, Block' bhView txs thouShaltNot) + + let nes'' = updateNES nes' bcur' ls' + bhb = bhbody bh + lab' = + At $ + LastAppliedBlock + (bheaderBlockNo bhb) + (bheaderSlotNo bhb) + (bhHash bh) + + pure $ ChainState nes'' cs' eta0' etaV' etaC' etaH' lab' + +instance + ( Era era + , Era era + , STS (BabelBBODY era) + , PredicateFailure (EraRule "BBODY" era) ~ BabelBbodyPredFailure era + , Event (EraRule "BBODY" era) ~ Event (BabelBBODY era) + ) => + Embed (BabelBBODY era) (CHAIN era) + where + wrapFailed = BbodyFailure + wrapEvent = BbodyEvent + +instance + ( Era era + , Era era + , PredicateFailure (EraRule "TICKN" era) ~ TicknPredicateFailure + , Event (EraRule "TICKN" era) ~ Void + ) => + Embed TICKN (CHAIN era) + where + wrapFailed = TicknFailure + wrapEvent = TicknEvent + +instance + ( Era era + , Era era + , STS (ShelleyTICK era) + , PredicateFailure (EraRule "TICK" era) ~ ShelleyTickPredFailure era + , Event (EraRule "TICK" era) ~ ShelleyTickEvent era + ) => + Embed (ShelleyTICK era) (CHAIN era) + where + wrapFailed = TickFailure + wrapEvent = TickEvent + +instance + ( Era era + , c ~ EraCrypto era + , Era era + , STS (PRTCL c) + ) => + Embed (PRTCL c) (CHAIN era) + where + wrapFailed = PrtclFailure + wrapEvent = PrtclEvent + +-- | Calculate the total ada pots in the chain state +totalAdaPots :: + ( EraTxOut era + , EraGov era + ) => + ChainState era -> + AdaPots +totalAdaPots = totalAdaPotsES . nesEs . chainNes + +-- | Calculate the total ada in the chain state +totalAda :: (EraTxOut era, EraGov era) => ChainState era -> Coin +totalAda = totalAdaES . nesEs . chainNes + +instance + ( ToExpr (PParams era) + , ToExpr (TxOut era) + , ToExpr (StashedAVVMAddresses era) + , ToExpr (GovState era) + ) => + ToExpr (ChainState era) + +instance ToExpr (HashHeader c) where + toExpr = defaultExprViaShow + +instance ToExpr (LastAppliedBlock c) diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/RulesTests.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/RulesTests.hs new file mode 100644 index 00000000000..b774eaf6702 --- /dev/null +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/RulesTests.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Test.Cardano.Ledger.Babel.RulesTests ( + chainExamples, + testTickF, +) +where + +import Cardano.Ledger.BaseTypes (StrictMaybe (..)) +import Cardano.Ledger.Shelley (Shelley) +import Cardano.Ledger.Shelley.API (ShelleyTICK, ShelleyTICKF) +import Cardano.Ledger.Shelley.LedgerState ( + EpochState (..), + LedgerState (..), + NewEpochState (..), + UTxOState (..), + totalObligation, + utxosGovStateL, + ) +import Cardano.Ledger.Shelley.RewardUpdate (PulsingRewUpdate (..), RewardUpdate (..)) +import Cardano.Ledger.Slot (EpochNo (..)) +import Cardano.Protocol.TPraos.API (GetLedgerView (..)) +import Control.State.Transition.Extended (TRC (..)) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import qualified Data.Set as Set +import Lens.Micro ((^.)) +import Test.Cardano.Ledger.Babel.Examples (testCHAINExample) +import Test.Cardano.Ledger.Babel.Examples.Prototype +import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators () +import Test.Cardano.Ledger.Shelley.Serialisation.Generators () +import Test.Cardano.Ledger.Shelley.Utils +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase) +import Test.Tasty.QuickCheck (Property, discard, testProperty, (===)) + +chainExamples :: TestTree +chainExamples = + testGroup + "CHAINexamples" + [ testCase "empty block" $ testCHAINExample exEmptyBlock + ] + +-- | The reward aggregation bug described in the Shelley ledger spec in +-- section 17.4 (in the Errata) resulted in needing to use 'aggregatedRewards' to change +-- the behavior of how rewards are collected starting at protocol version 3. +-- Instead of collecting a `Coin` for each stake credential, we collect 'Set Reward'. +-- In major protocol version 2, it is impossible for this set to be empty, but sadly this +-- property is not enforced in the types. For this reason, the property test +-- 'propTickfPerservesLedgerView' removes these empty sets from an otherwise arbitrary +-- 'NewEpochState'. +filterEmptyRewards :: NewEpochState Shelley -> NewEpochState Shelley +filterEmptyRewards (NewEpochState el bprev bcur es ru pd stash) = + NewEpochState el bprev bcur es ru' pd stash + where + removeEmptyRewards = Map.filter $ not . Set.null + ru' = case ru of + SNothing -> SNothing + SJust (Pulsing _ _) -> SNothing + SJust (Complete rewardUpdate) -> + SJust . Complete $ rewardUpdate {rs = removeEmptyRewards (rs rewardUpdate)} + +setDepositsToObligation :: NewEpochState Shelley -> NewEpochState Shelley +setDepositsToObligation nes = nes {nesEs = es {esLState = ls {lsUTxOState = utxoState}}} + where + es = nesEs nes + ls = esLState es + utxoState = + (lsUTxOState ls) + { utxosDeposited = + totalObligation + (lsCertState ls) + (utxoState ^. utxosGovStateL) + } + +-- | This property test checks the correctness of the TICKF transation. +-- TICKF is used by the consensus layer to get a ledger view in a computationally +-- cheaper way than using the TICK rule. +-- Therefore TICKF and TICK need to compute the same ledger view. +propTickfPerservesLedgerView :: NewEpochState Shelley -> Property +propTickfPerservesLedgerView nes = + let (EpochNo e) = nesEL nes + slot = slotFromEpoch (EpochNo $ e + 1) + nes' = setDepositsToObligation (filterEmptyRewards nes) + tickNes = runShelleyBase $ applySTSTest @(ShelleyTICK Shelley) (TRC ((), nes', slot)) + tickFNes = runShelleyBase $ applySTSTest @(ShelleyTICKF Shelley) (TRC ((), nes', slot)) + in fromMaybe discard $ do + Right tickNes' <- pure tickNes + Right tickFNes' <- pure tickFNes + pure $ currentLedgerView tickNes' === currentLedgerView tickFNes' + +testTickF :: TestTree +testTickF = testProperty "TICKF properties" propTickfPerservesLedgerView diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Translation/TranslatableGen.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Translation/TranslatableGen.hs new file mode 100644 index 00000000000..8ace248d207 --- /dev/null +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Translation/TranslatableGen.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Cardano.Ledger.Babel.Translation.TranslatableGen where + +import Cardano.Ledger.Alonzo.Scripts (AlonzoEraScript, AsIx (..), PlutusPurpose) +import Cardano.Ledger.Alonzo.TxWits (Redeemers (..)) +import Cardano.Ledger.Babel (Babel, BabelEra) +import Cardano.Ledger.Babel.Scripts (BabelPlutusPurpose (..)) +import Cardano.Ledger.Babel.TxBody (BabelTxBody (..)) +import Cardano.Ledger.Binary (mkSized) +import Cardano.Ledger.Core +import Cardano.Ledger.Crypto +import Cardano.Ledger.Plutus (Data (..), ExUnits, Language (..), SLanguage (..)) +import Cardano.Ledger.TxIn (TxIn (..)) +import qualified Data.Map.Strict as Map +import Data.Sequence.Strict (fromList) +import qualified Data.Set as Set +import Test.Cardano.Ledger.Alonzo.Translation.TranslatableGen ( + TranslatableGen (..), + TxInfoLanguage (..), + ) +import qualified Test.Cardano.Ledger.Babbage.Translation.TranslatableGen as BabbageTranslatableGen ( + genTx, + genTxOut, + utxoWithTx, + ) +import Test.Cardano.Ledger.Babel.Arbitrary () +import Test.Cardano.Ledger.Common + +instance TranslatableGen Babel where + tgRedeemers = genRedeemers + tgTx l = BabbageTranslatableGen.genTx @Babel (genTxBody l) + tgUtxo = BabbageTranslatableGen.utxoWithTx @Babel + mkTxInfoLanguage PlutusV1 = TxInfoLanguage SPlutusV1 + mkTxInfoLanguage PlutusV2 = TxInfoLanguage SPlutusV2 + mkTxInfoLanguage PlutusV3 = TxInfoLanguage SPlutusV3 + mkTxInfoLanguage PlutusV4 = TxInfoLanguage SPlutusV4 + +genTxBody :: forall c. Crypto c => Language -> Gen (BabelTxBody (BabelEra c)) +genTxBody l = do + let genTxOuts = + fromList + <$> listOf1 + ( mkSized (eraProtVerLow @Babel) + <$> BabbageTranslatableGen.genTxOut @(BabelEra c) l + ) + let genTxIns = Set.fromList <$> listOf1 (arbitrary :: Gen (TxIn c)) + BabelTxBody + <$> genTxIns + <*> arbitrary + <*> ( case l of -- refinputs + PlutusV1 -> pure Set.empty + _ -> arbitrary + ) + <*> genTxOuts + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> scale (`div` 15) arbitrary + <*> arbitrary + <*> scale (`div` 15) arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +genRedeemers :: + forall era. + (AlonzoEraScript era, PlutusPurpose AsIx era ~ BabelPlutusPurpose AsIx era) => + Gen (Redeemers era) +genRedeemers = do + d <- arbitrary :: Gen (Data era) + eu <- arbitrary :: Gen ExUnits + -- We provide `RdrmPtr Spend 0` as the only valid reedemer, because + -- for any other redeemer type, we would have to modify the body of the transaction + -- in order for the translation to succeed + Redeemers <$> elements [Map.singleton (BabelSpending $ AsIx 0) (d, eu), Map.empty] diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Utils.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Utils.hs new file mode 100644 index 00000000000..c16bdf66064 --- /dev/null +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Utils.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.Cardano.Ledger.Babel.Utils ( + mkSeedFromWords, + mkCertifiedVRF, + epochFromSlotNo, + evolveKESUntil, + slotFromEpoch, + epochSize, + mkHash, + mkKeyPair, + mkKeyPair', + mkGenKey, + mkKESKeyPair, + mkVRFKeyPair, + runShelleyBase, + maxKESIterations, + slotsPerKESIteration, + testSTS, + maxLLSupply, + applySTSTest, + genMultiAsset, + GenesisKeyPair, + getBlockNonce, + ChainProperty, + RawSeed (..), + Split (..), + module CoreUtils, +) +where + +import Cardano.Crypto.DSIGN.Class (DSIGNAlgorithm (..)) +import Cardano.Crypto.Hash ( + Blake2b_256, + Hash, + HashAlgorithm, + hashToBytes, + ) +import Cardano.Crypto.KES ( + KESAlgorithm (..), + deriveVerKeyKES, + genKeyKES, + ) +import Cardano.Crypto.Seed (Seed, mkSeedFromBytes) +import Cardano.Crypto.VRF ( + CertifiedVRF, + SignKeyVRF, + VRFAlgorithm (..), + certifiedOutput, + deriveVerKeyVRF, + evalCertified, + genKeyVRF, + ) +import qualified Cardano.Crypto.VRF as VRF +import Cardano.Ledger.BaseTypes ( + Globals (..), + Nonce, + ShelleyBase, + epochInfoPure, + mkNonceFromOutputVRF, + ) +import Cardano.Ledger.Binary (EncCBOR (..), hashWithEncoder, shelleyProtVer) +import Cardano.Ledger.Block (Block, bheader) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Babel.API.Validation (ApplyBlock) +import Cardano.Ledger.Crypto (Crypto (DSIGN)) +import Cardano.Ledger.Mary.Value (MultiAsset (MultiAsset)) +import Cardano.Ledger.Shelley.API (KeyRole (..), VKey (..)) +import Cardano.Ledger.Shelley.Core +import Cardano.Ledger.Slot (EpochNo, EpochSize (..), SlotNo) +import Cardano.Protocol.TPraos.API (GetLedgerView) +import Cardano.Protocol.TPraos.BHeader (BHBody (..), BHeader, bhbody) +import Cardano.Slotting.EpochInfo ( + epochInfoEpoch, + epochInfoFirst, + epochInfoSize, + ) +import Control.Monad.Reader.Class (asks) +import Control.Monad.Trans.Reader (runReaderT) +import Control.State.Transition.Extended hiding (Assertion) +import Data.Coerce (Coercible, coerce) +import Data.Functor.Identity (runIdentity) +import Data.List.NonEmpty (NonEmpty) +import Data.Word (Word64) +import Test.Cardano.Data (genNonEmptyMap) +import Test.Cardano.Ledger.Common (Arbitrary (arbitrary), Gen) +import Test.Cardano.Ledger.Core.KeyPair (KeyPair, pattern KeyPair) +import Test.Cardano.Ledger.Core.Utils as CoreUtils +import Test.Cardano.Ledger.Mary.Arbitrary () +import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (Mock) +import Test.Cardano.Ledger.Shelley.Generator.Core (RawSeed (RawSeed)) +import Test.Cardano.Ledger.TreeDiff (ToExpr) +import Test.Cardano.Protocol.TPraos.Create (KESKeyPair (..), VRFKeyPair (..), evolveKESUntil) +import Test.Control.State.Transition.Trace ( + applySTSTest, + checkTrace, + (.-), + (.->>), + ) +import Test.Tasty.HUnit ( + Assertion, + (@?=), + ) + +type ChainProperty era = + ( Mock (EraCrypto era) + , ApplyBlock era + , GetLedgerView era + , EraTx era + ) + +-- ================================================ + +class Split v where + vsplit :: v -> Integer -> ([v], Coin) + +-- =============================================================================== +-- Generating random transactions requires splitting Values into multiple Values +-- with the same underlying amount of Coin. This property is crucial to generating +-- transactions which have the preservation of ADA property. (vsplit n v) breaks +-- v into n different values, and one remainder Coin, where the sum of the Coin +-- in the original value, and the sum of the underlying Coin in the list plus the +-- remainder coin are equal. +-- Given: let (vs,coin) = split n value +-- Then: (coin value) == sum(map coin vs) <+> coin + +-- We introduce a new class Split which supplies this operation. +-- As new kinds of values become instances of the Val class, and we want to generate +-- transactions over these values, we will have to add additional instances here. + +instance Split Coin where + vsplit (Coin n) 0 = ([], Coin n) + vsplit (Coin n) m + | m <= 0 = error "must split coins into positive parts" + | otherwise = (take (fromIntegral m) (repeat (Coin (n `div` m))), Coin (n `rem` m)) + +type GenesisKeyPair c = KeyPair 'Genesis c + +-- | Construct a seed from a bunch of Word64s +-- +-- We multiply these words by some extra stuff to make sure they contain +-- enough bits for our seed. +mkSeedFromWords :: + RawSeed -> + Seed +mkSeedFromWords stuff = + mkSeedFromBytes . hashToBytes $ hashWithEncoder @Blake2b_256 shelleyProtVer encCBOR stuff + +-- | For testing purposes, generate a deterministic genesis key pair given a seed. +mkGenKey :: + DSIGNAlgorithm (DSIGN c) => + RawSeed -> + (SignKeyDSIGN (DSIGN c), VKey kd c) +mkGenKey seed = + let sk = genKeyDSIGN $ mkSeedFromWords seed + in (sk, VKey $ deriveVerKeyDSIGN sk) + +-- | For testing purposes, generate a deterministic key pair given a seed. +mkKeyPair :: + forall c kd. + DSIGNAlgorithm (DSIGN c) => + RawSeed -> + (SignKeyDSIGN (DSIGN c), VKey kd c) +mkKeyPair seed = + let sk = genKeyDSIGN $ mkSeedFromWords seed + in (sk, VKey $ deriveVerKeyDSIGN sk) + +-- | For testing purposes, generate a deterministic key pair given a seed. +mkKeyPair' :: + DSIGNAlgorithm (DSIGN c) => + RawSeed -> + KeyPair kd c +mkKeyPair' seed = KeyPair vk sk + where + (sk, vk) = mkKeyPair seed + +-- | For testing purposes, generate a deterministic VRF key pair given a seed. +mkVRFKeyPair :: Crypto c => RawSeed -> VRFKeyPair c +mkVRFKeyPair seed = + let sk = genKeyVRF $ mkSeedFromWords seed + in VRFKeyPair + { vrfSignKey = sk + , vrfVerKey = deriveVerKeyVRF sk + } + +-- | For testing purposes, create a VRF value +mkCertifiedVRF :: + ( VRF.Signable v a + , VRFAlgorithm v + , ContextVRF v ~ () + , Coercible b (CertifiedVRF v a) + ) => + a -> + SignKeyVRF v -> + b +mkCertifiedVRF a sk = + coerce $ evalCertified () a sk + +-- | For testing purposes, generate a deterministic KES key pair given a seed. +mkKESKeyPair :: Crypto c => RawSeed -> KESKeyPair c +mkKESKeyPair seed = + let sk = genKeyKES $ mkSeedFromWords seed + in KESKeyPair + { kesSignKey = sk + , kesVerKey = deriveVerKeyKES sk + } + +runShelleyBase :: ShelleyBase a -> a +runShelleyBase act = runIdentity $ runReaderT act testGlobals + +epochFromSlotNo :: SlotNo -> EpochNo +epochFromSlotNo = runIdentity . epochInfoEpoch (epochInfoPure testGlobals) + +slotFromEpoch :: EpochNo -> SlotNo +slotFromEpoch = runIdentity . epochInfoFirst (epochInfoPure testGlobals) + +epochSize :: EpochNo -> EpochSize +epochSize = runIdentity . epochInfoSize (epochInfoPure testGlobals) + +maxKESIterations :: Word64 +maxKESIterations = runShelleyBase (asks maxKESEvo) + +slotsPerKESIteration :: Word64 +slotsPerKESIteration = runShelleyBase (asks slotsPerKESPeriod) + +maxLLSupply :: Coin +maxLLSupply = Coin $ fromIntegral $ runShelleyBase (asks maxLovelaceSupply) + +testSTS :: + forall s. + (BaseM s ~ ShelleyBase, STS s, Eq (State s), Show (State s), ToExpr (State s)) => + Environment s -> + State s -> + Signal s -> + Either (NonEmpty (PredicateFailure s)) (State s) -> + Assertion +testSTS env initSt signal (Right expectedSt) = do + checkTrace @s runShelleyBase env $ pure initSt .- signal .->> expectedSt +testSTS env initSt sig predicateFailure@(Left _) = do + let st = runShelleyBase $ applySTSTest @s (TRC (env, initSt, sig)) + st @?= predicateFailure + +mkHash :: forall a h. HashAlgorithm h => Int -> Hash h a +mkHash i = coerce (hashWithEncoder @h shelleyProtVer encCBOR i) + +getBlockNonce :: forall era. Era era => Block (BHeader (EraCrypto era)) era -> Nonce +getBlockNonce = + mkNonceFromOutputVRF . certifiedOutput . bheaderEta . bhbody . bheader + +genMultiAsset :: forall c. Crypto c => Integer -> Gen (MultiAsset c) +genMultiAsset amount = do + MultiAsset <$> genNonEmptyMap arbitrary (genNonEmptyMap arbitrary (pure amount)) \ No newline at end of file diff --git a/eras/babel/test-suite/test/GenerateGoldenFileMain.hs b/eras/babel/test-suite/test/GenerateGoldenFileMain.hs new file mode 100644 index 00000000000..df043ad0d61 --- /dev/null +++ b/eras/babel/test-suite/test/GenerateGoldenFileMain.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeApplications #-} + +module Main where + +import Cardano.Ledger.Babel (Babel) +import Test.Cardano.Ledger.Alonzo.Translation.Golden (generateGoldenFile) +import Test.Cardano.Ledger.Babel.Arbitrary () +import Test.Cardano.Ledger.Babel.Translation.TranslatableGen () + +-- | Generates golden translation file for Babel era +main :: IO () +main = generateGoldenFile @Babel "eras/conway/test-suite/golden/translations.cbor" diff --git a/eras/babel/test-suite/test/Test/Cardano/Ledger/Conway/TxInfo.hs b/eras/babel/test-suite/test/Test/Cardano/Ledger/Conway/TxInfo.hs new file mode 100644 index 00000000000..a012ff2cc1f --- /dev/null +++ b/eras/babel/test-suite/test/Test/Cardano/Ledger/Conway/TxInfo.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Cardano.Ledger.Babel.TxInfo where + +import Data.Proxy (Proxy (..)) +import Test.Tasty (TestTree, testGroup) + +txInfoTests :: + forall era. + Proxy era -> + TestTree +txInfoTests _p = testGroup "Babel Plutus Tests" [] -- Disabled for now +-- B.txInfoTestsV2 p PlutusV3 -- The V2 tests in Babbage should all hold for V3 diff --git a/eras/babel/test-suite/test/Tests.hs b/eras/babel/test-suite/test/Tests.hs new file mode 100644 index 00000000000..011d33e7104 --- /dev/null +++ b/eras/babel/test-suite/test/Tests.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} + +module Main where + +import Cardano.Ledger.Babel (Babel) +import Data.Proxy (Proxy (..)) +import qualified Test.Cardano.Ledger.Babbage.TxInfo as Babbage (txInfoTests) +import Test.Cardano.Ledger.Babel.RulesTests (chainExamples) +import qualified Test.Cardano.Ledger.Babel.TxInfo as Babel (txInfoTests) +import Test.Tasty (TestTree, defaultMain, testGroup) + +main :: IO () +main = defaultMain defaultTests + +defaultTests :: TestTree +defaultTests = + testGroup + "Babel tests" + [ -- Babbage.txInfoTests (Proxy @Babel) + -- , Babel.txInfoTests (Proxy @Babel) + -- , + chainExamples + ] diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 053d8f523cd..97e58cad452 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -99,7 +99,8 @@ library deepseq, microlens, nothunks, - plutus-ledger-api ^>=1.26.0, + plutus-ledger-api ^>=1.30.0.0, + plutus-tx, set-algebra, small-steps >=1.1, text, diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs index d4e52f4b496..44bff15e68b 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs @@ -41,6 +41,8 @@ module Cardano.Ledger.Conway.PParams ( ppuDRepDepositL, ppuDRepActivityL, ppuMinFeeRefScriptCostPerByteL, + conwayPParamsPairs, + conwayApplyPPUpdates, PoolVotingThresholds (..), pvtCommitteeNoConfidenceL, pvtCommitteeNormalL, @@ -50,6 +52,8 @@ module Cardano.Ledger.Conway.PParams ( dvtCommitteeNormalL, dvtHardForkInitiationL, dvtMotionNoConfidenceL, + emptyConwayPParamsUpdate, + emptyConwayPParams, dvtPPNetworkGroupL, dvtPPGovGroupL, dvtPPTechnicalGroupL, diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Plutus/Context.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Plutus/Context.hs index 24dd833bbd5..22bb3690512 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Plutus/Context.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Plutus/Context.hs @@ -209,4 +209,4 @@ class ) => ConwayEraPlutusTxInfo (l :: Language) era where - toPlutusChangedParameters :: proxy l -> PParamsUpdate era -> PV3.ChangedParameters + toPlutusChangedParameters :: proxy l -> PParamsUpdate era -> PV3.ChangedParameters \ No newline at end of file diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs index 41db2b97564..b1cbbcb9cd8 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs @@ -18,6 +18,7 @@ module Cardano.Ledger.Conway.Rules.Ledger ( ConwayLEDGER, ConwayLedgerPredFailure (..), ConwayLedgerEvent (..), + ledgerTransition, ) where import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..)) @@ -398,7 +399,9 @@ ledgerTransition = do ) let utxoState' = utxoState - & utxosGovStateL . proposalsGovStateL .~ proposalsState + & utxosGovStateL + . proposalsGovStateL + .~ proposalsState pure (utxoState', certStateAfterCERTS) else pure (utxoState, certState) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs index 83597505dd1..ae75a436118 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs @@ -13,6 +13,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Ledger.Conway.Rules.Ratify ( + ConwayRATIFY, RatifyState (..), committeeAccepted, committeeAcceptedRatio, @@ -336,9 +337,12 @@ ratifyTransition = do let st' = st - & rsEnactStateL .~ newEnactState - & rsDelayedL .~ delayingAction govAction - & rsEnactedL %~ (Seq.:|> gas) + & rsEnactStateL + .~ newEnactState + & rsDelayedL + .~ delayingAction govAction + & rsEnactedL + %~ (Seq.:|> gas) trans @(ConwayRATIFY era) $ TRC (env, st', RatifySignal sigs) else do -- This action hasn't been ratified yet. Process the remaining actions. diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxos.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxos.hs index bb6dec693f7..46dc4a5f995 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxos.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxos.hs @@ -282,7 +282,7 @@ conwayEvalScriptsTxValid :: ) => TransitionRule (EraRule "UTXOS" era) conwayEvalScriptsTxValid = do - TRC (UtxoEnv _ pp certState, utxos@(UTxOState utxo _ _ govState _ _), tx) <- + TRC (UtxoEnv _ pp certState, utxos@(UTxOState utxo _ _ _ govState _ _), tx) <- judgmentContext let txBody = tx ^. bodyTxL diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Scripts.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Scripts.hs index ba479068839..7976976f828 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Scripts.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Scripts.hs @@ -102,6 +102,7 @@ instance Crypto c => AlonzoEraScript (ConwayEra c) where SPlutusV1 -> Just $ ConwayPlutusV1 plutus SPlutusV2 -> Just $ ConwayPlutusV2 plutus SPlutusV3 -> Just $ ConwayPlutusV3 plutus + SPlutusV4 -> Nothing withPlutusScript (ConwayPlutusV1 plutus) f = f plutus withPlutusScript (ConwayPlutusV2 plutus) f = f plutus diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Transition.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Transition.hs index 83dc9d6a328..f880b56cf9a 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Transition.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Transition.hs @@ -146,7 +146,12 @@ registerDelegs :: NewEpochState era -> NewEpochState era registerDelegs cfg = - nesEsL . esLStateL . lsCertStateL . certDStateL . dsUnifiedL . umElemsL + nesEsL + . esLStateL + . lsCertStateL + . certDStateL + . dsUnifiedL + . umElemsL %~ \m -> ListMap.foldrWithKey (\(k, v) -> Map.insertWith joinUMElems k $ delegateeToUMElem v) m delegs where delegs = cfg ^. tcDelegsL diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs index d4ae6381061..5d0d9aec636 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs @@ -81,7 +81,8 @@ instance Crypto c => TranslateEra (ConwayEra c) NewEpochState where -- the pulser will reset it. ratifyState = def - & rsEnactStateL .~ mkEnactState (es ^. epochStateGovStateL) + & rsEnactStateL + .~ mkEnactState (es ^. epochStateGovStateL) pure $ NewEpochState { nesEL = nesEL nes @@ -107,9 +108,12 @@ instance Crypto c => TranslateEra (ConwayEra c) Tx where let isValidTx = tx ^. isValidTxL newTx = mkBasicTx txBody - & witsTxL .~ txWits - & isValidTxL .~ isValidTx - & auxDataTxL .~ auxData + & witsTxL + .~ txWits + & isValidTxL + .~ isValidTx + & auxDataTxL + .~ auxData pure $ Tx newTx -------------------------------------------------------------------------------- @@ -169,16 +173,21 @@ translateGovState ctxt@ConwayGenesis {..} sgov = let curPParams = translateEra' ctxt (sgov ^. curPParamsGovStateL) prevPParams = translateEra' ctxt (sgov ^. prevPParamsGovStateL) in emptyGovState - & cgsCurPParamsL .~ curPParams - & cgsPrevPParamsL .~ prevPParams - & cgsCommitteeL .~ SJust cgCommittee - & cgsConstitutionL .~ cgConstitution + & cgsCurPParamsL + .~ curPParams + & cgsPrevPParamsL + .~ prevPParams + & cgsCommitteeL + .~ SJust cgCommittee + & cgsConstitutionL + .~ cgConstitution instance Crypto c => TranslateEra (ConwayEra c) UTxOState where translateEra ctxt us = pure UTxOState { API.utxosUtxo = translateEra' ctxt $ API.utxosUtxo us + , API.utxosFrxo = mempty , API.utxosDeposited = API.utxosDeposited us , API.utxosFees = API.utxosFees us , API.utxosGovState = diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Tx.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Tx.hs index d94ae8f7a3b..86527d065f3 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Tx.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Tx.hs @@ -6,6 +6,7 @@ module Cardano.Ledger.Conway.Tx ( module BabbageTxReExport, + getConwayMinFeeTx, ) where @@ -38,6 +39,8 @@ import Cardano.Ledger.Conway.TxWits () import Cardano.Ledger.Core import Cardano.Ledger.Crypto import Cardano.Ledger.Val (Val (..)) +import Control.Monad ((<=<)) +import qualified Data.Sequence.Strict as StrictSeq import Lens.Micro ((^.)) instance Crypto c => EraTx (ConwayEra c) where @@ -94,8 +97,8 @@ instance Crypto c => AlonzoEraTx (ConwayEra c) where {-# INLINE isValidTxL #-} instance Crypto c => EraSegWits (ConwayEra c) where - type TxSeq (ConwayEra c) = AlonzoTxSeq (ConwayEra c) - fromTxSeq = txSeqTxns - toTxSeq = AlonzoTxSeq - hashTxSeq = hashAlonzoTxSeq + type TxZones (ConwayEra c) = AlonzoTxSeq (ConwayEra c) + fromTxZones = fmap StrictSeq.singleton . txSeqTxns + toTxZones = AlonzoTxSeq . StrictSeq.forceToStrict . (StrictSeq.fromStrict <=< StrictSeq.fromStrict) + hashTxZones = hashAlonzoTxSeq numSegComponents = 4 diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs index 87ebb8b24ca..3ed0e1ede6b 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/TxInfo.hs @@ -113,6 +113,7 @@ import Control.Monad (unless, when, zipWithM) import Data.Aeson (ToJSON (..), (.=)) import Data.Foldable as F (Foldable (..)) import qualified Data.Map.Strict as Map +import Data.Maybe (fromJust) import qualified Data.OSet.Strict as OSet import qualified Data.Set as Set import GHC.Generics hiding (to) @@ -121,6 +122,8 @@ import NoThunks.Class (NoThunks) import qualified PlutusLedgerApi.V1 as PV1 import qualified PlutusLedgerApi.V2 as PV2 import qualified PlutusLedgerApi.V3 as PV3 +import qualified PlutusTx.AssocMap as PMap +import qualified PlutusTx.Eq instance Crypto c => EraPlutusContext (ConwayEra c) where type ContextError (ConwayEra c) = ConwayContextError (ConwayEra c) @@ -466,8 +469,20 @@ instance Crypto c => EraPlutusTxInfo 'PlutusV3 (ConwayEra c) where where txBody = tx ^. bodyTxL - toPlutusScriptContext proxy txInfo scriptPurpose = - PV3.ScriptContext txInfo <$> toPlutusScriptPurpose proxy scriptPurpose + toPlutusScriptContext proxy txInfo scriptPurpose = do + let redeemers :: PMap.Map PV3.ScriptPurpose PV3.Redeemer = PV3.txInfoRedeemers txInfo + purpose <- toPlutusScriptPurpose proxy scriptPurpose + let redeemer = fromJust $ PMap.lookup purpose redeemers -- TODO WG obviously partial + pure $ PV3.ScriptContext txInfo redeemer (fromScriptPurpose purpose) + +fromScriptPurpose :: PV3.ScriptPurpose -> PV3.ScriptInfo +fromScriptPurpose = \case + PV3.Minting cs -> PV3.MintingScript cs + PV3.Spending txOutRef -> PV3.SpendingScript txOutRef Nothing + PV3.Rewarding cred -> PV3.RewardingScript cred + PV3.Certifying index txCert -> PV3.CertifyingScript index txCert + PV3.Voting voter -> PV3.VotingScript voter + PV3.Proposing index proposal -> PV3.ProposingScript index proposal transTxId :: TxId c -> PV3.TxId transTxId txId = PV3.TxId (transSafeHash (unTxId txId)) @@ -655,9 +670,12 @@ transProtVer (ProtVer major minor) = -- ========================== -- Instances +instance PlutusTx.Eq.Eq PV3.ScriptPurpose where + (==) = undefined -- TODO WG (I don't want to go and recalculate the hashes of my forked Plutus repo) + instance Crypto c => ToPlutusData (PParamsUpdate (ConwayEra c)) where toPlutusData = pparamUpdateToData conwayPParamMap fromPlutusData = pparamUpdateFromData conwayPParamMap instance Crypto c => ConwayEraPlutusTxInfo 'PlutusV3 (ConwayEra c) where - toPlutusChangedParameters _ x = PV3.ChangedParameters (PV3.dataToBuiltinData (toPlutusData x)) + toPlutusChangedParameters _ x = PV3.ChangedParameters (PV3.dataToBuiltinData (toPlutusData x)) \ No newline at end of file diff --git a/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Translation/TranslatableGen.hs b/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Translation/TranslatableGen.hs index d45e986cd72..3cdd8c33cfd 100644 --- a/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Translation/TranslatableGen.hs +++ b/eras/conway/test-suite/src/Test/Cardano/Ledger/Conway/Translation/TranslatableGen.hs @@ -39,6 +39,8 @@ instance TranslatableGen Conway where mkTxInfoLanguage PlutusV1 = TxInfoLanguage SPlutusV1 mkTxInfoLanguage PlutusV2 = TxInfoLanguage SPlutusV2 mkTxInfoLanguage PlutusV3 = TxInfoLanguage SPlutusV3 + mkTxInfoLanguage lang = + error $ "Language " ++ show lang ++ " is not supported in " ++ eraName @Conway genTxBody :: forall c. Crypto c => Language -> Gen (ConwayTxBody (ConwayEra c)) genTxBody l = do diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/Translation.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/Translation.hs index e9bc69cb39e..fa5304695d2 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/Translation.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/Translation.hs @@ -137,6 +137,7 @@ instance Crypto c => TranslateEra (MaryEra c) UTxOState where return UTxOState { utxosUtxo = translateEra' ctxt $ utxosUtxo us + , utxosFrxo = mempty , utxosDeposited = utxosDeposited us , utxosFees = utxosFees us , utxosGovState = translateEra' ctxt $ utxosGovState us diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/Tx.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/Tx.hs index d9e166e9f52..d1d56ece70b 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/Tx.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/Tx.hs @@ -9,7 +9,13 @@ module Cardano.Ledger.Mary.Tx ( where import Cardano.Ledger.Allegra.Tx (validateTimelock) -import Cardano.Ledger.Core (EraTx (..), upgradeTxAuxData, upgradeTxBody, upgradeTxWits) +import Cardano.Ledger.Core ( + --EraRequiredTxsData (RequiredTxs), + EraTx (..), + upgradeTxAuxData, + upgradeTxBody, + upgradeTxWits, + ) import Cardano.Ledger.Crypto (Crypto, StandardCrypto) import Cardano.Ledger.Mary.Era (MaryEra) import Cardano.Ledger.Mary.PParams () @@ -17,6 +23,7 @@ import Cardano.Ledger.Mary.TxAuxData () import Cardano.Ledger.Mary.TxBody () import Cardano.Ledger.Mary.TxWits () import Cardano.Ledger.Shelley.Tx ( + --ShelleyRequiredTx, ShelleyTx (..), auxDataShelleyTxL, bodyShelleyTxL, @@ -28,6 +35,11 @@ import Cardano.Ledger.Shelley.Tx ( -- ======================================== +-- instance Crypto c => EraRequiredTxsData (MaryEra c) where +-- {-# SPECIALIZE instance EraRequiredTxsData (MaryEra StandardCrypto) #-} + +-- type RequiredTxs (MaryEra c) = ShelleyRequiredTx (MaryEra c) + instance Crypto c => EraTx (MaryEra c) where {-# SPECIALIZE instance EraTx (MaryEra StandardCrypto) #-} @@ -44,6 +56,9 @@ instance Crypto c => EraTx (MaryEra c) where auxDataTxL = auxDataShelleyTxL {-# INLINE auxDataTxL #-} + -- requiredTxsTxL = lens (const mempty) const + -- {-# INLINE requiredTxsTxL #-} + sizeTxF = sizeShelleyTxF {-# INLINE sizeTxF #-} diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/TxSeq.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/TxSeq.hs index 793797b8239..37840f51cb1 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/TxSeq.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/TxSeq.hs @@ -15,11 +15,13 @@ import Cardano.Ledger.Crypto (Crypto, StandardCrypto) import Cardano.Ledger.Mary.Era (MaryEra) import Cardano.Ledger.Mary.Tx () import Cardano.Ledger.Shelley.BlockChain (ShelleyTxSeq (..), bbHash, txSeqTxns) +import Control.Monad ((<=<)) +import qualified Data.Sequence.Strict as StrictSeq instance Crypto c => EraSegWits (MaryEra c) where {-# SPECIALIZE instance EraSegWits (MaryEra StandardCrypto) #-} - type TxSeq (MaryEra c) = ShelleyTxSeq (MaryEra c) - fromTxSeq = txSeqTxns - toTxSeq = ShelleyTxSeq - hashTxSeq = bbHash + type TxZones (MaryEra c) = ShelleyTxSeq (MaryEra c) + fromTxZones = fmap StrictSeq.singleton . txSeqTxns + toTxZones = ShelleyTxSeq . StrictSeq.forceToStrict . (StrictSeq.fromStrict <=< StrictSeq.fromStrict) + hashTxZones = bbHash numSegComponents = 3 diff --git a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Examples.hs b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Examples.hs index 5db1c8428c3..95416fa6d96 100644 --- a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Examples.hs +++ b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Examples.hs @@ -26,7 +26,7 @@ import Test.Tasty.HUnit (Assertion, (@?=)) ignoreAllButUTxO :: Either (NonEmpty (PredicateFailure (ShelleyLEDGER Mary))) (LedgerState Mary) -> Either (NonEmpty (PredicateFailure (ShelleyLEDGER Mary))) (UTxO Mary) -ignoreAllButUTxO = fmap (\(LedgerState (UTxOState utxo _ _ _ _ _) _) -> utxo) +ignoreAllButUTxO = fmap (\(LedgerState (UTxOState utxo _ _ _ _ _ _) _) -> utxo) testMaryNoDelegLEDGER :: HasCallStack => diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/ByronTranslation.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/ByronTranslation.hs index bd50d3e0c35..f66d876515f 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/ByronTranslation.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/ByronTranslation.hs @@ -149,8 +149,10 @@ translateToShelleyLedgerState transCtxt epochNo cvs = , esLState = ledgerState , esNonMyopic = def } - & prevPParamsEpochStateL .~ pparams - & curPParamsEpochStateL .~ pparams + & prevPParamsEpochStateL + .~ pparams + & curPParamsEpochStateL + .~ pparams utxoByron :: Byron.UTxO utxoByron = Byron.cvsUtxo cvs @@ -164,6 +166,7 @@ translateToShelleyLedgerState transCtxt epochNo cvs = { lsUTxOState = UTxOState { utxosUtxo = utxoShelley + , utxosFrxo = mempty , utxosDeposited = Coin 0 , utxosFees = Coin 0 , utxosGovState = emptyGovState diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs index eaa0dc89289..3043738a599 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs @@ -4,7 +4,11 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} @@ -65,7 +69,7 @@ class , Environment (EraRule "BBODY" era) ~ STS.BbodyEnv era , State (EraRule "BBODY" era) ~ STS.ShelleyBbodyState era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era - , EncCBORGroup (TxSeq era) + , EncCBORGroup (TxZones era) , State (EraRule "LEDGERS" era) ~ LedgerState era ) => ApplyBlock era diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs index a31e629d7a9..f4c2c15ec6f 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs @@ -77,7 +77,7 @@ totalAdaPotsES (EpochState (AccountState treasury_ reserves_) ls _ _) = , obligationsPot = obligationCertState certState <> govStateObligations } where - UTxOState u _ fees_ _ _ _ = lsUTxOState ls + UTxOState u _ _ fees_ _ _ _ = lsUTxOState ls certState@(CertState _ _ dstate) = lsCertState ls rewards_ = fromCompact $ sumRewardsUView (rewards dstate) coins = coinBalance u diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs index ce1c35c4b43..bc716818ac3 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs @@ -57,7 +57,7 @@ import Cardano.Ledger.SafeHash (SafeToHash (..)) import Cardano.Ledger.Shelley.Era (ShelleyEra) import Cardano.Ledger.Shelley.Tx (ShelleyTx, segwitTx) import Cardano.Ledger.Slot (SlotNo (..)) -import Control.Monad (unless) +import Control.Monad (unless, (<=<)) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BSL import Data.Coerce (coerce) @@ -65,7 +65,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Sequence (Seq) import qualified Data.Sequence as Seq -import Data.Sequence.Strict (StrictSeq) +import Data.Sequence.Strict (StrictSeq (fromStrict), forceToStrict) import qualified Data.Sequence.Strict as StrictSeq import Data.Typeable import GHC.Generics (Generic) @@ -82,10 +82,10 @@ data ShelleyTxSeq era = TxSeq' deriving (Generic) instance Crypto c => EraSegWits (ShelleyEra c) where - type TxSeq (ShelleyEra c) = ShelleyTxSeq (ShelleyEra c) - fromTxSeq = txSeqTxns - toTxSeq = ShelleyTxSeq - hashTxSeq = bbHash + type TxZones (ShelleyEra c) = ShelleyTxSeq (ShelleyEra c) + fromTxZones = fmap StrictSeq.singleton . txSeqTxns + toTxZones = ShelleyTxSeq . forceToStrict . (fromStrict <=< fromStrict) + hashTxZones = bbHash numSegComponents = 3 deriving via diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/IncrementalStake.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/IncrementalStake.hs index e24eb05a878..2777fbbd757 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/IncrementalStake.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/IncrementalStake.hs @@ -165,6 +165,7 @@ smartUTxOState :: smartUTxOState pp utxo c1 c2 st = UTxOState utxo + mempty c1 c2 st @@ -288,8 +289,12 @@ applyRUpdFiltered where !epochStateAns = EpochState as' ls' ss nm' - & curPParamsEpochStateL .~ es ^. curPParamsEpochStateL - & prevPParamsEpochStateL .~ es ^. prevPParamsEpochStateL + & curPParamsEpochStateL + .~ es + ^. curPParamsEpochStateL + & prevPParamsEpochStateL + .~ es + ^. prevPParamsEpochStateL utxoState_ = lsUTxOState ls dpState = lsCertState ls dState = certDState dpState diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/NewEpochState.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/NewEpochState.hs index 144728b7a94..115d2009216 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/NewEpochState.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/NewEpochState.hs @@ -73,6 +73,7 @@ genesisState genDelegs0 utxo0 = LedgerState ( UTxOState utxo0 + mempty (Coin 0) (Coin 0) emptyGovState @@ -126,8 +127,10 @@ updateNES { nesBcur = bcur , nesEs = EpochState acnt ls ss nm - & curPParamsEpochStateL .~ pp - & prevPParamsEpochStateL .~ pr + & curPParamsEpochStateL + .~ pp + & prevPParamsEpochStateL + .~ pr } returnRedeemAddrsToReserves :: diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs index ecbfe85ab5a..37ec726f69d 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs @@ -58,6 +58,7 @@ import Cardano.Ledger.Coin (Coin (..), CompactForm) import Cardano.Ledger.Credential (Credential (..), Ptr (..)) import Cardano.Ledger.Crypto (Crypto) import Cardano.Ledger.EpochBoundary (SnapShots (..), ssStakeDistrL, ssStakeMarkL) +import Cardano.Ledger.FRxO (FRxO) import Cardano.Ledger.Keys ( KeyHash (..), KeyPair, @@ -276,6 +277,7 @@ toIncrementalStakePairs iStake@(IStake _ _) = -- this invariant. This happens in the UTxO rule. data UTxOState era = UTxOState { utxosUtxo :: !(UTxO era) + , utxosFrxo :: !(FRxO era) , utxosDeposited :: Coin -- ^ This field is left lazy, because we only use it for assertions , utxosFees :: !Coin @@ -309,6 +311,7 @@ deriving via (UTxOState era) instance ( NoThunks (UTxO era) + , NoThunks (FRxO era) , NoThunks (GovState era) , Era era ) => @@ -320,10 +323,11 @@ instance ) => EncCBOR (UTxOState era) where - encCBOR (UTxOState ut dp fs us sd don) = + encCBOR (UTxOState ut fr dp fs us sd don) = encode $ Rec UTxOState !> To ut + !> To fr !> To dp !> To fs !> To us @@ -342,6 +346,7 @@ instance decShareCBOR credInterns = decodeRecordNamed "UTxOState" (const 6) $ do utxosUtxo <- decShareCBOR credInterns + utxosFrxo <- decShareCBOR credInterns utxosDeposited <- decCBOR utxosFees <- decCBOR -- TODO: implement proper sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486 @@ -362,9 +367,10 @@ instance (EraTxOut era, EraGov era) => ToJSON (UTxOState era) where toUTxOStatePairs :: (EraTxOut era, EraGov era, KeyValue e a) => UTxOState era -> [a] -toUTxOStatePairs utxoState@(UTxOState _ _ _ _ _ _) = +toUTxOStatePairs utxoState@(UTxOState _ _ _ _ _ _ _) = let UTxOState {..} = utxoState in [ "utxo" .= utxosUtxo + , "frxo" .= utxosFrxo , "deposited" .= utxosDeposited , "fees" .= utxosFees , "ppups" .= utxosGovState @@ -566,7 +572,7 @@ toLedgerStatePairs ls@(LedgerState _ _) = -------------------------------------------------------------------------------- instance EraGov era => Default (UTxOState era) where - def = UTxOState mempty mempty mempty def mempty mempty + def = UTxOState mempty mempty mempty mempty def mempty mempty instance Default (LedgerState era) => 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 30a2ee49fb5..264c2f01216 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs @@ -174,12 +174,12 @@ bbodyTransition = >>= \( TRC ( BbodyEnv pp account , BbodyState ls b - , UnserialisedBlock bhview txsSeq + , UnserialisedBlock bhview txsZones ) ) -> do - let txs = fromTxSeq txsSeq - actualBodySize = bBodySize (pp ^. ppProtocolVersionL) txsSeq - actualBodyHash = hashTxSeq txsSeq + let txs = fromTxZones txsZones + actualBodySize = bBodySize (pp ^. ppProtocolVersionL) txsZones + actualBodyHash = hashTxZones txsZones actualBodySize == fromIntegral (bhviewBSize bhview) @@ -191,7 +191,8 @@ bbodyTransition = ls' <- trans @(EraRule "LEDGERS" era) $ - TRC (LedgersEnv (bhviewSlot bhview) pp account, ls, StrictSeq.fromStrict txs) + TRC + (LedgersEnv (bhviewSlot bhview) pp account, ls, StrictSeq.fromStrict =<< StrictSeq.fromStrict txs) -- Note that this may not actually be a stake pool - it could be a genesis key -- delegate. However, this would only entail an overhead of 7 counts, and it's diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs index b107c23aaa3..daaed4144ba 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs @@ -97,7 +97,7 @@ snapTransition :: snapTransition = do TRC (snapEnv, s, _) <- judgmentContext - let SnapEnv (LedgerState (UTxOState _utxo _ fees _ incStake _) (CertState _ pstate dstate)) pp = snapEnv + let SnapEnv (LedgerState (UTxOState _utxo _ _ fees _ incStake _) (CertState _ pstate dstate)) pp = snapEnv -- per the spec: stakeSnap = stakeDistr @era utxo dstate pstate istakeSnap = incrementalStakeDistr pp incStake dstate pstate 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 21618639e2f..0a9179c3dd0 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs @@ -409,7 +409,7 @@ utxoInductive :: TransitionRule (EraRule "UTXO" era) utxoInductive = do TRC (UtxoEnv slot pp certState, utxos, tx) <- judgmentContext - let UTxOState utxo _ _ ppup _ _ = utxos + let UTxOState utxo _ _ _ ppup _ _ = utxos txBody = tx ^. bodyTxL outputs = txBody ^. outputsTxBodyL genDelegs = dsGenDelegs (certDState certState) @@ -648,6 +648,7 @@ updateUTxOState pp utxos txBody certState govState depositChangeEvent txUtxODiff pure $! UTxOState { utxosUtxo = UTxO newUTxO + , utxosFrxo = mempty , utxosDeposited = utxosDeposited <> depositChange , utxosFees = utxosFees <> txBody ^. feeTxBodyL , utxosGovState = govState diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs index f184c6c0d32..ceddcd173a8 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Tx.hs @@ -5,6 +5,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -13,6 +14,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} module Cardano.Ledger.Shelley.Tx ( @@ -37,9 +39,15 @@ module Cardano.Ledger.Shelley.Tx ( -- * Deprecated txwitsScript, hashMultiSigScript, + + -- * Babel Fees ) where +-- ShelleyRequiredTx (requiredTxs), +-- ShelleyRequiredTxRaw (..), +-- pattern ShelleyRequiredTx, + import Cardano.Ledger.Binary ( Annotator (..), DecCBOR (decCBOR), @@ -181,6 +189,78 @@ mkBasicShelleyTx txBody = , strAuxiliaryData = SNothing } +-- newtype ShelleyRequiredTxRaw era = ShelleyRequiredTxRaw (Set (TxId (EraCrypto era))) +-- deriving (Eq, Show, Generic) + +-- instance EraScript era => NoThunks (ShelleyRequiredTxRaw era) + +-- deriving newtype instance Era era => EncCBOR (ShelleyRequiredTxRaw era) + +-- deriving newtype instance Era era => DecCBOR (ShelleyRequiredTxRaw era) + +-- instance Era era => DecCBOR (Annotator (ShelleyRequiredTxRaw era)) where +-- decCBOR = pure <$> decCBOR + +-- deriving via +-- (Mem ShelleyRequiredTxRaw era) +-- instance +-- Era era => DecCBOR (Annotator (ShelleyRequiredTx era)) + +-- newtype ShelleyRequiredTx era +-- = RequiredTxBodyConstr (MemoBytes ShelleyRequiredTxRaw era) +-- deriving (Eq, Generic) +-- deriving newtype (Plain.ToCBOR, SafeToHash) + +-- deriving newtype instance EraScript era => Show (ShelleyRequiredTx era) + +-- instance EraScript era => NoThunks (ShelleyRequiredTx era) + +-- instance Memoized ShelleyRequiredTx where +-- type RawType ShelleyRequiredTx = ShelleyRequiredTxRaw + +-- deriving newtype instance EraRequiredTxsData era => NFData (ShelleyRequiredTxRaw era) +-- deriving newtype instance EraRequiredTxsData era => NFData (ShelleyRequiredTx era) + +-- pattern ShelleyRequiredTx :: +-- forall era. +-- EraScript era => +-- Set (TxId (EraCrypto era)) -> +-- ShelleyRequiredTx era +-- pattern ShelleyRequiredTx {requiredTxs} <- +-- (getMemoRawType -> ShelleyRequiredTxRaw requiredTxs) +-- where +-- ShelleyRequiredTx requiredTxs' = +-- mkMemoized $ ShelleyRequiredTxRaw requiredTxs' + +-- {-# COMPLETE ShelleyRequiredTx #-} + +-- instance EraScript era => Semigroup (ShelleyRequiredTx era) where +-- (ShelleyRequiredTx a) <> y | Set.null a = y +-- y <> (ShelleyRequiredTx a) | Set.null a = y +-- (ShelleyRequiredTx a) <> (ShelleyRequiredTx a') = ShelleyRequiredTx (a <> a') + +-- instance EraScript era => Monoid (ShelleyRequiredTx era) where +-- mempty = ShelleyRequiredTx mempty + +-- instance +-- (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => +-- EqRaw (ShelleyRequiredTx era) + +-- instance c ~ EraCrypto era => HashAnnotated (ShelleyRequiredTx era) EraIndependentRequiredTxs c where +-- hashAnnotated = getMemoSafeHash + +-- -- instance Crypto c => EraRequiredTxsData (ShelleyEra c) where +-- -- type RequiredTxs (ShelleyEra c) = ShelleyRequiredTx (ShelleyEra c) + +-- -- | Encodes memoized bytes created upon construction. +-- instance Era era => EncCBOR (ShelleyRequiredTx era) + +-- type instance MemoHashIndex ShelleyRequiredTxRaw = EraIndependentRequiredTxs + +-- deriving instance +-- HashAlgorithm (HASH (EraCrypto era)) => +-- Show (ShelleyRequiredTx era) + instance Crypto c => EraTx (ShelleyEra c) where {-# SPECIALIZE instance EraTx (ShelleyEra StandardCrypto) #-} @@ -197,6 +277,9 @@ instance Crypto c => EraTx (ShelleyEra c) where auxDataTxL = auxDataShelleyTxL {-# INLINE auxDataTxL #-} + -- requiredTxsTxL = lens (const mempty) const + -- {-# INLINE requiredTxsTxL #-} + sizeTxF = sizeShelleyTxF {-# INLINE sizeTxF #-} 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 7a69a7c71b1..f261b025f52 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Arbitrary.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Arbitrary.hs @@ -23,6 +23,8 @@ module Test.Cardano.Ledger.Shelley.Arbitrary ( ASC (..), StakeProportion (..), VRFNatVal (..), + -- genRequiredTx, + -- genRequiredTxRaw, ) where import qualified Cardano.Chain.UTxO as Byron @@ -31,14 +33,13 @@ import Cardano.Ledger.BaseTypes import Cardano.Ledger.Binary (EncCBOR) import Cardano.Ledger.Crypto import Cardano.Ledger.Shelley (ShelleyEra) -import Cardano.Ledger.Shelley.API ( - ApplyTxError (ApplyTxError), +import Cardano.Ledger.Shelley.API.Mempool (ApplyTxError (..)) +import Cardano.Ledger.Shelley.API.Types ( MultiSig (..), NominalDiffTimeMicro (..), ShelleyDelegCert, ShelleyGenesis (..), ShelleyGenesisStaking (ShelleyGenesisStaking), - ShelleyTx (ShelleyTx), ShelleyTxBody (ShelleyTxBody), ) import Cardano.Ledger.Shelley.Core @@ -64,6 +65,7 @@ import Cardano.Ledger.Shelley.Rules ( ShelleyUtxowPredFailure, VotingPeriod, ) +import Cardano.Ledger.Shelley.Tx import Cardano.Ledger.Shelley.TxAuxData import Cardano.Ledger.Shelley.TxCert ( GenesisDelegCert (..), @@ -185,6 +187,7 @@ instance <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary -- The 'genericShrink' function returns first the immediate subterms of a -- value (in case it is a recursive data-type), and then shrinks the value @@ -517,6 +520,17 @@ instance <*> scale (`div` 15) arbitrary <*> arbitrary +-- instance +-- ( EraScript era +-- , EraTxOut era +-- , EncCBOR (TxCert era) +-- ) => +-- Arbitrary (ShelleyRequiredTx era) +-- where +-- arbitrary = +-- ShelleyRequiredTx +-- <$> pure mempty -- arbitrary + genTx :: ( EraTx era , Arbitrary (TxBody era) @@ -530,6 +544,20 @@ genTx = <*> resize maxTxWits arbitrary <*> arbitrary +-- genRequiredTxRaw :: +-- -- EraTx era => +-- Gen (ShelleyRequiredTxRaw era) +-- genRequiredTxRaw = +-- ShelleyRequiredTxRaw +-- <$> pure mempty -- arbitrary + +-- genRequiredTx :: +-- EraTx era => +-- Gen (ShelleyRequiredTx era) +-- genRequiredTx = +-- ShelleyRequiredTx +-- <$> pure mempty -- arbitrary + maxTxWits :: Int maxTxWits = 5 diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/TreeDiff.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/TreeDiff.hs index 1c40c9c9228..45014b98bca 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/TreeDiff.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/TreeDiff.hs @@ -93,6 +93,22 @@ instance ) => ToExpr (ShelleyTxBody era) +-- Babel Fees + +-- instance +-- ( ToExpr (TxOut era) +-- , ToExpr (TxCert era) +-- , ToExpr (Update era) +-- ) => +-- ToExpr (ShelleyRequiredTxRaw era) + +-- instance +-- ( ToExpr (TxOut era) +-- , ToExpr (TxCert era) +-- , ToExpr (Update era) +-- ) => +-- ToExpr (ShelleyRequiredTx era) + -- PoolRank instance ToExpr Likelihood diff --git a/eras/shelley/test-suite/bench/Main.hs b/eras/shelley/test-suite/bench/Main.hs index 35ab5136d18..b505e8aab2c 100644 --- a/eras/shelley/test-suite/bench/Main.hs +++ b/eras/shelley/test-suite/bench/Main.hs @@ -173,7 +173,7 @@ touchCertState :: CertState c -> Int touchCertState (CertState _x _y _z) = 1 touchUTxOState :: Cardano.Ledger.Shelley.LedgerState.UTxOState cryto -> Int -touchUTxOState (UTxOState _utxo _deposited _fees _ppups _ _) = 2 +touchUTxOState (UTxOState _utxo _ _deposited _fees _ppups _ _) = 2 profileCreateRegKeys :: IO () profileCreateRegKeys = do diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/BenchmarkFunctions.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/BenchmarkFunctions.hs index 6e5fe4e1afc..7a3df8b69a3 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/BenchmarkFunctions.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/BenchmarkFunctions.hs @@ -146,6 +146,7 @@ initUTxO :: Integer -> UTxOState B initUTxO n = UTxOState (genesisCoins genesisId (injcoins n)) + mempty (Coin 0) (Coin 0) def @@ -158,18 +159,30 @@ initUTxO n = ppsBench :: (EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) => PParams era ppsBench = emptyPParams - & ppMaxBBSizeL .~ 50000 - & ppDL .~ unsafeBoundRational 0.5 - & ppEMaxL .~ EpochInterval 10000 - & ppKeyDepositL .~ Coin 0 - & ppMaxBHSizeL .~ 10000 - & ppMaxTxSizeL .~ 1000000000 - & ppMinFeeAL .~ Coin 0 - & ppMinFeeBL .~ Coin 0 - & ppMinUTxOValueL .~ Coin 10 - & ppPoolDepositL .~ Coin 0 - & ppRhoL .~ unsafeBoundRational 0.0021 - & ppTauL .~ unsafeBoundRational 0.2 + & ppMaxBBSizeL + .~ 50000 + & ppDL + .~ unsafeBoundRational 0.5 + & ppEMaxL + .~ EpochInterval 10000 + & ppKeyDepositL + .~ Coin 0 + & ppMaxBHSizeL + .~ 10000 + & ppMaxTxSizeL + .~ 1000000000 + & ppMinFeeAL + .~ Coin 0 + & ppMinFeeBL + .~ Coin 0 + & ppMinUTxOValueL + .~ Coin 10 + & ppPoolDepositL + .~ Coin 0 + & ppRhoL + .~ unsafeBoundRational 0.0021 + & ppTauL + .~ unsafeBoundRational 0.2 ledgerEnv :: (EraPParams era, ProtVerAtMost era 4, ProtVerAtMost era 6) => LedgerEnv era ledgerEnv = LedgerEnv (SlotNo 0) minBound ppsBench (AccountState (Coin 0) (Coin 0)) diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs index 87bbb1879ce..ba494bebc29 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs @@ -97,7 +97,7 @@ data ShelleyLedgerExamples era = ShelleyLedgerExamples deriving instance ( EraTx era , EraGov era - , Eq (TxSeq era) + , Eq (TxZones era) , Eq (PredicateFailure (EraRule "LEDGER" era)) , Eq (StashedAVVMAddresses era) , Eq (TranslationContext era) @@ -168,6 +168,43 @@ defaultShelleyLedgerExamples mkWitnesses mkAlonzoTx value txBody auxData transla Helper constructors -------------------------------------------------------------------------------} +exampleShelleyLedgerBlockTxs :: + forall era. + (EraSegWits era, PraosCrypto (EraCrypto era)) => + [Tx era] -> + Block (BHeader (EraCrypto era)) era +exampleShelleyLedgerBlockTxs txs = Block blockHeader blockBody + where + keys :: AllIssuerKeys (EraCrypto era) 'StakePool + keys = exampleKeys + + hotKey = kesSignKey $ snd $ NE.head $ aikHot keys + KeyPair vKeyCold _ = aikCold keys + + blockHeader :: BHeader (EraCrypto era) + blockHeader = BHeader blockHeaderBody (signedKES () 0 blockHeaderBody hotKey) + + blockHeaderBody :: BHBody (EraCrypto era) + blockHeaderBody = + BHBody + { bheaderBlockNo = BlockNo 3 + , bheaderSlotNo = SlotNo 9 + , bheaderPrev = BlockHash (HashHeader (mkDummyHash (2 :: Int))) + , bheaderVk = coerceKeyRole vKeyCold + , bheaderVrfVk = vrfVerKey $ aikVrf keys + , bheaderEta = mkCertifiedVRF (mkBytes 0) (vrfSignKey $ aikVrf keys) + , bheaderL = mkCertifiedVRF (mkBytes 1) (vrfSignKey $ aikVrf keys) + , bsize = 4 + , bhash = hashTxZones @era blockBody + , bheaderOCert = mkOCert keys 0 (KESPeriod 0) + , bprotver = ProtVer (natVersion @2) 0 + } + + blockBody = toTxZones @era (fmap StrictSeq.singleton (StrictSeq.fromList txs)) + + mkBytes :: Int -> Cardano.Ledger.BaseTypes.Seed + mkBytes = Seed . mkDummyHash @Blake2b_256 + exampleShelleyLedgerBlock :: forall era. (EraSegWits era, PraosCrypto (EraCrypto era)) => @@ -195,12 +232,12 @@ exampleShelleyLedgerBlock tx = Block blockHeader blockBody , bheaderEta = mkCertifiedVRF (mkBytes 0) (vrfSignKey $ aikVrf keys) , bheaderL = mkCertifiedVRF (mkBytes 1) (vrfSignKey $ aikVrf keys) , bsize = 2345 - , bhash = hashTxSeq @era blockBody + , bhash = hashTxZones @era blockBody , bheaderOCert = mkOCert keys 0 (KESPeriod 0) , bprotver = ProtVer (natVersion @2) 0 } - blockBody = toTxSeq @era (StrictSeq.fromList [tx]) + blockBody = toTxZones @era (fmap StrictSeq.singleton (StrictSeq.fromList [tx])) mkBytes :: Int -> Cardano.Ledger.BaseTypes.Seed mkBytes = Seed . mkDummyHash @Blake2b_256 @@ -339,6 +376,7 @@ exampleNewEpochState value ppp pp = , mkBasicTxOut addr value ) ] + , utxosFrxo = mempty , utxosDeposited = Coin 1000 , utxosFees = Coin 1 , utxosGovState = emptyGovState @@ -349,8 +387,10 @@ exampleNewEpochState value ppp pp = } , esNonMyopic = def } - & prevPParamsEpochStateL .~ ppp - & curPParamsEpochStateL .~ pp + & prevPParamsEpochStateL + .~ ppp + & curPParamsEpochStateL + .~ pp where addr :: Addr (EraCrypto era) addr = diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Federation.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Federation.hs index 45f2a00c645..7067a13d048 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Federation.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Federation.hs @@ -44,6 +44,7 @@ import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Word (Word64) +import Debug.Trace (trace) import GHC.Stack (HasCallStack) import Lens.Micro ((^.)) import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), vKey) @@ -117,13 +118,19 @@ coreNodeKeysBySchedule :: Word64 -> AllIssuerKeys (EraCrypto era) 'GenesisDelegate coreNodeKeysBySchedule pp slot = - case lookupInOverlaySchedule - firstSlot - (Map.keysSet genDelegs) - (pp ^. ppDG) - (activeSlotCoeff testGlobals) - slot' of - Nothing -> error $ "coreNodesForSlot: Cannot find keys for slot " <> show slot + case trace "IS IT FROM HERE 3" $ + lookupInOverlaySchedule + firstSlot + (Map.keysSet genDelegs) + (pp ^. ppDG) + (activeSlotCoeff testGlobals) + slot' of + Nothing -> + error $ + "coreNodesForSlot: Cannot find keys for slot " + <> show slot + <> " ... " + <> (show $ Map.keysSet (genDelegs @(EraCrypto era))) Just NonActiveSlot -> error $ "coreNodesForSlot: Non-active slot " <> show slot Just (ActiveSlot gkh) -> case Data.List.find (\((_, gk), _) -> hashKey gk == gkh) coreNodes of diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs index 804a60546ba..77bad6aef8e 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs @@ -46,6 +46,7 @@ import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe) import Data.Sequence (Seq) import qualified Data.Set as Set +import Debug.Trace (trace) import Lens.Micro ((^.)) import Lens.Micro.Extras (view) import Test.Cardano.Ledger.Core.KeyPair (vKey) @@ -231,20 +232,21 @@ selectNextSlotWithLeader SlotNo -> Maybe (ChainState era, AllIssuerKeys (EraCrypto era) 'BlockIssuer) selectLeaderForSlot slotNo = - (chainSt,) - <$> case lookupInOverlaySchedule firstEpochSlot (Map.keysSet cores) d f slotNo of - Nothing -> - coerce - <$> List.find - ( \(AllIssuerKeys {aikVrf, aikColdKeyHash}) -> - isLeader aikColdKeyHash (vrfSignKey aikVrf) - ) - ksStakePools - Just (ActiveSlot x) -> - coerce $ - Map.lookup x cores - >>= \y -> Map.lookup (genDelegKeyHash y) ksIndexedGenDelegates - _ -> Nothing + trace "IS IT FROM HERE 2" $ + (chainSt,) + <$> case lookupInOverlaySchedule firstEpochSlot (Map.keysSet cores) d f slotNo of + Nothing -> + coerce + <$> List.find + ( \(AllIssuerKeys {aikVrf, aikColdKeyHash}) -> + isLeader aikColdKeyHash (vrfSignKey aikVrf) + ) + ksStakePools + Just (ActiveSlot x) -> + coerce $ + Map.lookup x cores + >>= \y -> Map.lookup (genDelegKeyHash y) ksIndexedGenDelegates + _ -> Nothing where chainSt = tickChainState slotNo origChainState epochNonce = chainEpochNonce chainSt @@ -260,7 +262,7 @@ selectNextSlotWithLeader isLeader poolHash vrfKey = let y = VRF.evalCertified @(VRF (EraCrypto era)) () (mkSeed seedL slotNo epochNonce) vrfKey stake = maybe 0 individualPoolStake $ Map.lookup poolHash poolDistr - in case lookupInOverlaySchedule firstEpochSlot (Map.keysSet cores) d f slotNo of + in trace "IS IT FROM HERE 1" $ case lookupInOverlaySchedule firstEpochSlot (Map.keysSet cores) d f slotNo of Nothing -> checkLeaderValue (VRF.certifiedOutput y) stake f Just (ActiveSlot x) | coerceKeyRole x == poolHash -> True _ -> False diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Utxo.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Utxo.hs index bd8f93521f8..0686ab86354 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Utxo.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Utxo.hs @@ -157,7 +157,7 @@ genTx constants ) (LedgerEnv slot txIx pparams reserves) - (LedgerState utxoSt@(UTxOState utxo _ _ _ _ _) dpState) = + (LedgerState utxoSt@(UTxOState utxo _ _ _ _ _ _) dpState) = do ------------------------------------------------------------------------- -- Generate the building blocks of a TxBody diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs index db07bfb0340..26075feee63 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/LaxBlock.hs @@ -20,7 +20,7 @@ import Cardano.Ledger.Binary ( decodeRecordNamed, ) import Cardano.Ledger.Block (Block (..)) -import Cardano.Ledger.Core (Era, EraSegWits (TxSeq), EraTx) +import Cardano.Ledger.Core (Era, EraSegWits (TxZones), EraTx) import Cardano.Ledger.Shelley.BlockChain (ShelleyTxSeq, txSeqDecoder) import Data.Typeable (Typeable) @@ -32,7 +32,7 @@ newtype LaxBlock h era = LaxBlock (Block h era) blockDecoder :: ( EraTx era - , TxSeq era ~ ShelleyTxSeq era + , TxZones era ~ ShelleyTxSeq era , DecCBOR (Annotator h) ) => Bool -> @@ -44,12 +44,12 @@ blockDecoder lax = annotatorSlice $ txns <- txSeqDecoder lax pure $ Block' <$> header <*> txns -deriving stock instance (Era era, Show (TxSeq era), Show h) => Show (LaxBlock h era) +deriving stock instance (Era era, Show (TxZones era), Show h) => Show (LaxBlock h era) instance ( EraTx era , Typeable h - , TxSeq era ~ ShelleyTxSeq era + , TxZones era ~ ShelleyTxSeq era , DecCBOR (Annotator h) ) => DecCBOR (Annotator (LaxBlock h era)) diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs index d7c50c327c1..81bd139431d 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs @@ -280,7 +280,7 @@ checkPreservation SourceSignalTarget {source, target, signal} count = <> toDeltaCoin (sumRewards prevPP (rs ru)) ] - txs' = toList $ (fromTxSeq @era . bbody) signal + txs' = concatMap toList $ (fromTxZones @era . bbody) signal txs = zipWith dispTx txs' [0 :: Int ..] dispTx tx ix = @@ -329,7 +329,7 @@ utxoDepositsIncreaseByFeesWithdrawals SourceSignalTarget {source, signal, target circulation target <-> circulation source === withdrawals signal - <-> txFees ledgerTr + <-> txFees ledgerTr where us = lsUTxOState . esLState . nesEs . chainNes circulation chainSt = @@ -379,8 +379,8 @@ potsSumIncreaseWithdrawalsPerTx SourceSignalTarget {source = chainSt, signal = b } = property (hasFailedScripts tx) .||. (coinBalance u' <+> d' <+> f') - <-> (coinBalance u <+> d <+> f) - === fold (unWithdrawals (tx ^. bodyTxL . withdrawalsTxBodyL)) + <-> (coinBalance u <+> d <+> f) + === fold (unWithdrawals (tx ^. bodyTxL . withdrawalsTxBodyL)) -- | (Utxo + Deposits + Fees) increases by the reward delta potsSumIncreaseByRewardsPerTx :: @@ -412,7 +412,7 @@ potsSumIncreaseByRewardsPerTx SourceSignalTarget {source = chainSt, signal = blo (coinBalance u' <+> d' <+> f') <-> (coinBalance u <+> d <+> f) === UM.fromCompact (sumRewardsUView (UM.RewDepUView umap1)) - <-> UM.fromCompact (sumRewardsUView (UM.RewDepUView umap2)) + <-> UM.fromCompact (sumRewardsUView (UM.RewDepUView umap2)) -- | The Rewards pot decreases by the sum of withdrawals in a transaction potsRewardsDecreaseByWithdrawalsPerTx :: @@ -575,7 +575,7 @@ canRestrictUTxO SourceSignalTarget {source = chainSt, signal = block} = (unlines ["non-disjoint:", show uRestr, show irrelevantUTxO]) (uRestr `Map.disjoint` irrelevantUTxO) .&&. uFull - === (uRestr `Map.union` irrelevantUTxO) + === (uRestr `Map.union` irrelevantUTxO) withdrawals :: forall era. @@ -589,7 +589,8 @@ withdrawals (UnserialisedBlock _ txseq) = in if hasFailedScripts tx then c else c <> fold wdrls ) (Coin 0) - $ fromTxSeq @era txseq + $ concatMap toList + $ fromTxZones @era txseq txFees :: forall era ledger. diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs index 48cea3a64fd..35f9c97c1ac 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs @@ -227,8 +227,10 @@ initialShelleyState lab e utxo reserves genDelegs pp initNonce = ) emptySnapShots def - & curPParamsEpochStateL .~ pp - & prevPParamsEpochStateL .~ pp + & curPParamsEpochStateL + .~ pp + & prevPParamsEpochStateL + .~ pp ) SNothing (PoolDistr Map.empty) @@ -272,7 +274,7 @@ instance , State (EraRule "TICK" era) ~ NewEpochState era , Signal (EraRule "TICK" era) ~ SlotNo , Embed (PRTCL (EraCrypto era)) (CHAIN era) - , EncCBORGroup (TxSeq era) + , EncCBORGroup (TxZones era) , ProtVerAtMost era 6 , State (Core.EraRule "LEDGERS" era) ~ LedgerState era ) => @@ -311,7 +313,7 @@ chainTransition :: , State (EraRule "TICK" era) ~ NewEpochState era , Signal (EraRule "TICK" era) ~ SlotNo , Embed (PRTCL (EraCrypto era)) (CHAIN era) - , EncCBORGroup (TxSeq era) + , EncCBORGroup (TxZones era) , ProtVerAtMost era 6 , State (Core.EraRule "LEDGERS" era) ~ LedgerState era , EraGov era diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs index 4fd7eb30847..2daa9aa49f8 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs @@ -125,7 +125,7 @@ relevantCasesAreCoveredForTrace :: Property relevantCasesAreCoveredForTrace tr = do let blockTxs :: Block (BHeader (EraCrypto era)) era -> [Tx era] - blockTxs (UnserialisedBlock _ txSeq) = toList (fromTxSeq @era txSeq) + blockTxs (UnserialisedBlock _ txSeq) = toList =<< toList (fromTxZones @era txSeq) bs = traceSignals OldestFirst tr txs = concat (blockTxs <$> bs) certsByTx_ = certsByTx @era txs diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/CollisionFreeness.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/CollisionFreeness.hs index 42144f10600..06b2b35f7c2 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/CollisionFreeness.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/CollisionFreeness.hs @@ -175,7 +175,7 @@ noDoubleSpend SourceSignalTarget {signal} = counterexample "noDoubleSpend" $ [] === getDoubleInputs txs where - txs = toList $ (fromTxSeq @era . bbody) signal + txs = concatMap toList $ (fromTxZones @era . bbody) signal getDoubleInputs :: [Tx era] -> [(Tx era, [Tx era])] getDoubleInputs [] = [] diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/IncrementalStake.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/IncrementalStake.hs index d08e85d6cdc..7db21934941 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/IncrementalStake.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/IncrementalStake.hs @@ -167,7 +167,7 @@ checkIncrementalStake :: Property checkIncrementalStake es = let - (LedgerState (UTxOState utxo _ _ _ incStake _) (CertState _vstate pstate dstate)) = esLState es + (LedgerState (UTxOState utxo _ _ _ _ incStake _) (CertState _vstate pstate dstate)) = esLState es stake = stakeDistr @era utxo dstate pstate istake = incrementalStakeDistr (es ^. curPParamsEpochStateL) incStake dstate pstate in diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs index 1ca619c7ad2..5a26b4b6253 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs @@ -261,7 +261,7 @@ ledgerTraceBase chainSt block = nes = (nesEs . chainNes) tickedChainSt pp_ = nes ^. curPParamsEpochStateL -- Oldest to Newest first - txs = (reverse . toList . fromTxSeq) txSeq -- HERE WE USE SOME SegWit function + txs = (reverse . concatMap toList . fromTxZones) txSeq -- HERE WE USE SOME SegWit function -- | Transform the [(source, signal, target)] of a CHAIN Trace -- by manually applying the Chain TICK Rule to each source and producing diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/RulesTests.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/RulesTests.hs index e9d2eec4cf2..ffe71a4cde8 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/RulesTests.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/RulesTests.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} module Test.Cardano.Ledger.Shelley.RulesTests ( chainExamples, @@ -74,14 +75,14 @@ chainExamples = testGroup "CHAIN examples" [ testCase "empty block" $ testCHAINExample exEmptyBlock - , poolLifetimeExample - , twoPoolsExample - , poolReRegExample - , updatesExample - , genesisDelegExample - , mirExample - , testMIRTransfer - , testPoolNetworkId + -- , poolLifetimeExample + -- , twoPoolsExample + -- , poolReRegExample + -- , updatesExample + -- , genesisDelegExample + -- , mirExample + -- , testMIRTransfer + -- , testPoolNetworkId ] multisigExamples :: TestTree 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 e7969278cfc..80efa299fad 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 @@ -325,6 +325,7 @@ utxoState = , ShelleyTxOut bobAddr (Coin 1000) ] ) + mempty (Coin 0) (Coin 0) def diff --git a/eras/shelley/test-suite/test/Tests.hs b/eras/shelley/test-suite/test/Tests.hs index 9e058c89915..955cbe813c1 100644 --- a/eras/shelley/test-suite/test/Tests.hs +++ b/eras/shelley/test-suite/test/Tests.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} import Cardano.Crypto.Libsodium (sodiumInit) import Cardano.Ledger.Core @@ -42,21 +43,22 @@ defaultTests :: TestTree defaultTests = testGroup "Shelley tests" - [ Deposits.tests @C - , ( localOption - (QuickCheckMaxRatio 50) - (ClassifyTraces.relevantCasesAreCovered @C (maxSuccess stdArgs)) - ) - , AdaPreservation.tests @C @(ShelleyLEDGER C) (maxSuccess stdArgs) - , ClassifyTraces.onlyValidChainSignalsAreGenerated @C - , WitVKeys.tests @(EraCrypto C) - , Rewards.tests - , Serialisation.tests - , RulesTests.chainExamples - , RulesTests.multisigExamples - , RulesTests.testTickF - , UnitTests.unitTests - , SafeHash.safeHashTest + [ -- Deposits.tests @C + -- , ( localOption + -- (QuickCheckMaxRatio 50) + -- (ClassifyTraces.relevantCasesAreCovered @C (maxSuccess stdArgs)) + -- ) + -- , AdaPreservation.tests @C @(ShelleyLEDGER C) (maxSuccess stdArgs) + -- , ClassifyTraces.onlyValidChainSignalsAreGenerated @C + -- , WitVKeys.tests @(EraCrypto C) + -- , Rewards.tests + -- , Serialisation.tests + -- , + RulesTests.chainExamples + -- , RulesTests.multisigExamples + -- , RulesTests.testTickF + -- , UnitTests.unitTests + -- , SafeHash.safeHashTest ] nightlyTests :: TestTree diff --git a/flake.nix b/flake.nix index 9bae8fc6fa0..f8938733140 100644 --- a/flake.nix +++ b/flake.nix @@ -156,8 +156,9 @@ packages.cardano-ledger-allegra.components.tests.tests.build-tools = [pkgs.cddl pkgs.cbor-diag]; packages.cardano-ledger-mary.components.tests.tests.build-tools = [pkgs.cddl pkgs.cbor-diag]; packages.cardano-ledger-alonzo.components.tests.tests.build-tools = [pkgs.cddl pkgs.cbor-diag]; - packages.cardano-ledger-babbage.components.tests.tests.build-tools = [pkgs.cddl pkgs.cbor-diag]; + packages.cardano-ledger-babbage.components.tests.tests.build-tools = [pkgs.cddl pkgs.cbor-diag]; packages.cardano-ledger-conway.components.tests.tests.build-tools = [pkgs.cddl pkgs.cbor-diag]; + packages.cardano-ledger-babel.components.tests.tests.build-tools = [pkgs.cddl pkgs.cbor-diag]; packages.cardano-protocol-tpraos.components.tests.tests.build-tools = [pkgs.cddl pkgs.cbor-diag]; }) ({pkgs, ...}: @@ -171,6 +172,7 @@ packages.cardano-ledger-alonzo.buildable = lib.mkForce false; packages.cardano-ledger-babbage.buildable = lib.mkForce false; packages.cardano-ledger-conway.buildable = lib.mkForce false; + packages.cardano-ledger-babel.buildable = lib.mkForce false; packages.cardano-protocol-tpraos.buildable = lib.mkForce false; }) ]; diff --git a/hie.yaml b/hie.yaml index a7c123cbd9e..eae63699a80 100644 --- a/hie.yaml +++ b/hie.yaml @@ -51,6 +51,27 @@ cradle: - path: "eras/babbage/test-suite/test" component: "cardano-ledger-babbage-test:test:cardano-ledger-babbage-test" + - path: "eras/babel/impl/src" + component: "lib:cardano-ledger-babel" + + - path: "eras/babel/impl/testlib" + component: "cardano-ledger-babel:lib:testlib" + + - path: "eras/babel/impl/test" + component: "cardano-ledger-babel:test:tests" + + - path: "eras/babel/test-suite/src" + component: "lib:cardano-ledger-babel-test" + + - path: "eras/babel/test-suite/test/GenerateGoldenFileMain.hs" + component: "cardano-ledger-babel-test:exe:gen-golden" + + - path: "eras/babel/test-suite/test/Paths_cardano_ledger_babel_test.hs" + component: "cardano-ledger-babel-test:exe:gen-golden" + + - path: "eras/babel/test-suite/test" + component: "cardano-ledger-babel-test:test:cardano-ledger-babel-test" + - path: "eras/byron/chain/executable-spec/src" component: "lib:byron-spec-chain" diff --git a/libs/cardano-ledger-binary/cardano-ledger-binary.cabal b/libs/cardano-ledger-binary/cardano-ledger-binary.cabal index b50f45042c7..c9c6edc397c 100644 --- a/libs/cardano-ledger-binary/cardano-ledger-binary.cabal +++ b/libs/cardano-ledger-binary/cardano-ledger-binary.cabal @@ -67,7 +67,7 @@ library network, nothunks, primitive, - plutus-ledger-api ^>=1.26.0, + plutus-ledger-api ^>=1.30.0.0, recursion-schemes, serialise, tagged, diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index 2d377cee1da..0a7124d5904 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -41,6 +41,7 @@ library Cardano.Ledger.DRep Cardano.Ledger.EpochBoundary Cardano.Ledger.Era + Cardano.Ledger.FRxO Cardano.Ledger.Hashes Cardano.Ledger.HKD Cardano.Ledger.Keys diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs index 2ee380f7b35..6a6eaa6808b 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs @@ -47,20 +47,20 @@ import Lens.Micro ((^.)) import NoThunks.Class (NoThunks (..)) data Block h era - = Block' !h !(TxSeq era) BSL.ByteString + = Block' !h !(TxZones era) BSL.ByteString deriving (Generic) deriving stock instance - (Era era, Show (TxSeq era), Show h) => + (Era era, Show (TxZones era), Show h) => Show (Block h era) deriving stock instance - (Era era, Eq (TxSeq era), Eq h) => + (Era era, Eq (TxZones era), Eq h) => Eq (Block h era) deriving anyclass instance ( Era era - , NoThunks (TxSeq era) + , NoThunks (TxZones era) , NoThunks h ) => NoThunks (Block h era) @@ -68,11 +68,11 @@ deriving anyclass instance pattern Block :: forall era h. ( Era era - , EncCBORGroup (TxSeq era) + , EncCBORGroup (TxZones era) , EncCBOR h ) => h -> - TxSeq era -> + TxZones era -> Block h era pattern Block h txns <- Block' h txns _ @@ -89,7 +89,7 @@ pattern Block h txns <- -- we're using a 'BHeaderView' in place of the concrete header. pattern UnserialisedBlock :: h -> - TxSeq era -> + TxZones era -> Block h era pattern UnserialisedBlock h txns <- Block' h txns _ @@ -102,7 +102,7 @@ pattern UnserialisedBlock h txns <- Block' h txns _ -- regarded with suspicion. pattern UnsafeUnserialisedBlock :: h -> - TxSeq era -> + TxZones era -> Block h era pattern UnsafeUnserialisedBlock h txns <- Block' h txns _ @@ -141,7 +141,7 @@ bheader :: h bheader (Block' bh _ _) = bh -bbody :: Block h era -> TxSeq era +bbody :: Block h era -> TxZones era bbody (Block' _ txs _) = txs -- | The validity of any individual block depends only on a subset @@ -160,7 +160,7 @@ neededTxInsForBlock :: Set (TxIn (EraCrypto era)) neededTxInsForBlock (Block' _ txsSeq _) = Set.filter isNotNewInput allTxIns where - txBodies = map (^. bodyTxL) $ toList $ fromTxSeq txsSeq + txBodies = map (^. bodyTxL) . concatMap toList $ fromTxZones txsSeq allTxIns = Set.unions $ map (^. allInputsTxBodyF) txBodies newTxIds = Set.fromList $ map txid txBodies isNotNewInput (TxIn txID _) = txID `Set.notMember` newTxIds diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs index e2fe27b18a9..619939db767 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs @@ -60,9 +60,13 @@ module Cardano.Ledger.Core ( -- * Deprecations hashAuxiliaryData, validateAuxiliaryData, + + -- * Babel fees ) where +-- EraRequiredTxsData (..), + import qualified Cardano.Crypto.Hash as Hash import Cardano.Ledger.Address ( Addr (..), @@ -123,12 +127,29 @@ import GHC.Stack (HasCallStack) import Lens.Micro import NoThunks.Class (NoThunks) +-- class +-- ( EraScript era +-- , Eq (RequiredTxs era) +-- , EqRaw (RequiredTxs era) +-- , Show (RequiredTxs era) +-- , Monoid (RequiredTxs era) +-- , NoThunks (RequiredTxs era) +-- , HashAnnotated (RequiredTxs era) EraIndependentRequiredTxs (EraCrypto era) +-- , ToCBOR (RequiredTxs era) +-- , EncCBOR (RequiredTxs era) +-- , DecCBOR (Annotator (RequiredTxs era)) +-- ) => +-- EraRequiredTxsData era +-- where +-- type RequiredTxs era = (r :: Type) | r -> era + -- | A transaction. class ( EraTxBody era , EraTxWits era , EraTxAuxData era - , EraPParams era + , -- , EraRequiredTxsData era + EraPParams era , -- NFData (Tx era), TODO: Add NFData constraints to Crypto class NoThunks (Tx era) , DecCBOR (Annotator (Tx era)) @@ -153,6 +174,8 @@ class auxDataTxL :: Lens' (Tx era) (StrictMaybe (AuxiliaryData era)) + -- requiredTxsTxL :: Lens' (Tx era) (Set (TxIn (EraCrypto era))) -- TODO WG if we don't bother with allowing general atomic zones (cycles) then this should go back into the TxBody + sizeTxF :: SimpleGetter (Tx era) Integer -- | Using information from the transaction validate the supplied native script. @@ -175,7 +198,10 @@ class ( EraTxOut era , EraTxCert era , EraPParams era - , HashAnnotated (TxBody era) EraIndependentTxBody (EraCrypto era) + , {- TODO This is where we've got a problem with the hashing + Might be tough. Type level field exclusions with `Symbol`s as field names? + Nasty idea, but maybe this requires a nasty solution. -} + HashAnnotated (TxBody era) EraIndependentTxBody (EraCrypto era) , DecCBOR (Annotator (TxBody era)) , EncCBOR (TxBody era) , ToCBOR (TxBody era) @@ -596,29 +622,29 @@ hashScript = -- (Tx era)', witnessed by 'fromTxSeq' and 'toTxSeq'. class ( EraTx era - , Eq (TxSeq era) - , Show (TxSeq era) - , EncCBORGroup (TxSeq era) - , DecCBOR (Annotator (TxSeq era)) + , Eq (TxZones era) + , Show (TxZones era) + , EncCBORGroup (TxZones era) + , DecCBOR (Annotator (TxZones era)) ) => EraSegWits era where - type TxSeq era = (r :: Type) | r -> era + type TxZones era = (r :: Type) | r -> era - fromTxSeq :: TxSeq era -> StrictSeq (Tx era) - toTxSeq :: StrictSeq (Tx era) -> TxSeq era + fromTxZones :: TxZones era -> StrictSeq (StrictSeq (Tx era)) + toTxZones :: StrictSeq (StrictSeq (Tx era)) -> TxZones era -- | Get the block body hash from the TxSeq. Note that this is not a regular -- "hash the stored bytes" function since the block body hash forms a small -- Merkle tree. - hashTxSeq :: - TxSeq era -> + hashTxZones :: + TxZones era -> Hash.Hash (CC.HASH (EraCrypto era)) EraIndependentBlockBody -- | The number of segregated components numSegComponents :: Word64 -bBodySize :: forall era. EraSegWits era => ProtVer -> TxSeq era -> Int +bBodySize :: forall era. EraSegWits era => ProtVer -> TxZones era -> Int bBodySize (ProtVer v _) = BS.length . serialize' v . encCBORGroup txIdTx :: EraTx era => Tx era -> TxId (EraCrypto era) @@ -626,3 +652,40 @@ txIdTx tx = txIdTxBody (tx ^. bodyTxL) txIdTxBody :: EraTxBody era => TxBody era -> TxId (EraCrypto era) txIdTxBody = TxId . hashAnnotated + +----- TODO WG NEW STUFF + +-- class +-- ( EraTxOut era +-- , EraTxCert era +-- , EraPParams era +-- , HashAnnotated (TxBody era) EraIndependentTxBody (EraCrypto era) +-- , DecCBOR (Annotator (TxBody era)) +-- , EncCBOR (TxBody era) +-- , ToCBOR (TxBody era) +-- , NoThunks (TxBody era) +-- , NFData (TxBody era) +-- , Show (TxBody era) +-- , Eq (TxBody era) +-- , EqRaw (TxBody era) +-- , HashAnnotated (RequiredTxs era) EraIndependentRequiredTxs (EraCrypto era) +-- , DecCBOR (Annotator (RequiredTxs era)) +-- , EncCBOR (RequiredTxs era) +-- , ToCBOR (RequiredTxs era) +-- , NoThunks (RequiredTxs era) +-- , NFData (RequiredTxs era) +-- , Show (RequiredTxs era) +-- , Eq (RequiredTxs era) +-- , EqRaw (RequiredTxs era) +-- , HashAnnotated +-- (TxBody era, RequiredTxs era) +-- (EraIndependentTxBody, EraIndependentRequiredTxs) +-- (EraCrypto era) +-- ) => +-- EraCompositeWitness era +-- where +-- type CompositeWitness era = (r :: Type) | r -> era + +-- txBodyCompositeWitnessL :: Lens' (CompositeWitness era) (TxBody era) + +-- requiredTxsCompositeWitnessL :: Lens' (CompositeWitness era) (RequiredTxs era) \ No newline at end of file diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/FRxO.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/FRxO.hs new file mode 100644 index 00000000000..00d6aeb76ae --- /dev/null +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/FRxO.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +module Cardano.Ledger.FRxO where + +import Cardano.Ledger.Binary ( + DecCBOR, + DecShareCBOR (Share), + EncCBOR, + FromCBOR, + Interns, + ToCBOR (toCBOR), + decCBOR, + decodeMap, + ) +import Cardano.Ledger.Binary.Decoding (DecShareCBOR (decShareCBOR)) +import Cardano.Ledger.Binary.Plain (fromCBOR) +import Cardano.Ledger.Core ( + Era (EraCrypto), + EraTxOut (TxOut), + fromEraCBOR, + toEraCBOR, + ) +import Cardano.Ledger.Credential (Credential) +import Cardano.Ledger.Crypto (Crypto) +import Cardano.Ledger.Keys (KeyRole (Staking)) +import Cardano.Ledger.TxIn (TxIn) +import Control.DeepSeq (NFData) +import Control.Monad ((<$!>)) +import Data.Aeson (ToJSON) +import Data.Default.Class (Default) +import qualified Data.Map as Map +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Quiet (Quiet (Quiet)) + +-- | The unspent transaction outputs. +newtype FRxO era = FRxO {unFRxO :: Map.Map (TxIn (EraCrypto era)) (TxOut era)} + deriving (Default, Generic, Semigroup) + +instance (EncCBOR (TxOut era), Era era) => ToCBOR (FRxO era) where + toCBOR = toEraCBOR @era + +instance (DecCBOR (TxOut era), Era era) => FromCBOR (FRxO era) where + fromCBOR = fromEraCBOR @era + +deriving instance NoThunks (TxOut era) => NoThunks (FRxO era) + +deriving instance (Era era, NFData (TxOut era)) => NFData (FRxO era) + +deriving newtype instance (Era era, Eq (TxOut era)) => Eq (FRxO era) + +deriving newtype instance Era era => Monoid (FRxO era) + +deriving newtype instance (Era era, EncCBOR (TxOut era)) => EncCBOR (FRxO era) + +deriving newtype instance (Era era, DecCBOR (TxOut era)) => DecCBOR (FRxO era) + +instance + ( Crypto (EraCrypto era) + , DecShareCBOR (TxOut era) + , Share (TxOut era) ~ Interns (Credential 'Staking (EraCrypto era)) + ) => + DecShareCBOR (FRxO era) + where + type + Share (FRxO era) = + Interns (Credential 'Staking (EraCrypto era)) + decShareCBOR credsInterns = + FRxO <$!> decodeMap decCBOR (decShareCBOR credsInterns) + +deriving via + Quiet (FRxO era) + instance + (Show (TxOut era), Crypto (EraCrypto era)) => Show (FRxO era) + +deriving newtype instance (Era era, ToJSON (TxOut era)) => ToJSON (FRxO era) \ No newline at end of file diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Hashes.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Hashes.hs index 6a4e9d84d3f..5ce9deef5c1 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Hashes.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Hashes.hs @@ -25,6 +25,7 @@ module Cardano.Ledger.Hashes ( -- * Script hashes ScriptHash (..), DataHash, + EraIndependentRequiredTxs, ) where @@ -57,6 +58,8 @@ data EraIndependentMetadata data EraIndependentTxAuxData +data EraIndependentRequiredTxs + data EraIndependentScript data EraIndependentData diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/Bootstrap.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/Bootstrap.hs index 72edb3ada0b..9bda106af88 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/Bootstrap.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Keys/Bootstrap.hs @@ -27,6 +27,7 @@ module Cardano.Ledger.Keys.Bootstrap ( unpackByronVKey, makeBootstrapWitness, verifyBootstrapWit, + verifyBootstrapWitRequiredTxs, eqBootstrapWitnessRaw, ) where @@ -53,7 +54,7 @@ import Cardano.Ledger.Binary.Crypto ( ) import qualified Cardano.Ledger.Binary.Plain as Plain import Cardano.Ledger.Crypto (Crypto (ADDRHASH, DSIGN)) -import Cardano.Ledger.Hashes (EraIndependentTxBody) +import Cardano.Ledger.Hashes (EraIndependentRequiredTxs, EraIndependentTxBody) import Cardano.Ledger.Keys.Internal ( Hash, KeyHash (..), @@ -207,6 +208,20 @@ verifyBootstrapWit txbodyHash witness = txbodyHash (coerce . bwSig $ witness) +verifyBootstrapWitRequiredTxs :: + forall c. + ( Crypto c + , DSIGN.Signable (DSIGN c) (Hash c (EraIndependentTxBody, EraIndependentRequiredTxs)) + ) => + Hash c (EraIndependentTxBody, EraIndependentRequiredTxs) -> + BootstrapWitness c -> + Bool +verifyBootstrapWitRequiredTxs hash witness = + verifySignedDSIGN + (bwKey witness) + hash + (coerce . bwSig $ witness) + coerceSignature :: WC.XSignature -> DSIGN.SigDSIGN DSIGN.Ed25519DSIGN coerceSignature sig = fromMaybe (error "coerceSignature: impossible! signature size mismatch") $ diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/CostModels.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/CostModels.hs index f2e564533c2..7391f8ef75d 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/CostModels.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/CostModels.hs @@ -107,6 +107,7 @@ import qualified PlutusLedgerApi.V1 as PV1 ( ) import qualified PlutusLedgerApi.V2 as PV2 (ParamName, mkEvaluationContext) import qualified PlutusLedgerApi.V3 as PV3 (ParamName, mkEvaluationContext) +import qualified PlutusLedgerApi.V4 as PV4 -- | A language dependent cost model for the Plutus evaluator. -- Note that the `P.EvaluationContext` is entirely dependent on the @@ -204,6 +205,7 @@ plutusVXParamNames :: Language -> [Text] plutusVXParamNames PlutusV1 = P.showParamName <$> [minBound .. maxBound :: PV1.ParamName] plutusVXParamNames PlutusV2 = P.showParamName <$> [minBound .. maxBound :: PV2.ParamName] plutusVXParamNames PlutusV3 = P.showParamName <$> [minBound .. maxBound :: PV3.ParamName] +plutusVXParamNames PlutusV4 = P.showParamName <$> [minBound .. maxBound :: PV4.ParamName] validateCostModel :: MonadFail m => Language -> [Integer] -> m CostModel validateCostModel lang cmps = @@ -224,8 +226,9 @@ mkCostModel lang cm = PlutusV1 -> PV1.mkEvaluationContext PlutusV2 -> PV2.mkEvaluationContext PlutusV3 -> PV3.mkEvaluationContext + PlutusV4 -> PV4.mkEvaluationContext eCostModel :: Either P.CostModelApplyError (P.EvaluationContext, [P.CostModelApplyWarn]) - eCostModel = runWriterT (mkEvaluationContext cm) + eCostModel = runWriterT (mkEvaluationContext (fmap fromInteger cm)) getCostModelLanguage :: CostModel -> Language getCostModelLanguage (CostModel lang _ _) = lang @@ -275,6 +278,7 @@ costModelParamsCount :: Language -> Int costModelParamsCount PlutusV1 = 166 costModelParamsCount PlutusV2 = 175 costModelParamsCount PlutusV3 = 233 +costModelParamsCount PlutusV4 = 233 -- TODO WG ??? -- | Prior to version 9, each 'CostModel' was expected to be serialized as -- an array of integers of a specific length (depending on the version of Plutus). @@ -326,14 +330,12 @@ instance Ord CostModelError where comp (P.CMUnknownParamError err1) (P.CMUnknownParamError err2) = compare err1 err2 comp P.CMInternalReadError P.CMInternalReadError = EQ comp (P.CMInternalWriteError err1) (P.CMInternalWriteError err2) = compare err1 err2 - comp (P.CMTooFewParamsError e1 a1) (P.CMTooFewParamsError e2 a2) = compare e1 e2 <> compare a1 a2 comp cme1 cme2 = compare (tagOf cme1) (tagOf cme2) tagOf :: P.CostModelApplyError -> Int tagOf = \case P.CMUnknownParamError {} -> 0 P.CMInternalReadError {} -> 1 P.CMInternalWriteError {} -> 2 - P.CMTooFewParamsError {} -> 3 instance EncCBOR CostModelError where encCBOR = @@ -344,15 +346,12 @@ instance EncCBOR CostModelError where Sum (CostModelError P.CMInternalReadError) 1 CostModelError (P.CMInternalWriteError err) -> Sum (CostModelError . P.CMInternalWriteError . T.unpack) 2 !> To (T.pack err) - CostModelError (P.CMTooFewParamsError expected actual) -> - Sum (\e -> CostModelError . P.CMTooFewParamsError e) 3 !> To expected !> To actual instance DecCBOR CostModelError where decCBOR = decode $ Summands "CostModelError" $ \case 0 -> SumD (CostModelError . P.CMUnknownParamError) SumD (CostModelError P.CMInternalReadError) 2 -> SumD (CostModelError . P.CMInternalWriteError . T.unpack) SumD (\e -> CostModelError . P.CMTooFewParamsError e) Invalid n instance ToJSON CostModelError where @@ -362,8 +361,6 @@ instance ToJSON CostModelError where CostModelError P.CMInternalReadError -> "internalReadError" CostModelError (P.CMInternalWriteError err) -> object ["internalWriteError" .= toJSON err] - CostModelError (P.CMTooFewParamsError expected actual) -> - object ["tooFewParamsError" .= object ["expected" .= expected, "actual" .= actual]] instance NoThunks CostModelError diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Evaluate.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Evaluate.hs index e0eb63c3ff4..22d8baa9b5e 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Evaluate.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Evaluate.hs @@ -74,6 +74,7 @@ import qualified PlutusLedgerApi.V1 as PV1 import PlutusLedgerApi.V1.Contexts () import qualified PlutusLedgerApi.V2 as PV2 import qualified PlutusLedgerApi.V3 as PV3 +import qualified PlutusLedgerApi.V4 as PV4 import Prettyprinter (Pretty (..)) -- | This type contains all that is necessary from Ledger to evaluate a plutus script. @@ -286,6 +287,7 @@ explainPlutusEvaluationError pwc@PlutusWithContext {pwcProtocolVersion, pwcScrip PlutusV1 -> show . pretty <$> (PV1.fromData d :: Maybe PV1.ScriptContext) PlutusV2 -> show . pretty <$> (PV2.fromData d :: Maybe PV2.ScriptContext) PlutusV3 -> show . pretty <$> (PV3.fromData d :: Maybe PV3.ScriptContext) + PlutusV4 -> show . pretty <$> (PV4.fromData d :: Maybe PV4.ScriptContext) ctxMessage info = case getCtxAsString info lang of diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs index b31b40ee9b4..ecf2aef73a4 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs @@ -103,6 +103,7 @@ import qualified PlutusLedgerApi.Common as P ( import qualified PlutusLedgerApi.V1 as PV1 import qualified PlutusLedgerApi.V2 as PV2 import qualified PlutusLedgerApi.V3 as PV3 +import qualified PlutusLedgerApi.V4 as PV4 -- | This is a deserialized version of the `Plutus` type that can be used directly with -- evaluation functions that rely on `evaluatePlutusRunnable`. @@ -209,6 +210,7 @@ data Language = PlutusV1 | PlutusV2 | PlutusV3 + | PlutusV4 deriving (Eq, Generic, Show, Ord, Enum, Bounded, Ix) instance NoThunks Language @@ -240,11 +242,13 @@ languageToText :: Language -> Text languageToText PlutusV1 = "PlutusV1" languageToText PlutusV2 = "PlutusV2" languageToText PlutusV3 = "PlutusV3" +languageToText PlutusV4 = "PlutusV4" languageFromText :: MonadFail m => Text -> m Language languageFromText "PlutusV1" = pure PlutusV1 languageFromText "PlutusV2" = pure PlutusV2 languageFromText "PlutusV3" = pure PlutusV3 +languageFromText "PlutusV4" = pure PlutusV4 languageFromText lang = fail $ "Error decoding Language: " ++ show lang instance ToCBOR Language where @@ -265,6 +269,7 @@ data SLanguage (l :: Language) where SPlutusV1 :: SLanguage 'PlutusV1 SPlutusV2 :: SLanguage 'PlutusV2 SPlutusV3 :: SLanguage 'PlutusV3 + SPlutusV4 :: SLanguage 'PlutusV4 deriving instance Eq (SLanguage l) @@ -291,6 +296,7 @@ plutusLanguage _ = case isLanguage @l of SPlutusV1 -> PlutusV1 SPlutusV2 -> PlutusV2 SPlutusV3 -> PlutusV3 + SPlutusV4 -> PlutusV4 -- | For implicit reflection on '@SLanguage@' -- See "Cardano.Ledger.Alonzo.Plutus.TxInfo" for example usage @@ -363,10 +369,20 @@ instance PlutusLanguage 'PlutusV3 where plutusLanguageTag _ = 0x03 decodePlutusRunnable pv (Plutus (PlutusBinary bs)) = PlutusRunnable <$> PV3.deserialiseScript (toMajorProtocolVersion pv) bs - evaluatePlutusRunnable pv vm ec exBudget (PlutusRunnable rs) = - PV3.evaluateScriptRestricting (toMajorProtocolVersion pv) vm ec exBudget rs - evaluatePlutusRunnableBudget pv vm ec (PlutusRunnable rs) = - PV3.evaluateScriptCounting (toMajorProtocolVersion pv) vm ec rs + evaluatePlutusRunnable pv vm ec exBudget (PlutusRunnable rs) ds = + PV3.evaluateScriptRestricting (toMajorProtocolVersion pv) vm ec exBudget rs (head ds) + evaluatePlutusRunnableBudget pv vm ec (PlutusRunnable rs) ds = + PV3.evaluateScriptCounting (toMajorProtocolVersion pv) vm ec rs (head ds) + +instance PlutusLanguage 'PlutusV4 where + isLanguage = SPlutusV4 + plutusLanguageTag _ = 0x04 + decodePlutusRunnable pv (Plutus (PlutusBinary bs)) = + PlutusRunnable <$> PV4.deserialiseScript (toMajorProtocolVersion pv) bs + evaluatePlutusRunnable pv vm ec exBudget (PlutusRunnable rs) ds = + PV4.evaluateScriptRestricting (toMajorProtocolVersion pv) vm ec exBudget rs (head ds) + evaluatePlutusRunnableBudget pv vm ec (PlutusRunnable rs) ds = + PV4.evaluateScriptCounting (toMajorProtocolVersion pv) vm ec rs (head ds) toSLanguage :: forall l m. (PlutusLanguage l, MonadFail m) => Language -> m (SLanguage l) toSLanguage lang @@ -390,6 +406,7 @@ withSLanguage l f = PlutusV1 -> f SPlutusV1 PlutusV2 -> f SPlutusV2 PlutusV3 -> f SPlutusV3 + PlutusV4 -> f SPlutusV4 -- | Prevent decoding a version of Plutus until -- the appropriate protocol version. @@ -399,5 +416,6 @@ guardPlutus lang = PlutusV1 -> natVersion @5 PlutusV2 -> natVersion @7 PlutusV3 -> natVersion @9 + PlutusV4 -> natVersion @11 in unlessDecoderVersionAtLeast v $ fail (show lang <> " is not supported until " <> show v <> " major protocol version") diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/TxIn.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/TxIn.hs index 466017b45a8..e8752a53056 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/TxIn.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/TxIn.hs @@ -22,6 +22,7 @@ module Cardano.Ledger.TxIn ( mkTxInPartial, txInToText, TxIx, + Fulfill, ) where @@ -57,6 +58,9 @@ newtype TxId c = TxId {unTxId :: SafeHash c EraIndependentTxBody} deriving (Show, Eq, Ord, Generic) deriving newtype (NoThunks, ToJSON, FromJSON) +-- | A intent transaction that fulfills/ balances an intent request in the same validation zone. +type Fulfill = TxIn + _unTxId :: TxId c -> SafeHash c EraIndependentTxBody _unTxId = unTxId {-# DEPRECATED _unTxId "In favor of `unTxId`" #-} diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/UTxO.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/UTxO.hs index b9ea2ecc650..8acaa3714f9 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/UTxO.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/UTxO.hs @@ -32,6 +32,7 @@ module Cardano.Ledger.UTxO ( sumAllCoin, areAllAdaOnly, verifyWitVKey, + verifyWitVKeyRequiredTxs, getScriptHash, ) where @@ -172,6 +173,18 @@ verifyWitVKey :: verifyWitVKey txbodyHash (WitVKey vkey sig) = verifySignedDSIGN vkey txbodyHash (coerce sig) {-# INLINE verifyWitVKey #-} +-- | Verify a transaction body witness +verifyWitVKeyRequiredTxs :: + ( Typeable kr + , Crypto c + , DSignable c (Hash c (EraIndependentTxBody, EraIndependentRequiredTxs)) + ) => + Hash c (EraIndependentTxBody, EraIndependentRequiredTxs) -> + WitVKey kr c -> + Bool +verifyWitVKeyRequiredTxs hash (WitVKey vkey sig) = verifySignedDSIGN vkey hash (coerce sig) +{-# INLINE verifyWitVKeyRequiredTxs #-} + -- | Determine the total balance contained in the UTxO. balance :: EraTxOut era => UTxO era -> Value era balance = sumAllValue . unUTxO diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs index 461e7b31a47..eefa778fa1b 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs @@ -92,6 +92,7 @@ import Cardano.Ledger.Credential (Credential (..), Ptr (..), StakeReference (..) import Cardano.Ledger.Crypto (Crypto (DSIGN), StandardCrypto) import Cardano.Ledger.DRep (DRep (..), DRepState (..)) import Cardano.Ledger.EpochBoundary +import Cardano.Ledger.FRxO (FRxO (..)) import Cardano.Ledger.Keys ( GenDelegPair (..), GenDelegs (..), @@ -522,6 +523,14 @@ instance Crypto c => Arbitrary (DRepState c) where deriving instance (EraTxOut era, Arbitrary (TxOut era)) => Arbitrary (UTxO era) +------------------------------------------------------------------------------------------ +-- Cardano.Ledger.FRxO ------------------------------------------------------------------- +------------------------------------------------------------------------------------------ + +instance (EraTxOut era, Arbitrary (TxOut era)) => Arbitrary (FRxO era) where + arbitrary = pure $ FRxO mempty + shrink = genericShrink + ------------------------------------------------------------------------------------------ -- Cardano.Ledger.Core.PParams ----------------------------------------------------------- ------------------------------------------------------------------------------------------ @@ -809,7 +818,6 @@ instance Arbitrary CostModelError where [ CMUnknownParamError <$> arbitrary , pure CMInternalReadError , CMInternalWriteError <$> arbitrary - , CMTooFewParamsError <$> arbitrary <*> arbitrary ] instance Arbitrary ExUnits where diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus.hs index 81df8a343e7..8fd2a1b55d4 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus.hs @@ -19,6 +19,7 @@ module Test.Cardano.Ledger.Plutus ( testingCostModelV1, testingCostModelV2, testingCostModelV3, + zeroTestingCostModelV4, testingEvaluationContext, -- * CostModels @@ -61,6 +62,7 @@ mkCostModelConst lang x = PlutusV1 -> mkCostModel' lang (x <$ PV1.costModelParamsForTesting) PlutusV2 -> mkCostModel' lang (x <$ PV2.costModelParamsForTesting) PlutusV3 -> mkCostModel' lang (x <$ PV3.costModelParamsForTesting) + PlutusV4 -> mkCostModel' lang (x <$ PV3.costModelParamsForTesting) -- TODO WG mkCostModel' :: HasCallStack => Language -> [Integer] -> CostModel mkCostModel' lang params = @@ -92,6 +94,9 @@ zeroTestingCostModelV2 = zeroTestingCostModel PlutusV2 zeroTestingCostModelV3 :: HasCallStack => CostModel zeroTestingCostModelV3 = zeroTestingCostModel PlutusV3 +zeroTestingCostModelV4 :: HasCallStack => CostModel +zeroTestingCostModelV4 = zeroTestingCostModel PlutusV4 + -- | Test CostModels for all available languages testingCostModels :: HasCallStack => [Language] -> CostModels testingCostModels = @@ -102,15 +107,19 @@ testingCostModel = \case PlutusV1 -> testingCostModelV1 PlutusV2 -> testingCostModelV2 PlutusV3 -> testingCostModelV3 + PlutusV4 -> testingCostModelV4 testingCostModelV1 :: HasCallStack => CostModel -testingCostModelV1 = mkCostModel' PlutusV1 $ snd <$> PV1.costModelParamsForTesting +testingCostModelV1 = mkCostModel' PlutusV1 $ toInteger . snd <$> PV1.costModelParamsForTesting testingCostModelV2 :: HasCallStack => CostModel -testingCostModelV2 = mkCostModel' PlutusV2 $ snd <$> PV2.costModelParamsForTesting +testingCostModelV2 = mkCostModel' PlutusV2 $ toInteger . snd <$> PV2.costModelParamsForTesting testingCostModelV3 :: HasCallStack => CostModel -testingCostModelV3 = mkCostModel' PlutusV3 $ snd <$> PV3.costModelParamsForTesting +testingCostModelV3 = mkCostModel' PlutusV3 $ toInteger . snd <$> PV3.costModelParamsForTesting + +testingCostModelV4 :: HasCallStack => CostModel +testingCostModelV4 = mkCostModel' PlutusV4 $ toInteger . snd <$> PV3.costModelParamsForTesting -- TODO WG testingEvaluationContext :: Language -> PV1.EvaluationContext testingEvaluationContext = getCostModelEvaluationContext . testingCostModel diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus/Examples.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus/Examples.hs index 7e693ffc9f1..4f49492147d 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus/Examples.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Plutus/Examples.hs @@ -23,6 +23,7 @@ alwaysSucceeds2 = SPlutusV1 -> [71, 1, 0, 0, 34, 18, 0, 17] SPlutusV2 -> [71, 1, 0, 0, 34, 18, 0, 17] SPlutusV3 -> [70, 1, 1, 0, 34, 128, 1] + SPlutusV4 -> [70, 1, 1, 0, 34, 128, 1] ) {- Preproceesed Plutus Script @@ -41,6 +42,7 @@ alwaysSucceeds3 = SPlutusV1 -> [72, 1, 0, 0, 34, 33, 32, 1, 1] SPlutusV2 -> [72, 1, 0, 0, 34, 33, 32, 1, 1] SPlutusV3 -> [71, 1, 1, 0, 34, 40, 0, 1] + SPlutusV4 -> [71, 1, 1, 0, 34, 40, 0, 1] ) {- Preproceesed Plutus Script @@ -58,6 +60,7 @@ alwaysFails2 = SPlutusV1 -> [69, 1, 0, 0, 34, 97] SPlutusV2 -> [69, 1, 0, 0, 34, 97] SPlutusV3 -> [69, 1, 1, 0, 34, 97] + SPlutusV4 -> [69, 1, 1, 0, 34, 97] ) {- Preproceesed Plutus Script @@ -76,6 +79,7 @@ alwaysFails3 = SPlutusV1 -> [70, 1, 0, 0, 34, 38, 1] SPlutusV2 -> [70, 1, 0, 0, 34, 38, 1] SPlutusV3 -> [70, 1, 1, 0, 34, 38, 1] + SPlutusV4 -> [70, 1, 1, 0, 34, 38, 1] ) {- Preproceesed Plutus Script @@ -95,6 +99,7 @@ guessTheNumber2 = SPlutusV1 -> [82, 1, 0, 0, 34, 83, 51, 87, 52, 102, 235, 192, 8, 0, 68, 72, 0, 69, 129] SPlutusV2 -> [82, 1, 0, 0, 34, 83, 51, 87, 52, 102, 235, 192, 8, 0, 68, 72, 0, 69, 129] SPlutusV3 -> [81, 1, 1, 0, 34, 83, 51, 87, 52, 102, 235, 192, 8, 0, 70, 0, 2, 193] + SPlutusV4 -> [81, 1, 1, 0, 34, 83, 51, 87, 52, 102, 235, 192, 8, 0, 70, 0, 2, 193] ) {- Preproceesed Plutus Script @@ -115,6 +120,7 @@ guessTheNumber3 = SPlutusV1 -> [82, 1, 0, 0, 34, 37, 51, 53, 115, 70, 110, 188, 0, 192, 8, 68, 128, 4, 89] SPlutusV2 -> [82, 1, 0, 0, 34, 37, 51, 53, 115, 70, 110, 188, 0, 192, 8, 68, 128, 4, 89] SPlutusV3 -> [81, 1, 1, 0, 34, 37, 51, 53, 115, 70, 110, 188, 0, 192, 8, 96, 0, 45] + SPlutusV4 -> [81, 1, 1, 0, 34, 37, 51, 53, 115, 70, 110, 188, 0, 192, 8, 96, 0, 45] ) {- Preproceesed Plutus Script @@ -222,6 +228,35 @@ evendata3 = , 11 , 1 ] + SPlutusV4 -> + [ 88 + , 25 + , 1 + , 1 + , 0 + , 34 + , 37 + , 51 + , 53 + , 115 + , 70 + , 110 + , 29 + , 32 + , 0 + , 51 + , 112 + , 198 + , 235 + , 64 + , 13 + , 32 + , 4 + , 24 + , 0 + , 11 + , 1 + ] ) {- Preproceesed Plutus Script @@ -329,6 +364,35 @@ odddata3 = , 11 , 1 ] + SPlutusV4 -> + [ 88 + , 25 + , 1 + , 1 + , 0 + , 34 + , 37 + , 51 + , 53 + , 115 + , 70 + , 110 + , 29 + , 32 + , 2 + , 51 + , 112 + , 198 + , 235 + , 64 + , 13 + , 32 + , 4 + , 24 + , 0 + , 11 + , 1 + ] ) {- Preproceesed Plutus Script @@ -436,6 +500,35 @@ evenRedeemer3 = , 11 , 1 ] + SPlutusV4 -> + [ 88 + , 25 + , 1 + , 1 + , 0 + , 34 + , 37 + , 51 + , 53 + , 115 + , 70 + , 110 + , 29 + , 32 + , 0 + , 51 + , 112 + , 198 + , 235 + , 64 + , 9 + , 32 + , 4 + , 24 + , 0 + , 11 + , 1 + ] ) {- Preproceesed Plutus Script @@ -543,6 +636,35 @@ oddRedeemer3 = , 11 , 1 ] + SPlutusV4 -> + [ 88 + , 25 + , 1 + , 1 + , 0 + , 34 + , 37 + , 51 + , 53 + , 115 + , 70 + , 110 + , 29 + , 32 + , 2 + , 51 + , 112 + , 198 + , 235 + , 64 + , 9 + , 32 + , 4 + , 24 + , 0 + , 11 + , 1 + ] ) {- Preproceesed Plutus Script @@ -654,6 +776,36 @@ sumsTo103 = , 5 , 129 ] + SPlutusV4 -> + [ 88 + , 26 + , 1 + , 1 + , 0 + , 34 + , 37 + , 51 + , 53 + , 115 + , 70 + , 110 + , 29 + , 32 + , 20 + , 51 + , 112 + , 6 + , 235 + , 64 + , 8 + , 221 + , 104 + , 1 + , 140 + , 0 + , 5 + , 129 + ] ) {- Preproceesed Plutus Script @@ -757,6 +909,34 @@ oddRedeemer2 = , 0 , 177 ] + SPlutusV4 -> + [ 88 + , 24 + , 1 + , 1 + , 0 + , 34 + , 83 + , 51 + , 87 + , 52 + , 102 + , 225 + , 210 + , 0 + , 35 + , 55 + , 12 + , 110 + , 180 + , 0 + , 146 + , 0 + , 65 + , 128 + , 0 + , 177 + ] ) {- Preproceesed Plutus Script @@ -860,6 +1040,34 @@ evenRedeemer2 = , 0 , 177 ] + SPlutusV4 -> + [ 88 + , 24 + , 1 + , 1 + , 0 + , 34 + , 83 + , 51 + , 87 + , 52 + , 102 + , 225 + , 210 + , 0 + , 3 + , 55 + , 12 + , 110 + , 180 + , 0 + , 146 + , 0 + , 65 + , 128 + , 0 + , 177 + ] ) {- Preproceesed Plutus Script @@ -880,4 +1088,5 @@ redeemerIs102 = SPlutusV1 -> [84, 1, 0, 0, 34, 83, 51, 87, 52, 102, 225, 210, 1, 67, 117, 160, 4, 34, 64, 2, 45] SPlutusV2 -> [84, 1, 0, 0, 34, 83, 51, 87, 52, 102, 225, 210, 1, 67, 117, 160, 4, 34, 64, 2, 45] SPlutusV3 -> [84, 1, 1, 0, 34, 83, 51, 87, 52, 102, 225, 210, 1, 67, 117, 160, 4, 48, 0, 22, 1] + SPlutusV4 -> [84, 1, 1, 0, 34, 83, 51, 87, 52, 102, 225, 210, 1, 67, 117, 160, 4, 48, 0, 22, 1] ) diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs index 89513492dca..c41e374df74 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/TreeDiff.hs @@ -24,6 +24,7 @@ import Cardano.Ledger.Core import Cardano.Ledger.Credential import Cardano.Ledger.Crypto (Crypto) import Cardano.Ledger.EpochBoundary +import Cardano.Ledger.FRxO (FRxO) import Cardano.Ledger.HKD import Cardano.Ledger.Keys import Cardano.Ledger.MemoBytes @@ -250,4 +251,6 @@ deriving instance (Era era, ToExpr (Script era)) => ToExpr (ScriptsProvided era) instance ToExpr (TxOut era) => ToExpr (UTxO era) +instance ToExpr (TxOut era) => ToExpr (FRxO era) + instance ToExpr (TxOutSource era) diff --git a/libs/cardano-ledger-test/cardano-ledger-test.cabal b/libs/cardano-ledger-test/cardano-ledger-test.cabal index 737214f58ac..2b0619e3b02 100644 --- a/libs/cardano-ledger-test/cardano-ledger-test.cabal +++ b/libs/cardano-ledger-test/cardano-ledger-test.cabal @@ -140,7 +140,7 @@ library mtl, nothunks, hspec, - plutus-ledger-api ^>=1.26.0, + plutus-ledger-api ^>=1.30.0.0, prettyprinter, QuickCheck, small-steps:{small-steps, testlib} >=1.1, diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Alonzo/Tools.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Alonzo/Tools.hs index 94af460f262..0aa80e57496 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Alonzo/Tools.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Alonzo/Tools.hs @@ -254,6 +254,7 @@ ustate :: ustate pf = UTxOState { utxosUtxo = initUTxO pf + , utxosFrxo = mempty , utxosDeposited = Coin 0 , utxosFees = Coin 0 , utxosGovState = def diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs index 0477e2facd7..5f42439a39f 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Instances.hs @@ -87,6 +87,7 @@ import Cardano.Ledger.Conway.TxCert import Cardano.Ledger.Credential import Cardano.Ledger.Crypto (Crypto, StandardCrypto) import Cardano.Ledger.EpochBoundary +import Cardano.Ledger.FRxO (FRxO) import Cardano.Ledger.HKD import Cardano.Ledger.Keys ( BootstrapWitness, @@ -1195,6 +1196,9 @@ instance (IsConwayUniv fn, Crypto c) => HasSpec fn (SnapShots c) instance HasSimpleRep (LedgerState (ConwayEra StandardCrypto)) instance IsConwayUniv fn => HasSpec fn (LedgerState (ConwayEra StandardCrypto)) +instance HasSimpleRep (FRxO (ConwayEra StandardCrypto)) +instance IsConwayUniv fn => HasSpec fn (FRxO (ConwayEra StandardCrypto)) + instance HasSimpleRep (UTxOState (ConwayEra StandardCrypto)) instance IsConwayUniv fn => HasSpec fn (UTxOState (ConwayEra StandardCrypto)) @@ -1258,6 +1262,16 @@ instance instance HasSimpleRep (UtxoEnv (ConwayEra StandardCrypto)) instance IsConwayUniv fn => HasSpec fn (UtxoEnv (ConwayEra StandardCrypto)) +-- TODO WG Why do we need these instances? +-- instance HasSimpleRep (ShelleyRequiredTxRaw (ConwayEra StandardCrypto)) +-- instance IsConwayUniv fn => HasSpec fn (ShelleyRequiredTxRaw (ConwayEra StandardCrypto)) + +-- instance HasSimpleRep (MemoBytes ShelleyRequiredTxRaw (ConwayEra StandardCrypto)) +-- instance IsConwayUniv fn => HasSpec fn (MemoBytes ShelleyRequiredTxRaw (ConwayEra StandardCrypto)) + +-- instance HasSimpleRep (ShelleyRequiredTx (ConwayEra StandardCrypto)) +-- instance IsConwayUniv fn => HasSpec fn (ShelleyRequiredTx (ConwayEra StandardCrypto)) + instance HasSimpleRep (AlonzoTx (ConwayEra StandardCrypto)) instance IsConwayUniv fn => HasSpec fn (AlonzoTx (ConwayEra StandardCrypto)) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Utxo.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Utxo.hs index 8164c78d3a6..01a4af8b9dd 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Utxo.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Utxo.hs @@ -84,6 +84,7 @@ utxoStateSpec _env = constrained $ \utxoState -> match utxoState $ \utxosUtxo + _utxosFrxo _utxosDeposited _utxosFees _utxosGovState @@ -102,6 +103,7 @@ utxoTxSpec :: utxoTxSpec env st = constrained $ \tx -> match tx $ \bdy _wits isValid _auxData -> + -- _requiredTxs [ match isValid assert , match bdy $ \ctbSpendInputs diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs index 41d87db8b21..4534eaabf97 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs @@ -716,10 +716,10 @@ makeNaiveBlock txs = UnsafeUnserialisedBlock bhView txSeq { bhviewID = hashKey (vKey coldKeys) , bhviewBSize = fromIntegral $ bBodySize (ProtVer (eraProtVerLow @era) 0) txSeq , bhviewHSize = 0 - , bhviewBHash = hashTxSeq txSeq + , bhviewBHash = hashTxZones txSeq , bhviewSlot = SlotNo 0 } - txSeq = toTxSeq $ StrictSeq.fromList txs + txSeq = toTxZones $ StrictSeq.fromList (fmap StrictSeq.singleton txs) scriptStakeCredFail :: forall era. Scriptic era => Proof era -> StakeCredential (EraCrypto era) scriptStakeCredFail pf = ScriptHashObj (alwaysFailsHash 1 pf) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs index ce83f2aea91..d5e7ca33dca 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs @@ -260,7 +260,8 @@ testBBODY wit@(BBODY proof) initialSt block expected pparams = in case proof of Alonzo -> runSTS wit (TRC (env, initialSt, block)) (genericCont "" expected) Babbage -> runSTS wit (TRC (env, initialSt, block)) (genericCont "" expected) - Conway -> runSTS wit (TRC (env, initialSt, block)) (genericCont "" expected) + -- TODO WG + -- Conway -> runSTS wit (TRC (env, initialSt, block)) (genericCont "" expected) other -> error ("We cannot testBBODY in era " ++ show other) testUTXOW :: diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/AggPropTests.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/AggPropTests.hs index 775942d1478..805d15ddfe6 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/AggPropTests.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/AggPropTests.hs @@ -115,8 +115,6 @@ aggTests = -- and then redo the tests in that module in the Generic fashion forAllChainTrace :: (Testable prop, Reflect era) => Proof era -> Int -> (Trace (MOCKCHAIN era) -> prop) -> Property -forAllChainTrace p@Conway n propf = - property $ propf <$> genTrace p n (def {blocksizeMax = 4, slotDelta = (6, 12)}) initStableFields forAllChainTrace p@Babbage n propf = property $ propf <$> genTrace p n (def {blocksizeMax = 4, slotDelta = (6, 12)}) initStableFields forAllChainTrace p@Alonzo n propf = @@ -127,6 +125,9 @@ forAllChainTrace p@Allegra n propf = property $ propf <$> genTrace p n (def {blocksizeMax = 4, slotDelta = (6, 12)}) initStableFields forAllChainTrace p@Shelley n propf = property $ propf <$> genTrace p n (def {blocksizeMax = 4, slotDelta = (6, 12)}) initStableFields +forAllChainTrace _ _ _ = undefined -- p@Conway n propf +-- TODO WG +-- property $ propf <$> genTrace p n (def {blocksizeMax = 4, slotDelta = (6, 12)}) initStableFields -- =========================================================== diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs index 078eea073b0..65ec1e1650b 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs @@ -59,7 +59,7 @@ import Cardano.Ledger.BaseTypes ( StrictMaybe (..), UnitInterval, ) -import Cardano.Ledger.Binary (sizedValue) +import Cardano.Ledger.Binary (Sized, sizedValue) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Governance (GovProcedures (..)) @@ -77,7 +77,7 @@ import Cardano.Ledger.Shelley.Tx (ShelleyTx (..)) import Cardano.Ledger.Shelley.TxBody (ShelleyTxBody (..)) import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..)) import Cardano.Ledger.Shelley.TxWits (pattern ShelleyTxWits) -import Cardano.Ledger.TxIn (TxIn (..)) +import Cardano.Ledger.TxIn (Fulfill, TxIn (..)) import Cardano.Slotting.Slot (SlotNo (..)) import Data.Map (Map) import qualified Data.Map.Strict as Map @@ -136,6 +136,9 @@ data TxBodyField era | GovProcs (GovProcedures era) | CurrentTreasuryValue (StrictMaybe Coin) | TreasuryDonation Coin + | Fulfills (Set (Fulfill (EraCrypto era))) + | Requests (StrictSeq (Sized (TxOut era))) + | Requireds (Set (TxIn (EraCrypto era))) pattern Inputs' :: [TxIn (EraCrypto era)] -> TxBodyField era -- Set @@ -409,10 +412,13 @@ initialTxOut wit@Conway = mkBasicTxOut (initialAddr wit) mempty abstractTx :: Proof era -> Tx era -> [TxField era] abstractTx Conway (AlonzoTx txBody wit v auxdata) = + -- TODO WG [Body txBody, TxWits wit, Valid v, AuxData auxdata] abstractTx Babbage (AlonzoTx txBody wit v auxdata) = + -- TODO WG [Body txBody, TxWits wit, Valid v, AuxData auxdata] abstractTx Alonzo (AlonzoTx txBody wit v auxdata) = + -- TODO WG [Body txBody, TxWits wit, Valid v, AuxData auxdata] abstractTx Shelley (ShelleyTx txBody wit auxdata) = [Body txBody, TxWits wit, AuxData auxdata] diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs index c18dc88d476..55b577cbb21 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs @@ -396,7 +396,8 @@ instance TotalAda AccountState where totalAda (AccountState treasury reserves) = treasury <+> reserves instance Reflect era => TotalAda (UTxOState era) where - totalAda (UTxOState utxo _deposits fees gs _ donations) = + -- TODO WG don't need to do anything with frxo here right? + totalAda (UTxOState utxo _ _deposits fees gs _ donations) = totalAda utxo <+> fees <+> govStateTotalAda gs <+> donations -- we don't add in the _deposits, because it is invariant that this diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/MockChain.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/MockChain.hs index 6b2f9a0ceba..cdda3693453 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/MockChain.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/MockChain.hs @@ -15,9 +15,21 @@ module Test.Cardano.Ledger.Generic.MockChain where import Cardano.Ledger.BaseTypes (BlocksMade (..), ShelleyBase) + +-- import Cardano.Ledger.Conway.Rules ( +-- ConwayLedgersEnv (..), +-- ) + +import Cardano.Ledger.Allegra (AllegraEra) +import Cardano.Ledger.Api.Era (AlonzoEra) +import Cardano.Ledger.Babbage (BabbageEra) +import Cardano.Ledger.Conway (ConwayEra) import Cardano.Ledger.Keys (KeyHash, KeyRole (..)) +import Cardano.Ledger.Mary (MaryEra) +import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Shelley.Core import Cardano.Ledger.Shelley.LedgerState ( + AccountState, EpochState (..), LedgerState (..), NewEpochState (..), @@ -119,15 +131,49 @@ instance (Era era, NoThunks (NewEpochState era)) => NoThunks (MockChainState era -- ====================================================================== +-- type family LedgersEnv era where +-- LedgersEnv (ConwayEra StandardCrypto) = ConwayLedgersEnv (ConwayEra StandardCrypto) +-- LedgersEnv era = ShelleyLedgersEnv era + +-- TODO WG Can you use something like this to avoid duplication of API/Validation.hs? +class LedgersEra era where + type LedgersEnv era + getLedgersEnv :: SlotNo -> PParams era -> AccountState -> LedgersEnv era + +instance LedgersEra (ShelleyEra c) where + type LedgersEnv (ShelleyEra c) = ShelleyLedgersEnv (ShelleyEra c) + getLedgersEnv slot pparams account = LedgersEnv slot pparams account + +instance LedgersEra (BabbageEra c) where + type LedgersEnv (BabbageEra c) = ShelleyLedgersEnv (BabbageEra c) + getLedgersEnv slot pparams account = LedgersEnv slot pparams account + +instance LedgersEra (MaryEra c) where + type LedgersEnv (MaryEra c) = ShelleyLedgersEnv (MaryEra c) + getLedgersEnv slot pparams account = LedgersEnv slot pparams account + +instance LedgersEra (AlonzoEra c) where + type LedgersEnv (AlonzoEra c) = ShelleyLedgersEnv (AlonzoEra c) + getLedgersEnv slot pparams account = LedgersEnv slot pparams account + +instance LedgersEra (AllegraEra c) where + type LedgersEnv (AllegraEra c) = ShelleyLedgersEnv (AllegraEra c) + getLedgersEnv slot pparams account = LedgersEnv slot pparams account + +instance LedgersEra (ConwayEra c) where + type LedgersEnv (ConwayEra c) = ShelleyLedgersEnv (ConwayEra c) + getLedgersEnv slot pparams account = LedgersEnv slot pparams account + instance - ( EraGov era + ( LedgersEra era + , EraGov era , STS (ShelleyTICK era) , State (EraRule "TICK" era) ~ NewEpochState era , Signal (EraRule "TICK" era) ~ SlotNo , Environment (EraRule "TICK" era) ~ () , Embed (EraRule "TICK" era) (MOCKCHAIN era) , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) - , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era + , Environment (EraRule "LEDGERS" era) ~ LedgersEnv era , State (EraRule "LEDGERS" era) ~ LedgerState era , Embed (EraRule "LEDGERS" era) (MOCKCHAIN era) , Signal (EraRule "LEDGER" era) ~ Tx era @@ -160,7 +206,8 @@ instance let newblocksmade = BlocksMade (Map.unionWith (+) current (Map.singleton issuer 1)) newledgerState <- - trans @(EraRule "LEDGERS" era) $ TRC (LedgersEnv slot pparams account, ledgerState, fromStrict txs) + trans @(EraRule "LEDGERS" era) $ + TRC (getLedgersEnv slot pparams account, ledgerState, fromStrict txs) let newEpochstate = epochState {esLState = newledgerState} newNewEpochState = nes' {nesEs = newEpochstate, nesBcur = newblocksmade} 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 c867d9a570b..755439ac2a0 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 @@ -151,6 +151,7 @@ import Cardano.Ledger.EpochBoundary ( SnapShots (..), Stake (..), ) +import Cardano.Ledger.FRxO (FRxO (FRxO), unFRxO) import Cardano.Ledger.Keys ( GenDelegPair (..), GenDelegs (..), @@ -1086,6 +1087,9 @@ pcTxBodyField proof x = case x of GovProcs ga -> [("gov procedures", pcGovProcedures ga)] CurrentTreasuryValue ctv -> [("current treasury value", ppStrictMaybe pcCoin ctv)] TreasuryDonation td -> [("treasury donation", pcCoin td)] + Fulfills _fs -> [("fulfills", "fix me")] -- TODO WG + Requests _rqs -> [("requests", "fix me")] -- TODO WG + Requireds _rs -> [("requests", "fix me")] -- TODO WG pcTxField :: forall era. @@ -3240,10 +3244,11 @@ psNewEpochState proof (NewEpochState en (BlocksMade pbm) (BlocksMade cbm) es _ ( ] pcUTxOState :: Proof era -> UTxOState era -> PDoc -pcUTxOState proof (UTxOState u dep fs gs (IStake m _) don) = +pcUTxOState proof (UTxOState u f dep fs gs (IStake m _) don) = ppRecord "UTxOState" [ ("utxo", pcUTxO proof u) + , ("frxo", pcUTxO proof (UTxO . unFRxO $ f)) -- TODO WG , ("deposited", pcCoin dep) , ("fees", pcCoin fs) , ("govState", pcGovState proof gs) @@ -3256,10 +3261,11 @@ instance Reflect era => PrettyA (UTxOState era) where -- | Like pcUTxOState, except it prints only a summary of the UTxO psUTxOState :: forall era. Reflect era => Proof era -> UTxOState era -> PDoc -psUTxOState proof (UTxOState (UTxO u) dep fs gs (IStake m _) don) = +psUTxOState proof (UTxOState (UTxO u) (FRxO f) dep fs gs (IStake m _) don) = ppRecord "UTxOState" [ ("utxo", summaryMapCompact (Map.map (\x -> x ^. compactCoinTxOutL) u)) + , ("frxo", summaryMapCompact (Map.map (\x -> x ^. compactCoinTxOutL) f)) , ("deposited", pcCoin dep) , ("fees", pcCoin fs) , ("govState", pcGovState proof gs) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Properties.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Properties.hs index 0d38a1418f4..9d58012d1b7 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Properties.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Properties.hs @@ -280,7 +280,7 @@ adaIsPreservedBabbage numTx gensize = adaIsPreserved Babbage numTx gensize stakeInvariant :: EraTxOut era => MockChainState era -> MockChainState era -> Property stakeInvariant (MockChainState _ _ _ _) (MockChainState nes _ _ _) = case (lsUTxOState . esLState . nesEs) nes of - (UTxOState utxo _ _ _ istake _) -> istake === updateStakeDistribution def mempty mempty utxo + (UTxOState utxo _ _ _ _ istake _) -> istake === updateStakeDistribution def mempty mempty utxo incrementStakeInvariant :: ( Reflect era diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Same.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Same.hs index 3747fe01774..a7a400393be 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Same.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Same.hs @@ -17,7 +17,6 @@ module Test.Cardano.Ledger.Generic.Same where import Cardano.Ledger.Allegra.TxBody (AllegraTxBody (..)) -import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..)) import Cardano.Ledger.Alonzo.TxBody (AlonzoTxBody (..)) import Cardano.Ledger.Alonzo.TxSeq (AlonzoTxSeq (..)) import Cardano.Ledger.Alonzo.TxWits (AlonzoTxWits (..), Redeemers (..), TxDats (..)) @@ -27,6 +26,7 @@ import Cardano.Ledger.Binary (sizedValue) import Cardano.Ledger.Block (Block (..)) import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Governance (VotingProcedures (..)) +import Cardano.Ledger.Conway.Tx import Cardano.Ledger.Conway.TxBody (ConwayTxBody (..)) import Cardano.Ledger.Keys (KeyHash, KeyRole (Genesis)) import Cardano.Ledger.Mary.TxBody (MaryTxBody (..)) @@ -508,6 +508,7 @@ sameConwayTxBody :: ConwayTxBody era -> [(String, Maybe PDoc)] sameConwayTxBody + -- TODO WG add new stuff in here proof (ConwayTxBody i1 cl1 ri1 o1 cr1 tc1 c1 (Withdrawals w1) f1 v1 r1 m1 s1 d1 n1 vp1 pp1 ctv1 td1) (ConwayTxBody i2 cl2 ri2 o2 cr2 tc2 c2 (Withdrawals w2) f2 v2 r2 m2 s2 d2 n2 vp2 pp2 ctv2 td2) = @@ -570,6 +571,7 @@ sameAlonzoTx :: AlonzoTx era -> AlonzoTx era -> [(String, Maybe PDoc)] +-- TODO WG add new stuff in here sameAlonzoTx proof (AlonzoTx b1 w1 v1 aux1) (AlonzoTx b2 w2 v2 aux2) = extendLabel "TxBody " (sameTxBody proof b1 b2) ++ extendLabel "TxWits " (sameAlonzoTxWits proof w1 w2) @@ -621,7 +623,7 @@ sameAlonzoTxSeq proof (AlonzoTxSeq ss1) (AlonzoTxSeq ss2) = where f n t1 t2 = SomeM (show n) (sameTx proof) t1 t2 -sameTxSeq :: Reflect era => Proof era -> TxSeq era -> TxSeq era -> [(String, Maybe PDoc)] +sameTxSeq :: Reflect era => Proof era -> TxZones era -> TxZones era -> [(String, Maybe PDoc)] sameTxSeq proof@Shelley x y = sameShelleyTxSeq proof x y sameTxSeq proof@Allegra x y = sameShelleyTxSeq proof x y sameTxSeq proof@Mary x y = sameShelleyTxSeq proof x y diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Trace.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Trace.hs index 2deb14778f3..1d824284c97 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Trace.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Trace.hs @@ -215,8 +215,10 @@ makeEpochState gstate ledgerstate = , esLState = ledgerstate , esNonMyopic = def } - & prevPParamsEpochStateL .~ gePParams (gsGenEnv gstate) - & curPParamsEpochStateL .~ gePParams (gsGenEnv gstate) + & prevPParamsEpochStateL + .~ gePParams (gsGenEnv gstate) + & curPParamsEpochStateL + .~ gePParams (gsGenEnv gstate) snaps :: EraTxOut era => LedgerState era -> SnapShots (EraCrypto era) snaps (LedgerState UTxOState {utxosUtxo = u, utxosFees = f} (CertState _ pstate dstate)) = @@ -498,9 +500,9 @@ traceProp proof numTxInTrace gsize f = do forEachEpochTrace :: forall era prop. - ( Testable prop - , Reflect era - ) => + Testable prop => + -- , Reflect era + Proof era -> Int -> GenSize -> @@ -509,12 +511,12 @@ forEachEpochTrace :: forEachEpochTrace proof tracelen genSize f = do let newEpoch tr1 tr2 = nesEL (mcsNes tr1) /= nesEL (mcsNes tr2) trc <- case proof of - Conway -> genTrace proof tracelen genSize initStableFields Babbage -> genTrace proof tracelen genSize initStableFields Alonzo -> genTrace proof tracelen genSize initStableFields Allegra -> genTrace proof tracelen genSize initStableFields Mary -> genTrace proof tracelen genSize initStableFields Shelley -> genTrace proof tracelen genSize initStableFields + Conway -> genTrace proof tracelen genSize initStableFields let propf (subtrace, index) = counterexample ("Subtrace of EpochNo " ++ show index ++ " fails.") (f subtrace) -- The very last sub-trace may not be a full epoch, so we throw it away. case reverse (splitTrace newEpoch trc) of diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/TestableEra.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/TestableEra.hs index f8fb0134c43..fa320bb5c34 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/TestableEra.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/TestableEra.hs @@ -11,4 +11,4 @@ class , ApplyTx era , GetLedgerView era ) => - TestableEra era + TestableEra era \ No newline at end of file diff --git a/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Arbitrary.hs b/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Arbitrary.hs index d32c740cdc3..71fba2defab 100644 --- a/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Arbitrary.hs +++ b/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Arbitrary.hs @@ -37,6 +37,7 @@ import Cardano.Protocol.TPraos.OCert (KESPeriod (KESPeriod), OCert (..), OCertSi import Cardano.Protocol.TPraos.Rules.Overlay (OBftSlot) import Cardano.Protocol.TPraos.Rules.Prtcl (PrtclState) import Cardano.Protocol.TPraos.Rules.Tickn (TicknState) +import Data.Sequence.Strict (singleton) import Generic.Random (genericArbitraryU) import Test.Cardano.Ledger.Binary.Arbitrary () import Test.Cardano.Ledger.Common @@ -141,7 +142,7 @@ instance ) => Arbitrary (Block (BHeader c) era) where - arbitrary = Block <$> arbitrary <*> (toTxSeq <$> arbitrary) + arbitrary = Block <$> arbitrary <*> (toTxZones . singleton <$> arbitrary) -- | Use supplied keys to generate a Block. genBlock :: @@ -154,7 +155,7 @@ genBlock :: ) => [AllIssuerKeys c r] -> Gen (Block (BHeader c) era) -genBlock aiks = Block <$> genBHeader aiks <*> (toTxSeq <$> arbitrary) +genBlock aiks = Block <$> genBHeader aiks <*> (toTxZones <$> arbitrary) -- | For some purposes, a totally random block generator may not be suitable. -- There are tests in the ouroboros-network repository, for instance, that diff --git a/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Create.hs b/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Create.hs index e6c7b9ae3e7..2b947f7ac62 100644 --- a/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Create.hs +++ b/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Create.hs @@ -247,9 +247,9 @@ mkBlock :: Block (BHeader (EraCrypto era)) era mkBlock prev pKeys txns slotNo blockNo enonce kesPeriod keyRegKesPeriod oCert = let protVer = ProtVer (eraProtVerHigh @era) 0 - txseq = toTxSeq @era (StrictSeq.fromList txns) + txseq = toTxZones @era (fmap StrictSeq.singleton (StrictSeq.fromList txns)) bodySize = fromIntegral $ bBodySize protVer txseq - bodyHash = hashTxSeq @era txseq + bodyHash = hashTxZones @era txseq bhBody = mkBHBody protVer prev pKeys slotNo blockNo enonce oCert bodySize bodyHash bHeader = mkBHeader pKeys kesPeriod keyRegKesPeriod bhBody in Block bHeader txseq @@ -286,9 +286,9 @@ mkBlockFakeVRF :: Block (BHeader (EraCrypto era)) era mkBlockFakeVRF prev pKeys txns slotNo blockNo enonce bnonce l kesPeriod keyRegKesPeriod oCert = let protVer = ProtVer (eraProtVerHigh @era) 0 - txSeq = toTxSeq @era (StrictSeq.fromList txns) + txSeq = toTxZones @era (fmap StrictSeq.singleton (StrictSeq.fromList txns)) bodySize = fromIntegral $ bBodySize protVer txSeq - bodyHash = hashTxSeq txSeq + bodyHash = hashTxZones txSeq bhBody = mkBHBodyFakeVRF bnonce l protVer prev pKeys slotNo blockNo enonce oCert bodySize bodyHash bHeader = mkBHeader pKeys kesPeriod keyRegKesPeriod bhBody diff --git a/libs/plutus-preprocessor/plutus-preprocessor.cabal b/libs/plutus-preprocessor/plutus-preprocessor.cabal index e55aed14f09..e1bee253ae6 100644 --- a/libs/plutus-preprocessor/plutus-preprocessor.cabal +++ b/libs/plutus-preprocessor/plutus-preprocessor.cabal @@ -37,7 +37,7 @@ executable plutus-preprocessor base >=4.14 && <5, bytestring, cardano-ledger-core >=1.8.1, - plutus-tx, + plutus-tx ^>=1.30.0.0, plutus-tx-plugin, plutus-ledger-api, template-haskell From a02cf439f9f97df45582af1cee7f2360faa5128e Mon Sep 17 00:00:00 2001 From: Will Gould Date: Wed, 26 Jun 2024 13:53:11 +0100 Subject: [PATCH 02/19] Everything builds --- eras/babel/impl/cardano-ledger-babel.cabal | 2 +- .../src/Cardano/Ledger/Babel/Rules/Certs.hs | 20 ++++++- .../src/Cardano/Ledger/Babel/Rules/Deleg.hs | 4 +- .../src/Cardano/Ledger/Babel/Rules/Gov.hs | 5 +- .../src/Cardano/Ledger/Babel/Rules/GovCert.hs | 4 +- .../src/Cardano/Ledger/Babel/Rules/Ledger.hs | 35 ++++++++++++ .../src/Cardano/Ledger/Babel/Rules/Ledgers.hs | 6 +- .../src/Cardano/Ledger/Babel/Rules/Zone.hs | 3 + eras/babel/impl/test/Main.hs | 2 +- .../{Conway => Babel}/Binary/CddlSpec.hs | 4 +- .../Ledger/{Conway => Babel}/BinarySpec.hs | 6 +- .../{Conway => Babel}/CommitteeRatifySpec.hs | 13 +++-- .../{Conway => Babel}/DRepRatifySpec.hs | 15 ++--- .../Ledger/{Conway => Babel}/GenesisSpec.hs | 12 ++-- .../{Conway => Babel}/GovActionReorderSpec.hs | 4 +- .../{Conway => Babel}/Plutus/PlutusSpec.hs | 0 .../Test/Cardano/Ledger/Babel/Arbitrary.hs | 37 ++++++++++++ .../testlib/Test/Cardano/Ledger/Babel/Imp.hs | 29 +++++----- .../Cardano/Ledger/Babel/Imp/EnactSpec.hs | 9 +-- .../Cardano/Ledger/Babel/Imp/EpochSpec.hs | 27 ++++----- .../Cardano/Ledger/Babel/Imp/GovCertSpec.hs | 56 +++++++++---------- .../Test/Cardano/Ledger/Babel/Imp/GovSpec.hs | 48 ++++++++-------- .../Cardano/Ledger/Babel/Imp/RatifySpec.hs | 5 +- .../cardano-ledger-babel-test.cabal | 1 + .../src/Test/Cardano/Ledger/Babel/Examples.hs | 3 +- .../Ledger/Babel/Examples/Consensus.hs | 19 ++++--- .../Ledger/Babel/Examples/Prototype.hs | 22 ++++---- .../Ledger/{Conway => Babel}/TxInfo.hs | 0 28 files changed, 247 insertions(+), 144 deletions(-) rename eras/babel/impl/test/Test/Cardano/Ledger/{Conway => Babel}/Binary/CddlSpec.hs (95%) rename eras/babel/impl/test/Test/Cardano/Ledger/{Conway => Babel}/BinarySpec.hs (96%) rename eras/babel/impl/test/Test/Cardano/Ledger/{Conway => Babel}/CommitteeRatifySpec.hs (99%) rename eras/babel/impl/test/Test/Cardano/Ledger/{Conway => Babel}/DRepRatifySpec.hs (98%) rename eras/babel/impl/test/Test/Cardano/Ledger/{Conway => Babel}/GenesisSpec.hs (88%) rename eras/babel/impl/test/Test/Cardano/Ledger/{Conway => Babel}/GovActionReorderSpec.hs (97%) rename eras/babel/impl/test/Test/Cardano/Ledger/{Conway => Babel}/Plutus/PlutusSpec.hs (100%) rename eras/babel/test-suite/test/Test/Cardano/Ledger/{Conway => Babel}/TxInfo.hs (100%) diff --git a/eras/babel/impl/cardano-ledger-babel.cabal b/eras/babel/impl/cardano-ledger-babel.cabal index 20247becb75..a39f57266eb 100644 --- a/eras/babel/impl/cardano-ledger-babel.cabal +++ b/eras/babel/impl/cardano-ledger-babel.cabal @@ -192,7 +192,7 @@ test-suite tests cardano-ledger-babbage, cardano-ledger-babel, cardano-ledger-shelley:testlib, - cardano-ledger-conway:{cardano-ledger-conway, testlib}, + cardano-ledger-conway:{cardano-ledger-conway}, cardano-ledger-core, cardano-ledger-binary:testlib, cardano-slotting:testlib, diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Certs.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Certs.hs index 3c21ef1d066..21659378f10 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Certs.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Certs.hs @@ -7,10 +7,26 @@ module Cardano.Ledger.Babel.Rules.Certs where import Cardano.Ledger.Babel.Era (BabelEra) import Cardano.Ledger.Conway.Rules ( - ConwayCertsPredFailure, + ConwayCertPredFailure (..), + ConwayCertsPredFailure (CertFailure), + ConwayDelegPredFailure, + ConwayGovCertPredFailure, ) -import Cardano.Ledger.Core (EraRuleFailure, InjectRuleFailure) +import Cardano.Ledger.Core (EraRuleFailure, InjectRuleFailure (injectFailure)) +import Cardano.Ledger.Shelley.Rules (ShelleyPoolPredFailure) type instance EraRuleFailure "CERTS" (BabelEra c) = ConwayCertsPredFailure (BabelEra c) instance InjectRuleFailure "CERTS" ConwayCertsPredFailure (BabelEra c) + +instance InjectRuleFailure "CERTS" ConwayCertPredFailure (BabelEra c) where + injectFailure = CertFailure + +instance InjectRuleFailure "CERTS" ConwayDelegPredFailure (BabelEra c) where + injectFailure = CertFailure . DelegFailure + +instance InjectRuleFailure "CERTS" ShelleyPoolPredFailure (BabelEra c) where + injectFailure = CertFailure . PoolFailure + +instance InjectRuleFailure "CERTS" ConwayGovCertPredFailure (BabelEra c) where + injectFailure = CertFailure . GovCertFailure \ No newline at end of file diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Deleg.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Deleg.hs index 9c481542754..5dffd224a76 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Deleg.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Deleg.hs @@ -9,8 +9,10 @@ import Cardano.Ledger.Babel.Era (BabelEra) import Cardano.Ledger.Conway.Rules ( ConwayDelegPredFailure, ) -import Cardano.Ledger.Core (EraRuleFailure, InjectRuleFailure) +import Cardano.Ledger.Core (EraRuleEvent, EraRuleFailure, InjectRuleFailure, VoidEraRule) type instance EraRuleFailure "DELEG" (BabelEra c) = ConwayDelegPredFailure (BabelEra c) instance InjectRuleFailure "DELEG" ConwayDelegPredFailure (BabelEra c) + +type instance EraRuleEvent "DELEG" (BabelEra c) = VoidEraRule "DELEG" (BabelEra c) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Gov.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Gov.hs index f2eda69bdee..df0524362de 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Gov.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Gov.hs @@ -7,10 +7,13 @@ module Cardano.Ledger.Babel.Rules.Gov where import Cardano.Ledger.Babel.Era (BabelEra) import Cardano.Ledger.Conway.Rules ( + ConwayGovEvent, ConwayGovPredFailure, ) -import Cardano.Ledger.Core (EraRuleFailure, InjectRuleFailure) +import Cardano.Ledger.Core (EraRuleEvent, EraRuleFailure, InjectRuleFailure) type instance EraRuleFailure "GOV" (BabelEra c) = ConwayGovPredFailure (BabelEra c) instance InjectRuleFailure "GOV" ConwayGovPredFailure (BabelEra c) + +type instance EraRuleEvent "GOV" (BabelEra c) = ConwayGovEvent (BabelEra c) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/GovCert.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/GovCert.hs index 37d67630185..3afef1ef3d3 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/GovCert.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/GovCert.hs @@ -9,8 +9,10 @@ import Cardano.Ledger.Babel.Era (BabelEra) import Cardano.Ledger.Conway.Rules ( ConwayGovCertPredFailure, ) -import Cardano.Ledger.Core (EraRuleFailure, InjectRuleFailure) +import Cardano.Ledger.Core (EraRuleEvent, EraRuleFailure, InjectRuleFailure, VoidEraRule) type instance EraRuleFailure "GOVCERT" (BabelEra c) = ConwayGovCertPredFailure (BabelEra c) instance InjectRuleFailure "GOVCERT" ConwayGovCertPredFailure (BabelEra c) + +type instance EraRuleEvent "GOVCERT" (BabelEra c) = VoidEraRule "GOVCERT" (BabelEra c) \ No newline at end of file diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledger.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledger.hs index 4684923494d..ca5eecb7e46 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledger.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledger.hs @@ -24,6 +24,7 @@ import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..)) import Cardano.Crypto.Hash.Class (Hash) import Cardano.Ledger.Address (RewardAccount (..)) import Cardano.Ledger.Alonzo.Rules ( + AlonzoUtxosPredFailure, AlonzoUtxowEvent, ) import Cardano.Ledger.Alonzo.Scripts (AlonzoScript) @@ -42,6 +43,7 @@ import Cardano.Ledger.Babel.Era ( import Cardano.Ledger.Babel.Rules.Cert () import Cardano.Ledger.Babel.Rules.Certs () import Cardano.Ledger.Babel.Rules.Deleg () +import Cardano.Ledger.Babel.Rules.Gov () import Cardano.Ledger.Babel.Rules.GovCert () import Cardano.Ledger.Babel.Rules.Utxo (BabelUtxoPredFailure) import Cardano.Ledger.Babel.Rules.Utxos (BabelUtxosPredFailure) @@ -65,9 +67,12 @@ import Cardano.Ledger.Conway.Rules ( CertEnv, CertsEnv (CertsEnv), ConwayCERTS, + ConwayCertPredFailure, ConwayCertsEvent, ConwayCertsPredFailure, + ConwayDelegPredFailure, ConwayGOV, + ConwayGovCertPredFailure, ConwayGovEvent, ConwayGovPredFailure, GovEnv (GovEnv), @@ -87,6 +92,9 @@ import Cardano.Ledger.Shelley.LedgerState ( ) import Cardano.Ledger.Shelley.Rules ( LedgerEnv (..), + ShelleyPoolPredFailure, + ShelleyUtxoPredFailure, + ShelleyUtxowPredFailure, UtxoEnv (..), renderDepositEqualsObligationViolation, shelleyLedgerAssertions, @@ -139,15 +147,42 @@ instance InjectRuleFailure "LEDGER" BabelLedgerPredFailure (BabelEra c) instance InjectRuleFailure "LEDGER" BabelUtxowPredFailure (BabelEra c) where injectFailure = BabelUtxowFailure . injectFailure +instance InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure (BabelEra c) where + injectFailure = BabelUtxowFailure . injectFailure + instance InjectRuleFailure "LEDGER" BabelUtxoPredFailure (BabelEra c) where injectFailure = BabelUtxowFailure . injectFailure instance InjectRuleFailure "LEDGER" BabbageUtxoPredFailure (BabelEra c) where injectFailure = BabelUtxowFailure . injectFailure +instance InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure (BabelEra c) where + injectFailure = BabelUtxowFailure . injectFailure + instance InjectRuleFailure "LEDGER" BabelUtxosPredFailure (BabelEra c) where injectFailure = BabelUtxowFailure . injectFailure +instance InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure (BabelEra c) where + injectFailure = BabelUtxowFailure . injectFailure + +instance InjectRuleFailure "LEDGER" ConwayCertsPredFailure (BabelEra c) where + injectFailure = BabelCertsFailure + +instance InjectRuleFailure "LEDGER" ConwayCertPredFailure (BabelEra c) where + injectFailure = BabelCertsFailure . injectFailure + +instance InjectRuleFailure "LEDGER" ConwayDelegPredFailure (BabelEra c) where + injectFailure = BabelCertsFailure . injectFailure + +instance InjectRuleFailure "LEDGER" ShelleyPoolPredFailure (BabelEra c) where + injectFailure = BabelCertsFailure . injectFailure + +instance InjectRuleFailure "LEDGER" ConwayGovCertPredFailure (BabelEra c) where + injectFailure = BabelCertsFailure . injectFailure + +instance InjectRuleFailure "LEDGER" ConwayGovPredFailure (BabelEra c) where + injectFailure = BabelGovFailure . injectFailure + deriving instance ( Era era , Eq (PredicateFailure (EraRule "UTXOW" era)) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledgers.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledgers.hs index 7cdf8862ce5..4df25a0ad8e 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledgers.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledgers.hs @@ -17,6 +17,7 @@ module Cardano.Ledger.Babel.Rules.Ledgers (BabelLEDGERS, BabelLedgersEnv (..)) where +import Cardano.Ledger.Alonzo.Rules (AlonzoUtxosPredFailure) import Cardano.Ledger.Babel.Era (BabelEra, BabelLEDGERS) import Cardano.Ledger.Babel.Rules.Ledger (BabelLEDGER, BabelLedgerEvent, BabelLedgerPredFailure) import Cardano.Ledger.Babel.Rules.Pool () @@ -67,10 +68,13 @@ instance InjectRuleFailure "LEDGERS" BabelLedgerPredFailure (BabelEra c) where instance InjectRuleFailure "LEDGERS" BabelUtxowPredFailure (BabelEra c) where injectFailure = LedgerFailure . injectFailure +instance InjectRuleFailure "LEDGERS" BabelUtxoPredFailure (BabelEra c) where + injectFailure = LedgerFailure . injectFailure + instance InjectRuleFailure "LEDGERS" BabelUtxosPredFailure (BabelEra c) where injectFailure = LedgerFailure . injectFailure -instance InjectRuleFailure "LEDGERS" BabelUtxoPredFailure (BabelEra c) where +instance InjectRuleFailure "LEDGERS" AlonzoUtxosPredFailure (BabelEra c) where injectFailure = LedgerFailure . injectFailure instance diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs index efa5d77bdb7..18d13e83688 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs @@ -148,6 +148,9 @@ instance InjectRuleFailure "ZONE" BabelUtxoPredFailure (BabelEra c) where instance InjectRuleFailure "ZONE" BabelUtxosPredFailure (BabelEra c) where injectFailure = LedgersFailure . injectFailure +instance InjectRuleFailure "ZONE" AlonzoUtxosPredFailure (BabelEra c) where + injectFailure = LedgersFailure . injectFailure + deriving instance ( Era era , Show (PredicateFailure (EraRule "LEDGER" era)) diff --git a/eras/babel/impl/test/Main.hs b/eras/babel/impl/test/Main.hs index 75176f6b652..40cbb0e2b20 100644 --- a/eras/babel/impl/test/Main.hs +++ b/eras/babel/impl/test/Main.hs @@ -6,7 +6,6 @@ import Cardano.Ledger.Babel (Babel) import qualified Test.Cardano.Ledger.Alonzo.Binary.CostModelsSpec as CostModelsSpec import qualified Test.Cardano.Ledger.Alonzo.Binary.TxWitsSpec as TxWitsSpec import qualified Test.Cardano.Ledger.Alonzo.Imp as AlonzoImp -import Test.Cardano.Ledger.Common import qualified Test.Cardano.Ledger.Babel.Binary.CddlSpec as Cddl import qualified Test.Cardano.Ledger.Babel.Binary.Regression as Regression import qualified Test.Cardano.Ledger.Babel.BinarySpec as Binary @@ -17,6 +16,7 @@ import qualified Test.Cardano.Ledger.Babel.GovActionReorderSpec as GovActionReor import qualified Test.Cardano.Ledger.Babel.Imp as BabelImp import Test.Cardano.Ledger.Babel.Plutus.PlutusSpec as PlutusSpec import qualified Test.Cardano.Ledger.Babel.Proposals as Proposals +import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Core.JSON (roundTripJsonEraSpec) import qualified Test.Cardano.Ledger.Shelley.Imp as ShelleyImp diff --git a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/Binary/CddlSpec.hs b/eras/babel/impl/test/Test/Cardano/Ledger/Babel/Binary/CddlSpec.hs similarity index 95% rename from eras/babel/impl/test/Test/Cardano/Ledger/Conway/Binary/CddlSpec.hs rename to eras/babel/impl/test/Test/Cardano/Ledger/Babel/Binary/CddlSpec.hs index 7f08d14f252..59bce3425a2 100644 --- a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/Binary/CddlSpec.hs +++ b/eras/babel/impl/test/Test/Cardano/Ledger/Babel/Binary/CddlSpec.hs @@ -7,16 +7,16 @@ import Cardano.Ledger.Allegra.Scripts import Cardano.Ledger.Alonzo.Scripts (CostModels) import Cardano.Ledger.Alonzo.TxWits (Redeemers) import Cardano.Ledger.Babel (Babel) -import Cardano.Ledger.Babel.Governance (GovAction, ProposalProcedure, VotingProcedure) +import Cardano.Ledger.Conway.Governance (GovAction, ProposalProcedure, VotingProcedure) import Cardano.Ledger.Core import Cardano.Ledger.Plutus.Data (Data, Datum) +import Test.Cardano.Ledger.Babel.Binary.Cddl (readBabelCddlFiles) import Test.Cardano.Ledger.Binary.Cddl ( beforeAllCddlFile, cddlRoundTripAnnCborSpec, cddlRoundTripCborSpec, ) import Test.Cardano.Ledger.Common -import Test.Cardano.Ledger.Babel.Binary.Cddl (readBabelCddlFiles) spec :: Spec spec = diff --git a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/BinarySpec.hs b/eras/babel/impl/test/Test/Cardano/Ledger/Babel/BinarySpec.hs similarity index 96% rename from eras/babel/impl/test/Test/Cardano/Ledger/Conway/BinarySpec.hs rename to eras/babel/impl/test/Test/Cardano/Ledger/Babel/BinarySpec.hs index 674c353301b..a1aa6e048ad 100644 --- a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/BinarySpec.hs +++ b/eras/babel/impl/test/Test/Cardano/Ledger/Babel/BinarySpec.hs @@ -5,14 +5,14 @@ module Test.Cardano.Ledger.Babel.BinarySpec (spec) where import Cardano.Ledger.Babel import Cardano.Ledger.Babel.Genesis -import Cardano.Ledger.Babel.Governance +import Cardano.Ledger.Conway.Governance import Cardano.Ledger.Crypto import Data.Default.Class (def) -import Test.Cardano.Ledger.Binary.RoundTrip -import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Babel.Arbitrary () import Test.Cardano.Ledger.Babel.Binary.RoundTrip (roundTripBabelCommonSpec) import Test.Cardano.Ledger.Babel.TreeDiff () +import Test.Cardano.Ledger.Binary.RoundTrip +import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Core.Binary (specUpgrade) import Test.Cardano.Ledger.Core.Binary.RoundTrip (roundTripEraSpec) diff --git a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/CommitteeRatifySpec.hs b/eras/babel/impl/test/Test/Cardano/Ledger/Babel/CommitteeRatifySpec.hs similarity index 99% rename from eras/babel/impl/test/Test/Cardano/Ledger/Conway/CommitteeRatifySpec.hs rename to eras/babel/impl/test/Test/Cardano/Ledger/Babel/CommitteeRatifySpec.hs index 7a42d79a818..94ddaeefe4c 100644 --- a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/CommitteeRatifySpec.hs +++ b/eras/babel/impl/test/Test/Cardano/Ledger/Babel/CommitteeRatifySpec.hs @@ -12,11 +12,11 @@ module Test.Cardano.Ledger.Babel.CommitteeRatifySpec (spec) where -import Cardano.Ledger.BaseTypes (EpochNo (..), StrictMaybe (..)) -import Cardano.Ledger.CertState (CommitteeAuthorization (..), CommitteeState (..)) import Cardano.Ledger.Babel import Cardano.Ledger.Babel.Core -import Cardano.Ledger.Babel.Governance ( +import Cardano.Ledger.BaseTypes (EpochNo (..), StrictMaybe (..)) +import Cardano.Ledger.CertState (CommitteeAuthorization (..), CommitteeState (..)) +import Cardano.Ledger.Conway.Governance ( GovAction (..), GovActionState (..), ProposalProcedure (..), @@ -26,7 +26,8 @@ import Cardano.Ledger.Babel.Governance ( ensCommitteeL, rsEnactStateL, ) -import Cardano.Ledger.Babel.Rules ( +import Cardano.Ledger.Conway.PParams +import Cardano.Ledger.Conway.Rules ( committeeAccepted, committeeAcceptedRatio, ) @@ -39,8 +40,8 @@ import qualified Data.Map.Strict as Map import Data.Ratio ((%)) import qualified Data.Set as Set import Lens.Micro ((&), (.~)) -import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Babel.Arbitrary () +import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Core.Arbitrary () spec :: Spec @@ -81,7 +82,7 @@ acceptedRatioProp = acceptedProp :: forall era. - ( BabelEraPParams era + ( ConwayEraPParams era , Arbitrary (PParamsHKD Identity era) , Arbitrary (PParamsHKD StrictMaybe era) ) => diff --git a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/DRepRatifySpec.hs b/eras/babel/impl/test/Test/Cardano/Ledger/Babel/DRepRatifySpec.hs similarity index 98% rename from eras/babel/impl/test/Test/Cardano/Ledger/Conway/DRepRatifySpec.hs rename to eras/babel/impl/test/Test/Cardano/Ledger/Babel/DRepRatifySpec.hs index eb873968791..c3a3d520e47 100644 --- a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/DRepRatifySpec.hs +++ b/eras/babel/impl/test/Test/Cardano/Ledger/Babel/DRepRatifySpec.hs @@ -11,13 +11,13 @@ module Test.Cardano.Ledger.Babel.DRepRatifySpec (spec) where +import Cardano.Ledger.Babel +import Cardano.Ledger.Babel.Core import Cardano.Ledger.BaseTypes (EpochNo (..), StrictMaybe (..)) import Cardano.Ledger.CertState (CommitteeState (..)) import Cardano.Ledger.Coin (Coin (..), CompactForm (..)) import Cardano.Ledger.Compactible (Compactible (..)) -import Cardano.Ledger.Babel -import Cardano.Ledger.Babel.Core -import Cardano.Ledger.Babel.Governance ( +import Cardano.Ledger.Conway.Governance ( GovAction (..), GovActionState (..), RatifyEnv (..), @@ -27,7 +27,8 @@ import Cardano.Ledger.Babel.Governance ( pparamsUpdateThreshold, votingDRepThreshold, ) -import Cardano.Ledger.Babel.Rules ( +import Cardano.Ledger.Conway.PParams +import Cardano.Ledger.Conway.Rules ( dRepAccepted, dRepAcceptedRatio, ) @@ -44,8 +45,8 @@ import Data.Ratio ((%)) import qualified Data.Set as Set import Data.Word (Word64) import Lens.Micro -import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Babel.Arbitrary () +import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Core.Arbitrary () import Test.Cardano.Ledger.Core.Rational ((%!)) @@ -62,7 +63,7 @@ spec = do correctThresholdsProp :: forall era. - ( BabelEraPParams era + ( ConwayEraPParams era , Arbitrary (PParams era) , Arbitrary (PParamsUpdate era) ) => @@ -206,7 +207,7 @@ noStakeProp :: forall era. ( Arbitrary (PParamsHKD StrictMaybe era) , Arbitrary (PParamsHKD Identity era) - , BabelEraPParams era + , ConwayEraPParams era ) => Spec noStakeProp = diff --git a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs b/eras/babel/impl/test/Test/Cardano/Ledger/Babel/GenesisSpec.hs similarity index 88% rename from eras/babel/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs rename to eras/babel/impl/test/Test/Cardano/Ledger/Babel/GenesisSpec.hs index 453dadf982a..fed9bd8128d 100644 --- a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/GenesisSpec.hs +++ b/eras/babel/impl/test/Test/Cardano/Ledger/Babel/GenesisSpec.hs @@ -7,18 +7,18 @@ module Test.Cardano.Ledger.Babel.GenesisSpec (spec, expectedBabelGenesis) where import Cardano.Ledger.Babbage (Babbage) -import Cardano.Ledger.Babel (Babel) import Cardano.Ledger.Babel.Core -import Cardano.Ledger.Babel.PParams +import Cardano.Ledger.Conway (Conway) +import Cardano.Ledger.Conway.PParams import Cardano.Ledger.Plutus.CostModels (costModelsValid) import Cardano.Ledger.Plutus.Language (Language (PlutusV3)) import Data.Aeson hiding (Encoding) import Data.Functor.Identity (Identity) import qualified Data.Map.Strict as Map import Lens.Micro -import Paths_cardano_ledger_Babel (getDataFileName) -import Test.Cardano.Ledger.Common +import Paths_cardano_ledger_babel (getDataFileName) import Test.Cardano.Ledger.Babel.Genesis (expectedBabelGenesis) +import Test.Cardano.Ledger.Common import Test.Cardano.Slotting.Numeric () spec :: Spec @@ -40,9 +40,9 @@ goldenBabelGenesisJSON = Right x -> pure x cg `shouldBe` expectedBabelGenesis -propBabelPParamsUpgrade :: UpgradeBabelPParams Identity -> PParams Babbage -> Property +propBabelPParamsUpgrade :: UpgradeConwayPParams Identity -> PParams Babbage -> Property propBabelPParamsUpgrade ppu pp = property $ do - let pp' = upgradePParams ppu pp :: PParams Babel + let pp' = upgradePParams ppu pp :: PParams Conway pp' ^. ppPoolVotingThresholdsL `shouldBe` ucppPoolVotingThresholds ppu pp' ^. ppDRepVotingThresholdsL `shouldBe` ucppDRepVotingThresholds ppu pp' ^. ppCommitteeMinSizeL `shouldBe` ucppCommitteeMinSize ppu diff --git a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/GovActionReorderSpec.hs b/eras/babel/impl/test/Test/Cardano/Ledger/Babel/GovActionReorderSpec.hs similarity index 97% rename from eras/babel/impl/test/Test/Cardano/Ledger/Conway/GovActionReorderSpec.hs rename to eras/babel/impl/test/Test/Cardano/Ledger/Babel/GovActionReorderSpec.hs index 9454029dff0..8aff349186c 100644 --- a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/GovActionReorderSpec.hs +++ b/eras/babel/impl/test/Test/Cardano/Ledger/Babel/GovActionReorderSpec.hs @@ -4,7 +4,7 @@ module Test.Cardano.Ledger.Babel.GovActionReorderSpec (spec) where import Cardano.Ledger.Babel (Babel) -import Cardano.Ledger.Babel.Governance ( +import Cardano.Ledger.Conway.Governance ( GovActionState (..), actionPriority, gasAction, @@ -13,9 +13,9 @@ import Cardano.Ledger.Babel.Governance ( import Data.Foldable (Foldable (..)) import Data.List (sort) import qualified Data.Sequence.Strict as Seq +import Test.Cardano.Ledger.Babel.Arbitrary (ShuffledGovActionStates (..)) import Test.Cardano.Ledger.Binary.Arbitrary () import Test.Cardano.Ledger.Common -import Test.Cardano.Ledger.Babel.Arbitrary (ShuffledGovActionStates (..)) spec :: Spec spec = diff --git a/eras/babel/impl/test/Test/Cardano/Ledger/Conway/Plutus/PlutusSpec.hs b/eras/babel/impl/test/Test/Cardano/Ledger/Babel/Plutus/PlutusSpec.hs similarity index 100% rename from eras/babel/impl/test/Test/Cardano/Ledger/Conway/Plutus/PlutusSpec.hs rename to eras/babel/impl/test/Test/Cardano/Ledger/Babel/Plutus/PlutusSpec.hs diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Arbitrary.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Arbitrary.hs index a775328042c..22d04e2e5d6 100644 --- a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Arbitrary.hs +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Arbitrary.hs @@ -38,9 +38,11 @@ import Cardano.Ledger.Babel.Core import Cardano.Ledger.Babel.Genesis (BabelGenesis (..)) import Cardano.Ledger.Babel.Rules import Cardano.Ledger.Babel.Scripts (BabelPlutusPurpose (..)) +import Cardano.Ledger.Babel.TxBody (BabelTxBody (BabelTxBody)) import Cardano.Ledger.Babel.TxCert import Cardano.Ledger.Babel.TxInfo (BabelContextError) import Cardano.Ledger.BaseTypes (StrictMaybe (..)) +import Cardano.Ledger.Binary (Sized) import Cardano.Ledger.Conway.Governance import Cardano.Ledger.Crypto (Crypto) import Control.State.Transition.Extended (STS (PredicateFailure)) @@ -59,6 +61,41 @@ import Test.Cardano.Ledger.Babbage.Arbitrary () import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Conway.Arbitrary () +instance + ( BabelEraTxBody era + , Arbitrary (Sized (TxOut era)) + , Arbitrary (TxOut era) + , Arbitrary (Value era) + , Arbitrary (Script era) + , Arbitrary (PParamsUpdate era) + ) => + Arbitrary (BabelTxBody era) + where + arbitrary = + BabelTxBody + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> scale (`div` 15) arbitrary + <*> arbitrary + <*> scale (`div` 15) arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + instance ( EraPParams era , Arbitrary (PlutusPurpose AsItem era) diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp.hs index ebe57b23c3d..cdb41416154 100644 --- a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp.hs +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp.hs @@ -12,22 +12,20 @@ import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext (..)) import Cardano.Ledger.Alonzo.Rules (AlonzoUtxosPredFailure) import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure) import Cardano.Ledger.Babbage.TxInfo (BabbageContextError) -import Cardano.Ledger.BaseTypes (Inject, natVersion) import Cardano.Ledger.Babel.Core -import Cardano.Ledger.Babel.Governance (BabelGovState) -import Cardano.Ledger.Babel.PParams (BabelPParams) +import Cardano.Ledger.Babel.Governance () import Cardano.Ledger.Babel.Rules ( - BabelEpochEvent, - BabelGovCertPredFailure, - BabelGovPredFailure, - BabelNewEpochEvent, + ) import Cardano.Ledger.Babel.TxInfo (BabelContextError) +import Cardano.Ledger.BaseTypes (Inject, natVersion) +import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Conway.PParams +import Cardano.Ledger.Conway.Rules import Cardano.Ledger.Shelley.Rules (Event, ShelleyUtxoPredFailure, ShelleyUtxowPredFailure) import Data.Functor.Identity import Data.Typeable (Typeable) import qualified Test.Cardano.Ledger.Babbage.Imp as BabbageImp -import Test.Cardano.Ledger.Common import qualified Test.Cardano.Ledger.Babel.Imp.EnactSpec as Enact import qualified Test.Cardano.Ledger.Babel.Imp.EpochSpec as Epoch import qualified Test.Cardano.Ledger.Babel.Imp.GovCertSpec as GovCert @@ -36,27 +34,28 @@ import qualified Test.Cardano.Ledger.Babel.Imp.RatifySpec as Ratify import qualified Test.Cardano.Ledger.Babel.Imp.UtxoSpec as Utxo import qualified Test.Cardano.Ledger.Babel.Imp.UtxosSpec as Utxos import Test.Cardano.Ledger.Babel.ImpTest (BabelEraImp, withImpState, withImpStateWithProtVer) +import Test.Cardano.Ledger.Common spec :: forall era. ( BabelEraImp era - , GovState era ~ BabelGovState era - , PParamsHKD Identity era ~ BabelPParams Identity era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , GovState era ~ ConwayGovState era + , PParamsHKD Identity era ~ ConwayPParams Identity era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era , Inject (BabbageContextError era) (ContextError era) , Inject (BabelContextError era) (ContextError era) , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era - , InjectRuleFailure "LEDGER" BabelGovCertPredFailure era + , InjectRuleFailure "LEDGER" ConwayGovCertPredFailure era , NFData (Event (EraRule "ENACT" era)) , ToExpr (Event (EraRule "ENACT" era)) , Eq (Event (EraRule "ENACT" era)) , Typeable (Event (EraRule "ENACT" era)) - , InjectRuleEvent "TICK" BabelEpochEvent era - , Event (EraRule "EPOCH" era) ~ BabelEpochEvent era - , Event (EraRule "NEWEPOCH" era) ~ BabelNewEpochEvent era + , InjectRuleEvent "TICK" ConwayEpochEvent era + , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era + , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era ) => Spec spec = do diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EnactSpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EnactSpec.hs index 3af7441a94a..56316a0a5ed 100644 --- a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EnactSpec.hs +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EnactSpec.hs @@ -14,12 +14,13 @@ module Test.Cardano.Ledger.Babel.Imp.EnactSpec ( ) where import Cardano.Ledger.Address +import Cardano.Ledger.Babel.Core import Cardano.Ledger.BaseTypes import Cardano.Ledger.Coin -import Cardano.Ledger.Babel.Core -import Cardano.Ledger.Babel.Governance -import Cardano.Ledger.Babel.PParams -import Cardano.Ledger.Babel.Rules +import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Conway.PParams +import Cardano.Ledger.Conway.Rules +import Cardano.Ledger.Conway.TxBody (ConwayEraTxBody (..)) import Cardano.Ledger.Credential import Cardano.Ledger.Shelley.LedgerState import Cardano.Ledger.Val (zero, (<->)) diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EpochSpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EpochSpec.hs index cd830075df3..5a50011d02b 100644 --- a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EpochSpec.hs +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EpochSpec.hs @@ -15,12 +15,13 @@ module Test.Cardano.Ledger.Babel.Imp.EpochSpec ( ) where import Cardano.Ledger.Address (RewardAccount (..)) +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.Rules () import Cardano.Ledger.BaseTypes (EpochInterval (..), EpochNo (..)) import Cardano.Ledger.Coin -import Cardano.Ledger.Babel.Core -import Cardano.Ledger.Babel.Governance -import Cardano.Ledger.Babel.PParams -import Cardano.Ledger.Babel.Rules (BabelEpochEvent (GovInfoEvent), BabelNewEpochEvent (..)) +import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Conway.PParams +import Cardano.Ledger.Conway.Rules import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.Shelley.LedgerState import Cardano.Ledger.Shelley.Rules (Event, ShelleyTickEvent (..)) @@ -43,9 +44,9 @@ import Test.Cardano.Ledger.Imp.Common spec :: forall era. ( BabelEraImp era - , InjectRuleEvent "TICK" BabelEpochEvent era - , Event (EraRule "EPOCH" era) ~ BabelEpochEvent era - , Event (EraRule "NEWEPOCH" era) ~ BabelNewEpochEvent era + , InjectRuleEvent "TICK" ConwayEpochEvent era + , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era + , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era ) => SpecWith (ImpTestState era) spec = @@ -57,9 +58,9 @@ spec = relevantDuringBootstrapSpec :: forall era. ( BabelEraImp era - , InjectRuleEvent "TICK" BabelEpochEvent era - , Event (EraRule "EPOCH" era) ~ BabelEpochEvent era - , Event (EraRule "NEWEPOCH" era) ~ BabelNewEpochEvent era + , InjectRuleEvent "TICK" ConwayEpochEvent era + , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era + , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era ) => SpecWith (ImpTestState era) relevantDuringBootstrapSpec = do @@ -354,9 +355,9 @@ depositMovesToTreasuryWhenStakingAddressUnregisters = do eventsSpec :: forall era. ( BabelEraImp era - , InjectRuleEvent "TICK" BabelEpochEvent era - , Event (EraRule "NEWEPOCH" era) ~ BabelNewEpochEvent era - , Event (EraRule "EPOCH" era) ~ BabelEpochEvent era + , InjectRuleEvent "TICK" ConwayEpochEvent era + , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era + , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era ) => SpecWith (ImpTestState era) eventsSpec = describe "Events" $ do diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovCertSpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovCertSpec.hs index 9cb8e5fc3b6..896d56452f4 100644 --- a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovCertSpec.hs +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovCertSpec.hs @@ -14,27 +14,24 @@ module Test.Cardano.Ledger.Babel.Imp.GovCertSpec ( relevantDuringBootstrapSpec, ) where -import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Babel.Core ( EraGov (..), InjectRuleFailure (..), ppDRepDepositL, ) import Cardano.Ledger.Babel.Governance ( - BabelEraGov (..), - BabelGovState, - GovAction (..), - GovPurposeId (..), - Voter (..), - committeeMembersL, + ) -import Cardano.Ledger.Babel.Rules (BabelGovCertPredFailure (..)) +import Cardano.Ledger.Babel.Rules () import Cardano.Ledger.Babel.TxCert ( pattern AuthCommitteeHotKeyTxCert, pattern RegDRepTxCert, pattern ResignCommitteeColdTxCert, pattern UnRegDRepTxCert, ) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Conway.Rules import Cardano.Ledger.Core (EraTx (..), EraTxBody (..)) import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.Shelley.LedgerState ( @@ -50,17 +47,17 @@ import Data.Maybe.Strict (StrictMaybe (..)) import qualified Data.Sequence.Strict as SSeq import qualified Data.Set as Set import Lens.Micro ((&), (.~), (^.)) -import Test.Cardano.Ledger.Common hiding (assertBool, shouldBe) import Test.Cardano.Ledger.Babel.Arbitrary () import Test.Cardano.Ledger.Babel.ImpTest +import Test.Cardano.Ledger.Common hiding (assertBool, shouldBe) import Test.Cardano.Ledger.Core.Rational (IsRatio (..)) import Test.Cardano.Ledger.Imp.Common spec :: forall era. ( BabelEraImp era - , GovState era ~ BabelGovState era - , InjectRuleFailure "LEDGER" BabelGovCertPredFailure era + , Cardano.Ledger.Babel.Core.GovState era ~ ConwayGovState era + , Cardano.Ledger.Babel.Core.InjectRuleFailure "LEDGER" ConwayGovCertPredFailure era ) => SpecWith (ImpTestState era) spec = do @@ -124,15 +121,15 @@ spec = do relevantDuringBootstrapSpec :: forall era. ( BabelEraImp era - , InjectRuleFailure "LEDGER" BabelGovCertPredFailure era + , Cardano.Ledger.Babel.Core.InjectRuleFailure "LEDGER" ConwayGovCertPredFailure era ) => SpecWith (ImpTestState era) relevantDuringBootstrapSpec = do describe "succeeds for" $ do it "registering and unregistering a DRep" $ do - modifyPParams $ ppDRepDepositL .~ Coin 100 + modifyPParams $ Cardano.Ledger.Babel.Core.ppDRepDepositL .~ Coin 100 drepCred <- KeyHashObj <$> freshKeyHash - drepDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppDRepDepositL + drepDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . Cardano.Ledger.Babel.Core.ppDRepDepositL submitTx_ $ mkBasicTx mkBasicTxBody & bodyTxL @@ -164,8 +161,9 @@ relevantDuringBootstrapSpec = do .~ SSeq.singleton (AuthCommitteeHotKeyTxCert kh ccHotCred) describe "fails for" $ do it "invalid deposit provided with DRep registration cert" $ do - modifyPParams $ ppDRepDepositL .~ Coin 100 - expectedDRepDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppDRepDepositL + modifyPParams $ Cardano.Ledger.Babel.Core.ppDRepDepositL .~ Coin 100 + expectedDRepDeposit <- + getsNES $ nesEsL . curPParamsEpochStateL . Cardano.Ledger.Babel.Core.ppDRepDepositL let providedDRepDeposit = expectedDRepDeposit <+> Coin 10 khDRep <- freshKeyHash submitFailingTx @@ -175,12 +173,12 @@ relevantDuringBootstrapSpec = do .~ SSeq.singleton (RegDRepTxCert (KeyHashObj khDRep) providedDRepDeposit SNothing) ) - ( pure . injectFailure $ - BabelDRepIncorrectDeposit providedDRepDeposit expectedDRepDeposit + ( pure . Cardano.Ledger.Babel.Core.injectFailure $ + ConwayDRepIncorrectDeposit providedDRepDeposit expectedDRepDeposit ) it "invalid refund provided with DRep deregistration cert" $ do - modifyPParams $ ppDRepDepositL .~ Coin 100 - drepDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppDRepDepositL + modifyPParams $ Cardano.Ledger.Babel.Core.ppDRepDepositL .~ Coin 100 + drepDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . Cardano.Ledger.Babel.Core.ppDRepDepositL let refund = drepDeposit <+> Coin 10 drepCred <- KeyHashObj <$> freshKeyHash submitTx_ $ @@ -196,12 +194,12 @@ relevantDuringBootstrapSpec = do .~ SSeq.singleton (UnRegDRepTxCert drepCred refund) ) - ( pure . injectFailure $ - BabelDRepIncorrectRefund refund drepDeposit + ( pure . Cardano.Ledger.Babel.Core.injectFailure $ + ConwayDRepIncorrectRefund refund drepDeposit ) it "DRep already registered" $ do - modifyPParams $ ppDRepDepositL .~ Coin 100 - drepDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppDRepDepositL + modifyPParams $ Cardano.Ledger.Babel.Core.ppDRepDepositL .~ Coin 100 + drepDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . Cardano.Ledger.Babel.Core.ppDRepDepositL drepCred <- KeyHashObj <$> freshKeyHash let regTx = @@ -213,10 +211,10 @@ relevantDuringBootstrapSpec = do submitTx_ regTx submitFailingTx regTx - (pure . injectFailure $ BabelDRepAlreadyRegistered drepCred) + (pure . Cardano.Ledger.Babel.Core.injectFailure $ ConwayDRepAlreadyRegistered drepCred) it "unregistering a nonexistent DRep" $ do - modifyPParams $ ppDRepDepositL .~ Coin 100 - drepDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppDRepDepositL + modifyPParams $ Cardano.Ledger.Babel.Core.ppDRepDepositL .~ Coin 100 + drepDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . Cardano.Ledger.Babel.Core.ppDRepDepositL drepCred <- KeyHashObj <$> freshKeyHash submitFailingTx ( mkBasicTx mkBasicTxBody @@ -224,7 +222,7 @@ relevantDuringBootstrapSpec = do . certsTxBodyL .~ SSeq.singleton (UnRegDRepTxCert drepCred drepDeposit) ) - (pure . injectFailure $ BabelDRepNotRegistered drepCred) + (pure . Cardano.Ledger.Babel.Core.injectFailure $ ConwayDRepNotRegistered drepCred) it "registering a resigned CC member hotkey" $ do void registerInitialCommittee initialCommittee <- getCommitteeMembers @@ -244,4 +242,4 @@ relevantDuringBootstrapSpec = do .~ SSeq.singleton (ResignCommitteeColdTxCert ccCred SNothing) submitFailingTx registerHotKeyTx - (pure . injectFailure $ BabelCommitteeHasPreviouslyResigned ccCred) + (pure . Cardano.Ledger.Babel.Core.injectFailure $ ConwayCommitteeHasPreviouslyResigned ccCred) diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovSpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovSpec.hs index ff14f077950..b1381cce793 100644 --- a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovSpec.hs +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovSpec.hs @@ -22,11 +22,11 @@ import Cardano.Ledger.Allegra.Scripts ( pattern RequireSignature, ) import Cardano.Ledger.Babel.Core -import Cardano.Ledger.Babel.Governance import Cardano.Ledger.BaseTypes import Cardano.Ledger.Coin (Coin (Coin)) -import Cardano.Ledger.Conway.Governance (ConwayGovState) -import Cardano.Ledger.Conway.Rules (ConwayGovPredFailure (..)) +import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Conway.Rules +import Cardano.Ledger.Conway.TxBody (ConwayEraTxBody (votingProceduresTxBodyL)) import Cardano.Ledger.Credential (Credential (KeyHashObj)) import Cardano.Ledger.Plutus.CostModels (updateCostModels) import qualified Cardano.Ledger.Shelley.HardForks as HF @@ -51,7 +51,7 @@ spec :: forall era. ( BabelEraImp era , GovState era ~ ConwayGovState era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => SpecWith (ImpTestState era) spec = @@ -68,7 +68,7 @@ spec = relevantDuringBootstrapSpec :: forall era. ( BabelEraImp era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => SpecWith (ImpTestState era) relevantDuringBootstrapSpec = do @@ -103,7 +103,7 @@ unknownCostModelsSpec = predicateFailuresSpec :: forall era. ( BabelEraImp era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => SpecWith (ImpTestState era) predicateFailuresSpec = @@ -174,7 +174,7 @@ predicateFailuresSpec = hardForkSpec :: forall era. ( BabelEraImp era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => SpecWith (ImpTestState era) hardForkSpec = @@ -191,7 +191,7 @@ hardForkSpec = pparamUpdateSpec :: forall era. ( BabelEraImp era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => SpecWith (ImpTestState era) pparamUpdateSpec = @@ -271,7 +271,7 @@ pparamUpdateSpec = proposalsWithVotingSpec :: forall era. ( BabelEraImp era - , GovState era ~ BabelGovState era + , GovState era ~ ConwayGovState era ) => SpecWith (ImpTestState era) proposalsWithVotingSpec = @@ -543,7 +543,7 @@ proposalsWithVotingSpec = proposalsSpec :: forall era. ( BabelEraImp era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => SpecWith (ImpTestState era) proposalsSpec = @@ -799,8 +799,8 @@ proposalsSpec = votingSpec :: forall era. ( BabelEraImp era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era - , GovState era ~ BabelGovState era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era + , GovState era ~ ConwayGovState era ) => SpecWith (ImpTestState era) votingSpec = @@ -910,8 +910,8 @@ votingSpec = constitutionSpec :: forall era. ( BabelEraImp era - , GovState era ~ BabelGovState era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , GovState era ~ ConwayGovState era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => SpecWith (ImpTestState era) constitutionSpec = @@ -993,7 +993,7 @@ constitutionSpec = impAnn "Constitution has not been enacted yet" $ curConstitution' `shouldBe` curConstitution - BabelGovState expectedProposals _ _ _ _ expectedPulser <- + ConwayGovState expectedProposals _ _ _ _ expectedPulser <- getsNES newEpochStateGovStateL expectedEnactState <- getEnactState @@ -1008,14 +1008,14 @@ constitutionSpec = passEpoch >> passEpoch impAnn "Proposal gets removed after expiry" $ do - BabelGovState _ _ _ _ _ pulser <- getsNES newEpochStateGovStateL + ConwayGovState _ _ _ _ _ pulser <- getsNES newEpochStateGovStateL let ratifyState = extractDRepPulsingState pulser rsExpired ratifyState `shouldBe` Set.singleton govActionId policySpec :: forall era. ( BabelEraImp era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => SpecWith (ImpTestState era) policySpec = @@ -1110,7 +1110,7 @@ policySpec = networkIdSpec :: forall era. ( BabelEraImp era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => SpecWith (ImpTestState era) networkIdSpec = @@ -1139,7 +1139,7 @@ networkIdSpec = networkIdWithdrawalsSpec :: forall era. ( BabelEraImp era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => SpecWith (ImpTestState era) networkIdWithdrawalsSpec = @@ -1204,7 +1204,7 @@ firstHardForkCantFollow :: forall era. ( ShelleyEraImp era , BabelEraTxBody era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => ImpTestM era () firstHardForkCantFollow = do @@ -1241,7 +1241,7 @@ secondHardForkCantFollow :: forall era. ( ShelleyEraImp era , BabelEraTxBody era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => ImpTestM era () secondHardForkCantFollow = do @@ -1271,7 +1271,7 @@ secondHardForkCantFollow = do committeeMemberVotingOnCommitteeChange :: forall era. ( BabelEraImp era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => ImpTestM era () committeeMemberVotingOnCommitteeChange = do @@ -1294,7 +1294,7 @@ committeeMemberVotingOnCommitteeChange = do ccVoteOnConstitutionFailsWithMultipleVotes :: forall era. ( BabelEraImp era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => ImpTestM era () ccVoteOnConstitutionFailsWithMultipleVotes = do @@ -1340,7 +1340,7 @@ ccVoteOnConstitutionFailsWithMultipleVotes = do bootstrapPhaseSpec :: forall era. ( BabelEraImp era - , InjectRuleFailure "LEDGER" BabelGovPredFailure era + , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => SpecWith (ImpTestState era) bootstrapPhaseSpec = diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/RatifySpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/RatifySpec.hs index a41c76618d9..fa5d25a1f0b 100644 --- a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/RatifySpec.hs +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/RatifySpec.hs @@ -12,11 +12,10 @@ module Test.Cardano.Ledger.Babel.Imp.RatifySpec ( import Cardano.Ledger.Address import Cardano.Ledger.Babel.Core -import Cardano.Ledger.Babel.Governance -import Cardano.Ledger.Babel.PParams import Cardano.Ledger.BaseTypes import Cardano.Ledger.Coin -import Cardano.Ledger.Conway.Governance (ProposalProcedure (..)) +import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Conway.PParams import Cardano.Ledger.Credential import Cardano.Ledger.Keys import Cardano.Ledger.Shelley.LedgerState diff --git a/eras/babel/test-suite/cardano-ledger-babel-test.cabal b/eras/babel/test-suite/cardano-ledger-babel-test.cabal index 22dfb00442f..42a17ad5ba1 100644 --- a/eras/babel/test-suite/cardano-ledger-babel-test.cabal +++ b/eras/babel/test-suite/cardano-ledger-babel-test.cabal @@ -42,6 +42,7 @@ library cardano-ledger-babbage >=1.3 && <1.9, cardano-ledger-babbage-test >=1.1.1, cardano-ledger-binary >=1.0, + cardano-ledger-conway, cardano-ledger-babel:{cardano-ledger-babel, testlib} >=1.13 && <1.15, cardano-ledger-core:{cardano-ledger-core, testlib} >=1.11, cardano-ledger-allegra >=1.2, diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples.hs index 7fcebb2f7df..9ff273a6367 100644 --- a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples.hs +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples.hs @@ -9,10 +9,9 @@ module Test.Cardano.Ledger.Babel.Examples ( ) where -import Cardano.Ledger.Block (Block) import Cardano.Ledger.Babel (BabelEra) import Cardano.Ledger.Babel.Era (BabelBBODY) -import Cardano.Ledger.Babel.Rules +import Cardano.Ledger.Block (Block) import Cardano.Protocol.TPraos.BHeader (BHeader) import Control.State.Transition.Extended hiding (Assertion) import Data.List.NonEmpty (NonEmpty) diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Consensus.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Consensus.hs index 5e189ffea48..d532720f113 100644 --- a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Consensus.hs +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Consensus.hs @@ -17,20 +17,21 @@ import Cardano.Ledger.Alonzo.TxAuxData ( ) import Cardano.Ledger.Alonzo.TxWits (Redeemers (..), TxDats (..)) import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..)) -import Cardano.Ledger.BaseTypes -import Cardano.Ledger.Binary (mkSized) -import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Babel (Babel) import Cardano.Ledger.Babel.Core import Cardano.Ledger.Babel.Genesis (BabelGenesis (..)) -import Cardano.Ledger.Babel.Governance (VotingProcedures (..)) -import Cardano.Ledger.Babel.Rules (BabelCERTS, BabelCertsPredFailure (..), BabelLEDGER) +import Cardano.Ledger.Babel.Rules (BabelLEDGER) import Cardano.Ledger.Babel.Scripts (BabelPlutusPurpose (..)) import Cardano.Ledger.Babel.Translation () import Cardano.Ledger.Babel.Tx (AlonzoTx (..)) import Cardano.Ledger.Babel.TxBody (BabelTxBody (..)) -import Cardano.Ledger.Babel.TxCert import Cardano.Ledger.Babel.TxWits (AlonzoTxWits (..)) +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Binary (mkSized) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Conway.Governance +import Cardano.Ledger.Conway.Rules +import Cardano.Ledger.Conway.TxCert (ConwayTxCert (ConwayTxCertPool)) import Cardano.Ledger.Credential (Credential (KeyHashObj, ScriptHashObj)) import Cardano.Ledger.Crypto (StandardCrypto) import Cardano.Ledger.Keys (asWitness) @@ -82,7 +83,7 @@ ledgerExamplesBabel = , SLE.sleApplyTxError = ApplyTxError $ pure $ - wrapFailed @(BabelCERTS Babel) @(BabelLEDGER Babel) $ + wrapFailed @(ConwayCERTS Babel) @(BabelLEDGER Babel) $ DelegateeNotRegisteredDELEG @Babel (SLE.mkKeyHash 1) , SLE.sleRewardsCredentials = Set.fromList @@ -118,10 +119,10 @@ collateralOutput = NoDatum SNothing -exampleBabelCerts :: Era era => OSet.OSet (BabelTxCert era) +exampleBabelCerts :: Era era => OSet.OSet (ConwayTxCert era) exampleBabelCerts = OSet.fromList -- TODO should I add the new certs here? - [ BabelTxCertPool (RegPool examplePoolParams) + [ ConwayTxCertPool (RegPool examplePoolParams) ] exampleTxBodyBabel :: TxBody Babel diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Prototype.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Prototype.hs index f7648cf8a63..305396e0b86 100644 --- a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Prototype.hs +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Prototype.hs @@ -24,20 +24,9 @@ import Cardano.Ledger.Alonzo.Tx (IsValid (IsValid)) import Cardano.Ledger.Alonzo.TxWits (Redeemers (Redeemers), TxDats (TxDats)) import Cardano.Ledger.Babbage import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..)) -import Cardano.Ledger.BaseTypes ( - EpochInterval (EpochInterval), - Network (Mainnet), - Nonce, - StrictMaybe (..), - WithOrigin (At), - ) -import Cardano.Ledger.Binary (mkSized) -import Cardano.Ledger.Block (Block) -import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Babel (Babel, BabelEra) import Cardano.Ledger.Babel.Core import Cardano.Ledger.Babel.Genesis (BabelGenesis) -import Cardano.Ledger.Babel.Governance (VotingProcedures (VotingProcedures)) import Cardano.Ledger.Babel.Scripts ( AlonzoScript (TimelockScript), BabelPlutusPurpose (BabelSpending), @@ -45,6 +34,17 @@ import Cardano.Ledger.Babel.Scripts ( import Cardano.Ledger.Babel.Tx (AlonzoTx (AlonzoTx)) import Cardano.Ledger.Babel.TxBody import Cardano.Ledger.Babel.TxWits (AlonzoTxWits (AlonzoTxWits)) +import Cardano.Ledger.BaseTypes ( + EpochInterval (EpochInterval), + Network (Mainnet), + Nonce, + StrictMaybe (..), + WithOrigin (At), + ) +import Cardano.Ledger.Binary (mkSized) +import Cardano.Ledger.Block (Block) +import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Conway.Governance (VotingProcedures (..)) import Cardano.Ledger.Crypto import Cardano.Ledger.Keys ( GenDelegPair (GenDelegPair), diff --git a/eras/babel/test-suite/test/Test/Cardano/Ledger/Conway/TxInfo.hs b/eras/babel/test-suite/test/Test/Cardano/Ledger/Babel/TxInfo.hs similarity index 100% rename from eras/babel/test-suite/test/Test/Cardano/Ledger/Conway/TxInfo.hs rename to eras/babel/test-suite/test/Test/Cardano/Ledger/Babel/TxInfo.hs From 2d763522942e117e9b6117e34f7b693b81aa4b60 Mon Sep 17 00:00:00 2001 From: Will Gould Date: Wed, 26 Jun 2024 18:24:32 +0100 Subject: [PATCH 03/19] Removed a bunch of copy and pasted code --- .../impl/src/Cardano/Ledger/Allegra.hs | 4 + eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs | 3 +- .../impl/src/Cardano/Ledger/Babbage.hs | 3 +- eras/babel/impl/cardano-ledger-babel.cabal | 3 - eras/babel/impl/src/Cardano/Ledger/Babel.hs | 34 +- .../src/Cardano/Ledger/Babel/API/Genesis.hs | 125 ------- .../src/Cardano/Ledger/Babel/API/Mempool.hs | 321 ------------------ .../Cardano/Ledger/Babel/API/Validation.hs | 276 --------------- .../src/Cardano/Ledger/Babel/Rules/Bbody.hs | 10 +- .../Test/Cardano/Ledger/Babel/Rules/Chain.hs | 11 +- .../src/Test/Cardano/Ledger/Babel/Utils.hs | 2 +- eras/conway/impl/src/Cardano/Ledger/Conway.hs | 2 + eras/mary/impl/src/Cardano/Ledger/Mary.hs | 3 + .../Cardano/Ledger/Shelley/API/Validation.hs | 29 +- 14 files changed, 80 insertions(+), 746 deletions(-) delete mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/API/Genesis.hs delete mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/API/Mempool.hs delete mode 100644 eras/babel/impl/src/Cardano/Ledger/Babel/API/Validation.hs diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs index 3d6f7b76ca0..0ec039ca144 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- CanStartFromGenesis {-# OPTIONS_GHC -Wno-deprecations #-} @@ -28,6 +29,7 @@ import Cardano.Ledger.Shelley.API ( ApplyBlock, ApplyTx, CanStartFromGenesis (fromShelleyPParams), + EraLedgerRules, ) type Allegra = AllegraEra StandardCrypto @@ -43,6 +45,8 @@ instance instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => ApplyBlock (AllegraEra c) + where + type EraLedgerRules (AllegraEra c) = '[] instance Crypto c => CanStartFromGenesis (AllegraEra c) where fromShelleyPParams _ = translateEra' () diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs index 65d8905a581..23b51a99adc 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs @@ -72,7 +72,8 @@ reapplyAlonzoTx globals env state vtx = instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyTx (AlonzoEra c) where reapplyTx = reapplyAlonzoTx -instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock (AlonzoEra c) +instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock (AlonzoEra c) where + type EraLedgerRules (AlonzoEra c) = '[] instance Crypto c => API.CanStartFromGenesis (AlonzoEra c) where type AdditionalGenesisConfig (AlonzoEra c) = AlonzoGenesis diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs index 87b4a4b2260..8db8c86e2d5 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs @@ -45,7 +45,8 @@ type Babbage = BabbageEra StandardCrypto instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyTx (BabbageEra c) where reapplyTx = reapplyAlonzoTx -instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock (BabbageEra c) +instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock (BabbageEra c) where + type EraLedgerRules (BabbageEra c) = '[] instance Crypto c => API.CanStartFromGenesis (BabbageEra c) where type AdditionalGenesisConfig (BabbageEra c) = AlonzoGenesis diff --git a/eras/babel/impl/cardano-ledger-babel.cabal b/eras/babel/impl/cardano-ledger-babel.cabal index a39f57266eb..0a75c506746 100644 --- a/eras/babel/impl/cardano-ledger-babel.cabal +++ b/eras/babel/impl/cardano-ledger-babel.cabal @@ -50,12 +50,9 @@ library Cardano.Ledger.Babel.FRxO Cardano.Ledger.Babel.UTxO Cardano.Ledger.Babel.Plutus.Context - Cardano.Ledger.Babel.API.Validation hs-source-dirs: src other-modules: - Cardano.Ledger.Babel.API.Genesis - Cardano.Ledger.Babel.API.Mempool Cardano.Ledger.Babel.Rules.Gov Cardano.Ledger.Babel.Rules.Ledger Cardano.Ledger.Babel.Rules.Ledgers diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel.hs b/eras/babel/impl/src/Cardano/Ledger/Babel.hs index 084fc637487..8332259d902 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel.hs @@ -17,13 +17,8 @@ module Cardano.Ledger.Babel ( ) where +import Cardano.Crypto.DSIGN (Signable) import Cardano.Ledger.Babbage.TxBody () -import Cardano.Ledger.Babel.API.Genesis (CanStartFromGenesis (..)) -import Cardano.Ledger.Babel.API.Mempool ( - ApplyTx (reapplyTx), - ApplyTxError (ApplyTxError), - extractTx, - ) import Cardano.Ledger.Babel.Core import Cardano.Ledger.Babel.Era (BabelEra) import Cardano.Ledger.Babel.Genesis (BabelGenesis (..)) @@ -37,18 +32,43 @@ import Cardano.Ledger.Babel.TxInfo () import Cardano.Ledger.Babel.TxOut () import Cardano.Ledger.Babel.UTxO () import Cardano.Ledger.Conway.Governance (RunConwayRatify (..)) -import Cardano.Ledger.Crypto (Crypto, StandardCrypto) +import Cardano.Ledger.Crypto (Crypto (DSIGN), StandardCrypto) import Cardano.Ledger.Keys (DSignable, Hash) import Cardano.Ledger.Rules.ValidationMode (applySTSNonStatic) +import Cardano.Ledger.Shelley.API (ApplyBlock, EraLedgerRules) +import Cardano.Ledger.Shelley.API.Genesis (CanStartFromGenesis (..)) +import Cardano.Ledger.Shelley.API.Mempool ( + ApplyTx (reapplyTx), + ApplyTxError (ApplyTxError), + extractTx, + ) import Control.Arrow (left) import Control.Monad.Error.Class (liftEither) import Control.Monad.Reader (runReader) import Control.State.Transition (TRC (TRC)) +import qualified Cardano.Crypto.Hash.Class +import Cardano.Ledger.Babbage.Rules () +import Cardano.Ledger.Babbage.Transition () +import Cardano.Ledger.Babbage.Translation () +import Cardano.Ledger.Babbage.TxInfo () +import Cardano.Ledger.Babbage.UTxO () + type Babel = BabelEra StandardCrypto -- ===================================================== +instance + ( Crypto c + , DSignable c (Hash c EraIndependentTxBody) + , DSignable c (Hash c EraIndependentRequiredTxs) + , -- TODO WG figure out what you've done wrong to introduce this constraint + Signable (DSIGN c) (Cardano.Crypto.Hash.Class.Hash c EraIndependentTxBody) + ) => + ApplyBlock (BabelEra c) + where + type EraLedgerRules (BabelEra c) = '["ZONES"] + instance ( Crypto c , DSignable c (Hash c EraIndependentTxBody) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/API/Genesis.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/API/Genesis.hs deleted file mode 100644 index cd3141140af..00000000000 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/API/Genesis.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} - -module Cardano.Ledger.Babel.API.Genesis where - -import Cardano.Ledger.BaseTypes (BlocksMade (..), EpochNo (EpochNo)) -import Cardano.Ledger.Crypto (Crypto) -import Cardano.Ledger.EpochBoundary (emptySnapShots) -import Cardano.Ledger.Shelley (ShelleyEra) -import Cardano.Ledger.Shelley.API.Types ( - AccountState (AccountState), - CertState (CertState), - Coin (Coin), - DState (..), - EpochState (EpochState), - GenDelegs (GenDelegs), - LedgerState (LedgerState), - NewEpochState (NewEpochState), - PoolDistr (PoolDistr), - ShelleyGenesis (sgGenDelegs, sgMaxLovelaceSupply, sgProtocolParams), - StrictMaybe (SNothing), - genesisUTxO, - word64ToCoin, - ) -import Cardano.Ledger.Shelley.Core -import Cardano.Ledger.Shelley.LedgerState ( - StashedAVVMAddresses, - smartUTxOState, - ) -import qualified Cardano.Ledger.UMap as UM -import Cardano.Ledger.UTxO (coinBalance) -import Cardano.Ledger.Val (Val (..)) -import Data.Default.Class (Default, def) -import Data.Kind (Type) -import qualified Data.Map.Strict as Map -import Lens.Micro ((&), (.~)) - --- | Indicates that this era may be bootstrapped from 'ShelleyGenesis'. -class - ( EraTxOut era - , Default (StashedAVVMAddresses era) - , EraGov era - ) => - CanStartFromGenesis era - where - -- | Additional genesis configuration necessary for this era. - type AdditionalGenesisConfig era :: Type - - type AdditionalGenesisConfig era = () - - -- | Upgrade `PParams` from `ShelleyEra` all the way to the current one. - fromShelleyPParams :: - AdditionalGenesisConfig era -> - PParams (ShelleyEra (EraCrypto era)) -> - PParams era - - -- | Construct an initial state given a 'ShelleyGenesis' and any appropriate - -- 'AdditionalGenesisConfig' for the era. - initialState :: - ShelleyGenesis (EraCrypto era) -> - AdditionalGenesisConfig era -> - NewEpochState era - initialState = initialStateFromGenesis - -{-# DEPRECATED CanStartFromGenesis "Use `Cardano.Ledger.Shelley.Transition.EraTransition` instead" #-} -{-# DEPRECATED fromShelleyPParams "Use `Cardano.Ledger.Shelley.Transition.tcInitialPParamsG` instead" #-} -{-# DEPRECATED initialState "Use `Cardano.Ledger.Shelley.Transition.createInitialState` instead" #-} - -instance - Crypto c => - CanStartFromGenesis (ShelleyEra c) - where - fromShelleyPParams _ = id - --- | Helper function for constructing the initial state for any era -initialStateFromGenesis :: - forall era. - CanStartFromGenesis era => - -- | Genesis type - ShelleyGenesis (EraCrypto era) -> - AdditionalGenesisConfig era -> - NewEpochState era -initialStateFromGenesis sg ag = - NewEpochState - initialEpochNo - (BlocksMade Map.empty) - (BlocksMade Map.empty) - ( EpochState - (AccountState (Coin 0) reserves) - ( LedgerState - (smartUTxOState (fromShelleyPParams ag pp) initialUtxo (Coin 0) (Coin 0) govSt zero) - (CertState def def dState) - ) - emptySnapShots - def - ) - SNothing - (PoolDistr Map.empty) - def - where - initialEpochNo = EpochNo 0 - initialUtxo = genesisUTxO sg - reserves = word64ToCoin (sgMaxLovelaceSupply sg) <-> coinBalance initialUtxo - genDelegs = sgGenDelegs sg - pp = sgProtocolParams sg - govSt = - def - & curPParamsGovStateL - .~ fromShelleyPParams ag pp - & prevPParamsGovStateL - .~ fromShelleyPParams ag pp - - dState :: DState era - dState = - DState - { dsUnified = UM.empty - , dsFutureGenDelegs = Map.empty - , dsGenDelegs = GenDelegs genDelegs - , dsIRewards = def - } diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/API/Mempool.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/API/Mempool.hs deleted file mode 100644 index 4f717521b8b..00000000000 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/API/Mempool.hs +++ /dev/null @@ -1,321 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} - --- | Interface to the Conway ledger for the purposes of managing a Conway --- mempool. -module Cardano.Ledger.Babel.API.Mempool ( - ApplyTx (..), - ApplyTxError (..), - Validated, - extractTx, - coerceValidated, - translateValidated, - - -- * Exports for testing - MempoolEnv, - MempoolState, - applyTxsTransition, - unsafeMakeValidated, - - -- * Exports for compatibility - applyTxs, - mkMempoolEnv, - mkMempoolState, - overNewEpochState, -) -where - -import Cardano.Ledger.BaseTypes (Globals, ShelleyBase) -import Cardano.Ledger.Binary ( - DecCBOR (..), - EncCBOR (..), - FromCBOR (..), - ToCBOR (..), - encodeFoldableAsIndefLenList, - ifEncodingVersionAtLeast, - natVersion, - ) -import Cardano.Ledger.Core -import Cardano.Ledger.Keys -import Cardano.Ledger.Shelley (ShelleyEra) -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 (LedgerEnv) -import qualified Cardano.Ledger.Shelley.Rules as Ledger -import Cardano.Ledger.Slot (SlotNo) -import Control.Arrow (ArrowChoice (right), left) -import Control.DeepSeq (NFData) -import Control.Monad (foldM) -import Control.Monad.Except (Except, MonadError, liftEither) -import Control.Monad.Trans.Reader (runReader) -import Control.State.Transition.Extended ( - BaseM, - Environment, - PredicateFailure, - STS, - Signal, - State, - TRC (..), - applySTS, - ) -import Data.Coerce (Coercible, coerce) -import Data.Functor ((<&>)) -import Data.List.NonEmpty (NonEmpty) -import Data.Sequence (Seq) -import Data.Typeable (Typeable) -import Lens.Micro ((^.)) -import NoThunks.Class (NoThunks) - --- | A newtype which indicates that a transaction has been validated against --- some chain state. -newtype Validated tx = Validated tx - deriving (Eq, NoThunks, Show, NFData) - --- | Extract the underlying unvalidated Tx. -extractTx :: Validated tx -> tx -extractTx (Validated tx) = tx - -coerceValidated :: Coercible a b => Validated a -> Validated b -coerceValidated (Validated a) = Validated $ coerce a - --- Don't use this except in Testing to make Arbitrary instances, etc. -unsafeMakeValidated :: tx -> Validated tx -unsafeMakeValidated = Validated - --- | Translate a validated transaction across eras. --- --- This is not a `TranslateEra` instance since `Validated` is not itself --- era-parametrised. -translateValidated :: - forall era f. - TranslateEra era f => - TranslationContext era -> - Validated (f (PreviousEra era)) -> - Except (TranslationError era f) (Validated (f era)) -translateValidated ctx (Validated tx) = Validated <$> translateEra @era ctx tx - -class - ( EraTx era - , Eq (ApplyTxError era) - , Show (ApplyTxError era) - , Typeable (ApplyTxError era) - , STS (EraRule "LEDGER" era) - , BaseM (EraRule "LEDGER" era) ~ ShelleyBase - , Environment (EraRule "LEDGER" era) ~ LedgerEnv era - , State (EraRule "LEDGER" era) ~ MempoolState era - , Signal (EraRule "LEDGER" era) ~ Tx era - ) => - ApplyTx era - where - -- | Validate a transaction against a mempool state, and return both the new - -- mempool state and a "validated" 'TxInBlock'. - -- - -- The meaning of being "validated" depends on the era. In general, a - -- 'TxInBlock' has had all checks run, and can now only fail due to checks - -- which depend on the state; most notably, that UTxO inputs disappear. - applyTx :: - MonadError (ApplyTxError era) m => - Globals -> - MempoolEnv era -> - MempoolState era -> - Tx era -> - m (MempoolState era, Validated (Tx era)) - applyTx globals env state tx = - let res = - flip runReader globals - . applySTS @(EraRule "LEDGER" era) - $ TRC (env, state, tx) - in liftEither - . left ApplyTxError - . right (,Validated tx) - $ res - - -- | Reapply a previously validated 'Tx'. - -- - -- This applies the (validated) transaction to a new mempool state. It may - -- fail due to the mempool state changing (for example, a needed output - -- having already been spent). It should not fail due to any static check - -- (such as cryptographic checks). - -- - -- Implementations of this function may optionally skip the performance of - -- any static checks. This is not required, but strongly encouraged since - -- this function will be called each time the mempool revalidates - -- transactions against a new mempool state. - reapplyTx :: - MonadError (ApplyTxError era) m => - Globals -> - MempoolEnv era -> - MempoolState era -> - Validated (Tx era) -> - m (MempoolState era) - reapplyTx globals env state (Validated tx) = - let res = - flip runReader globals - . applySTS @(EraRule "LEDGER" era) - $ TRC (env, state, tx) - in liftEither - . left ApplyTxError - $ res - -instance - ( EraPParams (ShelleyEra c) - , DSignable c (Hash c EraIndependentTxBody) - ) => - ApplyTx (ShelleyEra c) - -type MempoolEnv era = Ledger.LedgerEnv era - -type MempoolState era = LedgerState.LedgerState era - --- | Construct the environment used to validate transactions from the full --- ledger state. --- --- Note that this function also takes a slot. During slot validation, the slot --- given here is the slot of the block containing the transactions. This slot is --- used for quite a number of things, but in general these do not determine the --- validity of the transaction. There are two exceptions: --- --- - Each transaction has a ttl (time-to-live) value. If the slot is beyond this --- value, then the transaction is invalid. --- - If the transaction contains a protocol update proposal, then it may only be --- included until a certain number of slots before the end of the epoch. A --- protocol update proposal submitted after this is considered invalid. -mkMempoolEnv :: - EraGov era => - NewEpochState era -> - SlotNo -> - MempoolEnv era -mkMempoolEnv - LedgerState.NewEpochState - { LedgerState.nesEs - } - slot = - Ledger.LedgerEnv - { Ledger.ledgerSlotNo = slot - , Ledger.ledgerIx = minBound - , Ledger.ledgerPp = nesEs ^. curPParamsEpochStateL - , Ledger.ledgerAccount = LedgerState.esAccountState nesEs - } - --- | Construct a mempool state from the wider ledger state. --- --- The given mempool state may then be evolved using 'applyTxs', but should be --- regenerated when the ledger state gets updated (e.g. through application of --- a new block). -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) - --- TODO: This instance can be switched back to a derived version, once we are officially --- in the Conway era: --- --- deriving newtype instance --- ( Era era --- , EncCBOR (PredicateFailure (EraRule "LEDGER" era)) --- ) => --- EncCBOR (ApplyTxError era) - -instance - ( Era era - , EncCBOR (PredicateFailure (EraRule "LEDGER" era)) - ) => - EncCBOR (ApplyTxError era) - where - encCBOR (ApplyTxError failures) = - ifEncodingVersionAtLeast - (natVersion @9) - (encCBOR failures) - (encodeFoldableAsIndefLenList encCBOR failures) - -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 - --- | Old 'applyTxs' -applyTxs :: - (ApplyTx era, MonadError (ApplyTxError era) m, EraGov era) => - Globals -> - SlotNo -> - Seq (Tx era) -> - NewEpochState era -> - m (NewEpochState era) -applyTxs - globals - slot - txs - state = - overNewEpochState (applyTxsTransition globals mempoolEnv txs) state - where - mempoolEnv = mkMempoolEnv state slot - -applyTxsTransition :: - forall era m. - ( ApplyTx era - , MonadError (ApplyTxError era) m - ) => - Globals -> - MempoolEnv era -> - Seq (Tx era) -> - MempoolState era -> - m (MempoolState era) -applyTxsTransition globals env txs state = - foldM - (\st tx -> fst <$> applyTx globals env st tx) - state - txs - --- | Transform a function over mempool states to one over the full --- 'NewEpochState'. -overNewEpochState :: - Functor f => - (MempoolState era -> f (MempoolState era)) -> - NewEpochState era -> - f (NewEpochState era) -overNewEpochState f st = do - f (mkMempoolState st) - <&> \ls -> - st - { LedgerState.nesEs = - (LedgerState.nesEs st) - { LedgerState.esLState = ls - } - } diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/API/Validation.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/API/Validation.hs deleted file mode 100644 index 0e9737c649f..00000000000 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/API/Validation.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ImpredicativeTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Interface to the block validation and chain extension logic in the Shelley --- API. -module Cardano.Ledger.Babel.API.Validation ( - ApplyBlock (..), - applyBlock, - applyTick, - TickTransitionError (..), - BlockTransitionError (..), - chainChecks, - ShelleyEraCrypto, -) -where - -import Cardano.Ledger.BHeaderView (BHeaderView) -import Cardano.Ledger.Babel.Era (BabelEra) -import Cardano.Ledger.Babel.Rules.Bbody (BabelBbodyState (BbodyState)) -import Cardano.Ledger.Babel.Rules.Zones () -import Cardano.Ledger.BaseTypes (Globals (..), ShelleyBase, Version) -import Cardano.Ledger.Binary (EncCBORGroup) -import Cardano.Ledger.Block (Block) -import qualified Cardano.Ledger.Chain as STS -import Cardano.Ledger.Conway.Rules () -import Cardano.Ledger.Core -import Cardano.Ledger.Crypto (Crypto) -import Cardano.Ledger.Keys (DSignable, Hash) -import Cardano.Ledger.Shelley.Core (EraGov) -import Cardano.Ledger.Shelley.LedgerState (LedgerState (..), NewEpochState, curPParamsEpochStateL) -import qualified Cardano.Ledger.Shelley.LedgerState as LedgerState -import Cardano.Ledger.Shelley.PParams () -import Cardano.Ledger.Shelley.Rules () -import qualified Cardano.Ledger.Shelley.Rules as STS -import Cardano.Ledger.Slot (SlotNo) -import Control.Arrow (left, right) -import Control.Monad.Except -import Control.Monad.Trans.Reader (runReader) -import Control.State.Transition.Extended -import Data.List.NonEmpty (NonEmpty) -import GHC.Generics (Generic) -import Lens.Micro ((^.)) -import NoThunks.Class (NoThunks (..)) - -{------------------------------------------------------------------------------- - Block validation API --------------------------------------------------------------------------------} - -class - ( STS (EraRule "TICK" era) - , BaseM (EraRule "TICK" era) ~ ShelleyBase - , Environment (EraRule "TICK" era) ~ () - , State (EraRule "TICK" era) ~ NewEpochState era - , Signal (EraRule "TICK" era) ~ SlotNo - , STS (EraRule "BBODY" era) - , BaseM (EraRule "BBODY" era) ~ ShelleyBase - , Environment (EraRule "BBODY" era) ~ STS.BbodyEnv era - , State (EraRule "BBODY" era) ~ BabelBbodyState era - , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era - , EncCBORGroup (TxZones era) - , State (EraRule "ZONES" era) ~ LedgerState era - ) => - ApplyBlock era - where - -- | Apply the header level ledger transition. - -- - -- This handles checks and updates that happen on a slot tick, as well as a - -- few header level checks, such as size constraints. - applyTickOpts :: - ApplySTSOpts ep -> - Globals -> - NewEpochState era -> - SlotNo -> - EventReturnType ep (EraRule "TICK" era) (NewEpochState era) - applyTickOpts opts globals state hdr = - either err id - . flip runReader globals - . applySTSOptsEither @(EraRule "TICK" era) opts - $ TRC ((), state, hdr) - where - err :: Show a => a -> b - err msg = error $ "Panic! applyTick failed: " <> show msg - - -- | Apply the block level ledger transition. - applyBlockOpts :: - forall ep m. - (EventReturnTypeRep ep, MonadError (BlockTransitionError era) m) => - ApplySTSOpts ep -> - Globals -> - NewEpochState era -> - Block (BHeaderView (EraCrypto era)) era -> - m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era)) - default applyBlockOpts :: - forall ep m. - (EventReturnTypeRep ep, MonadError (BlockTransitionError era) m, EraGov era) => - ApplySTSOpts ep -> - Globals -> - NewEpochState era -> - Block (BHeaderView (EraCrypto era)) era -> - m (EventReturnType ep (EraRule "BBODY" era) (NewEpochState era)) - applyBlockOpts opts globals state blk = - liftEither - . left BlockTransitionError - . right - ( mapEventReturn @ep @(EraRule "BBODY" era) $ - updateNewEpochState state - ) - $ res - where - res = - flip runReader globals - . applySTSOptsEither @(EraRule "BBODY" era) - opts - $ TRC (mkBbodyEnv state, bbs, blk) - bbs = - BbodyState - (LedgerState.esLState $ LedgerState.nesEs state) - (LedgerState.nesBcur state) - - -- | Re-apply a ledger block to the same state it has been applied to before. - -- - -- This function does no validation of whether the block applies successfully; - -- the caller implicitly guarantees that they have previously called - -- 'applyBlockTransition' on the same block and that this was successful. - reapplyBlock :: - Globals -> - NewEpochState era -> - Block (BHeaderView (EraCrypto era)) era -> - NewEpochState era - default reapplyBlock :: - EraGov era => - Globals -> - NewEpochState era -> - Block (BHeaderView (EraCrypto era)) era -> - NewEpochState era - reapplyBlock globals state blk = - updateNewEpochState state res - where - res = - flip runReader globals . reapplySTS @(EraRule "BBODY" era) $ - TRC (mkBbodyEnv state, bbs, blk) - bbs = - BbodyState - (LedgerState.esLState $ LedgerState.nesEs state) - (LedgerState.nesBcur state) - -applyTick :: - ApplyBlock era => - Globals -> - NewEpochState era -> - SlotNo -> - NewEpochState era -applyTick = - applyTickOpts $ - ApplySTSOpts - { asoAssertions = globalAssertionPolicy - , asoValidation = ValidateAll - , asoEvents = EPDiscard - } - -applyBlock :: - ( ApplyBlock era - , MonadError (BlockTransitionError era) m - ) => - Globals -> - NewEpochState era -> - Block (BHeaderView (EraCrypto era)) era -> - m (NewEpochState era) -applyBlock = - applyBlockOpts $ - ApplySTSOpts - { asoAssertions = globalAssertionPolicy - , asoValidation = ValidateAll - , asoEvents = EPDiscard - } - -type ShelleyEraCrypto c = - ( Crypto c - , DSignable c (Hash c EraIndependentTxBody) - ) - -{-# DEPRECATED ShelleyEraCrypto "Constraint synonyms are being removed" #-} - -instance - ( Crypto c - , DSignable c (Hash c EraIndependentTxBody) - , STS (EraRule "TICK" (BabelEra c)) - , STS (EraRule "BBODY" (BabelEra c)) - ) => - ApplyBlock (BabelEra c) - -{------------------------------------------------------------------------------- - CHAIN Transition checks --------------------------------------------------------------------------------} - -chainChecks :: - forall c m. - MonadError STS.ChainPredicateFailure m => - -- | Max major protocol version - Version -> - STS.ChainChecksPParams -> - BHeaderView c -> - m () -chainChecks = STS.chainChecks - -{------------------------------------------------------------------------------- - Applying blocks --------------------------------------------------------------------------------} - -mkBbodyEnv :: - EraGov era => - NewEpochState era -> - STS.BbodyEnv era -mkBbodyEnv - LedgerState.NewEpochState - { LedgerState.nesEs - } = - STS.BbodyEnv - { STS.bbodyPp = nesEs ^. curPParamsEpochStateL - , STS.bbodyAccount = LedgerState.esAccountState nesEs - } - -updateNewEpochState :: - (LedgerState era ~ State (EraRule "ZONES" era), EraGov era) => - NewEpochState era -> - BabelBbodyState era -> - NewEpochState era -updateNewEpochState ss (BbodyState ls bcur) = - LedgerState.updateNES ss bcur ls - -newtype TickTransitionError era - = TickTransitionError (NonEmpty (STS.PredicateFailure (EraRule "TICK" era))) - deriving (Generic) - -instance - NoThunks (STS.PredicateFailure (EraRule "TICK" era)) => - NoThunks (TickTransitionError era) - -deriving stock instance - Eq (STS.PredicateFailure (EraRule "TICK" era)) => - Eq (TickTransitionError era) - -deriving stock instance - Show (STS.PredicateFailure (EraRule "TICK" era)) => - Show (TickTransitionError era) - -newtype BlockTransitionError era - = BlockTransitionError (NonEmpty (STS.PredicateFailure (EraRule "BBODY" era))) - deriving (Generic) - -deriving stock instance - Eq (STS.PredicateFailure (EraRule "BBODY" era)) => - Eq (BlockTransitionError era) - -deriving stock instance - Show (STS.PredicateFailure (EraRule "BBODY" era)) => - Show (BlockTransitionError era) - -instance - NoThunks (STS.PredicateFailure (EraRule "BBODY" era)) => - NoThunks (BlockTransitionError era) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs index 13b9688c84c..bab9e671193 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs @@ -28,7 +28,7 @@ import Cardano.Ledger.Babel.Rules.Utxo (BabelUtxoPredFailure) import Cardano.Ledger.Babel.Rules.Utxow (BabelUtxowPredFailure) import Cardano.Ledger.Babel.Rules.Zone (BabelZonePredFailure) import Cardano.Ledger.Babel.Rules.Zones (BabelZonesPredFailure) -import Cardano.Ledger.BaseTypes (BlocksMade, ShelleyBase, epochInfoPure) +import Cardano.Ledger.BaseTypes (ShelleyBase, epochInfoPure) import Cardano.Ledger.Core import Cardano.Ledger.Keys (DSignable, HasKeyRole (coerceKeyRole), Hash) import Cardano.Ledger.Shelley.API ( @@ -39,6 +39,7 @@ import Cardano.Ledger.Shelley.BlockChain (incrBlocks) import Cardano.Ledger.Shelley.Rules ( BbodyEnv (BbodyEnv), ShelleyBbodyPredFailure, + ShelleyBbodyState (BbodyState), ShelleyLedgersPredFailure, ) import Cardano.Ledger.Slot (epochInfoEpoch, epochInfoFirst) @@ -60,9 +61,6 @@ import GHC.Generics (Generic) import Lens.Micro ((^.)) import NoThunks.Class (NoThunks) -data BabelBbodyState era - = BbodyState !(State (EraRule "ZONES" era)) !(BlocksMade (EraCrypto era)) - data BabelBbodyPredFailure era = WrongBlockBodySizeBBODY !Int -- Actual Body Size @@ -129,10 +127,11 @@ instance , Signal (EraRule "ZONES" era) ~ Seq (Seq (Tx era)) , Eq (PredicateFailure (EraRule "LEDGERS" era)) , Show (PredicateFailure (EraRule "LEDGERS" era)) + , State (EraRule "LEDGERS" era) ~ State (EraRule "ZONES" era) ) => STS (BabelBBODY era) where - type State (BabelBBODY era) = BabelBbodyState era + type State (BabelBBODY era) = ShelleyBbodyState era type Signal (BabelBBODY era) = Block (BHeaderView (EraCrypto era)) era @@ -154,6 +153,7 @@ bbodyTransition :: , Embed (EraRule "ZONES" era) (BabelBBODY era) , Environment (EraRule "ZONES" era) ~ ShelleyLedgersEnv era , Signal (EraRule "ZONES" era) ~ Seq (Seq (Tx era)) + , State (EraRule "LEDGERS" era) ~ State (EraRule "ZONES" era) ) => TransitionRule (BabelBBODY era) bbodyTransition = diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Rules/Chain.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Rules/Chain.hs index 5e7d0fbbee1..cc325fc1982 100644 --- a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Rules/Chain.hs +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Rules/Chain.hs @@ -26,6 +26,8 @@ module Test.Cardano.Ledger.Babel.Rules.Chain ( ) where import Cardano.Ledger.BHeaderView (BHeaderView) +import Cardano.Ledger.Babel.Era (BabelBBODY, BabelEra) +import Cardano.Ledger.Babel.Rules.Bbody (BabelBbodyPredFailure) import Cardano.Ledger.BaseTypes ( BlocksMade (..), Globals (..), @@ -42,8 +44,6 @@ import Cardano.Ledger.Chain ( pparamsToChainChecksPParams, ) import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Babel.Era (BabelBBODY, BabelEra) -import Cardano.Ledger.Babel.Rules.Bbody (BabelBbodyPredFailure, BabelBbodyState (..)) import qualified Cardano.Ledger.Core as Core import Cardano.Ledger.EpochBoundary (emptySnapShots) import Cardano.Ledger.Keys ( @@ -78,6 +78,7 @@ import Cardano.Ledger.Shelley.LedgerState ( ) import Cardano.Ledger.Shelley.Rules ( BbodyEnv (BbodyEnv), + ShelleyBbodyState (BbodyState), ShelleyTICK, ShelleyTickEvent, ShelleyTickPredFailure, @@ -262,7 +263,7 @@ instance ( EraGov era , Embed (EraRule "BBODY" era) (CHAIN era) , Environment (EraRule "BBODY" era) ~ BbodyEnv era - , State (EraRule "BBODY" era) ~ BabelBbodyState era + , State (EraRule "BBODY" era) ~ ShelleyBbodyState era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , Embed (EraRule "TICKN" era) (CHAIN era) , Environment (EraRule "TICKN" era) ~ TicknEnv @@ -302,7 +303,7 @@ chainTransition :: ( STS (CHAIN era) , Embed (EraRule "BBODY" era) (CHAIN era) , Environment (EraRule "BBODY" era) ~ BbodyEnv era - , State (EraRule "BBODY" era) ~ BabelBbodyState era + , State (EraRule "BBODY" era) ~ ShelleyBbodyState era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , Embed (EraRule "TICKN" era) (CHAIN era) , Environment (EraRule "TICKN" era) ~ TicknEnv @@ -314,7 +315,7 @@ chainTransition :: , Signal (EraRule "TICK" era) ~ SlotNo , Embed (PRTCL (EraCrypto era)) (CHAIN era) , EncCBORGroup (TxZones era) - , State (EraRule "ZONES" era) ~ LedgerState era + , State (EraRule "LEDGERS" era) ~ LedgerState era , EraGov era ) => TransitionRule (CHAIN era) diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Utils.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Utils.hs index c16bdf66064..2d530ce1f29 100644 --- a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Utils.hs +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Utils.hs @@ -74,7 +74,7 @@ import Cardano.Ledger.BaseTypes ( import Cardano.Ledger.Binary (EncCBOR (..), hashWithEncoder, shelleyProtVer) import Cardano.Ledger.Block (Block, bheader) import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Babel.API.Validation (ApplyBlock) +import Cardano.Ledger.Shelley.API.Validation (ApplyBlock) import Cardano.Ledger.Crypto (Crypto (DSIGN)) import Cardano.Ledger.Mary.Value (MultiAsset (MultiAsset)) import Cardano.Ledger.Shelley.API (KeyRole (..), VKey (..)) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway.hs b/eras/conway/impl/src/Cardano/Ledger/Conway.hs index 620a0c74dea..7072ff2cf34 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway.hs @@ -50,6 +50,8 @@ instance , DSignable c (Hash c EraIndependentTxBody) ) => API.ApplyBlock (ConwayEra c) + where + type EraLedgerRules (ConwayEra c) = '[] instance Crypto c => API.CanStartFromGenesis (ConwayEra c) where type AdditionalGenesisConfig (ConwayEra c) = ConwayGenesis c diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary.hs b/eras/mary/impl/src/Cardano/Ledger/Mary.hs index e83e1143c48..013dab59b1a 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- CanStartFromGenesis {-# OPTIONS_GHC -Wno-deprecations #-} @@ -41,6 +42,8 @@ instance instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => ApplyBlock (MaryEra c) + where + type EraLedgerRules (MaryEra c) = '[] instance Crypto c => CanStartFromGenesis (MaryEra c) where fromShelleyPParams () = translateEra' () . fromShelleyPParams () diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs index 3043738a599..7661cb27099 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs @@ -15,6 +15,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} -- | Interface to the block validation and chain extension logic in the Shelley -- API. @@ -50,6 +51,7 @@ import Control.Monad.Except import Control.Monad.Trans.Reader (runReader) import Control.State.Transition.Extended import Data.List.NonEmpty (NonEmpty) +import GHC.Base (Constraint, Symbol, Type) import GHC.Generics (Generic) import Lens.Micro ((^.)) import NoThunks.Class (NoThunks (..)) @@ -58,6 +60,26 @@ import NoThunks.Class (NoThunks (..)) Block validation API -------------------------------------------------------------------------------} +-- Define a type family for folding constraints +type family FoldConstraints (cs :: [Constraint]) :: Constraint where + FoldConstraints '[] = () + FoldConstraints (c ': cs) = (c, FoldConstraints cs) + +-- Helper type family to convert a list of rules to a list of constraints +type family RulesToConstraints (rules :: [Symbol]) (era :: Type) :: [Constraint] where + RulesToConstraints '[] era = '[] + RulesToConstraints (rule ': rules) era = + ( State (EraRule rule era) ~ LedgerState era + , State (EraRule rule era) ~ State (EraRule "LEDGERS" era) + ) + ': RulesToConstraints rules era + +-- Combine everything +type LedgerStateRulesFold rules era = + FoldConstraints ((State (EraRule "LEDGERS" era) ~ LedgerState era) ': RulesToConstraints rules era) + +-- type LedgerStateRules (rulesConstraint :: [Constraint]) era = type level fold with ~ LedgerState era? + class ( STS (EraRule "TICK" era) , BaseM (EraRule "TICK" era) ~ ShelleyBase @@ -70,10 +92,13 @@ class , State (EraRule "BBODY" era) ~ STS.ShelleyBbodyState era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , EncCBORGroup (TxZones era) - , State (EraRule "LEDGERS" era) ~ LedgerState era + , LedgerStateRulesFold (EraLedgerRules era) era ) => ApplyBlock era where + -- Type family to specify which rules should be included for each era + type EraLedgerRules (era :: Type) :: [Symbol] + -- | Apply the header level ledger transition. -- -- This handles checks and updates that happen on a slot tick, as well as a @@ -198,6 +223,8 @@ instance , DSignable c (Hash c EraIndependentTxBody) ) => ApplyBlock (ShelleyEra c) + where + type EraLedgerRules (ShelleyEra c) = '[] {------------------------------------------------------------------------------- CHAIN Transition checks From 28b073a6556e04f7d40e09a0d5b40e20f470b4f5 Mon Sep 17 00:00:00 2001 From: Will Gould Date: Wed, 26 Jun 2024 18:26:52 +0100 Subject: [PATCH 04/19] Removed outdated comments --- .../impl/src/Cardano/Ledger/Shelley/API/Validation.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs index 7661cb27099..bbdbf6f598d 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs @@ -60,12 +60,10 @@ import NoThunks.Class (NoThunks (..)) Block validation API -------------------------------------------------------------------------------} --- Define a type family for folding constraints type family FoldConstraints (cs :: [Constraint]) :: Constraint where FoldConstraints '[] = () FoldConstraints (c ': cs) = (c, FoldConstraints cs) --- Helper type family to convert a list of rules to a list of constraints type family RulesToConstraints (rules :: [Symbol]) (era :: Type) :: [Constraint] where RulesToConstraints '[] era = '[] RulesToConstraints (rule ': rules) era = @@ -74,12 +72,9 @@ type family RulesToConstraints (rules :: [Symbol]) (era :: Type) :: [Constraint] ) ': RulesToConstraints rules era --- Combine everything type LedgerStateRulesFold rules era = FoldConstraints ((State (EraRule "LEDGERS" era) ~ LedgerState era) ': RulesToConstraints rules era) --- type LedgerStateRules (rulesConstraint :: [Constraint]) era = type level fold with ~ LedgerState era? - class ( STS (EraRule "TICK" era) , BaseM (EraRule "TICK" era) ~ ShelleyBase From 094bd22114e4fc97f594b91d5345bac8e6f5a924 Mon Sep 17 00:00:00 2001 From: Will Gould Date: Wed, 26 Jun 2024 18:45:43 +0100 Subject: [PATCH 05/19] Improved naming and clarify comment --- eras/allegra/impl/src/Cardano/Ledger/Allegra.hs | 4 ++-- eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs | 2 +- eras/babbage/impl/src/Cardano/Ledger/Babbage.hs | 2 +- eras/babel/impl/src/Cardano/Ledger/Babel.hs | 4 ++-- eras/conway/impl/src/Cardano/Ledger/Conway.hs | 2 +- eras/mary/impl/src/Cardano/Ledger/Mary.hs | 2 +- .../impl/src/Cardano/Ledger/Shelley/API/Validation.hs | 8 ++++---- 7 files changed, 12 insertions(+), 12 deletions(-) diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs index 0ec039ca144..ff2efaaaf10 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs @@ -29,7 +29,7 @@ import Cardano.Ledger.Shelley.API ( ApplyBlock, ApplyTx, CanStartFromGenesis (fromShelleyPParams), - EraLedgerRules, + EraLedgerStateRules, ) type Allegra = AllegraEra StandardCrypto @@ -46,7 +46,7 @@ instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => ApplyBlock (AllegraEra c) where - type EraLedgerRules (AllegraEra c) = '[] + type EraLedgerStateRules (AllegraEra c) = '[] instance Crypto c => CanStartFromGenesis (AllegraEra c) where fromShelleyPParams _ = translateEra' () diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs index 23b51a99adc..dece1a80f57 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs @@ -73,7 +73,7 @@ instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyTx (A reapplyTx = reapplyAlonzoTx instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock (AlonzoEra c) where - type EraLedgerRules (AlonzoEra c) = '[] + type EraLedgerStateRules (AlonzoEra c) = '[] instance Crypto c => API.CanStartFromGenesis (AlonzoEra c) where type AdditionalGenesisConfig (AlonzoEra c) = AlonzoGenesis diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs index 8db8c86e2d5..4884104fd3d 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs @@ -46,7 +46,7 @@ instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyTx (B reapplyTx = reapplyAlonzoTx instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock (BabbageEra c) where - type EraLedgerRules (BabbageEra c) = '[] + type EraLedgerStateRules (BabbageEra c) = '[] instance Crypto c => API.CanStartFromGenesis (BabbageEra c) where type AdditionalGenesisConfig (BabbageEra c) = AlonzoGenesis diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel.hs b/eras/babel/impl/src/Cardano/Ledger/Babel.hs index 8332259d902..c0dc6aab7ea 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel.hs @@ -35,7 +35,7 @@ import Cardano.Ledger.Conway.Governance (RunConwayRatify (..)) import Cardano.Ledger.Crypto (Crypto (DSIGN), StandardCrypto) import Cardano.Ledger.Keys (DSignable, Hash) import Cardano.Ledger.Rules.ValidationMode (applySTSNonStatic) -import Cardano.Ledger.Shelley.API (ApplyBlock, EraLedgerRules) +import Cardano.Ledger.Shelley.API (ApplyBlock, EraLedgerStateRules) import Cardano.Ledger.Shelley.API.Genesis (CanStartFromGenesis (..)) import Cardano.Ledger.Shelley.API.Mempool ( ApplyTx (reapplyTx), @@ -67,7 +67,7 @@ instance ) => ApplyBlock (BabelEra c) where - type EraLedgerRules (BabelEra c) = '["ZONES"] + type EraLedgerStateRules (BabelEra c) = '["ZONES"] instance ( Crypto c diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway.hs b/eras/conway/impl/src/Cardano/Ledger/Conway.hs index 7072ff2cf34..cd71601a02a 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway.hs @@ -51,7 +51,7 @@ instance ) => API.ApplyBlock (ConwayEra c) where - type EraLedgerRules (ConwayEra c) = '[] + type EraLedgerStateRules (ConwayEra c) = '[] instance Crypto c => API.CanStartFromGenesis (ConwayEra c) where type AdditionalGenesisConfig (ConwayEra c) = ConwayGenesis c diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary.hs b/eras/mary/impl/src/Cardano/Ledger/Mary.hs index 013dab59b1a..d629bb809e7 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary.hs @@ -43,7 +43,7 @@ instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => ApplyBlock (MaryEra c) where - type EraLedgerRules (MaryEra c) = '[] + type EraLedgerStateRules (MaryEra c) = '[] instance Crypto c => CanStartFromGenesis (MaryEra c) where fromShelleyPParams () = translateEra' () . fromShelleyPParams () diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs index bbdbf6f598d..905143afbf5 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs @@ -87,12 +87,12 @@ class , State (EraRule "BBODY" era) ~ STS.ShelleyBbodyState era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , EncCBORGroup (TxZones era) - , LedgerStateRulesFold (EraLedgerRules era) era + , LedgerStateRulesFold (EraLedgerStateRules era) era ) => ApplyBlock era where - -- Type family to specify which rules should be included for each era - type EraLedgerRules (era :: Type) :: [Symbol] + -- Type family to specify which rules (if any) are equivalent to LedgerState for each era + type EraLedgerStateRules (era :: Type) :: [Symbol] -- | Apply the header level ledger transition. -- @@ -219,7 +219,7 @@ instance ) => ApplyBlock (ShelleyEra c) where - type EraLedgerRules (ShelleyEra c) = '[] + type EraLedgerStateRules (ShelleyEra c) = '[] {------------------------------------------------------------------------------- CHAIN Transition checks From 3282ac46ba9a4fec8afa9fca588a0913a544cce4 Mon Sep 17 00:00:00 2001 From: Will Gould Date: Thu, 27 Jun 2024 12:08:11 +0100 Subject: [PATCH 06/19] removed more code, removed debug traces --- eras/babel/impl/src/Cardano/Ledger/Babel.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel.hs b/eras/babel/impl/src/Cardano/Ledger/Babel.hs index c0dc6aab7ea..03cc5486262 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel.hs @@ -35,7 +35,7 @@ import Cardano.Ledger.Conway.Governance (RunConwayRatify (..)) import Cardano.Ledger.Crypto (Crypto (DSIGN), StandardCrypto) import Cardano.Ledger.Keys (DSignable, Hash) import Cardano.Ledger.Rules.ValidationMode (applySTSNonStatic) -import Cardano.Ledger.Shelley.API (ApplyBlock, EraLedgerStateRules) +import Cardano.Ledger.Shelley.API (ApplyBlock) import Cardano.Ledger.Shelley.API.Genesis (CanStartFromGenesis (..)) import Cardano.Ledger.Shelley.API.Mempool ( ApplyTx (reapplyTx), @@ -66,8 +66,6 @@ instance Signable (DSIGN c) (Cardano.Crypto.Hash.Class.Hash c EraIndependentTxBody) ) => ApplyBlock (BabelEra c) - where - type EraLedgerStateRules (BabelEra c) = '["ZONES"] instance ( Crypto c From 1a62d16e7bb810a24b2685768607562626c129d8 Mon Sep 17 00:00:00 2001 From: Will Gould Date: Thu, 27 Jun 2024 12:08:30 +0100 Subject: [PATCH 07/19] removed more code, removed debug traces --- .../impl/src/Cardano/Ledger/Allegra.hs | 3 -- eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs | 3 +- .../impl/src/Cardano/Ledger/Babbage.hs | 3 +- eras/conway/impl/src/Cardano/Ledger/Conway.hs | 2 -- eras/mary/impl/src/Cardano/Ledger/Mary.hs | 2 -- .../Cardano/Ledger/Shelley/API/Validation.hs | 23 +------------ .../Ledger/Shelley/Examples/Federation.hs | 14 ++++---- .../Cardano/Ledger/Shelley/Generator/Block.hs | 32 +++++++++---------- 8 files changed, 24 insertions(+), 58 deletions(-) diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs index ff2efaaaf10..3d7d0c8820c 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs @@ -29,7 +29,6 @@ import Cardano.Ledger.Shelley.API ( ApplyBlock, ApplyTx, CanStartFromGenesis (fromShelleyPParams), - EraLedgerStateRules, ) type Allegra = AllegraEra StandardCrypto @@ -45,8 +44,6 @@ instance instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => ApplyBlock (AllegraEra c) - where - type EraLedgerStateRules (AllegraEra c) = '[] instance Crypto c => CanStartFromGenesis (AllegraEra c) where fromShelleyPParams _ = translateEra' () diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs index dece1a80f57..65d8905a581 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs @@ -72,8 +72,7 @@ reapplyAlonzoTx globals env state vtx = instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyTx (AlonzoEra c) where reapplyTx = reapplyAlonzoTx -instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock (AlonzoEra c) where - type EraLedgerStateRules (AlonzoEra c) = '[] +instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock (AlonzoEra c) instance Crypto c => API.CanStartFromGenesis (AlonzoEra c) where type AdditionalGenesisConfig (AlonzoEra c) = AlonzoGenesis diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs index 4884104fd3d..87b4a4b2260 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs @@ -45,8 +45,7 @@ type Babbage = BabbageEra StandardCrypto instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyTx (BabbageEra c) where reapplyTx = reapplyAlonzoTx -instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock (BabbageEra c) where - type EraLedgerStateRules (BabbageEra c) = '[] +instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock (BabbageEra c) instance Crypto c => API.CanStartFromGenesis (BabbageEra c) where type AdditionalGenesisConfig (BabbageEra c) = AlonzoGenesis diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway.hs b/eras/conway/impl/src/Cardano/Ledger/Conway.hs index cd71601a02a..620a0c74dea 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway.hs @@ -50,8 +50,6 @@ instance , DSignable c (Hash c EraIndependentTxBody) ) => API.ApplyBlock (ConwayEra c) - where - type EraLedgerStateRules (ConwayEra c) = '[] instance Crypto c => API.CanStartFromGenesis (ConwayEra c) where type AdditionalGenesisConfig (ConwayEra c) = ConwayGenesis c diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary.hs b/eras/mary/impl/src/Cardano/Ledger/Mary.hs index d629bb809e7..188edf9258e 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary.hs @@ -42,8 +42,6 @@ instance instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => ApplyBlock (MaryEra c) - where - type EraLedgerStateRules (MaryEra c) = '[] instance Crypto c => CanStartFromGenesis (MaryEra c) where fromShelleyPParams () = translateEra' () . fromShelleyPParams () diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs index 905143afbf5..66be58dfb3a 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs @@ -51,7 +51,6 @@ import Control.Monad.Except import Control.Monad.Trans.Reader (runReader) import Control.State.Transition.Extended import Data.List.NonEmpty (NonEmpty) -import GHC.Base (Constraint, Symbol, Type) import GHC.Generics (Generic) import Lens.Micro ((^.)) import NoThunks.Class (NoThunks (..)) @@ -60,21 +59,6 @@ import NoThunks.Class (NoThunks (..)) Block validation API -------------------------------------------------------------------------------} -type family FoldConstraints (cs :: [Constraint]) :: Constraint where - FoldConstraints '[] = () - FoldConstraints (c ': cs) = (c, FoldConstraints cs) - -type family RulesToConstraints (rules :: [Symbol]) (era :: Type) :: [Constraint] where - RulesToConstraints '[] era = '[] - RulesToConstraints (rule ': rules) era = - ( State (EraRule rule era) ~ LedgerState era - , State (EraRule rule era) ~ State (EraRule "LEDGERS" era) - ) - ': RulesToConstraints rules era - -type LedgerStateRulesFold rules era = - FoldConstraints ((State (EraRule "LEDGERS" era) ~ LedgerState era) ': RulesToConstraints rules era) - class ( STS (EraRule "TICK" era) , BaseM (EraRule "TICK" era) ~ ShelleyBase @@ -87,13 +71,10 @@ class , State (EraRule "BBODY" era) ~ STS.ShelleyBbodyState era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , EncCBORGroup (TxZones era) - , LedgerStateRulesFold (EraLedgerStateRules era) era + , State (EraRule "LEDGERS" era) ~ LedgerState era ) => ApplyBlock era where - -- Type family to specify which rules (if any) are equivalent to LedgerState for each era - type EraLedgerStateRules (era :: Type) :: [Symbol] - -- | Apply the header level ledger transition. -- -- This handles checks and updates that happen on a slot tick, as well as a @@ -218,8 +199,6 @@ instance , DSignable c (Hash c EraIndependentTxBody) ) => ApplyBlock (ShelleyEra c) - where - type EraLedgerStateRules (ShelleyEra c) = '[] {------------------------------------------------------------------------------- CHAIN Transition checks diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Federation.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Federation.hs index 7067a13d048..d921acc6dd6 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Federation.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Federation.hs @@ -44,7 +44,6 @@ import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Word (Word64) -import Debug.Trace (trace) import GHC.Stack (HasCallStack) import Lens.Micro ((^.)) import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), vKey) @@ -118,13 +117,12 @@ coreNodeKeysBySchedule :: Word64 -> AllIssuerKeys (EraCrypto era) 'GenesisDelegate coreNodeKeysBySchedule pp slot = - case trace "IS IT FROM HERE 3" $ - lookupInOverlaySchedule - firstSlot - (Map.keysSet genDelegs) - (pp ^. ppDG) - (activeSlotCoeff testGlobals) - slot' of + case lookupInOverlaySchedule + firstSlot + (Map.keysSet genDelegs) + (pp ^. ppDG) + (activeSlotCoeff testGlobals) + slot' of Nothing -> error $ "coreNodesForSlot: Cannot find keys for slot " diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs index 77bad6aef8e..804a60546ba 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs @@ -46,7 +46,6 @@ import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe) import Data.Sequence (Seq) import qualified Data.Set as Set -import Debug.Trace (trace) import Lens.Micro ((^.)) import Lens.Micro.Extras (view) import Test.Cardano.Ledger.Core.KeyPair (vKey) @@ -232,21 +231,20 @@ selectNextSlotWithLeader SlotNo -> Maybe (ChainState era, AllIssuerKeys (EraCrypto era) 'BlockIssuer) selectLeaderForSlot slotNo = - trace "IS IT FROM HERE 2" $ - (chainSt,) - <$> case lookupInOverlaySchedule firstEpochSlot (Map.keysSet cores) d f slotNo of - Nothing -> - coerce - <$> List.find - ( \(AllIssuerKeys {aikVrf, aikColdKeyHash}) -> - isLeader aikColdKeyHash (vrfSignKey aikVrf) - ) - ksStakePools - Just (ActiveSlot x) -> - coerce $ - Map.lookup x cores - >>= \y -> Map.lookup (genDelegKeyHash y) ksIndexedGenDelegates - _ -> Nothing + (chainSt,) + <$> case lookupInOverlaySchedule firstEpochSlot (Map.keysSet cores) d f slotNo of + Nothing -> + coerce + <$> List.find + ( \(AllIssuerKeys {aikVrf, aikColdKeyHash}) -> + isLeader aikColdKeyHash (vrfSignKey aikVrf) + ) + ksStakePools + Just (ActiveSlot x) -> + coerce $ + Map.lookup x cores + >>= \y -> Map.lookup (genDelegKeyHash y) ksIndexedGenDelegates + _ -> Nothing where chainSt = tickChainState slotNo origChainState epochNonce = chainEpochNonce chainSt @@ -262,7 +260,7 @@ selectNextSlotWithLeader isLeader poolHash vrfKey = let y = VRF.evalCertified @(VRF (EraCrypto era)) () (mkSeed seedL slotNo epochNonce) vrfKey stake = maybe 0 individualPoolStake $ Map.lookup poolHash poolDistr - in trace "IS IT FROM HERE 1" $ case lookupInOverlaySchedule firstEpochSlot (Map.keysSet cores) d f slotNo of + in case lookupInOverlaySchedule firstEpochSlot (Map.keysSet cores) d f slotNo of Nothing -> checkLeaderValue (VRF.certifiedOutput y) stake f Just (ActiveSlot x) | coerceKeyRole x == poolHash -> True _ -> False From 0547cc758c61b3362206aa3a3b314acb843600fa Mon Sep 17 00:00:00 2001 From: Will Gould Date: Thu, 27 Jun 2024 15:15:47 +0100 Subject: [PATCH 08/19] Some TODOs and attempts at fixing plutus tests --- .../impl/src/Cardano/Ledger/Alonzo/TxWits.hs | 8 +- .../Ledger/Alonzo/Binary/TxWitsSpec.hs | 2 +- .../impl/src/Cardano/Ledger/Babel/Scripts.hs | 2 +- .../impl/src/Cardano/Ledger/Babel/TxInfo.hs | 2 + .../Test/Cardano/Ledger/Babel/GenesisSpec.hs | 1 + .../Test/Cardano/Ledger/Babel/Imp/UtxoSpec.hs | 1 + .../Cardano/Ledger/Babel/Imp/UtxosSpec.hs | 2 + .../Test/Cardano/Ledger/Babel/ImpTest.hs | 1 + .../Test/Cardano/Ledger/Conway/ImpTest.hs | 88 +++++++++++-------- 9 files changed, 63 insertions(+), 44 deletions(-) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs index 81b799d1346..7c383de1f96 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxWits.hs @@ -521,9 +521,9 @@ instance AlonzoEraScript era => EncCBOR (AlonzoTxWitsRaw era) where encCBOR (AlonzoTxWitsRaw vkeys boots scripts dats rdmrs) = encode $ Keyed - ( \a b c d e f g h -> - let ps = toScript @'PlutusV1 d <> toScript @'PlutusV2 e <> toScript @'PlutusV3 f - in AlonzoTxWitsRaw a b (c <> ps) g h + ( \a b c d e f g h i -> + let ps = toScript @'PlutusV1 d <> toScript @'PlutusV2 e <> toScript @'PlutusV3 f <> toScript @'PlutusV4 g + in AlonzoTxWitsRaw a b (c <> ps) h i ) !> Omit null (Key 0 $ To vkeys) !> Omit null (Key 2 $ To boots) @@ -537,6 +537,7 @@ instance AlonzoEraScript era => EncCBOR (AlonzoTxWitsRaw era) where !> Omit null (Key 3 $ encodePlutus SPlutusV1) !> Omit null (Key 6 $ encodePlutus SPlutusV2) !> Omit null (Key 7 $ encodePlutus SPlutusV3) + !> Omit null (Key 8 $ encodePlutus SPlutusV4) !> Omit nullDats (Key 4 $ To dats) !> Omit nullRedeemers (Key 5 $ To rdmrs) where @@ -662,6 +663,7 @@ instance txWitnessField 5 = fieldAA (\x wits -> wits {atwrRdmrsTxWits = x}) From txWitnessField 6 = fieldA addScripts (decodePlutus SPlutusV2) txWitnessField 7 = fieldA addScripts (decodePlutus SPlutusV3) + txWitnessField 8 = fieldA addScripts (decodePlutus SPlutusV4) txWitnessField n = field (\_ t -> t) (Invalid n) {-# INLINE txWitnessField #-} diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/TxWitsSpec.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/TxWitsSpec.hs index d0e927796da..edca562a818 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/TxWitsSpec.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/TxWitsSpec.hs @@ -95,7 +95,7 @@ plutusScriptsProp = do keys PlutusV1 = 3 :: Int keys PlutusV2 = 6 keys PlutusV3 = 7 - keys PlutusV4 = 7 + keys PlutusV4 = 8 nativeScriptsProp :: forall era. diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Scripts.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Scripts.hs index f159b3de638..2ae1f516b22 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Scripts.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Scripts.hs @@ -97,7 +97,7 @@ instance Crypto c => AlonzoEraScript (BabelEra c) where type PlutusPurpose f (BabelEra c) = BabelPlutusPurpose f (BabelEra c) - eraMaxLanguage = PlutusV3 + eraMaxLanguage = PlutusV4 mkPlutusScript plutus = case plutusSLanguage plutus of diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/TxInfo.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/TxInfo.hs index c4b8766a0f9..7a1a9fe78db 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/TxInfo.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/TxInfo.hs @@ -749,6 +749,8 @@ fromScriptPurposeV4 = \case PV4.Voting voter -> PV4.VotingScript voter PV4.Proposing index proposal -> PV4.ProposingScript index proposal +-- TODO WG: Add Fulfills + transTxCertV4 :: BabelEraTxCert era => TxCert era -> PV4.TxCert transTxCertV4 = \case RegPoolTxCert PoolParams {ppId, ppVrf} -> diff --git a/eras/babel/impl/test/Test/Cardano/Ledger/Babel/GenesisSpec.hs b/eras/babel/impl/test/Test/Cardano/Ledger/Babel/GenesisSpec.hs index fed9bd8128d..8ac8a979a63 100644 --- a/eras/babel/impl/test/Test/Cardano/Ledger/Babel/GenesisSpec.hs +++ b/eras/babel/impl/test/Test/Cardano/Ledger/Babel/GenesisSpec.hs @@ -40,6 +40,7 @@ goldenBabelGenesisJSON = Right x -> pure x cg `shouldBe` expectedBabelGenesis +-- TODO WG propBabelPParamsUpgrade :: UpgradeConwayPParams Identity -> PParams Babbage -> Property propBabelPParamsUpgrade ppu pp = property $ do let pp' = upgradePParams ppu pp :: PParams Conway diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxoSpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxoSpec.hs index f4d218d25a6..61f873b05cd 100644 --- a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxoSpec.hs +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxoSpec.hs @@ -91,6 +91,7 @@ spec = describe "UTxO" $ do (fromNativeScript @era <$>) <$> replicateM 3 nativeScript let + -- TODO WG psh1 = hashPlutusScript $ alwaysSucceeds3 SPlutusV3 ps1 <- impAnn "Expecting Plutus script" . expectJust $ impLookupPlutusScriptMaybe psh1 let diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxosSpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxosSpec.hs index 8ef755e1ac5..dc40d46dd0f 100644 --- a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxosSpec.hs +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxosSpec.hs @@ -517,6 +517,7 @@ govPolicySpec = do .~ ValidityInterval SNothing SNothing submitFailingTx tx [injectFailure $ ScriptWitnessNotValidatingUTXOW [scriptHash]] + -- TODO WG it "alwaysSucceeds Plutus govPolicy validates" $ do let alwaysSucceedsSh = hashPlutusScript (alwaysSucceeds2 SPlutusV3) (committeeMember :| _) <- registerInitialCommittee @@ -555,6 +556,7 @@ govPolicySpec = do } submitProposal_ proposal + -- TODO WG it "alwaysFails Plutus govPolicy does not validate" $ do let alwaysFailsSh = hashPlutusScript (alwaysFails2 SPlutusV3) (committeeMember :| _) <- registerInitialCommittee diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/ImpTest.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/ImpTest.hs index b7fbc4a7e31..a7e581ff59b 100644 --- a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/ImpTest.hs +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/ImpTest.hs @@ -335,6 +335,7 @@ instance ShelleyEraImp (BabelEra c) => AlonzoEraImp (BabelEra c) where plutusTestScripts SPlutusV1 <> plutusTestScripts SPlutusV2 <> plutusTestScripts SPlutusV3 + <> plutusTestScripts SPlutusV4 class ( AlonzoEraImp era 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 3f411e3e09b..e7a215635c8 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs @@ -300,6 +300,7 @@ instance ShelleyEraImp (ConwayEra c) => AlonzoEraImp (ConwayEra c) where plutusTestScripts SPlutusV1 <> plutusTestScripts SPlutusV2 <> plutusTestScripts SPlutusV3 + <> plutusTestScripts SPlutusV4 class ( AlonzoEraImp era @@ -376,13 +377,14 @@ setupDRepWithoutStake = do deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL submitTxAnn_ "Delegate to DRep" $ mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL - .~ SSeq.fromList - [ mkRegDepositDelegTxCert @era - (KeyHashObj delegatorKH) - (DelegVote (DRepCredential $ KeyHashObj drepKH)) - deposit - ] + & bodyTxL + . certsTxBodyL + .~ SSeq.fromList + [ mkRegDepositDelegTxCert @era + (KeyHashObj delegatorKH) + (DelegVote (DRepCredential $ KeyHashObj drepKH)) + deposit + ] pure (drepKH, delegatorKH) -- | Registers a new DRep and delegates the specified amount of ADA to it. @@ -404,19 +406,21 @@ setupSingleDRep stake = do (_, spendingKP) <- freshKeyPair submitTxAnn_ "Delegate to DRep" $ mkBasicTx mkBasicTxBody - & bodyTxL . outputsTxBodyL - .~ SSeq.singleton - ( mkBasicTxOut - (mkAddr (spendingKP, delegatorKP)) - (inject $ Coin stake) - ) - & bodyTxL . certsTxBodyL - .~ SSeq.fromList - [ mkRegDepositDelegTxCert @era - (KeyHashObj delegatorKH) - (DelegVote (DRepCredential $ KeyHashObj drepKH)) - zero - ] + & bodyTxL + . outputsTxBodyL + .~ SSeq.singleton + ( mkBasicTxOut + (mkAddr (spendingKP, delegatorKP)) + (inject $ Coin stake) + ) + & bodyTxL + . certsTxBodyL + .~ SSeq.fromList + [ mkRegDepositDelegTxCert @era + (KeyHashObj delegatorKH) + (DelegVote (DRepCredential $ KeyHashObj drepKH)) + zero + ] pure (KeyHashObj drepKH, KeyHashObj delegatorKH, spendingKP) getsPParams :: EraGov era => Lens' (PParams era) a -> ImpTestM era a @@ -447,13 +451,14 @@ setupPoolWithStake delegCoin = do pp <- getsNES $ nesEsL . curPParamsEpochStateL submitTxAnn_ "Delegate to stake pool" $ mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL - .~ SSeq.fromList - [ RegDepositDelegTxCert - credDelegatorStaking - (DelegStake khPool) - (pp ^. ppKeyDepositL) - ] + & bodyTxL + . certsTxBodyL + .~ SSeq.fromList + [ RegDepositDelegTxCert + credDelegatorStaking + (DelegStake khPool) + (pp ^. ppKeyDepositL) + ] pure (khPool, credDelegatorPayment, credDelegatorStaking) setupPoolWithoutStake :: @@ -469,13 +474,14 @@ setupPoolWithoutStake = do deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL submitTxAnn_ "Delegate to stake pool" $ mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL - .~ SSeq.fromList - [ RegDepositDelegTxCert - credDelegatorStaking - (DelegStake khPool) - deposit - ] + & bodyTxL + . certsTxBodyL + .~ SSeq.fromList + [ RegDepositDelegTxCert + credDelegatorStaking + (DelegStake khPool) + deposit + ] pure (khPool, credDelegatorStaking) -- | Submits a transaction with a Vote for the given governance action as @@ -628,7 +634,9 @@ trySubmitProposals :: trySubmitProposals proposals = do trySubmitTx $ mkBasicTx mkBasicTxBody - & bodyTxL . proposalProceduresTxBodyL .~ GHC.fromList (toList proposals) + & bodyTxL + . proposalProceduresTxBodyL + .~ GHC.fromList (toList proposals) submitFailingProposal :: ( ShelleyEraImp era @@ -1125,8 +1133,9 @@ registerCommitteeHotKey coldKey = do hotKey <- KeyHashObj <$> freshKeyHash submitTxAnn_ "Registering Committee Hot key" $ mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL - .~ SSeq.singleton (AuthCommitteeHotKeyTxCert coldKey hotKey) + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton (AuthCommitteeHotKeyTxCert coldKey hotKey) pure hotKey -- | Submits a transaction that resigns the cold key @@ -1138,8 +1147,9 @@ resignCommitteeColdKey :: resignCommitteeColdKey coldKey anchor = do submitTxAnn_ "Resigning Committee Cold key" $ mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL - .~ SSeq.singleton (ResignCommitteeColdTxCert coldKey anchor) + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton (ResignCommitteeColdTxCert coldKey anchor) electCommittee :: forall era. From 444ff77c504eca1129036878e2dff102cd29438e Mon Sep 17 00:00:00 2001 From: Will Gould Date: Thu, 27 Jun 2024 17:46:03 +0100 Subject: [PATCH 09/19] Workaround to allow different block structures in different eras (with possibly bad names) --- .../impl/src/Cardano/Ledger/Allegra/TxSeq.hs | 7 +- .../impl/src/Cardano/Ledger/Alonzo/TxSeq.hs | 8 +- .../test/Test/Cardano/Ledger/Alonzo/Golden.hs | 2 +- .../impl/src/Cardano/Ledger/Babbage/Tx.hs | 7 +- .../src/Cardano/Ledger/Babel/Rules/Bbody.hs | 15 +- .../babel/impl/src/Cardano/Ledger/Babel/Tx.hs | 10 +- .../cardano-ledger-babel-test.cabal | 14 +- .../Ledger/Babel/Examples/Consensus.hs | 372 ++++---- .../Ledger/Babel/Examples/Prototype.hs | 807 +++++++++--------- .../Test/Cardano/Ledger/Babel/RulesTests.hs | 13 +- .../impl/src/Cardano/Ledger/Conway/Tx.hs | 7 +- .../impl/src/Cardano/Ledger/Mary/TxSeq.hs | 7 +- .../src/Cardano/Ledger/Shelley/BlockChain.hs | 11 +- .../src/Cardano/Ledger/Shelley/Rules/Bbody.hs | 4 +- .../test-suite/bench/BenchValidation.hs | 10 +- .../bench/Cardano/Ledger/Shelley/Bench/Gen.hs | 4 +- .../Ledger/Shelley/Examples/Consensus.hs | 11 +- .../Cardano/Ledger/Shelley/Generator/Block.hs | 7 +- .../Ledger/Shelley/Generator/Trace/Chain.hs | 4 +- .../Ledger/Shelley/Rules/AdaPreservation.hs | 3 +- .../Ledger/Shelley/Rules/ClassifyTraces.hs | 2 +- .../Ledger/Shelley/Rules/CollisionFreeness.hs | 2 +- .../Cardano/Ledger/Shelley/Rules/TestChain.hs | 2 +- .../Ledger/Shelley/Examples/EmptyBlock.hs | 13 +- .../src/Cardano/Ledger/Block.hs | 2 +- .../src/Cardano/Ledger/Core.hs | 8 +- .../Cardano/Ledger/Examples/AlonzoBBODY.hs | 13 +- .../Test/Cardano/Protocol/TPraos/Arbitrary.hs | 11 +- .../Test/Cardano/Protocol/TPraos/Create.hs | 10 +- 29 files changed, 719 insertions(+), 667 deletions(-) diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxSeq.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxSeq.hs index 14255df196f..4e7a5df057e 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxSeq.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxSeq.hs @@ -15,13 +15,14 @@ import Cardano.Ledger.Allegra.Tx () import Cardano.Ledger.Core (EraSegWits (..)) import Cardano.Ledger.Crypto (Crypto, StandardCrypto) import Cardano.Ledger.Shelley.BlockChain (ShelleyTxSeq (..), bbHash, txSeqTxns) -import Control.Monad ((<=<)) import qualified Data.Sequence.Strict as StrictSeq instance Crypto c => EraSegWits (AllegraEra c) where {-# SPECIALIZE instance EraSegWits (AllegraEra StandardCrypto) #-} + type TxStructure (AllegraEra c) = StrictSeq.StrictSeq type TxZones (AllegraEra c) = ShelleyTxSeq (AllegraEra c) - fromTxZones = fmap StrictSeq.singleton . txSeqTxns - toTxZones = ShelleyTxSeq . StrictSeq.forceToStrict . (StrictSeq.fromStrict <=< StrictSeq.fromStrict) + fromTxZones = txSeqTxns + toTxZones = ShelleyTxSeq + flatten = txSeqTxns hashTxZones = bbHash numSegComponents = 3 diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs index b31cfce2afc..9400fc10dee 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs @@ -43,7 +43,7 @@ import Cardano.Ledger.Crypto import Cardano.Ledger.Keys (Hash) import Cardano.Ledger.SafeHash (SafeToHash, originalBytes) import Cardano.Ledger.Shelley.BlockChain (constructMetadata) -import Control.Monad (unless, (<=<)) +import Control.Monad (unless) import Data.ByteString (ByteString) import Data.ByteString.Builder (shortByteString, toLazyByteString) import qualified Data.ByteString.Lazy as BSL @@ -85,9 +85,11 @@ data AlonzoTxSeq era = AlonzoTxSeqRaw deriving (Generic) instance Crypto c => EraSegWits (AlonzoEra c) where + type TxStructure (AlonzoEra c) = StrictSeq type TxZones (AlonzoEra c) = AlonzoTxSeq (AlonzoEra c) - fromTxZones = fmap StrictSeq.singleton . txSeqTxns - toTxZones = AlonzoTxSeq . StrictSeq.forceToStrict . (StrictSeq.fromStrict <=< StrictSeq.fromStrict) + fromTxZones = txSeqTxns + toTxZones = AlonzoTxSeq + flatten = txSeqTxns hashTxZones = hashAlonzoTxSeq numSegComponents = 4 diff --git a/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Golden.hs b/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Golden.hs index eec7d7873da..5af26bc8216 100644 --- a/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Golden.hs +++ b/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/Golden.hs @@ -301,7 +301,7 @@ goldenMinFee = Left err -> error (show err) Right (Block _h txs :: Block (BHeader StandardCrypto) Alonzo) -> txs firstTx = - case concatMap toList $ fromTxZones @Alonzo txsSeq of + case toList $ fromTxZones @Alonzo txsSeq of tx : _ -> tx [] -> error "Block doesn't have any transactions" diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs index 34907abd7f4..0857d729e73 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs @@ -41,7 +41,6 @@ import Cardano.Ledger.Babbage.TxWits () import Cardano.Ledger.Core import Cardano.Ledger.Crypto import Control.Arrow (left) -import Control.Monad ((<=<)) import qualified Data.Sequence.Strict as StrictSeq newtype BabbageTxUpgradeError @@ -162,8 +161,10 @@ instance Crypto c => AlonzoEraTx (BabbageEra c) where -- type RequiredTxs (BabbageEra c) = BabbageRequiredTx (BabbageEra c) instance Crypto c => EraSegWits (BabbageEra c) where + type TxStructure (BabbageEra c) = StrictSeq.StrictSeq type TxZones (BabbageEra c) = AlonzoTxSeq (BabbageEra c) - fromTxZones = fmap StrictSeq.singleton . txSeqTxns - toTxZones = AlonzoTxSeq . StrictSeq.forceToStrict . (StrictSeq.fromStrict <=< StrictSeq.fromStrict) + fromTxZones = txSeqTxns + toTxZones = AlonzoTxSeq + flatten = fromTxZones hashTxZones = hashAlonzoTxSeq numSegComponents = 4 \ No newline at end of file diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs index bab9e671193..fb21ae5a5ac 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs @@ -55,6 +55,7 @@ import Control.State.Transition ( (?!), ) import Control.State.Transition.Simple (Embed (wrapFailed)) +import Data.Functor.Compose (Compose, getCompose) import Data.Sequence (Seq) import qualified Data.Sequence.Strict as StrictSeq import GHC.Generics (Generic) @@ -120,7 +121,8 @@ instance NoThunks (BabelBbodyPredFailure era) instance - ( EraSegWits era + ( TxStructure era ~ Compose StrictSeq.StrictSeq StrictSeq.StrictSeq + , EraSegWits era , DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody) , Embed (EraRule "ZONES" era) (BabelBBODY era) , Environment (EraRule "ZONES" era) ~ ShelleyLedgersEnv era @@ -148,7 +150,8 @@ instance bbodyTransition :: forall era. - ( STS (BabelBBODY era) + ( TxStructure era ~ Compose StrictSeq.StrictSeq StrictSeq.StrictSeq + , STS (BabelBBODY era) , EraSegWits era , Embed (EraRule "ZONES" era) (BabelBBODY era) , Environment (EraRule "ZONES" era) ~ ShelleyLedgersEnv era @@ -164,9 +167,11 @@ bbodyTransition = , UnserialisedBlock bhview txsSeq ) ) -> do - let txs = fromTxZones txsSeq - actualBodySize = bBodySize (pp ^. ppProtocolVersionL) txsSeq - actualBodyHash = hashTxZones txsSeq + let + txs :: StrictSeq.StrictSeq (StrictSeq.StrictSeq (Tx era)) + txs = getCompose $ fromTxZones txsSeq + actualBodySize = bBodySize (pp ^. ppProtocolVersionL) txsSeq + actualBodyHash = hashTxZones txsSeq actualBodySize == fromIntegral (bhviewBSize bhview) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Tx.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Tx.hs index 98aec771699..2e83c11dc46 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Tx.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Tx.hs @@ -77,12 +77,14 @@ import Cardano.Ledger.Crypto import Cardano.Ledger.Keys (Hash) import Cardano.Ledger.SafeHash (SafeToHash (..)) import Cardano.Ledger.Shelley.BlockChain (constructMetadata) -import Control.Monad (unless) +import Control.Monad (unless, (<=<)) import Data.ByteString (ByteString) import Data.ByteString.Builder (shortByteString, toLazyByteString) import qualified Data.ByteString.Lazy as BSL import Data.Coerce (coerce) import Data.Data (Proxy) +import qualified Data.Foldable as Foldable +import Data.Functor.Compose (Compose (Compose, getCompose)) import qualified Data.Map as Map import Data.Proxy (Proxy (..)) import qualified Data.Sequence as Seq @@ -139,9 +141,11 @@ instance Crypto c => AlonzoEraTx (BabelEra c) where -- type RequiredTxs (BabelEra c) = ShelleyRequiredTx (BabelEra c) instance Crypto c => Core.EraSegWits (BabelEra c) where + type TxStructure (BabelEra c) = Compose StrictSeq StrictSeq type TxZones (BabelEra c) = BabelTxZones (BabelEra c) - fromTxZones = txZonesTxns - toTxZones = BabelTxZones + fromTxZones = Compose . txZonesTxns + toTxZones = BabelTxZones . getCompose + flatten = StrictSeq.fromList . (Foldable.toList <=< Foldable.toList) . getCompose . Core.fromTxZones hashTxZones = hashBabelTxZones numSegComponents = 4 diff --git a/eras/babel/test-suite/cardano-ledger-babel-test.cabal b/eras/babel/test-suite/cardano-ledger-babel-test.cabal index 42a17ad5ba1..757022620cd 100644 --- a/eras/babel/test-suite/cardano-ledger-babel-test.cabal +++ b/eras/babel/test-suite/cardano-ledger-babel-test.cabal @@ -36,18 +36,18 @@ library build-depends: base >=4.14 && <5, - cardano-data, - cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib} >=1.6, + --cardano-ledger-alonzo:{cardano-ledger-alonzo, testlib} >=1.6, + cardano-ledger-alonzo >=1.6, cardano-ledger-alonzo-test, - cardano-ledger-babbage >=1.3 && <1.9, + -- cardano-ledger-babbage >=1.3 && <1.9, cardano-ledger-babbage-test >=1.1.1, cardano-ledger-binary >=1.0, - cardano-ledger-conway, + -- cardano-ledger-conway, cardano-ledger-babel:{cardano-ledger-babel, testlib} >=1.13 && <1.15, cardano-ledger-core:{cardano-ledger-core, testlib} >=1.11, - cardano-ledger-allegra >=1.2, + -- cardano-ledger-allegra >=1.2, cardano-ledger-mary >=1.4, - cardano-ledger-shelley-ma-test >=1.1, + -- cardano-ledger-shelley-ma-test >=1.1, cardano-ledger-shelley-test >=1.1, cardano-ledger-shelley:{cardano-ledger-shelley, testlib} >=1.6, cardano-strict-containers, @@ -55,7 +55,7 @@ library containers, data-default-class, small-steps:{small-steps, testlib} >=1.1, - plutus-ledger-api, + -- plutus-ledger-api, microlens, tasty-hunit, cardano-protocol-tpraos:{cardano-protocol-tpraos, testlib}, diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Consensus.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Consensus.hs index d532720f113..6ee628fa03e 100644 --- a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Consensus.hs +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Consensus.hs @@ -8,202 +8,202 @@ module Test.Cardano.Ledger.Babel.Examples.Consensus where -import Cardano.Ledger.Allegra.Scripts (Timelock (..)) -import Cardano.Ledger.Alonzo.Scripts (AlonzoScript (..), ExUnits (..)) -import Cardano.Ledger.Alonzo.Tx (IsValid (..)) -import Cardano.Ledger.Alonzo.TxAuxData ( - AuxiliaryDataHash (..), - mkAlonzoTxAuxData, - ) -import Cardano.Ledger.Alonzo.TxWits (Redeemers (..), TxDats (..)) -import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..)) -import Cardano.Ledger.Babel (Babel) -import Cardano.Ledger.Babel.Core -import Cardano.Ledger.Babel.Genesis (BabelGenesis (..)) -import Cardano.Ledger.Babel.Rules (BabelLEDGER) -import Cardano.Ledger.Babel.Scripts (BabelPlutusPurpose (..)) -import Cardano.Ledger.Babel.Translation () -import Cardano.Ledger.Babel.Tx (AlonzoTx (..)) -import Cardano.Ledger.Babel.TxBody (BabelTxBody (..)) -import Cardano.Ledger.Babel.TxWits (AlonzoTxWits (..)) -import Cardano.Ledger.BaseTypes -import Cardano.Ledger.Binary (mkSized) -import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Conway.Governance -import Cardano.Ledger.Conway.Rules -import Cardano.Ledger.Conway.TxCert (ConwayTxCert (ConwayTxCertPool)) -import Cardano.Ledger.Credential (Credential (KeyHashObj, ScriptHashObj)) -import Cardano.Ledger.Crypto (StandardCrypto) -import Cardano.Ledger.Keys (asWitness) -import Cardano.Ledger.Mary.Value (MaryValue (..)) -import Cardano.Ledger.Plutus.Data ( - Data (..), - Datum (..), - dataToBinaryData, - hashData, - ) -import Cardano.Ledger.Plutus.Language (Language (..)) -import Cardano.Ledger.SafeHash (hashAnnotated) -import Cardano.Ledger.Shelley.API ( - ApplyTxError (..), - NewEpochState (..), - ProposedPPUpdates (..), - RewardAccount (..), - TxId (..), - ) -import Cardano.Ledger.Shelley.Tx (ShelleyTx (..)) -import Cardano.Ledger.TxIn (mkTxInPartial) -import Control.State.Transition.Extended (Embed (..)) -import Data.Default.Class (Default (def)) -import qualified Data.Map.Strict as Map -import qualified Data.OSet.Strict as OSet -import Data.Proxy (Proxy (..)) -import qualified Data.Sequence.Strict as StrictSeq -import qualified Data.Set as Set -import Lens.Micro -import qualified PlutusLedgerApi.Common as P -import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysFails, alwaysSucceeds) -import Test.Cardano.Ledger.Babel.Genesis (expectedBabelGenesis) -import Test.Cardano.Ledger.Core.KeyPair (mkAddr, mkWitnessesVKey) -import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash) -import qualified Test.Cardano.Ledger.Mary.Examples.Consensus as MarySLE -import Test.Cardano.Ledger.Shelley.Examples.Consensus (examplePoolParams) -import qualified Test.Cardano.Ledger.Shelley.Examples.Consensus as SLE +-- import Cardano.Ledger.Allegra.Scripts (Timelock (..)) +-- import Cardano.Ledger.Alonzo.Scripts (AlonzoScript (..), ExUnits (..)) +-- import Cardano.Ledger.Alonzo.Tx (IsValid (..)) +-- import Cardano.Ledger.Alonzo.TxAuxData ( +-- AuxiliaryDataHash (..), +-- mkAlonzoTxAuxData, +-- ) +-- import Cardano.Ledger.Alonzo.TxWits (Redeemers (..), TxDats (..)) +-- import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..)) +-- import Cardano.Ledger.Babel (Babel) +-- import Cardano.Ledger.Babel.Core +-- import Cardano.Ledger.Babel.Genesis (BabelGenesis (..)) +-- import Cardano.Ledger.Babel.Rules (BabelLEDGER) +-- import Cardano.Ledger.Babel.Scripts (BabelPlutusPurpose (..)) +-- import Cardano.Ledger.Babel.Translation () +-- import Cardano.Ledger.Babel.Tx (AlonzoTx (..)) +-- import Cardano.Ledger.Babel.TxBody (BabelTxBody (..)) +-- import Cardano.Ledger.Babel.TxWits (AlonzoTxWits (..)) +-- import Cardano.Ledger.BaseTypes +-- import Cardano.Ledger.Binary (mkSized) +-- import Cardano.Ledger.Coin (Coin (..)) +-- import Cardano.Ledger.Conway.Governance +-- import Cardano.Ledger.Conway.Rules +-- import Cardano.Ledger.Conway.TxCert (ConwayTxCert (ConwayTxCertPool)) +-- import Cardano.Ledger.Credential (Credential (KeyHashObj, ScriptHashObj)) +-- import Cardano.Ledger.Crypto (StandardCrypto) +-- import Cardano.Ledger.Keys (asWitness) +-- import Cardano.Ledger.Mary.Value (MaryValue (..)) +-- import Cardano.Ledger.Plutus.Data ( +-- Data (..), +-- Datum (..), +-- dataToBinaryData, +-- hashData, +-- ) +-- import Cardano.Ledger.Plutus.Language (Language (..)) +-- import Cardano.Ledger.SafeHash (hashAnnotated) +-- import Cardano.Ledger.Shelley.API ( +-- ApplyTxError (..), +-- NewEpochState (..), +-- ProposedPPUpdates (..), +-- RewardAccount (..), +-- TxId (..), +-- ) +-- import Cardano.Ledger.Shelley.Tx (ShelleyTx (..)) +-- import Cardano.Ledger.TxIn (mkTxInPartial) +-- import Control.State.Transition.Extended (Embed (..)) +-- import Data.Default.Class (Default (def)) +-- import qualified Data.Map.Strict as Map +-- import qualified Data.OSet.Strict as OSet +-- import Data.Proxy (Proxy (..)) +-- import qualified Data.Sequence.Strict as StrictSeq +-- import qualified Data.Set as Set +-- import Lens.Micro +-- import qualified PlutusLedgerApi.Common as P +-- import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysFails, alwaysSucceeds) +-- import Test.Cardano.Ledger.Babel.Genesis (expectedBabelGenesis) +-- import Test.Cardano.Ledger.Core.KeyPair (mkAddr, mkWitnessesVKey) +-- import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash) +-- import qualified Test.Cardano.Ledger.Mary.Examples.Consensus as MarySLE +-- import Test.Cardano.Ledger.Shelley.Examples.Consensus (examplePoolParams) +-- import qualified Test.Cardano.Ledger.Shelley.Examples.Consensus as SLE -- ============================================================== -- | ShelleyLedgerExamples for Babel era -ledgerExamplesBabel :: - SLE.ShelleyLedgerExamples Babel -ledgerExamplesBabel = - SLE.ShelleyLedgerExamples - { SLE.sleBlock = SLE.exampleShelleyLedgerBlock exampleTransactionInBlock - , SLE.sleHashHeader = SLE.exampleHashHeader (Proxy @Babel) - , SLE.sleTx = exampleTransactionInBlock - , SLE.sleApplyTxError = - ApplyTxError $ - pure $ - wrapFailed @(ConwayCERTS Babel) @(BabelLEDGER Babel) $ - DelegateeNotRegisteredDELEG @Babel (SLE.mkKeyHash 1) - , SLE.sleRewardsCredentials = - Set.fromList - [ Left (Coin 100) - , Right (ScriptHashObj (SLE.mkScriptHash 1)) - , Right (KeyHashObj (SLE.mkKeyHash 2)) - ] - , SLE.sleResultExamples = resultExamples - , SLE.sleNewEpochState = exampleBabelNewEpochState - , SLE.sleChainDepState = SLE.exampleLedgerChainDepState 1 - , SLE.sleTranslationContext = exampleBabelGenesis - } - where - resultExamples = - SLE.ShelleyResultExamples - { SLE.srePParams = def - , SLE.sreProposedPPUpdates = examplePPPU - , SLE.srePoolDistr = SLE.examplePoolDistr - , SLE.sreNonMyopicRewards = SLE.exampleNonMyopicRewards - , SLE.sreShelleyGenesis = SLE.testShelleyGenesis - } - examplePPPU = - ProposedPPUpdates $ - Map.singleton - (SLE.mkKeyHash 0) - (emptyPParamsUpdate & ppuCollateralPercentageL .~ SJust 150) +-- ledgerExamplesBabel :: +-- SLE.ShelleyLedgerExamples Babel +-- ledgerExamplesBabel = +-- SLE.ShelleyLedgerExamples +-- { SLE.sleBlock = SLE.exampleShelleyLedgerBlock exampleTransactionInBlock +-- , SLE.sleHashHeader = SLE.exampleHashHeader (Proxy @Babel) +-- , SLE.sleTx = exampleTransactionInBlock +-- , SLE.sleApplyTxError = +-- ApplyTxError $ +-- pure $ +-- wrapFailed @(ConwayCERTS Babel) @(BabelLEDGER Babel) $ +-- DelegateeNotRegisteredDELEG @Babel (SLE.mkKeyHash 1) +-- , SLE.sleRewardsCredentials = +-- Set.fromList +-- [ Left (Coin 100) +-- , Right (ScriptHashObj (SLE.mkScriptHash 1)) +-- , Right (KeyHashObj (SLE.mkKeyHash 2)) +-- ] +-- , SLE.sleResultExamples = resultExamples +-- , SLE.sleNewEpochState = exampleBabelNewEpochState +-- , SLE.sleChainDepState = SLE.exampleLedgerChainDepState 1 +-- , SLE.sleTranslationContext = exampleBabelGenesis +-- } +-- where +-- resultExamples = +-- SLE.ShelleyResultExamples +-- { SLE.srePParams = def +-- , SLE.sreProposedPPUpdates = examplePPPU +-- , SLE.srePoolDistr = SLE.examplePoolDistr +-- , SLE.sreNonMyopicRewards = SLE.exampleNonMyopicRewards +-- , SLE.sreShelleyGenesis = SLE.testShelleyGenesis +-- } +-- examplePPPU = +-- ProposedPPUpdates $ +-- Map.singleton +-- (SLE.mkKeyHash 0) +-- (emptyPParamsUpdate & ppuCollateralPercentageL .~ SJust 150) -collateralOutput :: BabbageTxOut Babel -collateralOutput = - BabbageTxOut - (mkAddr (SLE.examplePayKey, SLE.exampleStakeKey)) - (MaryValue (Coin 8675309) mempty) - NoDatum - SNothing +-- collateralOutput :: BabbageTxOut Babel +-- collateralOutput = +-- BabbageTxOut +-- (mkAddr (SLE.examplePayKey, SLE.exampleStakeKey)) +-- (MaryValue (Coin 8675309) mempty) +-- NoDatum +-- SNothing -exampleBabelCerts :: Era era => OSet.OSet (ConwayTxCert era) -exampleBabelCerts = - OSet.fromList -- TODO should I add the new certs here? - [ ConwayTxCertPool (RegPool examplePoolParams) - ] +-- exampleBabelCerts :: Era era => OSet.OSet (ConwayTxCert era) +-- exampleBabelCerts = +-- OSet.fromList -- TODO should I add the new certs here? +-- [ ConwayTxCertPool (RegPool examplePoolParams) +-- ] -exampleTxBodyBabel :: TxBody Babel -exampleTxBodyBabel = - BabelTxBody - (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 1)) 0]) -- spending inputs - (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 2)) 1]) -- collateral inputs - (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 1)) 3]) -- reference inputs - ( StrictSeq.fromList - [ mkSized (eraProtVerHigh @Babel) $ - BabbageTxOut - (mkAddr (SLE.examplePayKey, SLE.exampleStakeKey)) - (MarySLE.exampleMultiAssetValue 2) - (Datum $ dataToBinaryData datumExample) -- inline datum - (SJust $ alwaysSucceeds @'PlutusV2 3) -- reference script - ] - ) - (SJust $ mkSized (eraProtVerHigh @Babel) collateralOutput) -- collateral return - (SJust $ Coin 8675309) -- collateral tot - exampleBabelCerts -- txcerts - ( Withdrawals $ - Map.singleton - (RewardAccount Testnet (SLE.keyToCredential SLE.exampleStakeKey)) - (Coin 100) -- txwdrls - ) - (Coin 999) -- txfee - (ValidityInterval (SJust (SlotNo 2)) (SJust (SlotNo 4))) -- txvldt - (Set.singleton $ SLE.mkKeyHash 212) -- reqSignerHashes - exampleMultiAsset -- mint - (SJust $ mkDummySafeHash (Proxy @StandardCrypto) 42) -- scriptIntegrityHash - (SJust . AuxiliaryDataHash $ mkDummySafeHash (Proxy @StandardCrypto) 42) -- adHash - (SJust Mainnet) -- txnetworkid - (VotingProcedures mempty) - mempty - (SJust $ Coin 867530900000) -- current treasury value - mempty - mempty - mempty - mempty - where - MaryValue _ exampleMultiAsset = MarySLE.exampleMultiAssetValue 3 +-- exampleTxBodyBabel :: TxBody Babel +-- exampleTxBodyBabel = +-- BabelTxBody +-- (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 1)) 0]) -- spending inputs +-- (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 2)) 1]) -- collateral inputs +-- (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 1)) 3]) -- reference inputs +-- ( StrictSeq.fromList +-- [ mkSized (eraProtVerHigh @Babel) $ +-- BabbageTxOut +-- (mkAddr (SLE.examplePayKey, SLE.exampleStakeKey)) +-- (MarySLE.exampleMultiAssetValue 2) +-- (Datum $ dataToBinaryData datumExample) -- inline datum +-- (SJust $ alwaysSucceeds @'PlutusV2 3) -- reference script +-- ] +-- ) +-- (SJust $ mkSized (eraProtVerHigh @Babel) collateralOutput) -- collateral return +-- (SJust $ Coin 8675309) -- collateral tot +-- exampleBabelCerts -- txcerts +-- ( Withdrawals $ +-- Map.singleton +-- (RewardAccount Testnet (SLE.keyToCredential SLE.exampleStakeKey)) +-- (Coin 100) -- txwdrls +-- ) +-- (Coin 999) -- txfee +-- (ValidityInterval (SJust (SlotNo 2)) (SJust (SlotNo 4))) -- txvldt +-- (Set.singleton $ SLE.mkKeyHash 212) -- reqSignerHashes +-- exampleMultiAsset -- mint +-- (SJust $ mkDummySafeHash (Proxy @StandardCrypto) 42) -- scriptIntegrityHash +-- (SJust . AuxiliaryDataHash $ mkDummySafeHash (Proxy @StandardCrypto) 42) -- adHash +-- (SJust Mainnet) -- txnetworkid +-- (VotingProcedures mempty) +-- mempty +-- (SJust $ Coin 867530900000) -- current treasury value +-- mempty +-- mempty +-- mempty +-- mempty +-- where +-- MaryValue _ exampleMultiAsset = MarySLE.exampleMultiAssetValue 3 -datumExample :: Data Babel -datumExample = Data (P.I 191) +-- datumExample :: Data Babel +-- datumExample = Data (P.I 191) -redeemerExample :: Data Babel -redeemerExample = Data (P.I 919) +-- redeemerExample :: Data Babel +-- redeemerExample = Data (P.I 919) -exampleTx :: ShelleyTx Babel -exampleTx = - ShelleyTx - exampleTxBodyBabel - ( AlonzoTxWits - (mkWitnessesVKey (hashAnnotated exampleTxBodyBabel) [asWitness SLE.examplePayKey]) -- vkey - mempty -- bootstrap - ( Map.singleton - (hashScript @Babel $ alwaysSucceeds @'PlutusV1 3) - (alwaysSucceeds @'PlutusV1 3) -- txscripts - ) - (TxDats $ Map.singleton (hashData datumExample) datumExample) - ( Redeemers $ - Map.singleton (BabelSpending $ AsIx 0) (redeemerExample, ExUnits 5000 5000) - ) -- redeemers - ) - ( SJust $ - mkAlonzoTxAuxData - SLE.exampleAuxDataMap -- metadata - [alwaysFails @'PlutusV1 2, TimelockScript $ RequireAllOf mempty] -- Scripts - ) +-- exampleTx :: ShelleyTx Babel +-- exampleTx = +-- ShelleyTx +-- exampleTxBodyBabel +-- ( AlonzoTxWits +-- (mkWitnessesVKey (hashAnnotated exampleTxBodyBabel) [asWitness SLE.examplePayKey]) -- vkey +-- mempty -- bootstrap +-- ( Map.singleton +-- (hashScript @Babel $ alwaysSucceeds @'PlutusV1 3) +-- (alwaysSucceeds @'PlutusV1 3) -- txscripts +-- ) +-- (TxDats $ Map.singleton (hashData datumExample) datumExample) +-- ( Redeemers $ +-- Map.singleton (BabelSpending $ AsIx 0) (redeemerExample, ExUnits 5000 5000) +-- ) -- redeemers +-- ) +-- ( SJust $ +-- mkAlonzoTxAuxData +-- SLE.exampleAuxDataMap -- metadata +-- [alwaysFails @'PlutusV1 2, TimelockScript $ RequireAllOf mempty] -- Scripts +-- ) -exampleTransactionInBlock :: AlonzoTx Babel -exampleTransactionInBlock = AlonzoTx b w (IsValid True) a -- mempty - where - ShelleyTx b w a = exampleTx +-- exampleTransactionInBlock :: AlonzoTx Babel +-- exampleTransactionInBlock = AlonzoTx b w (IsValid True) a -- mempty +-- where +-- ShelleyTx b w a = exampleTx -exampleBabelNewEpochState :: NewEpochState Babel -exampleBabelNewEpochState = - SLE.exampleNewEpochState - (MarySLE.exampleMultiAssetValue 1) - emptyPParams - (emptyPParams & ppCoinsPerUTxOByteL .~ CoinPerByte (Coin 1)) +-- exampleBabelNewEpochState :: NewEpochState Babel +-- exampleBabelNewEpochState = +-- SLE.exampleNewEpochState +-- (MarySLE.exampleMultiAssetValue 1) +-- emptyPParams +-- (emptyPParams & ppCoinsPerUTxOByteL .~ CoinPerByte (Coin 1)) -exampleBabelGenesis :: BabelGenesis StandardCrypto -exampleBabelGenesis = expectedBabelGenesis +-- exampleBabelGenesis :: BabelGenesis StandardCrypto +-- exampleBabelGenesis = expectedBabelGenesis diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Prototype.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Prototype.hs index 305396e0b86..4a978024d43 100644 --- a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Prototype.hs +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Examples/Prototype.hs @@ -14,200 +14,130 @@ -- Example demonstrating using the protocol parameter update system. module Test.Cardano.Ledger.Babel.Examples.Prototype where -import Cardano.Ledger.Allegra.Scripts (Timelock (RequireAllOf)) -import Cardano.Ledger.Alonzo.Data ( - AuxiliaryDataHash (AuxiliaryDataHash), - Datum (NoDatum), - mkAlonzoTxAuxData, - ) -import Cardano.Ledger.Alonzo.Tx (IsValid (IsValid)) -import Cardano.Ledger.Alonzo.TxWits (Redeemers (Redeemers), TxDats (TxDats)) -import Cardano.Ledger.Babbage -import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..)) -import Cardano.Ledger.Babel (Babel, BabelEra) -import Cardano.Ledger.Babel.Core -import Cardano.Ledger.Babel.Genesis (BabelGenesis) -import Cardano.Ledger.Babel.Scripts ( - AlonzoScript (TimelockScript), - BabelPlutusPurpose (BabelSpending), - ) -import Cardano.Ledger.Babel.Tx (AlonzoTx (AlonzoTx)) -import Cardano.Ledger.Babel.TxBody -import Cardano.Ledger.Babel.TxWits (AlonzoTxWits (AlonzoTxWits)) -import Cardano.Ledger.BaseTypes ( - EpochInterval (EpochInterval), - Network (Mainnet), - Nonce, - StrictMaybe (..), - WithOrigin (At), - ) -import Cardano.Ledger.Binary (mkSized) -import Cardano.Ledger.Block (Block) -import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Conway.Governance (VotingProcedures (..)) -import Cardano.Ledger.Crypto -import Cardano.Ledger.Keys ( - GenDelegPair (GenDelegPair), - Hash, - KeyPair (KeyPair), - KeyRole (GenesisDelegate), - VerKeyVRF, - asWitness, - hashKey, - vKey, - ) -import Cardano.Ledger.Mary.Value (MaryValue (MaryValue)) -import Cardano.Ledger.Plutus (Datum (Datum), Language (PlutusV1), dataToBinaryData) -import Cardano.Ledger.Plutus.Data (Data (Data), hashData) -import Cardano.Ledger.Plutus.ExUnits (ExUnits (ExUnits)) -import Cardano.Ledger.Plutus.Language (Language (PlutusV2)) -import Cardano.Ledger.SafeHash (hashAnnotated) -import Cardano.Ledger.Shelley.API (hashVerKeyVRF) -import Cardano.Ledger.Shelley.API.Types (Network (Testnet)) -import Cardano.Ledger.Shelley.LedgerState ( - FutureGenDeleg (FutureGenDeleg), - NewEpochState, - StashedAVVMAddresses, - ) -import Cardano.Ledger.Shelley.Tx (ShelleyTx (ShelleyTx)) -import Cardano.Ledger.Shelley.TxBody (RewardAccount (RewardAccount)) -import Cardano.Ledger.Slot ( - BlockNo (..), - EpochNo (..), - SlotNo (..), - ) -import Cardano.Ledger.TxIn (TxId (TxId), mkTxInPartial) -import Cardano.Ledger.UTxO (UTxO (..), balance) -import Cardano.Ledger.Val ((<->)) -import qualified Cardano.Ledger.Val as Val -import Cardano.Protocol.TPraos.API (PraosCrypto) -import Cardano.Protocol.TPraos.BHeader ( - BHeader, - HashHeader (HashHeader), - LastAppliedBlock (LastAppliedBlock), - hashHeaderToNonce, - ) -import Cardano.Protocol.TPraos.OCert (KESPeriod (..)) -import Data.Default.Class (Default) -import qualified Data.Map.Strict as Map -import Data.Proxy (Proxy (Proxy)) -import qualified Data.Sequence.Strict as StrictSeq -import qualified Data.Set as Set -import GHC.Stack (HasCallStack) -import Lens.Micro ((&), (.~)) -import qualified PlutusLedgerApi.Common as P -import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysFails) -import Test.Cardano.Ledger.Alonzo.Scripts (alwaysSucceeds) -import Test.Cardano.Ledger.Babel.Examples -import Test.Cardano.Ledger.Babel.Examples.Combinators (evolveNonceUnfrozen, newLab) -import qualified Test.Cardano.Ledger.Babel.Examples.Combinators as C -import Test.Cardano.Ledger.Babel.Examples.Consensus (exampleBabelCerts) -import Test.Cardano.Ledger.Babel.Genesis (expectedBabelGenesis) -import Test.Cardano.Ledger.Babel.Rules.Chain (ChainState, initialBabelState) -import Test.Cardano.Ledger.Core.KeyPair (mkAddr, mkWitnessesVKey) -import Test.Cardano.Ledger.Core.Utils (unsafeBoundRational) -import qualified Test.Cardano.Ledger.Mary.Examples.Consensus as MarySLE -import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (ExMock) -import qualified Test.Cardano.Ledger.Shelley.Examples.Cast as Cast -import qualified Test.Cardano.Ledger.Shelley.Examples.Consensus as SLE -import Test.Cardano.Ledger.Shelley.Examples.Federation ( - coreNodeKeysBySchedule, - coreNodeVK, - genDelegs, - ) -import Test.Cardano.Ledger.Shelley.Generator.Core ( - NatNonce (..), - RawSeed (RawSeed), - VRFKeyPair (vrfVerKey), - genesisCoins, - mkBlockFakeVRF, - mkOCert, - ) -import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId) -import Test.Cardano.Ledger.Shelley.Generator.ShelleyEraGen () -import Test.Cardano.Ledger.Shelley.Generator.Trace.Chain () -import Test.Cardano.Ledger.Shelley.Utils ( - getBlockNonce, - maxLLSupply, - mkDummySafeHash, - mkHash, - mkKeyPair, - mkVRFKeyPair, - ) - ------------------- - -initUTxO :: EraTxOut era => UTxO era -initUTxO = - genesisCoins - genesisId - [ mkBasicTxOut Cast.aliceAddr aliceInitCoin - , mkBasicTxOut Cast.bobAddr bobInitCoin - ] - where - aliceInitCoin = Val.inject $ Coin $ 10 * 1000 * 1000 * 1000 * 1000 * 1000 - bobInitCoin = Val.inject $ Coin $ 1 * 1000 * 1000 * 1000 * 1000 * 1000 - -initStEx1 :: - ( EraTxOut era - , Default (StashedAVVMAddresses era) - , EraGov era - ) => - ChainState era -initStEx1 = initSt (UTxO mempty) -- initUTxO - -blockEx1 :: - forall era. - ( EraSegWits era - , Tx era ~ AlonzoTx Babel - , PraosCrypto (EraCrypto era) - ) => - Block (BHeader (EraCrypto era)) era -blockEx1 = SLE.exampleShelleyLedgerBlockTxs mempty -- exampleTransactionInBlock - -exampleTransactionInBlock :: AlonzoTx Babel -exampleTransactionInBlock = AlonzoTx b w (IsValid True) a - where - ShelleyTx b w a = exampleTx - -blockNonce :: - forall era. - ( EraSegWits era - , Tx era ~ AlonzoTx Babel - , PraosCrypto (EraCrypto era) - ) => - Nonce -blockNonce = getBlockNonce (blockEx1 @era) - -expectedStEx1 :: - forall era. - ( EraSegWits era - , EraGov era - , Default (StashedAVVMAddresses era) - , Tx era ~ AlonzoTx Babel - , PraosCrypto (EraCrypto era) - ) => - ChainState era -expectedStEx1 = evolveNonceUnfrozen (blockNonce @era) . newLab blockEx1 $ initStEx1 - --- | = Empty Block Example --- --- This is the most minimal example of using the CHAIN STS transition. --- It applies an empty block to an initial shelley chain state. --- --- The only things that change in the chain state are the --- evolving and candidate nonces, and the last applied block. -exEmptyBlock :: - ( EraSegWits era - , Default (StashedAVVMAddresses era) - , EraGov era - , Tx era ~ AlonzoTx Babel - , PraosCrypto (EraCrypto era) - ) => - CHAINExample (BHeader (EraCrypto era)) era -exEmptyBlock = CHAINExample initStEx1 blockEx1 (Right expectedStEx1) +-- import Cardano.Ledger.Allegra.Scripts (Timelock (RequireAllOf)) +-- import Cardano.Ledger.Alonzo.Data ( +-- AuxiliaryDataHash (AuxiliaryDataHash), +-- Datum (NoDatum), +-- mkAlonzoTxAuxData, +-- ) +-- import Cardano.Ledger.Alonzo.Tx (IsValid (IsValid)) +-- import Cardano.Ledger.Alonzo.TxWits (Redeemers (Redeemers), TxDats (TxDats)) +-- import Cardano.Ledger.Babbage +-- import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..)) +-- import Cardano.Ledger.Babel (Babel, BabelEra) +-- import Cardano.Ledger.Babel.Core +-- import Cardano.Ledger.Babel.Genesis (BabelGenesis) +-- import Cardano.Ledger.Babel.Scripts ( +-- AlonzoScript (TimelockScript), +-- BabelPlutusPurpose (BabelSpending), +-- ) +-- import Cardano.Ledger.Babel.Tx (AlonzoTx (AlonzoTx)) +-- import Cardano.Ledger.Babel.TxBody +-- import Cardano.Ledger.Babel.TxWits (AlonzoTxWits (AlonzoTxWits)) +-- import Cardano.Ledger.BaseTypes ( +-- EpochInterval (EpochInterval), +-- Network (Mainnet), +-- Nonce, +-- StrictMaybe (..), +-- WithOrigin (At), +-- ) +-- import Cardano.Ledger.Binary (mkSized) +-- import Cardano.Ledger.Block (Block) +-- import Cardano.Ledger.Coin (Coin (..)) +-- import Cardano.Ledger.Conway.Governance (VotingProcedures (..)) +-- import Cardano.Ledger.Crypto +-- import Cardano.Ledger.Keys ( +-- GenDelegPair (GenDelegPair), +-- Hash, +-- KeyPair (KeyPair), +-- KeyRole (GenesisDelegate), +-- VerKeyVRF, +-- asWitness, +-- hashKey, +-- vKey, +-- ) +-- import Cardano.Ledger.Mary.Value (MaryValue (MaryValue)) +-- import Cardano.Ledger.Plutus (Datum (Datum), Language (PlutusV1), dataToBinaryData) +-- import Cardano.Ledger.Plutus.Data (Data (Data), hashData) +-- import Cardano.Ledger.Plutus.ExUnits (ExUnits (ExUnits)) +-- import Cardano.Ledger.Plutus.Language (Language (PlutusV2)) +-- import Cardano.Ledger.SafeHash (hashAnnotated) +-- import Cardano.Ledger.Shelley.API (hashVerKeyVRF) +-- import Cardano.Ledger.Shelley.API.Types (Network (Testnet)) +-- import Cardano.Ledger.Shelley.LedgerState ( +-- FutureGenDeleg (FutureGenDeleg), +-- NewEpochState, +-- StashedAVVMAddresses, +-- ) +-- import Cardano.Ledger.Shelley.Tx (ShelleyTx (ShelleyTx)) +-- import Cardano.Ledger.Shelley.TxBody (RewardAccount (RewardAccount)) +-- import Cardano.Ledger.Slot ( +-- BlockNo (..), +-- EpochNo (..), +-- SlotNo (..), +-- ) +-- import Cardano.Ledger.TxIn (TxId (TxId), mkTxInPartial) +-- import Cardano.Ledger.UTxO (UTxO (..), balance) +-- import Cardano.Ledger.Val ((<->)) +-- import qualified Cardano.Ledger.Val as Val +-- import Cardano.Protocol.TPraos.API (PraosCrypto) +-- import Cardano.Protocol.TPraos.BHeader ( +-- BHeader, +-- HashHeader (HashHeader), +-- LastAppliedBlock (LastAppliedBlock), +-- hashHeaderToNonce, +-- ) +-- import Cardano.Protocol.TPraos.OCert (KESPeriod (..)) +-- import Data.Default.Class (Default) +-- import qualified Data.Map.Strict as Map +-- import Data.Proxy (Proxy (Proxy)) +-- import qualified Data.Sequence.Strict as StrictSeq +-- import qualified Data.Set as Set +-- import GHC.Stack (HasCallStack) +-- import Lens.Micro ((&), (.~)) +-- import qualified PlutusLedgerApi.Common as P +-- import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysFails) +-- import Test.Cardano.Ledger.Alonzo.Scripts (alwaysSucceeds) +-- import Test.Cardano.Ledger.Babel.Examples +-- import Test.Cardano.Ledger.Babel.Examples.Combinators (evolveNonceUnfrozen, newLab) +-- import qualified Test.Cardano.Ledger.Babel.Examples.Combinators as C + +-- -- import Test.Cardano.Ledger.Babel.Examples.Consensus (exampleBabelCerts) +-- import Test.Cardano.Ledger.Babel.Genesis (expectedBabelGenesis) +-- import Test.Cardano.Ledger.Babel.Rules.Chain (ChainState, initialBabelState) +-- import Test.Cardano.Ledger.Core.KeyPair (mkAddr, mkWitnessesVKey) +-- import Test.Cardano.Ledger.Core.Utils (unsafeBoundRational) +-- import qualified Test.Cardano.Ledger.Mary.Examples.Consensus as MarySLE +-- import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (ExMock) +-- import qualified Test.Cardano.Ledger.Shelley.Examples.Cast as Cast +-- import qualified Test.Cardano.Ledger.Shelley.Examples.Consensus as SLE +-- import Test.Cardano.Ledger.Shelley.Examples.Federation ( +-- coreNodeKeysBySchedule, +-- coreNodeVK, +-- genDelegs, +-- ) +-- import Test.Cardano.Ledger.Shelley.Generator.Core ( +-- NatNonce (..), +-- RawSeed (RawSeed), +-- VRFKeyPair (vrfVerKey), +-- genesisCoins, +-- mkBlockFakeVRF, +-- mkOCert, +-- ) +-- import Test.Cardano.Ledger.Shelley.Generator.EraGen (genesisId) +-- import Test.Cardano.Ledger.Shelley.Generator.ShelleyEraGen () +-- import Test.Cardano.Ledger.Shelley.Generator.Trace.Chain () +-- import Test.Cardano.Ledger.Shelley.Utils ( +-- getBlockNonce, +-- maxLLSupply, +-- mkDummySafeHash, +-- mkHash, +-- mkKeyPair, +-- mkVRFKeyPair, +-- ) -- ------------------ + -- initUTxO :: EraTxOut era => UTxO era -- initUTxO = -- genesisCoins @@ -219,58 +149,239 @@ exEmptyBlock = CHAINExample initStEx1 blockEx1 (Right expectedStEx1) -- aliceInitCoin = Val.inject $ Coin $ 10 * 1000 * 1000 * 1000 * 1000 * 1000 -- bobInitCoin = Val.inject $ Coin $ 1 * 1000 * 1000 * 1000 * 1000 * 1000 --- initStGenesisDeleg :: +-- initStEx1 :: -- ( EraTxOut era +-- , Default (StashedAVVMAddresses era) +-- , EraGov era +-- ) => +-- ChainState era +-- initStEx1 = initSt (UTxO mempty) -- initUTxO + +-- blockEx1 :: +-- forall era. +-- ( EraSegWits era +-- , Tx era ~ AlonzoTx Babel +-- , PraosCrypto (EraCrypto era) +-- ) => +-- Block (BHeader (EraCrypto era)) era +-- blockEx1 = SLE.exampleShelleyLedgerBlockTxs mempty -- exampleTransactionInBlock + +-- exampleTransactionInBlock :: AlonzoTx Babel +-- exampleTransactionInBlock = AlonzoTx b w (IsValid True) a +-- where +-- ShelleyTx b w a = exampleTx + +-- blockNonce :: +-- forall era. +-- ( EraSegWits era +-- , Tx era ~ AlonzoTx Babel +-- , PraosCrypto (EraCrypto era) +-- ) => +-- Nonce +-- blockNonce = getBlockNonce (blockEx1 @era) + +-- expectedStEx1 :: +-- forall era. +-- ( EraSegWits era -- , EraGov era -- , Default (StashedAVVMAddresses era) +-- , Tx era ~ AlonzoTx Babel +-- , PraosCrypto (EraCrypto era) -- ) => -- ChainState era --- initStGenesisDeleg = initSt initUTxO +-- expectedStEx1 = evolveNonceUnfrozen (blockNonce @era) . newLab blockEx1 $ initStEx1 +-- -- | = Empty Block Example -- -- --- -- Block 1, Slot 10, Epoch 0 +-- -- This is the most minimal example of using the CHAIN STS transition. +-- -- It applies an empty block to an initial shelley chain state. -- -- +-- -- The only things that change in the chain state are the +-- -- evolving and candidate nonces, and the last applied block. +-- exEmptyBlock :: +-- ( EraSegWits era +-- , Default (StashedAVVMAddresses era) +-- , EraGov era +-- , Tx era ~ AlonzoTx Babel +-- , PraosCrypto (EraCrypto era) +-- ) => +-- CHAINExample (BHeader (EraCrypto era)) era +-- exEmptyBlock = CHAINExample initStEx1 blockEx1 (Right expectedStEx1) + +-- -- ------------------ +-- -- initUTxO :: EraTxOut era => UTxO era +-- -- initUTxO = +-- -- genesisCoins +-- -- genesisId +-- -- [ mkBasicTxOut Cast.aliceAddr aliceInitCoin +-- -- , mkBasicTxOut Cast.bobAddr bobInitCoin +-- -- ] +-- -- where +-- -- aliceInitCoin = Val.inject $ Coin $ 10 * 1000 * 1000 * 1000 * 1000 * 1000 +-- -- bobInitCoin = Val.inject $ Coin $ 1 * 1000 * 1000 * 1000 * 1000 * 1000 + +-- -- initStGenesisDeleg :: +-- -- ( EraTxOut era +-- -- , EraGov era +-- -- , Default (StashedAVVMAddresses era) +-- -- ) => +-- -- ChainState era +-- -- initStGenesisDeleg = initSt initUTxO + +-- -- -- +-- -- -- Block 1, Slot 10, Epoch 0 +-- -- -- + +-- -- newGenDelegate :: +-- -- Crypto c => +-- -- KeyPair 'GenesisDelegate c +-- -- newGenDelegate = KeyPair vkCold skCold +-- -- where +-- -- (skCold, vkCold) = mkKeyPair (RawSeed 108 0 0 0 1) + +-- -- newGenesisVrfKH :: forall c. Crypto c => Hash c (VerKeyVRF c) +-- -- newGenesisVrfKH = hashVerKeyVRF (vrfVerKey (mkVRFKeyPair @c (RawSeed 9 8 7 6 5))) + +-- -- feeTx1 :: Coin +-- -- feeTx1 = Coin 1 + +-- -- blockEx1 :: +-- -- forall c. +-- -- ExMock (EraCrypto (BabelEra c)) => +-- -- Block (BHeader c) (BabelEra c) +-- -- blockEx1 = +-- -- mkBlockFakeVRF @(BabelEra c) +-- -- lastByronHeaderHash +-- -- (coreNodeKeysBySchedule @(BabelEra c) ppEx 10) +-- -- [txEx1] +-- -- (SlotNo 10) +-- -- (BlockNo 1) +-- -- (nonce0 @c) +-- -- (NatNonce 1) +-- -- minBound +-- -- 0 +-- -- 0 +-- -- (mkOCert @c (coreNodeKeysBySchedule @(BabelEra c) ppEx 10) 0 (KESPeriod 0)) + +-- -- txEx1 :: forall c. ExMock (EraCrypto (BabelEra c)) => AlonzoTx (BabelEra c) +-- -- txEx1 = +-- -- AlonzoTx +-- -- exampleTxBodyBabel +-- -- ( AlonzoTxWits +-- -- (mkWitnessesVKey (hashAnnotated exampleTxBodyBabel) [asWitness SLE.examplePayKey]) -- vkey +-- -- mempty -- bootstrap +-- -- ( Map.singleton +-- -- (hashScript @(BabelEra c) $ alwaysSucceeds @'PlutusV1 3) +-- -- (alwaysSucceeds @'PlutusV1 3) -- txscripts +-- -- ) +-- -- (TxDats $ Map.singleton (hashData datumExample) datumExample) +-- -- ( Redeemers $ +-- -- Map.singleton (BabelSpending $ AsIx 0) (redeemerExample, ExUnits 5000 5000) +-- -- ) -- redeemers +-- -- ) +-- -- (IsValid True) +-- -- SNothing + +-- -- newGenDeleg :: +-- -- forall c. +-- -- Crypto c => +-- -- (FutureGenDeleg c, GenDelegPair c) +-- -- newGenDeleg = +-- -- ( FutureGenDeleg (SlotNo 43) (hashKey $ coreNodeVK 0) +-- -- , GenDelegPair (hashKey . vKey $ newGenDelegate) (newGenesisVrfKH @c) +-- -- ) + +-- -- expectedStEx1 :: +-- -- forall c. +-- -- ExMock (EraCrypto (BabelEra c)) => +-- -- ChainState (BabelEra c) +-- -- expectedStEx1 = +-- -- C.evolveNonceUnfrozen (getBlockNonce @(BabelEra c) blockEx1) +-- -- . C.newLab blockEx1 +-- -- . C.feesAndDeposits ppEx feeTx1 [] [] +-- -- . C.newUTxO exampleTxBodyBabel +-- -- . C.setFutureGenDeleg newGenDeleg +-- -- $ initStGenesisDeleg + +-- -- -- === Block 1, Slot 10, Epoch 0 +-- -- -- +-- -- -- In the first block, stage a new future genesis delegate +-- -- genesisDelegation1 :: +-- -- ExMock (EraCrypto (BabelEra c)) => +-- -- CHAINExample (BHeader c) (BabelEra c) +-- -- genesisDelegation1 = CHAINExample initStGenesisDeleg blockEx1 (Right expectedStEx1) + +-- collateralOutput :: Crypto c => BabbageTxOut (BabelEra c) +-- collateralOutput = +-- BabbageTxOut +-- (mkAddr (SLE.examplePayKey, SLE.exampleStakeKey)) +-- (MaryValue (Coin 8675309) mempty) +-- NoDatum +-- SNothing --- newGenDelegate :: --- Crypto c => --- KeyPair 'GenesisDelegate c --- newGenDelegate = KeyPair vkCold skCold +-- testOutput :: Crypto c => BabbageTxOut (BabelEra c) +-- testOutput = +-- BabbageTxOut +-- (mkAddr (SLE.examplePayKey, SLE.exampleStakeKey)) +-- (MarySLE.exampleMultiAssetValue 2) +-- (Datum $ dataToBinaryData datumExample) -- inline datum +-- (SJust $ alwaysSucceeds @'PlutusV2 3) -- reference script + +-- exampleTxBodyBabel :: forall c. Crypto c => BabelTxBody (BabelEra c) +-- exampleTxBodyBabel = +-- BabelTxBody +-- (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 1)) 0]) -- spending inputs +-- (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 2)) 1]) -- collateral inputs +-- (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 1)) 3]) -- reference inputs +-- ( StrictSeq.fromList +-- [ mkSized (eraProtVerHigh @Babel) testOutput +-- -- BabbageTxOut +-- -- (mkAddr @c (SLE.examplePayKey, SLE.exampleStakeKey)) +-- -- (MarySLE.exampleMultiAssetValue 2) +-- -- (Datum $ dataToBinaryData datumExample) -- inline datum +-- -- (SJust $ alwaysSucceeds @'PlutusV2 3) -- reference script +-- ] +-- ) +-- (SJust $ mkSized (eraProtVerHigh @Babel) collateralOutput) -- collateral return +-- (SJust $ Coin 8675309) -- collateral tot +-- exampleBabelCerts -- txcerts +-- ( Withdrawals $ +-- Map.singleton +-- (RewardAccount Testnet (SLE.keyToCredential SLE.exampleStakeKey)) +-- (Coin 100) -- txwdrls +-- ) +-- (Coin 999) -- txfee +-- (ValidityInterval (SJust (SlotNo 2)) (SJust (SlotNo 4))) -- txvldt +-- (Set.singleton $ SLE.mkKeyHash 212) -- reqSignerHashes +-- exampleMultiAsset -- mint +-- (SJust $ mkDummySafeHash (Proxy @c) 42) -- scriptIntegrityHash +-- (SJust . AuxiliaryDataHash $ mkDummySafeHash (Proxy @c) 42) -- adHash +-- (SJust Mainnet) -- txnetworkid +-- (VotingProcedures mempty) +-- mempty +-- (SJust $ Coin 867530900000) -- current treasury value +-- mempty +-- mempty +-- mempty +-- mempty -- where --- (skCold, vkCold) = mkKeyPair (RawSeed 108 0 0 0 1) +-- MaryValue _ exampleMultiAsset = MarySLE.exampleMultiAssetValue 3 --- newGenesisVrfKH :: forall c. Crypto c => Hash c (VerKeyVRF c) --- newGenesisVrfKH = hashVerKeyVRF (vrfVerKey (mkVRFKeyPair @c (RawSeed 9 8 7 6 5))) +-- datumExample :: Crypto c => Data (BabelEra c) +-- datumExample = Data (P.I 191) --- feeTx1 :: Coin --- feeTx1 = Coin 1 +-- redeemerExample :: Crypto c => Data (BabelEra c) +-- redeemerExample = Data (P.I 919) --- blockEx1 :: --- forall c. --- ExMock (EraCrypto (BabelEra c)) => --- Block (BHeader c) (BabelEra c) --- blockEx1 = --- mkBlockFakeVRF @(BabelEra c) --- lastByronHeaderHash --- (coreNodeKeysBySchedule @(BabelEra c) ppEx 10) --- [txEx1] --- (SlotNo 10) --- (BlockNo 1) --- (nonce0 @c) --- (NatNonce 1) --- minBound --- 0 --- 0 --- (mkOCert @c (coreNodeKeysBySchedule @(BabelEra c) ppEx 10) 0 (KESPeriod 0)) - --- txEx1 :: forall c. ExMock (EraCrypto (BabelEra c)) => AlonzoTx (BabelEra c) --- txEx1 = --- AlonzoTx +-- exampleTx :: ShelleyTx Babel +-- exampleTx = +-- ShelleyTx -- exampleTxBodyBabel -- ( AlonzoTxWits -- (mkWitnessesVKey (hashAnnotated exampleTxBodyBabel) [asWitness SLE.examplePayKey]) -- vkey -- mempty -- bootstrap -- ( Map.singleton --- (hashScript @(BabelEra c) $ alwaysSucceeds @'PlutusV1 3) +-- (hashScript @Babel $ alwaysSucceeds @'PlutusV1 3) -- (alwaysSucceeds @'PlutusV1 3) -- txscripts -- ) -- (TxDats $ Map.singleton (hashData datumExample) datumExample) @@ -278,186 +389,76 @@ exEmptyBlock = CHAINExample initStEx1 blockEx1 (Right expectedStEx1) -- Map.singleton (BabelSpending $ AsIx 0) (redeemerExample, ExUnits 5000 5000) -- ) -- redeemers -- ) --- (IsValid True) --- SNothing +-- ( SJust $ +-- mkAlonzoTxAuxData +-- SLE.exampleAuxDataMap -- metadata +-- [alwaysFails @'PlutusV1 2, TimelockScript $ RequireAllOf mempty] -- Scripts +-- ) --- newGenDeleg :: +-- -- ------ + +-- -- | Initial Protocol Parameters +-- ppEx :: EraPParams era => PParams era +-- ppEx = +-- emptyPParams +-- & ppMaxBBSizeL +-- .~ 50000 +-- & ppMaxBHSizeL +-- .~ 10000 +-- & ppMaxTxSizeL +-- .~ 10000 +-- & ppEMaxL +-- .~ EpochInterval 10000 +-- & ppKeyDepositL +-- .~ Coin 7 +-- & ppPoolDepositL +-- .~ Coin 250 +-- & ppTauL +-- .~ unsafeBoundRational 0.2 +-- & ppRhoL +-- .~ unsafeBoundRational 0.0021 + +-- -- | === The hash of the last Bryon Header +-- -- +-- -- The first block of the Shelley era will point back to the +-- -- last block of the Byron era. +-- -- For our purposes in the examples we can bootstrap the chain +-- -- by just coercing the value. +-- -- When this transition actually occurs, +-- -- the consensus layer will do the work of making +-- -- sure that the hash gets translated across the fork. +-- lastByronHeaderHash :: -- forall c. -- Crypto c => --- (FutureGenDeleg c, GenDelegPair c) --- newGenDeleg = --- ( FutureGenDeleg (SlotNo 43) (hashKey $ coreNodeVK 0) --- , GenDelegPair (hashKey . vKey $ newGenDelegate) (newGenesisVrfKH @c) --- ) +-- HashHeader c +-- lastByronHeaderHash = HashHeader $ mkHash 0 --- expectedStEx1 :: +-- -- | === Initial Nonce +-- nonce0 :: -- forall c. --- ExMock (EraCrypto (BabelEra c)) => --- ChainState (BabelEra c) --- expectedStEx1 = --- C.evolveNonceUnfrozen (getBlockNonce @(BabelEra c) blockEx1) --- . C.newLab blockEx1 --- . C.feesAndDeposits ppEx feeTx1 [] [] --- . C.newUTxO exampleTxBodyBabel --- . C.setFutureGenDeleg newGenDeleg --- $ initStGenesisDeleg - --- -- === Block 1, Slot 10, Epoch 0 +-- Crypto c => +-- Nonce +-- nonce0 = hashHeaderToNonce (lastByronHeaderHash @c) + +-- -- | === Initial Chain State -- -- --- -- In the first block, stage a new future genesis delegate --- genesisDelegation1 :: --- ExMock (EraCrypto (BabelEra c)) => --- CHAINExample (BHeader c) (BabelEra c) --- genesisDelegation1 = CHAINExample initStGenesisDeleg blockEx1 (Right expectedStEx1) - -collateralOutput :: Crypto c => BabbageTxOut (BabelEra c) -collateralOutput = - BabbageTxOut - (mkAddr (SLE.examplePayKey, SLE.exampleStakeKey)) - (MaryValue (Coin 8675309) mempty) - NoDatum - SNothing - -testOutput :: Crypto c => BabbageTxOut (BabelEra c) -testOutput = - BabbageTxOut - (mkAddr (SLE.examplePayKey, SLE.exampleStakeKey)) - (MarySLE.exampleMultiAssetValue 2) - (Datum $ dataToBinaryData datumExample) -- inline datum - (SJust $ alwaysSucceeds @'PlutusV2 3) -- reference script - -exampleTxBodyBabel :: forall c. Crypto c => BabelTxBody (BabelEra c) -exampleTxBodyBabel = - BabelTxBody - (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 1)) 0]) -- spending inputs - (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 2)) 1]) -- collateral inputs - (Set.fromList [mkTxInPartial (TxId (mkDummySafeHash Proxy 1)) 3]) -- reference inputs - ( StrictSeq.fromList - [ mkSized (eraProtVerHigh @Babel) testOutput - -- BabbageTxOut - -- (mkAddr @c (SLE.examplePayKey, SLE.exampleStakeKey)) - -- (MarySLE.exampleMultiAssetValue 2) - -- (Datum $ dataToBinaryData datumExample) -- inline datum - -- (SJust $ alwaysSucceeds @'PlutusV2 3) -- reference script - ] - ) - (SJust $ mkSized (eraProtVerHigh @Babel) collateralOutput) -- collateral return - (SJust $ Coin 8675309) -- collateral tot - exampleBabelCerts -- txcerts - ( Withdrawals $ - Map.singleton - (RewardAccount Testnet (SLE.keyToCredential SLE.exampleStakeKey)) - (Coin 100) -- txwdrls - ) - (Coin 999) -- txfee - (ValidityInterval (SJust (SlotNo 2)) (SJust (SlotNo 4))) -- txvldt - (Set.singleton $ SLE.mkKeyHash 212) -- reqSignerHashes - exampleMultiAsset -- mint - (SJust $ mkDummySafeHash (Proxy @c) 42) -- scriptIntegrityHash - (SJust . AuxiliaryDataHash $ mkDummySafeHash (Proxy @c) 42) -- adHash - (SJust Mainnet) -- txnetworkid - (VotingProcedures mempty) - mempty - (SJust $ Coin 867530900000) -- current treasury value - mempty - mempty - mempty - mempty - where - MaryValue _ exampleMultiAsset = MarySLE.exampleMultiAssetValue 3 - -datumExample :: Crypto c => Data (BabelEra c) -datumExample = Data (P.I 191) - -redeemerExample :: Crypto c => Data (BabelEra c) -redeemerExample = Data (P.I 919) - -exampleTx :: ShelleyTx Babel -exampleTx = - ShelleyTx - exampleTxBodyBabel - ( AlonzoTxWits - (mkWitnessesVKey (hashAnnotated exampleTxBodyBabel) [asWitness SLE.examplePayKey]) -- vkey - mempty -- bootstrap - ( Map.singleton - (hashScript @Babel $ alwaysSucceeds @'PlutusV1 3) - (alwaysSucceeds @'PlutusV1 3) -- txscripts - ) - (TxDats $ Map.singleton (hashData datumExample) datumExample) - ( Redeemers $ - Map.singleton (BabelSpending $ AsIx 0) (redeemerExample, ExUnits 5000 5000) - ) -- redeemers - ) - ( SJust $ - mkAlonzoTxAuxData - SLE.exampleAuxDataMap -- metadata - [alwaysFails @'PlutusV1 2, TimelockScript $ RequireAllOf mempty] -- Scripts - ) - --- ------ - --- | Initial Protocol Parameters -ppEx :: EraPParams era => PParams era -ppEx = - emptyPParams - & ppMaxBBSizeL - .~ 50000 - & ppMaxBHSizeL - .~ 10000 - & ppMaxTxSizeL - .~ 10000 - & ppEMaxL - .~ EpochInterval 10000 - & ppKeyDepositL - .~ Coin 7 - & ppPoolDepositL - .~ Coin 250 - & ppTauL - .~ unsafeBoundRational 0.2 - & ppRhoL - .~ unsafeBoundRational 0.0021 - --- | === The hash of the last Bryon Header --- --- The first block of the Shelley era will point back to the --- last block of the Byron era. --- For our purposes in the examples we can bootstrap the chain --- by just coercing the value. --- When this transition actually occurs, --- the consensus layer will do the work of making --- sure that the hash gets translated across the fork. -lastByronHeaderHash :: - forall c. - Crypto c => - HashHeader c -lastByronHeaderHash = HashHeader $ mkHash 0 - --- | === Initial Nonce -nonce0 :: - forall c. - Crypto c => - Nonce -nonce0 = hashHeaderToNonce (lastByronHeaderHash @c) - --- | === Initial Chain State --- --- The initial state for the examples uses the function --- 'initialShelleyState' with the genesis delegation --- 'genDelegs' and any given starting 'UTxO' set. -initSt :: - forall era. - ( EraTxOut era - , Default (StashedAVVMAddresses era) - , EraGov era - ) => - UTxO era -> - ChainState era -initSt utxo = - initialBabelState - (At $ LastAppliedBlock (BlockNo 0) (SlotNo 0) lastByronHeaderHash) - (EpochNo 0) - utxo - (maxLLSupply <-> Val.coin (balance utxo)) - genDelegs - (ppEx @era) - (nonce0 @(EraCrypto era)) \ No newline at end of file +-- -- The initial state for the examples uses the function +-- -- 'initialShelleyState' with the genesis delegation +-- -- 'genDelegs' and any given starting 'UTxO' set. +-- initSt :: +-- forall era. +-- ( EraTxOut era +-- , Default (StashedAVVMAddresses era) +-- , EraGov era +-- ) => +-- UTxO era -> +-- ChainState era +-- initSt utxo = +-- initialBabelState +-- (At $ LastAppliedBlock (BlockNo 0) (SlotNo 0) lastByronHeaderHash) +-- (EpochNo 0) +-- utxo +-- (maxLLSupply <-> Val.coin (balance utxo)) +-- genDelegs +-- (ppEx @era) +-- (nonce0 @(EraCrypto era)) \ No newline at end of file diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/RulesTests.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/RulesTests.hs index b774eaf6702..3957796595e 100644 --- a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/RulesTests.hs +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/RulesTests.hs @@ -31,21 +31,24 @@ import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import qualified Data.Set as Set import Lens.Micro ((^.)) -import Test.Cardano.Ledger.Babel.Examples (testCHAINExample) -import Test.Cardano.Ledger.Babel.Examples.Prototype + +-- import Test.Cardano.Ledger.Babel.Examples (testCHAINExample) +-- import Test.Cardano.Ledger.Babel.Examples.Prototype import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators () import Test.Cardano.Ledger.Shelley.Serialisation.Generators () import Test.Cardano.Ledger.Shelley.Utils import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase) + +-- import Test.Tasty.HUnit (testCase) import Test.Tasty.QuickCheck (Property, discard, testProperty, (===)) chainExamples :: TestTree chainExamples = testGroup "CHAINexamples" - [ testCase "empty block" $ testCHAINExample exEmptyBlock - ] + [] + +-- testCase "empty block" $ testCHAINExample exEmptyBlock -- | The reward aggregation bug described in the Shelley ledger spec in -- section 17.4 (in the Errata) resulted in needing to use 'aggregatedRewards' to change diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Tx.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Tx.hs index 86527d065f3..fb7744ef25b 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Tx.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Tx.hs @@ -39,7 +39,6 @@ import Cardano.Ledger.Conway.TxWits () import Cardano.Ledger.Core import Cardano.Ledger.Crypto import Cardano.Ledger.Val (Val (..)) -import Control.Monad ((<=<)) import qualified Data.Sequence.Strict as StrictSeq import Lens.Micro ((^.)) @@ -97,8 +96,10 @@ instance Crypto c => AlonzoEraTx (ConwayEra c) where {-# INLINE isValidTxL #-} instance Crypto c => EraSegWits (ConwayEra c) where + type TxStructure (ConwayEra c) = StrictSeq.StrictSeq type TxZones (ConwayEra c) = AlonzoTxSeq (ConwayEra c) - fromTxZones = fmap StrictSeq.singleton . txSeqTxns - toTxZones = AlonzoTxSeq . StrictSeq.forceToStrict . (StrictSeq.fromStrict <=< StrictSeq.fromStrict) + fromTxZones = txSeqTxns + toTxZones = AlonzoTxSeq + flatten = fromTxZones hashTxZones = hashAlonzoTxSeq numSegComponents = 4 diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/TxSeq.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/TxSeq.hs index 37840f51cb1..c59ad0e24e2 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/TxSeq.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/TxSeq.hs @@ -15,13 +15,14 @@ import Cardano.Ledger.Crypto (Crypto, StandardCrypto) import Cardano.Ledger.Mary.Era (MaryEra) import Cardano.Ledger.Mary.Tx () import Cardano.Ledger.Shelley.BlockChain (ShelleyTxSeq (..), bbHash, txSeqTxns) -import Control.Monad ((<=<)) import qualified Data.Sequence.Strict as StrictSeq instance Crypto c => EraSegWits (MaryEra c) where {-# SPECIALIZE instance EraSegWits (MaryEra StandardCrypto) #-} + type TxStructure (MaryEra c) = StrictSeq.StrictSeq type TxZones (MaryEra c) = ShelleyTxSeq (MaryEra c) - fromTxZones = fmap StrictSeq.singleton . txSeqTxns - toTxZones = ShelleyTxSeq . StrictSeq.forceToStrict . (StrictSeq.fromStrict <=< StrictSeq.fromStrict) + fromTxZones = txSeqTxns + toTxZones = ShelleyTxSeq + flatten = fromTxZones hashTxZones = bbHash numSegComponents = 3 diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs index bc716818ac3..131030db2a2 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/BlockChain.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -57,7 +58,7 @@ import Cardano.Ledger.SafeHash (SafeToHash (..)) import Cardano.Ledger.Shelley.Era (ShelleyEra) import Cardano.Ledger.Shelley.Tx (ShelleyTx, segwitTx) import Cardano.Ledger.Slot (SlotNo (..)) -import Control.Monad (unless, (<=<)) +import Control.Monad (unless) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BSL import Data.Coerce (coerce) @@ -65,7 +66,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Sequence (Seq) import qualified Data.Sequence as Seq -import Data.Sequence.Strict (StrictSeq (fromStrict), forceToStrict) +import Data.Sequence.Strict (StrictSeq) import qualified Data.Sequence.Strict as StrictSeq import Data.Typeable import GHC.Generics (Generic) @@ -82,9 +83,11 @@ data ShelleyTxSeq era = TxSeq' deriving (Generic) instance Crypto c => EraSegWits (ShelleyEra c) where + type TxStructure (ShelleyEra c) = StrictSeq type TxZones (ShelleyEra c) = ShelleyTxSeq (ShelleyEra c) - fromTxZones = fmap StrictSeq.singleton . txSeqTxns - toTxZones = ShelleyTxSeq . forceToStrict . (fromStrict <=< fromStrict) + fromTxZones = txSeqTxns + toTxZones = ShelleyTxSeq + flatten = fromTxZones hashTxZones = bbHash numSegComponents = 3 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 264c2f01216..aadc095de14 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs @@ -177,7 +177,7 @@ bbodyTransition = , UnserialisedBlock bhview txsZones ) ) -> do - let txs = fromTxZones txsZones + let txs = flatten txsZones actualBodySize = bBodySize (pp ^. ppProtocolVersionL) txsZones actualBodyHash = hashTxZones txsZones @@ -192,7 +192,7 @@ bbodyTransition = ls' <- trans @(EraRule "LEDGERS" era) $ TRC - (LedgersEnv (bhviewSlot bhview) pp account, ls, StrictSeq.fromStrict =<< StrictSeq.fromStrict txs) + (LedgersEnv (bhviewSlot bhview) pp account, ls, StrictSeq.fromStrict txs) -- Note that this may not actually be a stake pool - it could be a genesis key -- delegate. However, this would only entail an overhead of 7 counts, and it's diff --git a/eras/shelley/test-suite/bench/BenchValidation.hs b/eras/shelley/test-suite/bench/BenchValidation.hs index e9bdb06711e..725bbb31e3e 100644 --- a/eras/shelley/test-suite/bench/BenchValidation.hs +++ b/eras/shelley/test-suite/bench/BenchValidation.hs @@ -56,6 +56,7 @@ import Control.DeepSeq (NFData (rnf)) import Control.Monad.Except () import qualified Data.Map.Strict as Map import Data.Proxy +import qualified Data.Sequence.Strict as StrictSeq import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (Mock) import Test.Cardano.Ledger.Shelley.Constants (defaultConstants) import Test.Cardano.Ledger.Shelley.Generator.Core (GenEnv) @@ -75,7 +76,8 @@ instance NFData (ValidateInput era) where rnf (ValidateInput a b c) = seq a (seq b (seq c ())) validateInput :: - ( EraGen era + ( TxStructure era ~ StrictSeq.StrictSeq + , EraGen era , Mock (EraCrypto era) , EraRule "LEDGERS" era ~ API.ShelleyLEDGERS era , QC.HasTrace (API.ShelleyLEDGERS era) (GenEnv era) @@ -88,7 +90,8 @@ validateInput :: validateInput utxoSize = genValidateInput utxoSize genValidateInput :: - ( EraGen era + ( TxStructure era ~ StrictSeq.StrictSeq + , EraGen era , Mock (EraCrypto era) , EraRule "LEDGERS" era ~ API.ShelleyLEDGERS era , QC.HasTrace (API.ShelleyLEDGERS era) (GenEnv era) @@ -167,7 +170,8 @@ instance Crypto c => NFData (UpdateInputs c) where genUpdateInputs :: forall era. - ( EraGen era + ( TxStructure era ~ StrictSeq.StrictSeq + , EraGen era , Mock (EraCrypto era) , MinLEDGER_STS era , GetLedgerView era diff --git a/eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs b/eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs index e23baa1b846..b0132cf68de 100644 --- a/eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs +++ b/eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs @@ -32,6 +32,7 @@ import Control.State.Transition.Extended import Data.Either (fromRight) import qualified Data.Map.Strict as Map import Data.Proxy +import qualified Data.Sequence.Strict as StrictSeq import Test.Cardano.Ledger.Shelley.BenchmarkFunctions (ledgerEnv) import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (Mock) import Test.Cardano.Ledger.Shelley.Constants ( @@ -82,7 +83,8 @@ genChainState n ge = -- | Benchmark generating a block given a chain state. genBlock :: - ( Mock (EraCrypto era) + ( TxStructure era ~ StrictSeq.StrictSeq + , Mock (EraCrypto era) , EraGen era , MinLEDGER_STS era , GetLedgerView era diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs index ba494bebc29..f3d99c95ec2 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs @@ -114,7 +114,8 @@ type ShelleyBasedEra' era = defaultShelleyLedgerExamples :: forall era. - ( ShelleyBasedEra' era + ( TxStructure era ~ StrictSeq + , ShelleyBasedEra' era , EraSegWits era , EraGov era , PredicateFailure (EraRule "DELEGS" era) ~ ShelleyDelegsPredFailure era @@ -170,7 +171,7 @@ defaultShelleyLedgerExamples mkWitnesses mkAlonzoTx value txBody auxData transla exampleShelleyLedgerBlockTxs :: forall era. - (EraSegWits era, PraosCrypto (EraCrypto era)) => + (TxStructure era ~ StrictSeq, EraSegWits era, PraosCrypto (EraCrypto era)) => [Tx era] -> Block (BHeader (EraCrypto era)) era exampleShelleyLedgerBlockTxs txs = Block blockHeader blockBody @@ -200,14 +201,14 @@ exampleShelleyLedgerBlockTxs txs = Block blockHeader blockBody , bprotver = ProtVer (natVersion @2) 0 } - blockBody = toTxZones @era (fmap StrictSeq.singleton (StrictSeq.fromList txs)) + blockBody = toTxZones @era (StrictSeq.fromList txs) mkBytes :: Int -> Cardano.Ledger.BaseTypes.Seed mkBytes = Seed . mkDummyHash @Blake2b_256 exampleShelleyLedgerBlock :: forall era. - (EraSegWits era, PraosCrypto (EraCrypto era)) => + (TxStructure era ~ StrictSeq, EraSegWits era, PraosCrypto (EraCrypto era)) => Tx era -> Block (BHeader (EraCrypto era)) era exampleShelleyLedgerBlock tx = Block blockHeader blockBody @@ -237,7 +238,7 @@ exampleShelleyLedgerBlock tx = Block blockHeader blockBody , bprotver = ProtVer (natVersion @2) 0 } - blockBody = toTxZones @era (fmap StrictSeq.singleton (StrictSeq.fromList [tx])) + blockBody = toTxZones @era (StrictSeq.fromList [tx]) mkBytes :: Int -> Cardano.Ledger.BaseTypes.Seed mkBytes = Seed . mkDummyHash @Blake2b_256 diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs index 804a60546ba..6f1548f006d 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs @@ -45,6 +45,7 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe) import Data.Sequence (Seq) +import qualified Data.Sequence.Strict as StrictSeq import qualified Data.Set as Set import Lens.Micro ((^.)) import Lens.Micro.Extras (view) @@ -89,7 +90,8 @@ type TxGen era = -- | Generate a valid block. genBlock :: forall era. - ( MinLEDGER_STS era + ( TxStructure era ~ StrictSeq.StrictSeq + , MinLEDGER_STS era , ApplyBlock era , Mock (EraCrypto era) , GetLedgerView era @@ -109,7 +111,8 @@ genBlock ge = genBlockWithTxGen genTxs ge genBlockWithTxGen :: forall era. - ( Mock (EraCrypto era) + ( TxStructure era ~ StrictSeq.StrictSeq + , Mock (EraCrypto era) , GetLedgerView era , ApplyBlock era , EraGen era diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs index 1443c78c34a..de5a0446c43 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs @@ -50,6 +50,7 @@ import qualified Data.ListMap as LM import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Proxy (Proxy (..)) +import qualified Data.Sequence.Strict as StrictSeq import Lens.Micro ((^.)) import Lens.Micro.Extras (view) import Numeric.Natural (Natural) @@ -85,7 +86,8 @@ import Test.QuickCheck (Gen) -- The CHAIN STS at the root of the STS allows for generating blocks of transactions -- with meaningful delegation certificates, protocol and application updates, withdrawals etc. instance - ( EraGen era + ( TxStructure era ~ StrictSeq.StrictSeq + , EraGen era , EraSegWits era , Mock (EraCrypto era) , ApplyBlock era diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs index 81bd139431d..714224ba810 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs @@ -280,7 +280,7 @@ checkPreservation SourceSignalTarget {source, target, signal} count = <> toDeltaCoin (sumRewards prevPP (rs ru)) ] - txs' = concatMap toList $ (fromTxZones @era . bbody) signal + txs' = toList $ (fromTxZones @era . bbody) signal txs = zipWith dispTx txs' [0 :: Int ..] dispTx tx ix = @@ -589,7 +589,6 @@ withdrawals (UnserialisedBlock _ txseq) = in if hasFailedScripts tx then c else c <> fold wdrls ) (Coin 0) - $ concatMap toList $ fromTxZones @era txseq txFees :: diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs index 2daa9aa49f8..a4ed34c55f0 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/ClassifyTraces.hs @@ -125,7 +125,7 @@ relevantCasesAreCoveredForTrace :: Property relevantCasesAreCoveredForTrace tr = do let blockTxs :: Block (BHeader (EraCrypto era)) era -> [Tx era] - blockTxs (UnserialisedBlock _ txSeq) = toList =<< toList (fromTxZones @era txSeq) + blockTxs (UnserialisedBlock _ txSeq) = toList (fromTxZones @era txSeq) bs = traceSignals OldestFirst tr txs = concat (blockTxs <$> bs) certsByTx_ = certsByTx @era txs diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/CollisionFreeness.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/CollisionFreeness.hs index 06b2b35f7c2..ac474a08948 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/CollisionFreeness.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/CollisionFreeness.hs @@ -175,7 +175,7 @@ noDoubleSpend SourceSignalTarget {signal} = counterexample "noDoubleSpend" $ [] === getDoubleInputs txs where - txs = concatMap toList $ (fromTxZones @era . bbody) signal + txs = toList $ (fromTxZones @era . bbody) signal getDoubleInputs :: [Tx era] -> [(Tx era, [Tx era])] getDoubleInputs [] = [] diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs index 5a26b4b6253..2307526032d 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs @@ -261,7 +261,7 @@ ledgerTraceBase chainSt block = nes = (nesEs . chainNes) tickedChainSt pp_ = nes ^. curPParamsEpochStateL -- Oldest to Newest first - txs = (reverse . concatMap toList . fromTxZones) txSeq -- HERE WE USE SOME SegWit function + txs = (reverse . toList . fromTxZones) txSeq -- HERE WE USE SOME SegWit function -- | Transform the [(source, signal, target)] of a CHAIN Trace -- by manually applying the Chain TICK Rule to each source and producing diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/EmptyBlock.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/EmptyBlock.hs index 858c62ae276..3085278abc2 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/EmptyBlock.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/EmptyBlock.hs @@ -19,6 +19,7 @@ import Cardano.Ledger.UTxO (UTxO (..)) import Cardano.Protocol.TPraos.BHeader (BHeader) import Cardano.Protocol.TPraos.OCert (KESPeriod (..)) import Data.Default.Class +import qualified Data.Sequence.Strict as StrictSeq import GHC.Stack (HasCallStack) import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (ExMock) import Test.Cardano.Ledger.Shelley.Examples (CHAINExample (..)) @@ -55,7 +56,8 @@ initStEx1 = initSt (UTxO mempty) blockEx1 :: forall era. - ( HasCallStack + ( TxStructure era ~ StrictSeq.StrictSeq + , HasCallStack , EraSegWits era , ExMock (EraCrypto era) , ProtVerAtMost era 4 @@ -78,7 +80,8 @@ blockEx1 = blockNonce :: forall era. - ( HasCallStack + ( TxStructure era ~ StrictSeq.StrictSeq + , HasCallStack , EraSegWits era , ExMock (EraCrypto era) , ProtVerAtMost era 4 @@ -89,7 +92,8 @@ blockNonce = getBlockNonce (blockEx1 @era) expectedStEx1 :: forall era. - ( EraSegWits era + ( TxStructure era ~ StrictSeq.StrictSeq + , EraSegWits era , ExMock (EraCrypto era) , ProtVerAtMost era 4 , ProtVerAtMost era 6 @@ -107,7 +111,8 @@ expectedStEx1 = evolveNonceUnfrozen (blockNonce @era) . newLab blockEx1 $ initSt -- The only things that change in the chain state are the -- evolving and candidate nonces, and the last applied block. exEmptyBlock :: - ( ExMock (EraCrypto era) + ( TxStructure era ~ StrictSeq.StrictSeq + , ExMock (EraCrypto era) , EraSegWits era , ProtVerAtMost era 4 , ProtVerAtMost era 6 diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs index 6a6eaa6808b..9d3831a46ce 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs @@ -160,7 +160,7 @@ neededTxInsForBlock :: Set (TxIn (EraCrypto era)) neededTxInsForBlock (Block' _ txsSeq _) = Set.filter isNotNewInput allTxIns where - txBodies = map (^. bodyTxL) . concatMap toList $ fromTxZones txsSeq + txBodies = map (^. bodyTxL) . toList $ flatten txsSeq allTxIns = Set.unions $ map (^. allInputsTxBodyF) txBodies newTxIds = Set.fromList $ map txid txBodies isNotNewInput (TxIn txID _) = txID `Set.notMember` newTxIds diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs index 619939db767..a7b42af8671 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs @@ -626,13 +626,17 @@ class , Show (TxZones era) , EncCBORGroup (TxZones era) , DecCBOR (Annotator (TxZones era)) + , Foldable (TxStructure era) ) => EraSegWits era where + type TxStructure era :: Type -> Type type TxZones era = (r :: Type) | r -> era - fromTxZones :: TxZones era -> StrictSeq (StrictSeq (Tx era)) - toTxZones :: StrictSeq (StrictSeq (Tx era)) -> TxZones era + fromTxZones :: TxZones era -> TxStructure era (Tx era) + toTxZones :: TxStructure era (Tx era) -> TxZones era + + flatten :: TxZones era -> StrictSeq (Tx era) -- | Get the block body hash from the TxSeq. Note that this is not a regular -- "hash the stored bytes" function since the block body hash forms a small diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs index 4534eaabf97..1ca7e12c333 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs @@ -132,7 +132,8 @@ tests = alonzoBBODYexamplesP :: forall era. - ( HasTokens era + ( TxStructure era ~ StrictSeq.StrictSeq + , HasTokens era , PostShelley era , Value era ~ MaryValue (EraCrypto era) , EraSegWits era @@ -190,7 +191,8 @@ initialBBodyState pf utxo = } testAlonzoBlock :: - ( GoodCrypto (EraCrypto era) + ( TxStructure era ~ StrictSeq.StrictSeq + , GoodCrypto (EraCrypto era) , HasTokens era , Scriptic era , EraSegWits era @@ -708,7 +710,10 @@ coldKeys = KeyPair vk sk (sk, vk) = mkKeyPair (RawSeed 1 2 3 2 1) makeNaiveBlock :: - forall era. EraSegWits era => [Tx era] -> Block (BHeaderView (EraCrypto era)) era + forall era. + (TxStructure era ~ StrictSeq.StrictSeq, EraSegWits era) => + [Tx era] -> + Block (BHeaderView (EraCrypto era)) era makeNaiveBlock txs = UnsafeUnserialisedBlock bhView txSeq where bhView = @@ -719,7 +724,7 @@ makeNaiveBlock txs = UnsafeUnserialisedBlock bhView txSeq , bhviewBHash = hashTxZones txSeq , bhviewSlot = SlotNo 0 } - txSeq = toTxZones $ StrictSeq.fromList (fmap StrictSeq.singleton txs) + txSeq = toTxZones $ StrictSeq.fromList txs scriptStakeCredFail :: forall era. Scriptic era => Proof era -> StakeCredential (EraCrypto era) scriptStakeCredFail pf = ScriptHashObj (alwaysFailsHash 1 pf) diff --git a/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Arbitrary.hs b/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Arbitrary.hs index 71fba2defab..828299c654f 100644 --- a/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Arbitrary.hs +++ b/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Arbitrary.hs @@ -37,7 +37,7 @@ import Cardano.Protocol.TPraos.OCert (KESPeriod (KESPeriod), OCert (..), OCertSi import Cardano.Protocol.TPraos.Rules.Overlay (OBftSlot) import Cardano.Protocol.TPraos.Rules.Prtcl (PrtclState) import Cardano.Protocol.TPraos.Rules.Tickn (TicknState) -import Data.Sequence.Strict (singleton) +import Data.Sequence.Strict (StrictSeq, singleton) import Generic.Random (genericArbitraryU) import Test.Cardano.Ledger.Binary.Arbitrary () import Test.Cardano.Ledger.Common @@ -133,7 +133,8 @@ instance Crypto c => Arbitrary (OCert c) where deriving newtype instance Arbitrary KESPeriod instance - ( Era era + ( TxStructure era ~ StrictSeq + , Era era , c ~ EraCrypto era , EraSegWits era , KES.Signable (KES c) ~ SignableRepresentation @@ -146,7 +147,8 @@ instance -- | Use supplied keys to generate a Block. genBlock :: - ( DSIGN.Signable (DSIGN c) (OCertSignable c) + ( TxStructure era ~ StrictSeq + , DSIGN.Signable (DSIGN c) (OCertSignable c) , VRF.Signable (VRF c) Seed , KES.Signable (KES c) (BHBody c) , EraSegWits era @@ -167,7 +169,8 @@ genBlock aiks = Block <$> genBHeader aiks <*> (toTxZones <$> arbitrary) -- This generator uses 'mkBlock' provide more coherent blocks. genCoherentBlock :: forall era r. - ( EraSegWits era + ( TxStructure era ~ StrictSeq + , EraSegWits era , Arbitrary (Tx era) , KES.Signable (KES (EraCrypto era)) ~ SignableRepresentation , DSIGN.Signable (DSIGN (EraCrypto era)) ~ SignableRepresentation diff --git a/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Create.hs b/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Create.hs index 2b947f7ac62..05d9a484154 100644 --- a/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Create.hs +++ b/libs/cardano-protocol-tpraos/testlib/Test/Cardano/Protocol/TPraos/Create.hs @@ -222,7 +222,8 @@ evolveKESUntil sk1 (KESPeriod current) (KESPeriod target) = go sk1 current targe mkBlock :: forall era r. - ( EraSegWits era + ( TxStructure era ~ StrictSeq + , EraSegWits era , VRF.Signable (VRF (EraCrypto era)) Seed , KES.Signable (KES (EraCrypto era)) (BHBody (EraCrypto era)) ) => @@ -247,7 +248,7 @@ mkBlock :: Block (BHeader (EraCrypto era)) era mkBlock prev pKeys txns slotNo blockNo enonce kesPeriod keyRegKesPeriod oCert = let protVer = ProtVer (eraProtVerHigh @era) 0 - txseq = toTxZones @era (fmap StrictSeq.singleton (StrictSeq.fromList txns)) + txseq = toTxZones @era (StrictSeq.fromList txns) bodySize = fromIntegral $ bBodySize protVer txseq bodyHash = hashTxZones @era txseq bhBody = mkBHBody protVer prev pKeys slotNo blockNo enonce oCert bodySize bodyHash @@ -257,7 +258,8 @@ mkBlock prev pKeys txns slotNo blockNo enonce kesPeriod keyRegKesPeriod oCert = -- | Create a block with a faked VRF result. mkBlockFakeVRF :: forall era r. - ( EraSegWits era + ( TxStructure era ~ StrictSeq + , EraSegWits era , VRF.Signable (VRF (EraCrypto era)) (WithResult Seed) , KES.Signable (KES (EraCrypto era)) (BHBody (EraCrypto era)) ) => @@ -286,7 +288,7 @@ mkBlockFakeVRF :: Block (BHeader (EraCrypto era)) era mkBlockFakeVRF prev pKeys txns slotNo blockNo enonce bnonce l kesPeriod keyRegKesPeriod oCert = let protVer = ProtVer (eraProtVerHigh @era) 0 - txSeq = toTxZones @era (fmap StrictSeq.singleton (StrictSeq.fromList txns)) + txSeq = toTxZones @era (StrictSeq.fromList txns) bodySize = fromIntegral $ bBodySize protVer txSeq bodyHash = hashTxZones txSeq bhBody = From 1933c99f80aeef420b4b4e6dd99630f5fee81ae2 Mon Sep 17 00:00:00 2001 From: Will Gould Date: Tue, 2 Jul 2024 18:43:39 +0100 Subject: [PATCH 10/19] Parameterised ShelleyBbodyState as solution to LedgerState rigidity --- .../impl/src/Cardano/Ledger/Allegra.hs | 3 +- .../Test/Cardano/Ledger/Allegra/Imp.hs | 5 +- .../Test/Cardano/Ledger/Allegra/ImpTest.hs | 9 +- eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs | 9 +- .../src/Cardano/Ledger/Alonzo/Rules/Bbody.hs | 6 +- .../testlib/Test/Cardano/Ledger/Alonzo/Imp.hs | 12 +- .../Cardano/Ledger/Alonzo/Imp/UtxosSpec.hs | 47 ++-- .../Test/Cardano/Ledger/Alonzo/ImpTest.hs | 117 ++++++---- .../impl/src/Cardano/Ledger/Babbage.hs | 2 +- .../Test/Cardano/Ledger/Babbage/Imp.hs | 4 +- .../Test/Cardano/Ledger/Babbage/ImpTest.hs | 9 +- eras/babel/impl/src/Cardano/Ledger/Babel.hs | 10 +- .../Cardano/Ledger/Babel/LedgerState/Types.hs | 106 +++++++++ .../src/Cardano/Ledger/Babel/Rules/Bbody.hs | 4 +- .../src/Cardano/Ledger/Babel/Rules/Ledger.hs | 109 +++++++-- .../src/Cardano/Ledger/Babel/Rules/Ledgers.hs | 11 +- .../src/Cardano/Ledger/Babel/Rules/Utxo.hs | 13 +- .../src/Cardano/Ledger/Babel/Rules/Utxos.hs | 131 ++++++++--- .../src/Cardano/Ledger/Babel/Rules/Utxow.hs | 17 +- .../src/Cardano/Ledger/Babel/Rules/Zone.hs | 21 +- .../Cardano/Ledger/Babel/Binary/Regression.hs | 25 +- .../testlib/Test/Cardano/Ledger/Babel/Imp.hs | 3 +- .../Cardano/Ledger/Babel/Imp/EnactSpec.hs | 3 +- .../Test/Cardano/Ledger/Babel/Imp/GovSpec.hs | 16 +- .../Cardano/Ledger/Babel/Imp/UtxosSpec.hs | 6 +- .../Test/Cardano/Ledger/Babel/ImpTest.hs | 76 +++--- .../Test/Cardano/Ledger/Babel/Rules/Chain.hs | 9 +- .../src/Test/Cardano/Ledger/Babel/Utils.hs | 2 +- eras/conway/impl/src/Cardano/Ledger/Conway.hs | 2 +- .../Ledger/Conway/Binary/Regression.hs | 42 ++-- .../testlib/Test/Cardano/Ledger/Conway/Imp.hs | 9 +- .../Cardano/Ledger/Conway/Imp/EnactSpec.hs | 56 +++-- .../Test/Cardano/Ledger/Conway/Imp/GovSpec.hs | 76 +++--- .../Cardano/Ledger/Conway/Imp/RatifySpec.hs | 139 ++++++----- .../Cardano/Ledger/Conway/Imp/UtxoSpec.hs | 13 +- .../Cardano/Ledger/Conway/Imp/UtxosSpec.hs | 176 ++++++++------ .../Test/Cardano/Ledger/Conway/ImpTest.hs | 216 +++++++++++------- eras/mary/impl/src/Cardano/Ledger/Mary.hs | 3 +- .../testlib/Test/Cardano/Ledger/Mary/Imp.hs | 8 +- .../Test/Cardano/Ledger/Mary/Imp/UtxoSpec.hs | 21 +- .../Test/Cardano/Ledger/Mary/ImpTest.hs | 10 +- .../src/Cardano/Ledger/Shelley/API/Mempool.hs | 28 ++- .../Cardano/Ledger/Shelley/API/Validation.hs | 19 +- .../src/Cardano/Ledger/Shelley/LedgerState.hs | 1 + .../Ledger/Shelley/LedgerState/Types.hs | 14 ++ .../src/Cardano/Ledger/Shelley/Rules/Bbody.hs | 12 +- .../Test/Cardano/Ledger/Shelley/Imp.hs | 11 +- .../Cardano/Ledger/Shelley/Imp/EpochSpec.hs | 5 +- .../Cardano/Ledger/Shelley/Imp/LedgerSpec.hs | 17 +- .../Cardano/Ledger/Shelley/Imp/UtxoSpec.hs | 16 +- .../Cardano/Ledger/Shelley/Imp/UtxowSpec.hs | 3 +- .../Test/Cardano/Ledger/Shelley/ImpTest.hs | 211 +++++++++++------ .../test-suite/bench/BenchValidation.hs | 16 +- .../bench/Cardano/Ledger/Shelley/Bench/Gen.hs | 2 +- .../Cardano/Ledger/Shelley/Generator/Block.hs | 8 +- .../Ledger/Shelley/Generator/Trace/Chain.hs | 4 +- .../Cardano/Ledger/Shelley/Rules/Chain.hs | 4 +- .../Cardano/Ledger/Shelley/Rules/TestChain.hs | 2 +- .../src/Test/Cardano/Ledger/Shelley/Utils.hs | 2 +- libs/cardano-ledger-api/test/Tests.hs | 3 +- .../Cardano/Ledger/Conformance/Spec/Conway.hs | 3 +- .../bench/Bench/Cardano/Ledger/ApplyTx.hs | 1 + .../Cardano/Ledger/Examples/AlonzoBBODY.hs | 4 +- .../Cardano/Ledger/Examples/STSTestUtils.hs | 4 +- .../Test/Cardano/Ledger/Generic/PrettyCore.hs | 4 +- .../src/Test/Cardano/Ledger/TestableEra.hs | 4 +- libs/ledger-state/bench/Performance.hs | 1 + 67 files changed, 1293 insertions(+), 662 deletions(-) diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs index 3d7d0c8820c..85a70a64d7b 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -43,7 +44,7 @@ instance instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => - ApplyBlock (AllegraEra c) + ApplyBlock "LEDGERS" (AllegraEra c) instance Crypto c => CanStartFromGenesis (AllegraEra c) where fromShelleyPParams _ = translateEra' () diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp.hs index 357e802267f..1a1f9aef62a 100644 --- a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp.hs +++ b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Test.Cardano.Ledger.Allegra.Imp (spec) where @@ -13,8 +14,8 @@ import qualified Test.Cardano.Ledger.Shelley.Imp as ShelleyImp import Test.Cardano.Ledger.Shelley.ImpTest (ShelleyEraImp) spec :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era ) => diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs index 79384cc84ec..b42520f545c 100644 --- a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs +++ b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -18,6 +20,7 @@ import Cardano.Ledger.Allegra.Core import Cardano.Ledger.Allegra.Scripts (Timelock (..)) import Cardano.Ledger.Crypto (Crypto (..)) import Cardano.Ledger.Keys (KeyHash, KeyRole (..)) +import Cardano.Ledger.Shelley.LedgerState (LedgerState) import Control.Monad.State.Strict (get) import qualified Data.Map.Strict as Map import Data.Sequence.Strict (StrictSeq (..)) @@ -35,7 +38,7 @@ instance , DSIGN c ~ Ed25519DSIGN , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody) ) => - ShelleyEraImp (AllegraEra c) + ShelleyEraImp LedgerState (AllegraEra c) where initImpTestState = pure () @@ -44,7 +47,9 @@ instance fixupTx = shelleyFixupTx impAllegraSatisfyNativeScript :: - (ShelleyEraImp era, NativeScript era ~ Timelock era) => + ( ShelleyEraImp ls era + , NativeScript era ~ Timelock era + ) => Set.Set (KeyHash 'Witness (EraCrypto era)) -> NativeScript era -> ImpTestM era (Maybe (Map.Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era)))) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs index 65d8905a581..86a03caba7b 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs @@ -47,7 +47,7 @@ import Cardano.Ledger.Shelley.API.Mempool import Control.Arrow (left) import Control.Monad.Except (MonadError, liftEither) import Control.Monad.Reader (runReader) -import Control.State.Transition.Extended (TRC (TRC)) +import Control.State.Transition.Extended (STS (State), TRC (TRC)) type Alonzo = AlonzoEra StandardCrypto @@ -55,7 +55,10 @@ type Alonzo = AlonzoEra StandardCrypto reapplyAlonzoTx :: forall era m. - (API.ApplyTx era, MonadError (ApplyTxError era) m) => + ( API.ApplyTx era + , MonadError (ApplyTxError era) m + , State (EraRule "LEDGER" era) ~ API.LedgerState era + ) => Globals -> MempoolEnv era -> MempoolState era -> @@ -72,7 +75,7 @@ reapplyAlonzoTx globals env state vtx = instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyTx (AlonzoEra c) where reapplyTx = reapplyAlonzoTx -instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock (AlonzoEra c) +instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock "LEDGERS" (AlonzoEra c) instance Crypto c => API.CanStartFromGenesis (AlonzoEra c) where type AdditionalGenesisConfig (AlonzoEra c) = AlonzoGenesis 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 6ee9dd2da22..b5d98ba9d07 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs @@ -181,7 +181,7 @@ bbodyTransition :: , Signal (someBBODY era) ~ Block (BHeaderView (EraCrypto era)) era , PredicateFailure (someBBODY era) ~ AlonzoBbodyPredFailure era , BaseM (someBBODY era) ~ ShelleyBase - , State (someBBODY era) ~ ShelleyBbodyState era + , State (someBBODY era) ~ ShelleyBbodyState "LEDGERS" era , Environment (someBBODY era) ~ BbodyEnv era , Embed (EraRule "LEDGERS" era) (someBBODY era) , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era @@ -244,7 +244,7 @@ bbodyTransition = pointWiseExUnits (<=) txTotal ppMax ?! TooManyExUnits txTotal ppMax pure $ - BbodyState @era + BbodyState @"LEDGERS" @era ls' ( incrBlocks (isOverlaySlot firstSlotNo (pp ^. ppDG) slot) @@ -269,7 +269,7 @@ instance where type State (AlonzoBBODY era) = - ShelleyBbodyState era + ShelleyBbodyState "LEDGERS" era type Signal (AlonzoBBODY era) = diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs index e94c3527230..a3ccd1f9e14 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs @@ -4,19 +4,23 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Test.Cardano.Ledger.Alonzo.Imp where import Cardano.Ledger.Alonzo.Core import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure, ShelleyUtxowPredFailure) import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxosSpec as Utxos -import Test.Cardano.Ledger.Alonzo.ImpTest (MaryEraImp, withImpState) +import Test.Cardano.Ledger.Alonzo.ImpTest ( + MaryEraImp, + withImpState, + ) import Test.Cardano.Ledger.Common (Spec, describe) import qualified Test.Cardano.Ledger.Mary.Imp as MaryImp spec :: - forall era. - ( MaryEraImp era + forall era ls. + ( MaryEraImp ls era , AlonzoEraTx era , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era @@ -24,5 +28,5 @@ spec :: Spec spec = do MaryImp.spec @era - describe "AlonzoImpSpec" . withImpState @era $ do + describe "AlonzoImpSpec" . withImpState @ls @era $ do Utxos.spec @era diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxosSpec.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxosSpec.hs index 0cef49fc2cd..fe5580e7883 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxosSpec.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp/UtxosSpec.hs @@ -45,20 +45,24 @@ import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Core.Utils (txInAt) import Test.Cardano.Ledger.Plutus.Examples (guessTheNumber3) -submitProducingTx :: forall era. ShelleyEraImp era => ImpTestM era (TxIn (EraCrypto era)) +submitProducingTx :: + forall era ls. + ShelleyEraImp ls era => + ImpTestM era (TxIn (EraCrypto era)) submitProducingTx = fmap (txInAt (0 :: Int)) . submitTxAnn "Sumbit a transaction with a script output" $ mkBasicTx mkBasicTxBody - & bodyTxL . outputsTxBodyL - .~ SSeq.singleton - ( mkBasicTxOut - (Addr Testnet (ScriptHashObj $ hashPlutusScript (guessTheNumber3 SPlutusV1)) StakeRefNull) - (inject (Coin 100)) - ) + & bodyTxL + . outputsTxBodyL + .~ SSeq.singleton + ( mkBasicTxOut + (Addr Testnet (ScriptHashObj $ hashPlutusScript (guessTheNumber3 SPlutusV1)) StakeRefNull) + (inject (Coin 100)) + ) spec :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , AlonzoEraTx era ) => SpecWith (ImpTestState era) @@ -67,20 +71,25 @@ spec = describe "UTXOS" $ do txIn0 <- submitProducingTx submitTxAnn_ "Submit a transaction that consumes the script output" $ mkBasicTx mkBasicTxBody - & bodyTxL . inputsTxBodyL - .~ Set.singleton txIn0 + & bodyTxL + . inputsTxBodyL + .~ Set.singleton txIn0 it "Invalid plutus script fails in phase 2" $ do txIn0 <- submitProducingTx exUnits <- getsNES $ nesEsL . curPParamsEpochStateL . ppMaxTxExUnitsL impAnn "Submitting consuming transaction" $ submitTx_ ( mkBasicTx mkBasicTxBody - & bodyTxL . inputsTxBodyL .~ Set.singleton txIn0 - & isValidTxL .~ IsValid False - & witsTxL . rdmrsTxWitsL - .~ Redeemers - ( Map.singleton - (mkSpendingPurpose $ AsIx 0) - (Data $ P.I 32, exUnits) - ) + & bodyTxL + . inputsTxBodyL + .~ Set.singleton txIn0 + & isValidTxL + .~ IsValid False + & witsTxL + . rdmrsTxWitsL + .~ Redeemers + ( Map.singleton + (mkSpendingPurpose $ AsIx 0) + (Data $ P.I 32, exUnits) + ) ) diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs index 4359cb2a039..dcd5b8426cb 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs @@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -57,6 +58,7 @@ import Cardano.Ledger.Plutus.Language ( PlutusLanguage, ) import Cardano.Ledger.Shelley.LedgerState ( + LedgerState, NewEpochState, curPParamsEpochStateL, esLStateL, @@ -88,20 +90,20 @@ import Test.Cardano.Ledger.Plutus ( import Test.Cardano.Ledger.Plutus.Examples class - ( MaryEraImp era + ( MaryEraImp ls era , AlonzoEraScript era , AlonzoEraTxWits era , AlonzoEraTx era , AlonzoEraUTxO era ) => - AlonzoEraImp era + AlonzoEraImp ls era where scriptTestContexts :: Map (ScriptHash (EraCrypto era)) ScriptTestContext initAlonzoImpNES :: - forall era. + forall era ls. ( AlonzoEraPParams era - , ShelleyEraImp era + , ShelleyEraImp ls era , AlonzoEraScript era ) => NewEpochState era -> @@ -110,13 +112,17 @@ initAlonzoImpNES = nesEsL . curPParamsEpochStateL %~ initPParams where initPParams pp = pp - & ppMaxValSizeL .~ 1_000_000_000 - & ppMaxTxExUnitsL .~ ExUnits 10_000_000 10_000_000 + & ppMaxValSizeL + .~ 1_000_000_000 + & ppMaxTxExUnitsL + .~ ExUnits 10_000_000 10_000_000 & ppCostModelsL - .~ testingCostModels - [PlutusV1 .. eraMaxLanguage @era] + .~ testingCostModels + [PlutusV1 .. eraMaxLanguage @era] -makeCollateralInput :: ShelleyEraImp era => ImpTestM era (TxIn (EraCrypto era)) +makeCollateralInput :: + ShelleyEraImp ls era => + ImpTestM era (TxIn (EraCrypto era)) makeCollateralInput = do -- TODO: make more accurate let collateral = Coin 10_000_000 @@ -124,7 +130,9 @@ makeCollateralInput = do withFixup fixupTx $ sendCoinTo addr collateral addCollateralInput :: - (AlonzoEraImp era, ScriptsNeeded era ~ AlonzoScriptsNeeded era) => + ( AlonzoEraImp ls era + , ScriptsNeeded era ~ AlonzoScriptsNeeded era + ) => Tx era -> ImpTestM era (Tx era) addCollateralInput tx = impAnn "addCollateralInput" $ do @@ -135,19 +143,21 @@ addCollateralInput tx = impAnn "addCollateralInput" $ do collateralInput <- makeCollateralInput pure $ tx - & bodyTxL . collateralInputsTxBodyL <>~ Set.singleton collateralInput + & bodyTxL + . collateralInputsTxBodyL + <>~ Set.singleton collateralInput impLookupPlutusScriptMaybe :: - forall era. - AlonzoEraImp era => + forall era ls. + AlonzoEraImp ls era => ScriptHash (EraCrypto era) -> Maybe (PlutusScript era) impLookupPlutusScriptMaybe sh = (\(ScriptTestContext plutus _) -> mkPlutusScript plutus) =<< impGetScriptContextMaybe @era sh impGetPlutusContexts :: - forall era. - (ScriptsNeeded era ~ AlonzoScriptsNeeded era, AlonzoEraImp era) => + forall era ls. + (ScriptsNeeded era ~ AlonzoScriptsNeeded era, AlonzoEraImp ls era) => Tx era -> ImpTestM era @@ -161,8 +171,8 @@ impGetPlutusContexts tx = do pure $ catMaybes mbyContexts fixupRedeemerIndices :: - forall era. - AlonzoEraImp era => + forall era ls. + AlonzoEraImp ls era => Tx era -> ImpTestM era (Tx era) fixupRedeemerIndices tx = impAnn "fixupRedeemerIndices" $ do @@ -175,13 +185,14 @@ fixupRedeemerIndices tx = impAnn "fixupRedeemerIndices" $ do updateIndex x = x pure $ tx - & witsTxL . rdmrsTxWitsL - %~ (\(Redeemers m) -> Redeemers $ Map.mapKeys updateIndex m) + & witsTxL + . rdmrsTxWitsL + %~ (\(Redeemers m) -> Redeemers $ Map.mapKeys updateIndex m) fixupRedeemers :: - forall era. + forall era ls. ( ScriptsNeeded era ~ AlonzoScriptsNeeded era - , AlonzoEraImp era + , AlonzoEraImp ls era ) => Tx era -> ImpTestM era (Tx era) @@ -195,12 +206,14 @@ fixupRedeemers tx = impAnn "fixupRedeemers" $ do newRedeemers = Map.fromList (mkNewRedeemers <$> contexts) pure $ tx - & witsTxL . rdmrsTxWitsL .~ Redeemers (Map.union oldRedeemers newRedeemers) + & witsTxL + . rdmrsTxWitsL + .~ Redeemers (Map.union oldRedeemers newRedeemers) fixupScriptWits :: - forall era. + forall era ls. ( ScriptsNeeded era ~ AlonzoScriptsNeeded era - , AlonzoEraImp era + , AlonzoEraImp ls era ) => Tx era -> ImpTestM era (Tx era) @@ -223,13 +236,15 @@ fixupScriptWits tx = impAnn "fixupScriptWits" $ do (sh,) <$> plutusToScript plutus pure $ tx - & witsTxL . scriptTxWitsL <>~ Map.fromList scriptWits + & witsTxL + . scriptTxWitsL + <>~ Map.fromList scriptWits fixupDatums :: - forall era. + forall era ls. ( HasCallStack , ScriptsNeeded era ~ AlonzoScriptsNeeded era - , AlonzoEraImp era + , AlonzoEraImp ls era ) => Tx era -> ImpTestM era (Tx era) @@ -240,19 +255,20 @@ fixupDatums tx = impAnn "fixupDatums" $ do let TxDats prevDats = tx ^. witsTxL . datsTxWitsL pure $ tx - & witsTxL . datsTxWitsL - .~ TxDats - (Map.union prevDats $ fromElems hashData (catMaybes datums)) + & witsTxL + . datsTxWitsL + .~ TxDats + (Map.union prevDats $ fromElems hashData (catMaybes datums)) where collectDatums :: PlutusPurpose AsIxItem era -> ImpTestM era (Maybe (Data era)) collectDatums purpose = do let txIn = unAsItem <$> toSpendingPurpose (hoistPlutusPurpose toAsItem purpose) - txOut <- traverse (impLookupUTxO @era) txIn + txOut <- traverse (impLookupUTxO @ls @era) txIn pure $ getData =<< txOut getData :: TxOut era -> Maybe (Data era) getData txOut = case txOut ^. datumTxOutF of - DatumHash _dh -> spendDatum <$> Map.lookup (txOutScriptHash txOut) (scriptTestContexts @era) + DatumHash _dh -> spendDatum <$> Map.lookup (txOutScriptHash txOut) (scriptTestContexts @ls @era) _ -> Nothing txOutScriptHash txOut @@ -263,8 +279,8 @@ fixupDatums tx = impAnn "fixupDatums" $ do spendDatum _ = error "Context does not have a spending datum" fixupPPHash :: - forall era. - AlonzoEraImp era => + forall era ls. + AlonzoEraImp ls era => Tx era -> ImpTestM era (Tx era) fixupPPHash tx = impAnn "fixupPPHash" $ do @@ -285,11 +301,13 @@ fixupPPHash tx = impAnn "fixupPPHash" $ do (tx ^. witsTxL . datsTxWitsL) pure $ tx - & bodyTxL . scriptIntegrityHashTxBodyL .~ integrityHash + & bodyTxL + . scriptIntegrityHashTxBodyL + .~ integrityHash fixupOutputDatums :: - forall era. - AlonzoEraImp era => + forall era ls. + AlonzoEraImp ls era => Tx era -> ImpTestM era (Tx era) fixupOutputDatums tx = impAnn "fixupOutputDatums" $ do @@ -307,18 +325,21 @@ fixupOutputDatums tx = impAnn "fixupOutputDatums" $ do expectJust mbySpendDatum pure $ txOut - & dataHashTxOutL .~ SJust (hashData @era $ Data spendDatum) + & dataHashTxOutL + .~ SJust (hashData @era $ Data spendDatum) _ -> pure txOut _ -> pure txOut newOutputs <- traverse addDatum $ tx ^. bodyTxL . outputsTxBodyL pure $ tx - & bodyTxL . outputsTxBodyL .~ newOutputs + & bodyTxL + . outputsTxBodyL + .~ newOutputs alonzoFixupTx :: ( ScriptsNeeded era ~ AlonzoScriptsNeeded era , HasCallStack - , AlonzoEraImp era + , AlonzoEraImp ls era ) => Tx era -> ImpTestM era (Tx era) @@ -379,7 +400,7 @@ instance , DSIGN c ~ Ed25519DSIGN , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody) ) => - ShelleyEraImp (AlonzoEra c) + ShelleyEraImp LedgerState (AlonzoEra c) where initImpTestState = impNESL %= initAlonzoImpNES impSatisfyNativeScript = impAllegraSatisfyNativeScript @@ -392,21 +413,21 @@ instance , DSIGN c ~ Ed25519DSIGN , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody) ) => - MaryEraImp (AlonzoEra c) + MaryEraImp LedgerState (AlonzoEra c) -instance MaryEraImp (AlonzoEra c) => AlonzoEraImp (AlonzoEra c) where +instance MaryEraImp LedgerState (AlonzoEra c) => AlonzoEraImp LedgerState (AlonzoEra c) where scriptTestContexts = plutusTestScripts SPlutusV1 impGetScriptContextMaybe :: - forall era. - AlonzoEraImp era => + forall era ls. + AlonzoEraImp ls era => ScriptHash (EraCrypto era) -> Maybe ScriptTestContext -impGetScriptContextMaybe sh = Map.lookup sh $ scriptTestContexts @era +impGetScriptContextMaybe sh = Map.lookup sh $ scriptTestContexts @ls @era impGetScriptContext :: - forall era. - AlonzoEraImp era => + forall era ls. + AlonzoEraImp ls era => ScriptHash (EraCrypto era) -> ImpTestM era ScriptTestContext impGetScriptContext sh = diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs index 87b4a4b2260..f62b062b9da 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs @@ -45,7 +45,7 @@ type Babbage = BabbageEra StandardCrypto instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyTx (BabbageEra c) where reapplyTx = reapplyAlonzoTx -instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock (BabbageEra c) +instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock "LEDGERS" (BabbageEra c) instance Crypto c => API.CanStartFromGenesis (BabbageEra c) where type AdditionalGenesisConfig (BabbageEra c) = AlonzoGenesis diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp.hs index 58ebc74c333..318cb09a2db 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp.hs @@ -14,8 +14,8 @@ import Test.Cardano.Ledger.Alonzo.ImpTest (AlonzoEraImp) import Test.Cardano.Ledger.Common spec :: - forall era. - ( AlonzoEraImp era + forall era ls. + ( AlonzoEraImp ls era , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era ) => diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/ImpTest.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/ImpTest.hs index f41d22a4673..8309e0a7fbb 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/ImpTest.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/ImpTest.hs @@ -1,5 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -17,6 +19,7 @@ import Cardano.Ledger.Babbage (BabbageEra) import Cardano.Ledger.Core import Cardano.Ledger.Crypto (Crypto (..)) import Cardano.Ledger.Plutus.Language (SLanguage (..)) +import Cardano.Ledger.Shelley.LedgerState (LedgerState) import Lens.Micro.Mtl ((%=)) import Test.Cardano.Ledger.Alonzo.ImpTest import Test.Cardano.Ledger.Babbage.TreeDiff () @@ -29,13 +32,13 @@ instance , DSIGN c ~ Ed25519DSIGN , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody) ) => - ShelleyEraImp (BabbageEra c) + ShelleyEraImp LedgerState (BabbageEra c) where initImpTestState = impNESL %= initAlonzoImpNES impSatisfyNativeScript = impAllegraSatisfyNativeScript fixupTx = alonzoFixupTx -instance ShelleyEraImp (BabbageEra c) => MaryEraImp (BabbageEra c) +instance ShelleyEraImp ls (BabbageEra c) => MaryEraImp ls (BabbageEra c) -instance ShelleyEraImp (BabbageEra c) => AlonzoEraImp (BabbageEra c) where +instance ShelleyEraImp ls (BabbageEra c) => AlonzoEraImp ls (BabbageEra c) where scriptTestContexts = plutusTestScripts SPlutusV1 <> plutusTestScripts SPlutusV2 diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel.hs b/eras/babel/impl/src/Cardano/Ledger/Babel.hs index 03cc5486262..02434e43506 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel.hs @@ -53,6 +53,9 @@ import Cardano.Ledger.Babbage.Transition () import Cardano.Ledger.Babbage.Translation () import Cardano.Ledger.Babbage.TxInfo () import Cardano.Ledger.Babbage.UTxO () +import Cardano.Ledger.Babel.LedgerState.Types (LedgerStateTemp) +import Cardano.Ledger.Shelley.LedgerState (HasLedgerState (from)) +import Data.Default.Class (Default) type Babel = BabelEra StandardCrypto @@ -64,8 +67,9 @@ instance , DSignable c (Hash c EraIndependentRequiredTxs) , -- TODO WG figure out what you've done wrong to introduce this constraint Signable (DSIGN c) (Cardano.Crypto.Hash.Class.Hash c EraIndependentTxBody) + , Default (LedgerStateTemp (BabelEra c)) ) => - ApplyBlock (BabelEra c) + ApplyBlock "ZONES" (BabelEra c) instance ( Crypto c @@ -79,8 +83,8 @@ instance flip runReader globals . applySTSNonStatic @(EraRule "LEDGER" (BabelEra c)) - $ TRC (env, state, extractTx vtx) - in liftEither . left ApplyTxError $ res + $ TRC (env, from state, extractTx vtx) + in liftEither . left ApplyTxError $ from <$> res instance Crypto c => CanStartFromGenesis (BabelEra c) where type AdditionalGenesisConfig (BabelEra c) = BabelGenesis c diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs index 84c828a355c..b9f3d3bf6c1 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs @@ -23,14 +23,18 @@ module Cardano.Ledger.Babel.LedgerState.Types where import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Conway.Core (EraCrypto, EraGov, EraTxOut, GovState) import Cardano.Ledger.FRxO (FRxO) +import Cardano.Ledger.Shelley.API (LedgerState (..), UTxOState (..)) import Cardano.Ledger.Shelley.LedgerState ( CertState, + HasLedgerState (..), IncrementalStake, ) import Cardano.Ledger.UTxO (UTxO) import Control.DeepSeq (NFData) import Data.Default.Class (Default (def)) import GHC.Generics (Generic) +import Lens.Micro (lens, (&), (.~), (^.)) +import Lens.Micro.Type (Lens') -- type instance Ledger (ConwayEra c) = LedgerStateTemp (ConwayEra c) @@ -42,6 +46,17 @@ data LedgerStateTemp era = LedgerStateTemp } deriving (Generic) +instance Default (UTxOStateTemp era) => Default (LedgerStateTemp era) where + def = LedgerStateTemp def def + +instance HasLedgerState LedgerStateTemp era where + hlsUtxoStateL = lens getter setter + where + getter s = toUTxOState (s ^. lstUtxoStateL) + setter s b = s & lstUtxoStateL .~ fromUTxOState b + hlsCertStateL = lstCertStateL + mkLedgerState utxos = LedgerStateTemp (fromUTxOState utxos) + deriving stock instance ( EraTxOut era , Show (GovState era) @@ -54,6 +69,68 @@ deriving stock instance ) => Eq (LedgerStateTemp era) +-- Conversion + +-- | Convert from LedgerState to LedgerStateTemp +fromLedgerState :: LedgerState era -> LedgerStateTemp era +fromLedgerState LedgerState {lsUTxOState, lsCertState} = + LedgerStateTemp + { lstUTxOState = fromUTxOState lsUTxOState + , lstCertState = lsCertState + } + +-- | Convert from UTxOState to UTxOStateTemp +fromUTxOState :: UTxOState era -> UTxOStateTemp era +fromUTxOState + UTxOState + { utxosUtxo + , utxosFrxo + , utxosDeposited + , utxosFees + , utxosGovState + , utxosStakeDistr + , utxosDonation + } = + UTxOStateTemp + { utxostUtxo = utxosUtxo + , utxostFrxo = utxosFrxo + , utxostDeposited = utxosDeposited + , utxostFees = utxosFees + , utxostGovState = utxosGovState + , utxostStakeDistr = utxosStakeDistr + , utxostDonation = utxosDonation + } + +-- | Convert from LedgerStateTemp to LedgerState +toLedgerState :: LedgerStateTemp era -> LedgerState era +toLedgerState LedgerStateTemp {lstUTxOState, lstCertState} = + LedgerState + { lsUTxOState = toUTxOState lstUTxOState + , lsCertState = lstCertState + } + +-- | Convert from UTxOStateTemp to UTxOState +toUTxOState :: UTxOStateTemp era -> UTxOState era +toUTxOState + UTxOStateTemp + { utxostUtxo + , utxostFrxo + , utxostDeposited + , utxostFees + , utxostGovState + , utxostStakeDistr + , utxostDonation + } = + UTxOState + { utxosUtxo = utxostUtxo + , utxosFrxo = utxostFrxo + , utxosDeposited = utxostDeposited + , utxosFees = utxostFees + , utxosGovState = utxostGovState + , utxosStakeDistr = utxostStakeDistr + , utxosDonation = utxostDonation + } + -------- data UTxOStateTemp era = UTxOStateTemp @@ -68,6 +145,35 @@ data UTxOStateTemp era = UTxOStateTemp } deriving (Generic) +-- Lenses + +lstUtxoStateL :: Lens' (LedgerStateTemp era) (UTxOStateTemp era) +lstUtxoStateL = lens lstUTxOState (\s x -> s {lstUTxOState = x}) + +lstCertStateL :: Lens' (LedgerStateTemp era) (CertState era) +lstCertStateL = lens lstCertState (\s x -> s {lstCertState = x}) + +utxostUtxoL :: Lens' (UTxOStateTemp era) (UTxO era) +utxostUtxoL = lens utxostUtxo (\s x -> s {utxostUtxo = x}) + +utxostFrxoL :: Lens' (UTxOStateTemp era) (FRxO era) +utxostFrxoL = lens utxostFrxo (\s x -> s {utxostFrxo = x}) + +utxostDepositedL :: Lens' (UTxOStateTemp era) Coin +utxostDepositedL = lens utxostDeposited (\s x -> s {utxostDeposited = x}) + +utxostFeesL :: Lens' (UTxOStateTemp era) Coin +utxostFeesL = lens utxostFees (\s x -> s {utxostFees = x}) + +utxostGovStateL :: Lens' (UTxOStateTemp era) (GovState era) +utxostGovStateL = lens utxostGovState (\s x -> s {utxostGovState = x}) + +utxostStakeDistrL :: Lens' (UTxOStateTemp era) (IncrementalStake (EraCrypto era)) +utxostStakeDistrL = lens utxostStakeDistr (\s x -> s {utxostStakeDistr = x}) + +utxostDonationL :: Lens' (UTxOStateTemp era) Coin +utxostDonationL = lens utxostDonation (\s x -> s {utxostDonation = x}) + -- ==================================================== -------------------------------------------------------------------------------- diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs index fb21ae5a5ac..b3c98d8d7f3 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs @@ -129,11 +129,10 @@ instance , Signal (EraRule "ZONES" era) ~ Seq (Seq (Tx era)) , Eq (PredicateFailure (EraRule "LEDGERS" era)) , Show (PredicateFailure (EraRule "LEDGERS" era)) - , State (EraRule "LEDGERS" era) ~ State (EraRule "ZONES" era) ) => STS (BabelBBODY era) where - type State (BabelBBODY era) = ShelleyBbodyState era + type State (BabelBBODY era) = ShelleyBbodyState "ZONES" era type Signal (BabelBBODY era) = Block (BHeaderView (EraCrypto era)) era @@ -156,7 +155,6 @@ bbodyTransition :: , Embed (EraRule "ZONES" era) (BabelBBODY era) , Environment (EraRule "ZONES" era) ~ ShelleyLedgersEnv era , Signal (EraRule "ZONES" era) ~ Seq (Seq (Tx era)) - , State (EraRule "LEDGERS" era) ~ State (EraRule "ZONES" era) ) => TransitionRule (BabelBBODY era) bbodyTransition = diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledger.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledger.hs index ca5eecb7e46..c169becb385 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledger.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledger.hs @@ -4,6 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -40,6 +41,12 @@ import Cardano.Ledger.Babel.Era ( BabelLEDGER, BabelUTXOW, ) +import Cardano.Ledger.Babel.LedgerState.Types ( + LedgerStateTemp (..), + UTxOStateTemp (utxostGovState, utxostUtxo), + utxostDepositedL, + utxostGovStateL, + ) import Cardano.Ledger.Babel.Rules.Cert () import Cardano.Ledger.Babel.Rules.Certs () import Cardano.Ledger.Babel.Rules.Deleg () @@ -51,6 +58,7 @@ import Cardano.Ledger.Babel.Rules.Utxow (BabelUtxowPredFailure) import Cardano.Ledger.BaseTypes (ShelleyBase, StrictMaybe (..), epochInfoPure) import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) import Cardano.Ledger.Binary.Coders +import Cardano.Ledger.CertState (Obligations, obligationCertState, sumObligation) import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Governance ( @@ -80,14 +88,12 @@ import Cardano.Ledger.Conway.Rules ( import Cardano.Ledger.Credential (Credential) import Cardano.Ledger.Crypto (Crypto (..)) import Cardano.Ledger.Keys (KeyRole (..)) +import Cardano.Ledger.Shelley.AdaPots (consumedTxBody, producedTxBody) import Cardano.Ledger.Shelley.LedgerState ( CertState (..), DState (..), - LedgerState (..), - UTxOState (..), asTreasuryL, certVStateL, - utxosGovStateL, vsCommitteeStateL, ) import Cardano.Ledger.Shelley.Rules ( @@ -96,9 +102,8 @@ import Cardano.Ledger.Shelley.Rules ( ShelleyUtxoPredFailure, ShelleyUtxowPredFailure, UtxoEnv (..), - renderDepositEqualsObligationViolation, - shelleyLedgerAssertions, ) +import Cardano.Ledger.Shelley.Rules.Reports (showTxCerts) import Cardano.Ledger.Slot (epochInfoEpoch) import Cardano.Ledger.UMap (UView (..), dRepMap) import qualified Cardano.Ledger.UMap as UMap @@ -107,6 +112,8 @@ import Control.DeepSeq (NFData) import Control.Monad (when) import Control.Monad.Trans.Reader (asks) import Control.State.Transition.Extended ( + Assertion (PostCondition), + AssertionViolation (..), Embed (..), STS (..), TRC (..), @@ -278,7 +285,7 @@ instance , Embed (EraRule "UTXOW" era) (BabelLEDGER era) , Embed (EraRule "GOV" era) (BabelLEDGER era) , Embed (EraRule "CERTS" era) (BabelLEDGER era) - , State (EraRule "UTXOW" era) ~ UTxOState era + , State (EraRule "UTXOW" era) ~ UTxOStateTemp era , State (EraRule "CERTS" era) ~ CertState era , State (EraRule "GOV" era) ~ Proposals era , Environment (EraRule "UTXOW" era) ~ UtxoEnv era @@ -290,7 +297,7 @@ instance ) => STS (BabelLEDGER era) where - type State (BabelLEDGER era) = LedgerState era + type State (BabelLEDGER era) = LedgerStateTemp era type Signal (BabelLEDGER era) = Tx era type Environment (BabelLEDGER era) = LedgerEnv era type BaseM (BabelLEDGER era) = ShelleyBase @@ -302,7 +309,7 @@ instance renderAssertionViolation = renderDepositEqualsObligationViolation - assertions = shelleyLedgerAssertions @era @BabelLEDGER + assertions = babelLedgerAssertions @era @BabelLEDGER -- ======================================= @@ -313,13 +320,13 @@ ledgerTransition :: , ConwayEraGov era , GovState era ~ ConwayGovState era , Signal (someLEDGER era) ~ Tx era - , State (someLEDGER era) ~ LedgerState era + , State (someLEDGER era) ~ LedgerStateTemp era , Environment (someLEDGER era) ~ LedgerEnv era , PredicateFailure (someLEDGER era) ~ BabelLedgerPredFailure era , Embed (EraRule "UTXOW" era) (someLEDGER era) , Embed (EraRule "GOV" era) (someLEDGER era) , Embed (EraRule "CERTS" era) (someLEDGER era) - , State (EraRule "UTXOW" era) ~ UTxOState era + , State (EraRule "UTXOW" era) ~ UTxOStateTemp era , State (EraRule "CERTS" era) ~ CertState era , State (EraRule "GOV" era) ~ Proposals era , Environment (EraRule "UTXOW" era) ~ UtxoEnv era @@ -333,7 +340,7 @@ ledgerTransition :: ) => TransitionRule (someLEDGER era) ledgerTransition = do - TRC (LedgerEnv slot _txIx pp account, LedgerState utxoState certState, tx) <- judgmentContext + TRC (LedgerEnv slot _txIx pp account, LedgerStateTemp utxoState certState, tx) <- judgmentContext let actualTreasuryValue = account ^. asTreasuryL in case tx ^. bodyTxL . currentTreasuryValueTxBodyL of @@ -382,15 +389,15 @@ ledgerTransition = do (txIdTxBody txBody) currentEpoch pp - (utxoState ^. utxosGovStateL . proposalsGovStateL . pRootsL . L.to toPrevGovActionIds) - (utxoState ^. utxosGovStateL . constitutionGovStateL . constitutionScriptL) + (utxoState ^. utxostGovStateL . proposalsGovStateL . pRootsL . L.to toPrevGovActionIds) + (utxoState ^. utxostGovStateL . constitutionGovStateL . constitutionScriptL) (certState ^. certVStateL . vsCommitteeStateL) - , utxoState ^. utxosGovStateL . proposalsGovStateL + , utxoState ^. utxostGovStateL . proposalsGovStateL , govProcedures ) let utxoState' = utxoState - & utxosGovStateL + & utxostGovStateL . proposalsGovStateL .~ proposalsState pure (utxoState', certStateAfterCERTS) @@ -408,7 +415,7 @@ ledgerTransition = do , utxoState' , tx ) - pure $ LedgerState utxoState'' certStateAfterCERTS + pure $ LedgerStateTemp utxoState'' certStateAfterCERTS instance ( EraTx era @@ -448,7 +455,7 @@ instance , EraUTxO era , BabbageEraTxBody era , Embed (EraRule "UTXO" era) (BabelUTXOW era) - , State (EraRule "UTXO" era) ~ UTxOState era + , State (EraRule "UTXO" era) ~ UTxOStateTemp era , Environment (EraRule "UTXO" era) ~ UtxoEnv era , Script era ~ AlonzoScript era , TxOut era ~ BabbageTxOut era @@ -464,3 +471,71 @@ instance where wrapFailed = BabelUtxowFailure wrapEvent = UtxowEvent + +-- Helpers + +renderDepositEqualsObligationViolation :: + ( EraTx era + , EraGov era + , Environment t ~ LedgerEnv era + , Signal t ~ Tx era + , State t ~ LedgerStateTemp era + ) => + AssertionViolation t -> + String +renderDepositEqualsObligationViolation + AssertionViolation {avSTS, avMsg, avCtx = TRC (LedgerEnv slot _ pp _, _, tx), avState} = + case avState of + Nothing -> "\nAssertionViolation " ++ avSTS ++ " " ++ avMsg ++ " (avState is Nothing)." + Just lstate -> + let certstate = lstCertState lstate + utxoSt = lstUTxOState lstate + utxo = utxostUtxo utxoSt + txb = tx ^. bodyTxL + pot = utxoSt ^. utxostDepositedL + in "\n\nAssertionViolation (" + <> avSTS + <> ")\n\n " + <> avMsg + <> "\n\nCERTS\n" + <> showTxCerts txb + <> "\n(slot,keyDeposit,poolDeposit) " + <> show (slot, pp ^. ppKeyDepositL, pp ^. ppPoolDepositL) + <> "\nThe Pot (utxosDeposited) = " + <> show pot + <> "\n" + <> show (allObligations certstate (utxostGovState utxoSt)) + <> "\nConsumed = " + <> show (consumedTxBody txb pp certstate utxo) + <> "\nProduced = " + <> show (producedTxBody txb pp certstate) + +babelLedgerAssertions :: + ( EraGov era + , State (rule era) ~ LedgerStateTemp era + ) => + [Assertion (rule era)] +babelLedgerAssertions = + [ PostCondition + "Deposit pot must equal obligation (LEDGER)" + ( \(TRC (_, _, _)) + (LedgerStateTemp utxoSt dpstate) -> potEqualsObligation dpstate utxoSt + ) + ] + +potEqualsObligation :: + EraGov era => + CertState era -> + UTxOStateTemp era -> + Bool +potEqualsObligation certState utxoSt = obligations == pot + where + obligations = totalObligation certState (utxoSt ^. utxostGovStateL) + pot = utxoSt ^. utxostDepositedL + +allObligations :: EraGov era => CertState era -> GovState era -> Obligations +allObligations certState govState = + obligationCertState certState <> obligationGovState govState + +totalObligation :: EraGov era => CertState era -> GovState era -> Coin +totalObligation certState govState = sumObligation (allObligations certState govState) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledgers.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledgers.hs index 4df25a0ad8e..3d1e888ddf9 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledgers.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledgers.hs @@ -19,6 +19,7 @@ module Cardano.Ledger.Babel.Rules.Ledgers (BabelLEDGERS, BabelLedgersEnv (..)) w import Cardano.Ledger.Alonzo.Rules (AlonzoUtxosPredFailure) import Cardano.Ledger.Babel.Era (BabelEra, BabelLEDGERS) +import Cardano.Ledger.Babel.LedgerState.Types (LedgerStateTemp) import Cardano.Ledger.Babel.Rules.Ledger (BabelLEDGER, BabelLedgerEvent, BabelLedgerPredFailure) import Cardano.Ledger.Babel.Rules.Pool () import Cardano.Ledger.Babel.Rules.Utxo (BabelUtxoPredFailure) @@ -27,7 +28,7 @@ import Cardano.Ledger.Babel.Rules.Utxow (BabelUtxowPredFailure) import Cardano.Ledger.BaseTypes (ShelleyBase) import Cardano.Ledger.Core import Cardano.Ledger.Keys (DSignable, Hash) -import Cardano.Ledger.Shelley.API.Types (AccountState, LedgerEnv (LedgerEnv), LedgerState) +import Cardano.Ledger.Shelley.API.Types (AccountState, LedgerEnv (LedgerEnv)) import Cardano.Ledger.Shelley.Rules ( ShelleyLedgersEvent (LedgerEvent), ShelleyLedgersPredFailure (..), @@ -81,14 +82,14 @@ instance ( Era era , Embed (EraRule "LEDGER" era) (BabelLEDGERS era) , Environment (EraRule "LEDGER" era) ~ LedgerEnv era - , State (EraRule "LEDGER" era) ~ LedgerState era + , State (EraRule "LEDGER" era) ~ LedgerStateTemp era , Signal (EraRule "LEDGER" era) ~ Tx era , DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody) - , Default (LedgerState era) + , Default (LedgerStateTemp era) ) => STS (BabelLEDGERS era) where - type State (BabelLEDGERS era) = LedgerState era + type State (BabelLEDGERS era) = LedgerStateTemp era type Signal (BabelLEDGERS era) = Seq (Tx era) type Environment (BabelLEDGERS era) = BabelLedgersEnv era type BaseM (BabelLEDGERS era) = ShelleyBase @@ -101,7 +102,7 @@ ledgersTransition :: forall era. ( Embed (EraRule "LEDGER" era) (BabelLEDGERS era) , Environment (EraRule "LEDGER" era) ~ LedgerEnv era - , State (EraRule "LEDGER" era) ~ LedgerState era + , State (EraRule "LEDGER" era) ~ LedgerStateTemp era , Signal (EraRule "LEDGER" era) ~ Tx era ) => TransitionRule (BabelLEDGERS era) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxo.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxo.hs index 905eaee5af6..332d41d5a07 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxo.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxo.hs @@ -49,6 +49,7 @@ import qualified Cardano.Ledger.Babbage.Rules as Babbage ( ) import Cardano.Ledger.Babel.Core import Cardano.Ledger.Babel.Era (BabelEra, BabelUTXO, BabelUTXOS) +import Cardano.Ledger.Babel.LedgerState.Types (UTxOStateTemp (..)) import Cardano.Ledger.Babel.Rules.Utxos ( BabelUtxosPredFailure (..), ) @@ -71,8 +72,6 @@ import Cardano.Ledger.Binary.Coders ( import Cardano.Ledger.Coin (Coin, DeltaCoin) import Cardano.Ledger.Plutus (ExUnits) import Cardano.Ledger.Rules.ValidationMode (Test, runTest, runTestOnSignal) -import Cardano.Ledger.Shelley.LedgerState (utxosUtxo) -import qualified Cardano.Ledger.Shelley.LedgerState as Shelley (UTxOState) import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure) import qualified Cardano.Ledger.Shelley.Rules as Shelley ( UtxoEnv (UtxoEnv), @@ -285,21 +284,21 @@ utxoTransition :: , InjectRuleFailure "UTXO" AlonzoUtxoPredFailure era , InjectRuleFailure "UTXO" BabbageUtxoPredFailure era , Environment (EraRule "UTXO" era) ~ Shelley.UtxoEnv era - , State (EraRule "UTXO" era) ~ Shelley.UTxOState era + , State (EraRule "UTXO" era) ~ UTxOStateTemp era , Signal (EraRule "UTXO" era) ~ AlonzoTx era , BaseM (EraRule "UTXO" era) ~ ShelleyBase , STS (EraRule "UTXO" era) , -- In this function we we call the UTXOS rule, so we need some assumptions Embed (EraRule "UTXOS" era) (EraRule "UTXO" era) , Environment (EraRule "UTXOS" era) ~ Shelley.UtxoEnv era - , State (EraRule "UTXOS" era) ~ Shelley.UTxOState era + , State (EraRule "UTXOS" era) ~ UTxOStateTemp era , Signal (EraRule "UTXOS" era) ~ Tx era , InjectRuleFailure "UTXO" BabelUtxoPredFailure era ) => TransitionRule (EraRule "UTXO" era) utxoTransition = do TRC (Shelley.UtxoEnv slot pp certState, utxos, tx) <- judgmentContext - let utxo = utxosUtxo utxos + let utxo = utxostUtxo utxos {- txb := txbody tx -} let txBody = body tx @@ -401,13 +400,13 @@ instance , InjectRuleFailure "UTXO" BabelUtxoPredFailure era , Embed (EraRule "UTXOS" era) (BabelUTXO era) , Environment (EraRule "UTXOS" era) ~ Shelley.UtxoEnv era - , State (EraRule "UTXOS" era) ~ Shelley.UTxOState era + , State (EraRule "UTXOS" era) ~ UTxOStateTemp era , Signal (EraRule "UTXOS" era) ~ Tx era , PredicateFailure (EraRule "UTXO" era) ~ BabelUtxoPredFailure era ) => STS (BabelUTXO era) where - type State (BabelUTXO era) = Shelley.UTxOState era + type State (BabelUTXO era) = UTxOStateTemp era type Signal (BabelUTXO era) = AlonzoTx era type Environment (BabelUTXO era) = Shelley.UtxoEnv era type BaseM (BabelUTXO era) = ShelleyBase diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs index ca07d304280..13eb8f563dc 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs @@ -26,15 +26,20 @@ module Cardano.Ledger.Babel.Rules.Utxos ( import Cardano.Ledger.Alonzo.Plutus.Context (ContextError, EraPlutusContext) import Cardano.Ledger.Alonzo.Plutus.Evaluate ( CollectError (..), + collectPlutusScriptsWithContext, + evalPlutusScripts, ) import Cardano.Ledger.Alonzo.Rules ( AlonzoUtxoEvent (..), AlonzoUtxoPredFailure (..), AlonzoUtxosEvent, AlonzoUtxosPredFailure, - TagMismatchDescription, + TagMismatchDescription (..), + invalidBegin, + invalidEnd, validBegin, validEnd, + when2Phase, ) import qualified Cardano.Ledger.Alonzo.Rules as Alonzo ( AlonzoUtxosEvent (..), @@ -44,44 +49,44 @@ import Cardano.Ledger.Alonzo.UTxO ( AlonzoEraUTxO, AlonzoScriptsNeeded, ) +import Cardano.Ledger.Babbage.Collateral (collAdaBalance, collOuts) import Cardano.Ledger.Babbage.Rules ( BabbageUTXO, BabbageUtxoPredFailure (..), - babbageEvalScriptsTxInvalid, expectScriptsToPass, ) import Cardano.Ledger.Babbage.Tx import Cardano.Ledger.Babel.Core import Cardano.Ledger.Babel.Era (BabelEra, BabelUTXOS) import Cardano.Ledger.Babel.FRxO (txfrxo) +import Cardano.Ledger.Babel.LedgerState.Types (UTxOStateTemp (..), utxostDonationL) import Cardano.Ledger.Babel.TxInfo () -import Cardano.Ledger.BaseTypes (ShelleyBase) +import Cardano.Ledger.BaseTypes (Globals (..), ShelleyBase) import Cardano.Ledger.Binary ( DecCBOR (..), EncCBOR (..), ) import Cardano.Ledger.Binary.Coders import Cardano.Ledger.CertState (certsTotalDepositsTxBody, certsTotalRefundsTxBody) -import Cardano.Ledger.Coin (Coin) +import Cardano.Ledger.Coin (Coin (Coin), DeltaCoin (..)) import Cardano.Ledger.Conway.Core (ConwayEraPParams, ConwayEraTxBody (treasuryDonationTxBodyL)) import Cardano.Ledger.Conway.Governance (ConwayGovState (..)) import Cardano.Ledger.FRxO (FRxO (FRxO, unFRxO)) -import Cardano.Ledger.Plutus ( - PlutusWithContext, - ) +import Cardano.Ledger.Plutus (PlutusWithContext, ScriptFailure (..)) +import Cardano.Ledger.Plutus.Evaluate (ScriptResult (..)) import Cardano.Ledger.SafeHash (SafeHash, hashAnnotated) import Cardano.Ledger.Shelley.LedgerState ( CertState, UTxOState (..), updateStakeDistribution, - utxosDonationL, ) import Cardano.Ledger.Shelley.Rules (UtxoEnv (..)) import Cardano.Ledger.UTxO (EraUTxO (..), UTxO (UTxO, unUTxO)) import Cardano.Ledger.Val ((<->)) import Control.DeepSeq (NFData) +import Control.Monad.Trans.Reader (asks) import Control.State.Transition.Extended -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.Map as Map import Data.MapExtras (extractKeys) import Debug.Trace (traceEvent) @@ -231,7 +236,7 @@ instance where type BaseM (BabelUTXOS era) = Cardano.Ledger.BaseTypes.ShelleyBase type Environment (BabelUTXOS era) = UtxoEnv era - type State (BabelUTXOS era) = UTxOState era + type State (BabelUTXOS era) = UTxOStateTemp era type Signal (BabelUTXOS era) = AlonzoTx era type PredicateFailure (BabelUTXOS era) = BabelUtxosPredFailure era type Event (BabelUTXOS era) = BabelUtxosEvent era @@ -269,18 +274,20 @@ utxosTransition :: , Signal (EraRule "UTXOS" era) ~ Tx era , STS (EraRule "UTXOS" era) , Environment (EraRule "UTXOS" era) ~ UtxoEnv era - , State (EraRule "UTXOS" era) ~ UTxOState era + , State (EraRule "UTXOS" era) ~ UTxOStateTemp era , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era , BaseM (EraRule "UTXOS" era) ~ ShelleyBase , InjectRuleEvent "UTXOS" AlonzoUtxosEvent era , InjectRuleEvent "UTXOS" BabelUtxosEvent era + , Event (EraRule "UTXOS" era) ~ BabelUtxosEvent era + , PredicateFailure (EraRule "UTXOS" era) ~ BabelUtxosPredFailure era ) => TransitionRule (EraRule "UTXOS" era) utxosTransition = judgmentContext >>= \(TRC (_, _, tx)) -> do case tx ^. isValidTxL of IsValid True -> babelEvalScriptsTxValid - IsValid False -> babbageEvalScriptsTxInvalid + IsValid False -> babelEvalScriptsTxInvalid babelEvalScriptsTxValid :: forall era. @@ -291,7 +298,7 @@ babelEvalScriptsTxValid :: , ScriptsNeeded era ~ AlonzoScriptsNeeded era , Signal (EraRule "UTXOS" era) ~ Tx era , STS (EraRule "UTXOS" era) - , State (EraRule "UTXOS" era) ~ UTxOState era + , State (EraRule "UTXOS" era) ~ UTxOStateTemp era , Environment (EraRule "UTXOS" era) ~ UtxoEnv era , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era , BaseM (EraRule "UTXOS" era) ~ ShelleyBase @@ -300,7 +307,7 @@ babelEvalScriptsTxValid :: ) => TransitionRule (EraRule "UTXOS" era) babelEvalScriptsTxValid = do - TRC (UtxoEnv _ pp certState, utxos@(UTxOState utxo _frxo _ _ govState _ _), tx) <- + TRC (UtxoEnv _ pp certState, utxos@(UTxOStateTemp utxo _frxo _ _ govState _ _), tx) <- judgmentContext let txBody = tx ^. bodyTxL @@ -317,7 +324,7 @@ babelEvalScriptsTxValid = do govState (tellEvent . injectEvent . TotalDeposits (hashAnnotated txBody)) (\a b -> tellEvent . injectEvent $ TxUTxODiff a b) - pure $! utxos' & utxosDonationL <>~ txBody ^. treasuryDonationTxBodyL + pure $! utxos' & utxostDonationL <>~ txBody ^. treasuryDonationTxBodyL -- | This monadic action captures the final stages of the UTXO(S) rule. In particular it -- applies all of the UTxO related aditions and removals, gathers all of the fees into the @@ -329,48 +336,102 @@ babelEvalScriptsTxValid = do updateUTxOState :: (BabelEraTxBody era, Monad m) => PParams era -> - UTxOState era -> + UTxOStateTemp era -> TxBody era -> CertState era -> GovState era -> (Coin -> m ()) -> (UTxO era -> UTxO era -> m ()) -> - m (UTxOState era) + m (UTxOStateTemp era) updateUTxOState pp utxos txBody certState govState depositChangeEvent txUtxODiffEvent = do - let UTxOState - { utxosUtxo - , utxosFrxo - , utxosDeposited - , utxosFees - , utxosStakeDistr - , utxosDonation + let UTxOStateTemp + { utxostUtxo + , utxostFrxo + , utxostDeposited + , utxostFees + , utxostStakeDistr + , utxostDonation } = utxos - UTxO utxo = utxosUtxo + UTxO utxo = utxostUtxo !utxoAdd = txouts txBody -- These will be inserted into the UTxO {- utxoDel = txins txb ◁ utxo -} !(utxoWithout, utxoDel) = extractKeys utxo (txBody ^. inputsTxBodyL) {- newUTxO = (txins txb ⋪ utxo) ∪ outs txb -} newUTxO = utxoWithout `Map.union` unUTxO utxoAdd - FRxO frxo = utxosFrxo + FRxO frxo = utxostFrxo !frxoAdd = txfrxo txBody -- These will be inserted into the FRxO {- utxoDel = txins txb ◁ utxo -} !(frxoWithout, _frxoDel) = extractKeys frxo (txBody ^. fulfillsTxBodyL) {- newUTxO = (txins txb ⋪ utxo) ∪ outs txb -} newFRxO = frxoWithout `Map.union` unFRxO frxoAdd deletedUTxO = UTxO utxoDel - newIncStakeDistro = updateStakeDistribution pp utxosStakeDistr deletedUTxO utxoAdd + newIncStakeDistro = updateStakeDistribution pp utxostStakeDistr deletedUTxO utxoAdd totalRefunds = certsTotalRefundsTxBody pp certState txBody totalDeposits = certsTotalDepositsTxBody pp certState txBody depositChange = totalDeposits <-> totalRefunds depositChangeEvent depositChange txUtxODiffEvent deletedUTxO utxoAdd pure $! - UTxOState - { utxosUtxo = UTxO newUTxO - , utxosFrxo = FRxO newFRxO - , utxosDeposited = utxosDeposited <> depositChange - , utxosFees = utxosFees <> txBody ^. feeTxBodyL - , utxosGovState = govState - , utxosStakeDistr = newIncStakeDistro - , utxosDonation = utxosDonation + UTxOStateTemp + { utxostUtxo = UTxO newUTxO + , utxostFrxo = FRxO newFRxO + , utxostDeposited = utxostDeposited <> depositChange + , utxostFees = utxostFees <> txBody ^. feeTxBodyL + , utxostGovState = govState + , utxostStakeDistr = newIncStakeDistro + , utxostDonation = utxostDonation + } + +babelEvalScriptsTxInvalid :: + forall era. + ( AlonzoEraTx era + , BabbageEraTxBody era + , EraPlutusContext era + , AlonzoEraUTxO era + , ScriptsNeeded era ~ AlonzoScriptsNeeded era + , STS (EraRule "UTXOS" era) + , Environment (EraRule "UTXOS" era) ~ UtxoEnv era + , Signal (EraRule "UTXOS" era) ~ Tx era + , State (EraRule "UTXOS" era) ~ UTxOStateTemp era + , BaseM (EraRule "UTXOS" era) ~ ShelleyBase + , Event (EraRule "UTXOS" era) ~ BabelUtxosEvent era + , PredicateFailure (EraRule "UTXOS" era) ~ BabelUtxosPredFailure era + ) => + TransitionRule (EraRule "UTXOS" era) +babelEvalScriptsTxInvalid = do + TRC (UtxoEnv _ pp _, us@(UTxOStateTemp utxo _ _ fees _ _ _), tx) <- judgmentContext + {- txb := txbody tx -} + let txBody = tx ^. bodyTxL + sysSt <- liftSTS $ asks systemStart + ei <- liftSTS $ asks epochInfo + + () <- pure $! traceEvent invalidBegin () + + case collectPlutusScriptsWithContext ei sysSt pp tx utxo of + Right sLst -> + {- sLst := collectTwoPhaseScriptInputs pp tx utxo -} + {- isValid tx = evalScripts tx sLst = False -} + whenFailureFree $ + when2Phase $ case evalPlutusScripts tx sLst of + Passes _ -> + failBecause $ + ValidationTagMismatch (tx ^. isValidTxL) PassedUnexpectedly + Fails ps fs -> do + mapM_ (tellEvent . SuccessfulPlutusScriptsEvent @era) (nonEmpty ps) + tellEvent (FailedPlutusScriptsEvent (scriptFailurePlutus <$> fs)) + Left info -> failBecause (CollectErrors info) + + () <- pure $! traceEvent invalidEnd () + + {- utxoKeep = txBody ^. collateralInputsTxBodyL ⋪ utxo -} + {- utxoDel = txBody ^. collateralInputsTxBodyL ◁ utxo -} + let !(utxoKeep, utxoDel) = extractKeys (unUTxO utxo) (txBody ^. collateralInputsTxBodyL) + UTxO collouts = collOuts txBody + DeltaCoin collateralFees = collAdaBalance txBody utxoDel -- NEW to Babbage + pure $! + us {- (collInputs txb ⋪ utxo) ∪ collouts tx -} + { utxostUtxo = UTxO (Map.union utxoKeep collouts) -- NEW to Babbage + {- fees + collateralFees -} + , utxostFees = fees <> Coin collateralFees -- NEW to Babbage + , utxostStakeDistr = updateStakeDistribution pp (utxostStakeDistr us) (UTxO utxoDel) (UTxO collouts) } diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs index 10d6740b8be..3ae6fffc07b 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs @@ -58,6 +58,10 @@ import qualified Cardano.Ledger.Babbage.Rules as Babbage ( import Cardano.Ledger.Babbage.UTxO (getReferenceScripts) import Cardano.Ledger.Babel.Core import Cardano.Ledger.Babel.Era (BabelEra, BabelUTXO, BabelUTXOW) + +-- verifyBootstrapWitRequiredTxs, + +import Cardano.Ledger.Babel.LedgerState.Types (UTxOStateTemp (..)) import Cardano.Ledger.Babel.Rules.Utxo (BabelUtxoPredFailure) import Cardano.Ledger.Babel.Rules.Utxos (BabelUtxosPredFailure) import Cardano.Ledger.Babel.UTxO (getBabelWitsVKeyNeeded) @@ -79,12 +83,9 @@ import Cardano.Ledger.Keys ( WitVKey (WitVKey), bwKey, verifyBootstrapWit, - -- verifyBootstrapWitRequiredTxs, ) import Cardano.Ledger.Rules.ValidationMode (Test, runTest, runTestOnSignal) import Cardano.Ledger.SafeHash (extractHash, hashAnnotated) -import Cardano.Ledger.Shelley.API (utxosUtxo) -import qualified Cardano.Ledger.Shelley.LedgerState as Shelley (UTxOState) import Cardano.Ledger.Shelley.Rules ( ShelleyUtxoPredFailure, ShelleyUtxowEvent (UtxoEvent), @@ -268,14 +269,14 @@ instance , -- Allow UTXOW to call UTXO Embed (EraRule "UTXO" era) (BabelUTXOW era) , Environment (EraRule "UTXO" era) ~ Shelley.UtxoEnv era - , State (EraRule "UTXO" era) ~ Shelley.UTxOState era + , State (EraRule "UTXO" era) ~ UTxOStateTemp era , Signal (EraRule "UTXO" era) ~ Tx era , Eq (PredicateFailure (EraRule "UTXOS" era)) , Show (PredicateFailure (EraRule "UTXOS" era)) ) => STS (BabelUTXOW era) where - type State (BabelUTXOW era) = Shelley.UTxOState era + type State (BabelUTXOW era) = UTxOStateTemp era type Signal (BabelUTXOW era) = Tx era type Environment (BabelUTXOW era) = Shelley.UtxoEnv era type BaseM (BabelUTXOW era) = ShelleyBase @@ -412,7 +413,7 @@ babelUtxowTransition :: , -- , Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentRequiredTxs) Environment (EraRule "UTXOW" era) ~ Shelley.UtxoEnv era , Signal (EraRule "UTXOW" era) ~ Tx era - , State (EraRule "UTXOW" era) ~ Shelley.UTxOState era + , State (EraRule "UTXOW" era) ~ UTxOStateTemp era , InjectRuleFailure "UTXOW" ShelleyUtxowPredFailure era , InjectRuleFailure "UTXOW" AlonzoUtxowPredFailure era , InjectRuleFailure "UTXOW" BabbageUtxowPredFailure era @@ -420,7 +421,7 @@ babelUtxowTransition :: Embed (EraRule "UTXO" era) (EraRule "UTXOW" era) , Environment (EraRule "UTXO" era) ~ Shelley.UtxoEnv era , Signal (EraRule "UTXO" era) ~ Tx era - , State (EraRule "UTXO" era) ~ Shelley.UTxOState era + , State (EraRule "UTXO" era) ~ UTxOStateTemp era ) => TransitionRule (EraRule "UTXOW" era) babelUtxowTransition = do @@ -430,7 +431,7 @@ babelUtxowTransition = do {- txb := txbody tx -} {- txw := txwits tx -} {- witsKeyHashes := { hashKey vk | vk ∈ dom(txwitsVKey txw) } -} - let utxo = utxosUtxo u + let utxo = utxostUtxo u txBody = tx ^. bodyTxL witsKeyHashes = witsFromTxWitnesses tx inputs = (txBody ^. referenceInputsTxBodyL) `Set.union` (txBody ^. inputsTxBodyL) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs index 18d13e83688..a68ce8a20db 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs @@ -87,6 +87,11 @@ import Cardano.Ledger.Alonzo.Rules ( import Cardano.Ledger.Alonzo.UTxO (AlonzoEraUTxO, AlonzoScriptsNeeded) import Cardano.Ledger.Babbage.Collateral (collAdaBalance, collOuts) import Cardano.Ledger.Babel.Core (ppMaxTxExUnitsL) +import Cardano.Ledger.Babel.LedgerState.Types ( + LedgerStateTemp, + fromLedgerState, + toLedgerState, + ) import Cardano.Ledger.Babel.Rules.Ledger (BabelLedgerPredFailure) import Cardano.Ledger.Babel.Rules.Ledgers (BabelLEDGERS, BabelLedgersEnv (BabelLedgersEnv)) import Cardano.Ledger.Babel.Rules.Utxo (BabelUtxoPredFailure (..)) @@ -178,7 +183,7 @@ instance , Show (PredicateFailure (EraRule "LEDGER" era)) , ConwayEraPParams era , Environment (EraRule "LEDGERS" era) ~ BabelLedgersEnv era - , State (EraRule "LEDGERS" era) ~ LedgerState era + , State (EraRule "LEDGERS" era) ~ LedgerStateTemp era , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) , Embed (EraRule "LEDGERS" era) (BabelZONE era) , EraTx era @@ -213,7 +218,7 @@ zoneTransition :: forall era. ( EraRule "ZONE" era ~ BabelZONE era , Environment (EraRule "LEDGERS" era) ~ BabelLedgersEnv era - , State (EraRule "LEDGERS" era) ~ LedgerState era + , State (EraRule "LEDGERS" era) ~ LedgerStateTemp era , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) , Embed (EraRule "LEDGERS" era) (BabelZONE era) , BabelEraTxBody era @@ -249,8 +254,14 @@ zoneTransition = runTestOnSignal $ failureUnless (chkLinear (Foldable.toList txs)) CheckLinearFailure {- totExunits tx ≤ maxTxExUnits pp -} runTestOnSignal $ validateExUnitsTooBigUTxO pParams (Foldable.toList txs) - trans @(EraRule "LEDGERS" era) $ - TRC (BabelLedgersEnv slotNo ixRange pParams accountState, LedgerState utxoState certState, txs) + lsTemp <- -- TODO WG: Should we be checking FRxO is empty before converting? + trans @(EraRule "LEDGERS" era) $ + TRC + ( BabelLedgersEnv slotNo ixRange pParams accountState + , fromLedgerState $ LedgerState utxoState certState + , txs + ) + pure $ toLedgerState lsTemp else -- ZONE-N do -- Check that only the last transaction is invalid @@ -326,7 +337,7 @@ babelEvalScriptsTxInvalid :: , BabelEraTxBody era , AlonzoEraTx era , Environment (EraRule "LEDGERS" era) ~ BabelLedgersEnv era - , State (EraRule "LEDGERS" era) ~ LedgerState era + , State (EraRule "LEDGERS" era) ~ LedgerStateTemp era , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) , Embed (EraRule "LEDGERS" era) (BabelZONE era) , Eq (PredicateFailure (EraRule "LEDGER" era)) diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Binary/Regression.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Binary/Regression.hs index 9ec1c929061..24a7236fa8a 100644 --- a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Binary/Regression.hs +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Binary/Regression.hs @@ -10,16 +10,6 @@ module Test.Cardano.Ledger.Babel.Binary.Regression where -import Cardano.Ledger.BaseTypes (Inject (..), StrictMaybe (..), TxIx (..)) -import Cardano.Ledger.Binary ( - EncCBOR (..), - decCBOR, - decodeFull, - decodeFullAnnotatorFromHexText, - mkVersion, - serialize, - ) -import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Babel (Babel) import Cardano.Ledger.Babel.Core ( BabbageEraTxBody (..), @@ -31,11 +21,22 @@ import Cardano.Ledger.Babel.Core ( eraProtVerLow, txIdTx, ) +import Cardano.Ledger.Babel.LedgerState.Types (LedgerStateTemp) import Cardano.Ledger.Babel.Rules ( BabelLedgerPredFailure (..), BabelUtxoPredFailure (..), BabelUtxowPredFailure (..), ) +import Cardano.Ledger.BaseTypes (Inject (..), StrictMaybe (..), TxIx (..)) +import Cardano.Ledger.Binary ( + EncCBOR (..), + decCBOR, + decodeFull, + decodeFullAnnotatorFromHexText, + mkVersion, + serialize, + ) +import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Plutus.Language (SLanguage (..), hashPlutusScript) import Cardano.Ledger.TxIn (TxIn (..)) import Control.Monad ((<=<)) @@ -92,7 +93,7 @@ spec = describe "Regression" $ do , "49848004800504d9010281d8799f182aff0581840000d8799f182aff820000f4f6" ] describe "ImpTest" $ - withImpState @Babel $ + withImpState @LedgerStateTemp @Babel $ it "InsufficientCollateral is not encoded with negative coin #4198" $ do let lockedVal = inject $ Coin 100 (_, collateralAddress) <- freshKeyAddr @@ -103,7 +104,7 @@ spec = describe "Regression" $ do lockScriptAddress = mkScriptAddr scriptHash skp (_, collateralReturnAddr) <- freshKeyAddr lockedTx <- - submitTxAnn @Babel "Script locked tx" $ + submitTxAnn @LedgerStateTemp @Babel "Script locked tx" $ mkBasicTx mkBasicTxBody & bodyTxL . outputsTxBodyL diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp.hs index cdb41416154..de119bb6d0e 100644 --- a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp.hs +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp.hs @@ -14,6 +14,7 @@ import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure) import Cardano.Ledger.Babbage.TxInfo (BabbageContextError) import Cardano.Ledger.Babel.Core import Cardano.Ledger.Babel.Governance () +import Cardano.Ledger.Babel.LedgerState.Types import Cardano.Ledger.Babel.Rules ( ) @@ -70,7 +71,7 @@ spec = do Utxos.spec @era Ratify.spec @era describe "BabelImpSpec - bootstrap phase (protocol version 9)" $ - withImpState @era $ do + withImpState @LedgerStateTemp @era $ do Enact.relevantDuringBootstrapSpec @era Epoch.relevantDuringBootstrapSpec @era Gov.relevantDuringBootstrapSpec @era diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EnactSpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EnactSpec.hs index 56316a0a5ed..70229c6b9de 100644 --- a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EnactSpec.hs +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/EnactSpec.hs @@ -15,6 +15,7 @@ module Test.Cardano.Ledger.Babel.Imp.EnactSpec ( import Cardano.Ledger.Address import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Babel.LedgerState.Types (LedgerStateTemp) import Cardano.Ledger.BaseTypes import Cardano.Ledger.Coin import Cardano.Ledger.Conway.Governance @@ -158,7 +159,7 @@ treasuryWithdrawalsSpec = impAnn "submit in individual proposals in the same epoch" $ do traverse_ ( \w -> do - gaId <- submitTreasuryWithdrawals @era [w] + gaId <- submitTreasuryWithdrawals @LedgerStateTemp @era [w] submitYesVote_ (DRepVoter drepC) gaId submitYesVote_ (CommitteeVoter committeeC) gaId ) diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovSpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovSpec.hs index b1381cce793..2bf85977ad4 100644 --- a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovSpec.hs +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/GovSpec.hs @@ -1191,8 +1191,8 @@ proposalWithRewardAccount action = do -- | Tests the first hardfork in the Babel era where the PrevGovActionID is SNothing firstHardForkFollows :: - forall era. - (ShelleyEraImp era, BabelEraTxBody era) => + forall era ls. + (ShelleyEraImp ls era, BabelEraTxBody era) => (ProtVer -> ProtVer) -> ImpTestM era () firstHardForkFollows computeNewFromOld = do @@ -1201,8 +1201,8 @@ firstHardForkFollows computeNewFromOld = do -- | Negative (deliberatey failing) first hardfork in the Babel era where the PrevGovActionID is SNothing firstHardForkCantFollow :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , BabelEraTxBody era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => @@ -1225,8 +1225,8 @@ firstHardForkCantFollow = do -- | Tests a second hardfork in the Babel era where the PrevGovActionID is SJust secondHardForkFollows :: - forall era. - (ShelleyEraImp era, BabelEraTxBody era) => + forall era ls. + (ShelleyEraImp ls era, BabelEraTxBody era) => (ProtVer -> ProtVer) -> ImpTestM era () secondHardForkFollows computeNewFromOld = do @@ -1238,8 +1238,8 @@ secondHardForkFollows computeNewFromOld = do -- | Negative (deliberatey failing) first hardfork in the Babel era where the PrevGovActionID is SJust secondHardForkCantFollow :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , BabelEraTxBody era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxosSpec.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxosSpec.hs index dc40d46dd0f..14a4e94b5ad 100644 --- a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxosSpec.hs +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/Imp/UtxosSpec.hs @@ -725,7 +725,7 @@ scriptLockedTxOut shSpending = mkRefTxOut :: ( BabbageEraTxOut era - , AlonzoEraImp era + , AlonzoEraImp ls era ) => ScriptHash (EraCrypto era) -> ImpTestM era (TxOut era) @@ -739,9 +739,9 @@ mkRefTxOut sh = do .~ maybeToStrictMaybe (fromPlutusScript <$> mbyPlutusScript) setupRefTx :: - forall era. + forall era ls. ( BabbageEraTxOut era - , AlonzoEraImp era + , AlonzoEraImp ls era ) => ImpTestM era (TxId (EraCrypto era)) setupRefTx = do diff --git a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/ImpTest.hs b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/ImpTest.hs index a7e581ff59b..98ead1b9e50 100644 --- a/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/ImpTest.hs +++ b/eras/babel/impl/testlib/Test/Cardano/Ledger/Babel/ImpTest.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} @@ -114,6 +115,7 @@ import Cardano.Ledger.Allegra.Scripts (Timelock) import Cardano.Ledger.Alonzo.Scripts (AlonzoScript) import Cardano.Ledger.Babel (BabelEra) import Cardano.Ledger.Babel.Core hiding (proposals) +import Cardano.Ledger.Babel.LedgerState.Types (LedgerStateTemp) import Cardano.Ledger.Babel.TxCert ( BabelEraTxCert, Delegatee (..), @@ -258,7 +260,7 @@ instance , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody) , Eq (ConwayGovEvent (BabelEra c)) ) => - ShelleyEraImp (BabelEra c) + ShelleyEraImp LedgerStateTemp (BabelEra c) where initImpTestState = do kh <- fst <$> freshKeyPair @@ -328,9 +330,9 @@ instance , DSIGN c ~ Ed25519DSIGN , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody) ) => - MaryEraImp (BabelEra c) + MaryEraImp LedgerStateTemp (BabelEra c) -instance ShelleyEraImp (BabelEra c) => AlonzoEraImp (BabelEra c) where +instance ShelleyEraImp LedgerStateTemp (BabelEra c) => AlonzoEraImp LedgerStateTemp (BabelEra c) where scriptTestContexts = plutusTestScripts SPlutusV1 <> plutusTestScripts SPlutusV2 @@ -338,7 +340,7 @@ instance ShelleyEraImp (BabelEra c) => AlonzoEraImp (BabelEra c) where <> plutusTestScripts SPlutusV4 class - ( AlonzoEraImp era + ( AlonzoEraImp LedgerStateTemp era , ConwayEraGov era , BabelEraTxBody era , STS (EraRule "ENACT" era) @@ -372,8 +374,8 @@ registerInitialCommittee = do -- | Submit a transaction that registers a new DRep and return the keyhash -- belonging to that DRep registerDRep :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , BabelEraTxCert era ) => ImpTestM era (KeyHash 'DRepRole (EraCrypto era)) @@ -398,9 +400,9 @@ registerDRep = do -- that could count as delegated stake to the DRep, so that we can test that -- rewards are also calculated nonetheless. setupDRepWithoutStake :: - forall era. + forall era ls. ( BabelEraTxCert era - , ShelleyEraImp era + , ShelleyEraImp ls era ) => ImpTestM era @@ -425,9 +427,9 @@ setupDRepWithoutStake = do -- | Registers a new DRep and delegates the specified amount of ADA to it. setupSingleDRep :: - forall era. + forall era ls. ( BabelEraTxCert era - , ShelleyEraImp era + , ShelleyEraImp ls era ) => Integer -> ImpTestM @@ -468,7 +470,7 @@ getsPParams f = getsNES $ nesEsL . curPParamsEpochStateL . f -- in Babel. The Shelley version of this function would have to separately -- register the staking credential and then delegate it. setupPoolWithStake :: - (ShelleyEraImp era, BabelEraTxCert era) => + (ShelleyEraImp ls era, BabelEraTxCert era) => Coin -> ImpTestM era @@ -498,7 +500,7 @@ setupPoolWithStake delegCoin = do pure (khPool, credDelegatorPayment, credDelegatorStaking) setupPoolWithoutStake :: - (ShelleyEraImp era, BabelEraTxCert era) => + (ShelleyEraImp ls era, BabelEraTxCert era) => ImpTestM era ( KeyHash 'StakePool (EraCrypto era) @@ -523,7 +525,7 @@ setupPoolWithoutStake = do -- | Submits a transaction with a Vote for the given governance action as -- some voter submitVote :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , BabelEraTxBody era , HasCallStack ) => @@ -536,7 +538,7 @@ submitVote vote voter gaId = trySubmitVote vote voter gaId >>= expectRightDeep -- | Submits a transaction that votes "Yes" for the given governance action as -- some voter submitYesVote_ :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , BabelEraTxBody era , HasCallStack ) => @@ -546,7 +548,7 @@ submitYesVote_ :: submitYesVote_ voter gaId = void $ submitVote VoteYes voter gaId submitVote_ :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , BabelEraTxBody era , HasCallStack ) => @@ -557,7 +559,7 @@ submitVote_ :: submitVote_ vote voter gaId = void $ submitVote vote voter gaId submitFailingVote :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , BabelEraTxBody era , HasCallStack ) => @@ -571,7 +573,7 @@ submitFailingVote voter gaId expectedFailure = -- | Submits a transaction that votes "Yes" for the given governance action as -- some voter, and expects an `Either` result. trySubmitVote :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , BabelEraTxBody era ) => Vote -> @@ -603,19 +605,19 @@ trySubmitVote vote voter gaId = ) submitProposal_ :: - (ShelleyEraImp era, BabelEraTxBody era, HasCallStack) => + (ShelleyEraImp ls era, BabelEraTxBody era, HasCallStack) => ProposalProcedure era -> ImpTestM era () submitProposal_ = void . submitProposal submitProposal :: - (ShelleyEraImp era, BabelEraTxBody era, HasCallStack) => + (ShelleyEraImp ls era, BabelEraTxBody era, HasCallStack) => ProposalProcedure era -> ImpTestM era (GovActionId (EraCrypto era)) submitProposal proposal = trySubmitProposal proposal >>= expectRightExpr submitProposals :: - (ShelleyEraImp era, ConwayEraGov era, BabelEraTxBody era, HasCallStack) => + (ShelleyEraImp ls era, ConwayEraGov era, BabelEraTxBody era, HasCallStack) => NE.NonEmpty (ProposalProcedure era) -> ImpTestM era (NE.NonEmpty (GovActionId (EraCrypto era))) submitProposals proposals = do @@ -641,7 +643,7 @@ submitProposals proposals = do -- | Submits a transaction that proposes the given proposal trySubmitProposal :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , BabelEraTxBody era ) => ProposalProcedure era -> @@ -663,7 +665,7 @@ trySubmitProposal proposal = do Left err -> Left err trySubmitProposals :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , BabelEraTxBody era ) => NE.NonEmpty (ProposalProcedure era) -> @@ -676,7 +678,7 @@ trySubmitProposals proposals = do .~ GHC.fromList (toList proposals) submitFailingProposal :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , BabelEraTxBody era , HasCallStack ) => @@ -689,7 +691,7 @@ submitFailingProposal proposal expectedFailure = -- | Submits a transaction that proposes the given governance action. For proposing -- multiple actions in the same transaciton use `trySubmitGovActions` instead. trySubmitGovAction :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , BabelEraTxBody era ) => GovAction era -> @@ -724,7 +726,7 @@ submitAndExpireProposalToMakeReward expectedReward stakingC = do -- | Submits a transaction that proposes the given governance action trySubmitGovActions :: - (ShelleyEraImp era, BabelEraTxBody era) => + (ShelleyEraImp ls era, BabelEraTxBody era) => NE.NonEmpty (GovAction era) -> ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) (Tx era)) trySubmitGovActions gas = do @@ -741,8 +743,8 @@ trySubmitGovActions gas = do trySubmitProposals proposals submitGovAction :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , BabelEraTxBody era , HasCallStack ) => @@ -753,8 +755,8 @@ submitGovAction ga = do pure gaId submitGovAction_ :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , BabelEraTxBody era , HasCallStack ) => @@ -763,8 +765,8 @@ submitGovAction_ :: submitGovAction_ = void . submitGovAction submitGovActions :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , BabelEraTxBody era , HasCallStack ) => @@ -776,7 +778,7 @@ submitGovActions gas = do pure $ NE.zipWith (\idx _ -> GovActionId txId (GovActionIx idx)) (0 NE.:| [1 ..]) gas submitTreasuryWithdrawals :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , BabelEraTxBody era , ConwayEraGov era ) => @@ -814,8 +816,8 @@ getGovPolicy = nesEpochStateL . epochStateGovStateL . constitutionGovStateL . constitutionScriptL submitFailingGovAction :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , BabelEraTxBody era , HasCallStack ) => @@ -1163,7 +1165,7 @@ logRatificationChecks gaId = do -- | Submits a transaction that registers a hot key for the given cold key. -- Returns the hot key hash. registerCommitteeHotKey :: - (ShelleyEraImp era, BabelEraTxCert era) => + (ShelleyEraImp ls era, BabelEraTxCert era) => Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era (Credential 'HotCommitteeRole (EraCrypto era)) registerCommitteeHotKey coldKey = do @@ -1177,7 +1179,7 @@ registerCommitteeHotKey coldKey = do -- | Submits a transaction that resigns the cold key resignCommitteeColdKey :: - (ShelleyEraImp era, BabelEraTxCert era) => + (ShelleyEraImp ls era, BabelEraTxCert era) => Credential 'ColdCommitteeRole (EraCrypto era) -> StrictMaybe (Anchor (EraCrypto era)) -> ImpTestM era () @@ -1294,7 +1296,7 @@ proposalsShowDebug ps showRoots = <> ["----- Proposals End -----"] submitConstitutionGovAction :: - (ShelleyEraImp era, BabelEraTxBody era) => + (ShelleyEraImp ls era, BabelEraTxBody era) => StrictMaybe (GovActionId (EraCrypto era)) -> ImpTestM era (GovActionId (EraCrypto era)) submitConstitutionGovAction gid = do diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Rules/Chain.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Rules/Chain.hs index cc325fc1982..8ede5d346e9 100644 --- a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Rules/Chain.hs +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Rules/Chain.hs @@ -27,6 +27,7 @@ module Test.Cardano.Ledger.Babel.Rules.Chain ( import Cardano.Ledger.BHeaderView (BHeaderView) import Cardano.Ledger.Babel.Era (BabelBBODY, BabelEra) +import Cardano.Ledger.Babel.LedgerState.Types import Cardano.Ledger.Babel.Rules.Bbody (BabelBbodyPredFailure) import Cardano.Ledger.BaseTypes ( BlocksMade (..), @@ -263,7 +264,7 @@ instance ( EraGov era , Embed (EraRule "BBODY" era) (CHAIN era) , Environment (EraRule "BBODY" era) ~ BbodyEnv era - , State (EraRule "BBODY" era) ~ ShelleyBbodyState era + , State (EraRule "BBODY" era) ~ ShelleyBbodyState "ZONES" era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , Embed (EraRule "TICKN" era) (CHAIN era) , Environment (EraRule "TICKN" era) ~ TicknEnv @@ -277,7 +278,7 @@ instance , EncCBORGroup (TxZones era) , ProtVerAtMost era 10 , State (EraRule "ZONES" era) ~ LedgerState era - , State (Core.EraRule "LEDGERS" era) ~ LedgerState era + , State (Core.EraRule "LEDGERS" era) ~ LedgerStateTemp era ) => STS (CHAIN era) where @@ -303,7 +304,7 @@ chainTransition :: ( STS (CHAIN era) , Embed (EraRule "BBODY" era) (CHAIN era) , Environment (EraRule "BBODY" era) ~ BbodyEnv era - , State (EraRule "BBODY" era) ~ ShelleyBbodyState era + , State (EraRule "BBODY" era) ~ ShelleyBbodyState "ZONES" era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , Embed (EraRule "TICKN" era) (CHAIN era) , Environment (EraRule "TICKN" era) ~ TicknEnv @@ -315,7 +316,7 @@ chainTransition :: , Signal (EraRule "TICK" era) ~ SlotNo , Embed (PRTCL (EraCrypto era)) (CHAIN era) , EncCBORGroup (TxZones era) - , State (EraRule "LEDGERS" era) ~ LedgerState era + , State (EraRule "ZONES" era) ~ LedgerState era , EraGov era ) => TransitionRule (CHAIN era) diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Utils.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Utils.hs index 2d530ce1f29..def5fb93537 100644 --- a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Utils.hs +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Utils.hs @@ -116,7 +116,7 @@ import Test.Tasty.HUnit ( type ChainProperty era = ( Mock (EraCrypto era) - , ApplyBlock era + , ApplyBlock "LEDGERS" era , GetLedgerView era , EraTx era ) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway.hs b/eras/conway/impl/src/Cardano/Ledger/Conway.hs index 620a0c74dea..22c3eb3712a 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway.hs @@ -49,7 +49,7 @@ instance ( Crypto c , DSignable c (Hash c EraIndependentTxBody) ) => - API.ApplyBlock (ConwayEra c) + API.ApplyBlock "LEDGERS" (ConwayEra c) instance Crypto c => API.CanStartFromGenesis (ConwayEra c) where type AdditionalGenesisConfig (ConwayEra c) = ConwayGenesis c diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Regression.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Regression.hs index 6b8757ad6e2..ed0002f2c7c 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Regression.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Regression.hs @@ -37,6 +37,7 @@ import Cardano.Ledger.Conway.Rules ( ConwayUtxowPredFailure (..), ) import Cardano.Ledger.Plutus.Language (SLanguage (..), hashPlutusScript) +import Cardano.Ledger.Shelley.LedgerState (LedgerState) import Cardano.Ledger.TxIn (TxIn (..)) import Control.Monad ((<=<)) import qualified Data.Sequence.Strict as SSeq @@ -92,7 +93,7 @@ spec = describe "Regression" $ do , "49848004800504d9010281d8799f182aff0581840000d8799f182aff820000f4f6" ] describe "ImpTest" $ - withImpState @Conway $ + withImpState @LedgerState @Conway $ it "InsufficientCollateral is not encoded with negative coin #4198" $ do let lockedVal = inject $ Coin 100 (_, collateralAddress) <- freshKeyAddr @@ -103,15 +104,17 @@ spec = describe "Regression" $ do lockScriptAddress = mkScriptAddr scriptHash skp (_, collateralReturnAddr) <- freshKeyAddr lockedTx <- - submitTxAnn @Conway "Script locked tx" $ + submitTxAnn @LedgerState @Conway "Script locked tx" $ mkBasicTx mkBasicTxBody - & bodyTxL . outputsTxBodyL - .~ SSeq.fromList - [ mkBasicTxOut lockScriptAddress lockedVal - , mkBasicTxOut collateralAddress (inject $ Coin 1) - ] - & bodyTxL . collateralReturnTxBodyL - .~ SJust (mkBasicTxOut collateralReturnAddr . inject $ Coin 1) + & bodyTxL + . outputsTxBodyL + .~ SSeq.fromList + [ mkBasicTxOut lockScriptAddress lockedVal + , mkBasicTxOut collateralAddress (inject $ Coin 1) + ] + & bodyTxL + . collateralReturnTxBodyL + .~ SJust (mkBasicTxOut collateralReturnAddr . inject $ Coin 1) let modifyRootCoin = coinTxOutL .~ Coin 989482376 modifyRootTxOut (x SSeq.:<| SSeq.Empty) = @@ -122,17 +125,26 @@ spec = describe "Regression" $ do breakCollaterals tx = pure $ tx - & bodyTxL . collateralReturnTxBodyL - .~ SJust (mkBasicTxOut collateralReturnAddr . inject $ Coin 1_000_000_000) - & bodyTxL . feeTxBodyL .~ Coin 178349 - & bodyTxL . outputsTxBodyL %~ modifyRootTxOut - & witsTxL . addrTxWitsL .~ mempty + & bodyTxL + . collateralReturnTxBodyL + .~ SJust (mkBasicTxOut collateralReturnAddr . inject $ Coin 1_000_000_000) + & bodyTxL + . feeTxBodyL + .~ Coin 178349 + & bodyTxL + . outputsTxBodyL + %~ modifyRootTxOut + & witsTxL + . addrTxWitsL + .~ mempty res <- impAnn "Consume the script locked output" $ withPostFixup (updateAddrTxWits <=< breakCollaterals) $ do trySubmitTx @Conway $ mkBasicTx mkBasicTxBody - & bodyTxL . inputsTxBodyL .~ Set.singleton (TxIn (txIdTx lockedTx) $ TxIx 0) + & bodyTxL + . inputsTxBodyL + .~ Set.singleton (TxIn (txIdTx lockedTx) $ TxIx 0) pFailure <- impAnn "Expecting failure" $ expectLeftDeepExpr res let hasInsufficientCollateral 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 5269b93c56b..993ea3938d1 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs @@ -23,6 +23,7 @@ import Cardano.Ledger.Conway.Rules ( ConwayNewEpochEvent, ) import Cardano.Ledger.Conway.TxInfo (ConwayContextError) +import Cardano.Ledger.Shelley.LedgerState (LedgerState) import Cardano.Ledger.Shelley.Rules (Event, ShelleyUtxoPredFailure, ShelleyUtxowPredFailure) import Data.Functor.Identity import Data.Typeable (Typeable) @@ -35,7 +36,11 @@ import qualified Test.Cardano.Ledger.Conway.Imp.GovSpec as Gov 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 -import Test.Cardano.Ledger.Conway.ImpTest (ConwayEraImp, withImpState, withImpStateWithProtVer) +import Test.Cardano.Ledger.Conway.ImpTest ( + ConwayEraImp, + withImpState, + withImpStateWithProtVer, + ) spec :: forall era. @@ -71,7 +76,7 @@ spec = do Utxos.spec @era Ratify.spec @era describe "ConwayImpSpec - bootstrap phase (protocol version 9)" $ - withImpState @era $ do + withImpState @LedgerState @era $ do Enact.relevantDuringBootstrapSpec @era Epoch.relevantDuringBootstrapSpec @era Gov.relevantDuringBootstrapSpec @era diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs index 9ffdac274d0..3f74efce379 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EnactSpec.hs @@ -130,7 +130,9 @@ treasuryWithdrawalsSpec = impAnn "Submit a treasury donation that can cover the withdrawals" $ do let tx = mkBasicTx mkBasicTxBody - & bodyTxL . treasuryDonationTxBodyL .~ (sumRequested <-> initialTreasury) + & bodyTxL + . treasuryDonationTxBodyL + .~ (sumRequested <-> initialTreasury) submitTx_ tx passNEpochs 2 getTreasury `shouldReturn` zero @@ -155,7 +157,7 @@ treasuryWithdrawalsSpec = impAnn "submit in individual proposals in the same epoch" $ do traverse_ ( \w -> do - gaId <- submitTreasuryWithdrawals @era [w] + gaId <- submitTreasuryWithdrawals @LedgerState @era [w] submitYesVote_ (DRepVoter drepC) gaId submitYesVote_ (CommitteeVoter committeeC) gaId ) @@ -198,8 +200,14 @@ hardForkInitiationSpec = (committeeMember :| _) <- registerInitialCommittee modifyPParams $ \pp -> pp - & ppDRepVotingThresholdsL . dvtHardForkInitiationL .~ 2 %! 3 - & ppPoolVotingThresholdsL . pvtHardForkInitiationL .~ 2 %! 3 + & ppDRepVotingThresholdsL + . dvtHardForkInitiationL + .~ 2 + %! 3 + & ppPoolVotingThresholdsL + . pvtHardForkInitiationL + .~ 2 + %! 3 _ <- setupPoolWithStake $ Coin 22_000_000 (stakePoolId1, _, _) <- setupPoolWithStake $ Coin 22_000_000 (stakePoolId2, _, _) <- setupPoolWithStake $ Coin 22_000_000 @@ -227,8 +235,13 @@ hardForkInitiationNoDRepsSpec = (committeeMember :| _) <- registerInitialCommittee modifyPParams $ \pp -> pp - & ppDRepVotingThresholdsL . dvtHardForkInitiationL .~ def - & ppPoolVotingThresholdsL . pvtHardForkInitiationL .~ 2 %! 3 + & ppDRepVotingThresholdsL + . dvtHardForkInitiationL + .~ def + & ppPoolVotingThresholdsL + . pvtHardForkInitiationL + .~ 2 + %! 3 _ <- setupPoolWithStake $ Coin 22_000_000 (stakePoolId1, _, _) <- setupPoolWithStake $ Coin 22_000_000 (stakePoolId2, _, _) <- setupPoolWithStake $ Coin 22_000_000 @@ -249,9 +262,16 @@ noConfidenceSpec = it "NoConfidence" $ do modifyPParams $ \pp -> pp - & ppDRepVotingThresholdsL . dvtCommitteeNoConfidenceL .~ 1 %! 2 - & ppPoolVotingThresholdsL . pvtCommitteeNoConfidenceL .~ 1 %! 2 - & ppCommitteeMaxTermLengthL .~ EpochInterval 200 + & ppDRepVotingThresholdsL + . dvtCommitteeNoConfidenceL + .~ 1 + %! 2 + & ppPoolVotingThresholdsL + . pvtCommitteeNoConfidenceL + .~ 1 + %! 2 + & ppCommitteeMaxTermLengthL + .~ EpochInterval 200 let getCommittee = getsNES $ @@ -404,8 +424,13 @@ actionPrioritySpec = it "proposals of same priority are enacted in order of submission" $ do modifyPParams $ \pp -> pp - & ppDRepVotingThresholdsL . dvtPPEconomicGroupL .~ def - & ppPoolVotingThresholdsL . pvtPPSecurityGroupL .~ 1 %! 1 + & ppDRepVotingThresholdsL + . dvtPPEconomicGroupL + .~ def + & ppPoolVotingThresholdsL + . pvtPPSecurityGroupL + .~ 1 + %! 1 (committeeC :| _) <- registerInitialCommittee (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000 @@ -437,8 +462,13 @@ actionPrioritySpec = it "only the first action of a transaction gets enacted" $ do modifyPParams $ \pp -> pp - & ppDRepVotingThresholdsL . dvtPPEconomicGroupL .~ def - & ppPoolVotingThresholdsL . pvtPPSecurityGroupL .~ 1 %! 1 + & ppDRepVotingThresholdsL + . dvtPPEconomicGroupL + .~ def + & ppPoolVotingThresholdsL + . pvtPPSecurityGroupL + .~ 1 + %! 1 (committeeC :| _) <- registerInitialCommittee (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000 gaids <- diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs index a55af62491b..a993f6a5d38 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs @@ -91,7 +91,8 @@ unknownCostModelsSpec = gai <- submitParameterChange SNothing $ emptyPParamsUpdate - & ppuCostModelsL .~ SJust newCostModels + & ppuCostModelsL + .~ SJust newCostModels submitYesVote_ (DRepVoter drepC) gai submitYesVote_ (CommitteeVoter hotCommitteeC) gai passNEpochs 2 @@ -200,7 +201,8 @@ pparamUpdateSpec = rew <- registerRewardAccount let ppUpdate = emptyPParamsUpdate - & lenz .~ SJust val + & lenz + .~ SJust val ga = ParameterChange SNothing ppUpdate SNothing submitFailingProposal ( ProposalProcedure @@ -848,12 +850,14 @@ votingSpec = it "CC cannot ratify if below threshold" $ do modifyPParams $ \pp -> pp - & ppGovActionLifetimeL .~ EpochInterval 3 + & ppGovActionLifetimeL + .~ EpochInterval 3 & ppDRepVotingThresholdsL - .~ def - { dvtUpdateToConstitution = 1 %! 2 - } - & ppCommitteeMinSizeL .~ 2 + .~ def + { dvtUpdateToConstitution = 1 %! 2 + } + & ppCommitteeMinSizeL + .~ 2 (dRepCred, _, _) <- setupSingleDRep 1_000_000 ccColdCred0 <- KeyHashObj <$> freshKeyHash ccColdCred1 <- KeyHashObj <$> freshKeyHash @@ -1036,7 +1040,8 @@ policySpec = let pparamsUpdate = def - & ppuCommitteeMinSizeL .~ SJust 1 + & ppuCommitteeMinSizeL + .~ SJust 1 rewardAccount <- registerRewardAccount submitProposal_ ProposalProcedure @@ -1066,7 +1071,8 @@ policySpec = let pparamsUpdate = def - & ppuCommitteeMinSizeL .~ SJust 2 + & ppuCommitteeMinSizeL + .~ SJust 2 res <- trySubmitProposal ProposalProcedure @@ -1184,8 +1190,10 @@ proposalWithRewardAccount action = do -- | Tests the first hardfork in the Conway era where the PrevGovActionID is SNothing firstHardForkFollows :: - forall era. - (ShelleyEraImp era, ConwayEraTxBody era) => + forall era ls. + ( ShelleyEraImp ls era + , ConwayEraTxBody era + ) => (ProtVer -> ProtVer) -> ImpTestM era () firstHardForkFollows computeNewFromOld = do @@ -1194,8 +1202,8 @@ firstHardForkFollows computeNewFromOld = do -- | Negative (deliberatey failing) first hardfork in the Conway era where the PrevGovActionID is SNothing firstHardForkCantFollow :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , ConwayEraTxBody era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => @@ -1218,8 +1226,10 @@ firstHardForkCantFollow = do -- | Tests a second hardfork in the Conway era where the PrevGovActionID is SJust secondHardForkFollows :: - forall era. - (ShelleyEraImp era, ConwayEraTxBody era) => + forall era ls. + ( ShelleyEraImp ls era + , ConwayEraTxBody era + ) => (ProtVer -> ProtVer) -> ImpTestM era () secondHardForkFollows computeNewFromOld = do @@ -1231,8 +1241,8 @@ secondHardForkFollows computeNewFromOld = do -- | Negative (deliberatey failing) first hardfork in the Conway era where the PrevGovActionID is SJust secondHardForkCantFollow :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , ConwayEraTxBody era , InjectRuleFailure "LEDGER" ConwayGovPredFailure era ) => @@ -1307,22 +1317,22 @@ ccVoteOnConstitutionFailsWithMultipleVotes = do mkBasicTx $ mkBasicTxBody & votingProceduresTxBodyL - .~ VotingProcedures - ( Map.fromList - [ - ( DRepVoter drepCred2 - , Map.singleton committeeProposal $ VotingProcedure VoteYes SNothing - ) - , - ( CommitteeVoter ccCred - , Map.singleton committeeProposal $ VotingProcedure VoteNo SNothing - ) - , - ( DRepVoter drepCred - , Map.singleton committeeProposal $ VotingProcedure VoteYes SNothing - ) - ] - ) + .~ VotingProcedures + ( Map.fromList + [ + ( DRepVoter drepCred2 + , Map.singleton committeeProposal $ VotingProcedure VoteYes SNothing + ) + , + ( CommitteeVoter ccCred + , Map.singleton committeeProposal $ VotingProcedure VoteNo SNothing + ) + , + ( DRepVoter drepCred + , Map.singleton committeeProposal $ VotingProcedure VoteYes SNothing + ) + ] + ) impAnn "Try to vote as a committee member" $ submitFailingTx voteTx diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs index 5f1a10576fa..8964e5b2804 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/RatifySpec.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Test.Cardano.Ledger.Conway.Imp.RatifySpec ( spec, @@ -147,7 +148,7 @@ paramChangeAffectsProposalsSpec = SNothing ( emptyPParamsUpdate & ppuDRepVotingThresholdsL - .~ SJust (drepVotingThresholds & dvtCommitteeNormalL .~ threshold) + .~ SJust (drepVotingThresholds & dvtCommitteeNormalL .~ threshold) ) SNothing pcGai <- submitGovAction paramChange @@ -210,7 +211,7 @@ paramChangeAffectsProposalsSpec = SNothing ( emptyPParamsUpdate & ppuPoolVotingThresholdsL - .~ SJust (poolVotingThresholds & pvtCommitteeNormalL .~ threshold) + .~ SJust (poolVotingThresholds & pvtCommitteeNormalL .~ threshold) ) SNothing pcGai <- submitGovAction paramChange @@ -283,7 +284,7 @@ paramChangeAffectsProposalsSpec = parent ( emptyPParamsUpdate & ppuDRepVotingThresholdsL - .~ SJust (drepVotingThresholds & dvtPPGovGroupL .~ threshold) + .~ SJust (drepVotingThresholds & dvtPPGovGroupL .~ threshold) ) SNothing parentGai <- submitGovAction $ paramChange SNothing largerThreshold @@ -324,7 +325,8 @@ committeeMinSizeAffectsInFlightProposalsSpec = gaiPC <- submitParameterChange SNothing $ emptyPParamsUpdate - & ppuCommitteeMinSizeL .~ SJust 2 + & ppuCommitteeMinSizeL + .~ SJust 2 submitYesVote_ (CommitteeVoter hotCommitteeC) gaiPC submitYesVote_ (DRepVoter drepC) gaiPC treasury <- getsNES $ nesEsL . esAccountStateL . asTreasuryL @@ -377,8 +379,12 @@ spoVotesCommitteeUpdates = _ <- setupPoolWithStake $ Coin 1_000 modifyPParams $ \pp -> pp - & ppPoolVotingThresholdsL . pvtMotionNoConfidenceL .~ 1 %! 2 - & ppDRepVotingThresholdsL .~ def + & ppPoolVotingThresholdsL + . pvtMotionNoConfidenceL + .~ 1 + %! 2 + & ppDRepVotingThresholdsL + .~ def gai <- submitGovAction $ NoConfidence SNothing -- 1 % 4 stake yes; 3 % 4 stake abstain; yes / stake - abstain > 1 % 2 submitYesVote_ (StakePoolVoter spoK1) gai @@ -391,8 +397,12 @@ spoVotesCommitteeUpdates = _ <- setupPoolWithStake $ Coin 1_000 modifyPParams $ \pp -> pp - & ppPoolVotingThresholdsL . pvtCommitteeNormalL .~ 1 %! 2 - & ppDRepVotingThresholdsL .~ def + & ppPoolVotingThresholdsL + . pvtCommitteeNormalL + .~ 1 + %! 2 + & ppDRepVotingThresholdsL + .~ def committeeC <- KeyHashObj <$> freshKeyHash gai <- @@ -450,15 +460,16 @@ votingSpec = let ppUpdate = emptyPParamsUpdate & ppuPoolVotingThresholdsL - .~ SJust - PoolVotingThresholds - { pvtPPSecurityGroup = 1 %! 2 - , pvtMotionNoConfidence = 1 %! 2 - , pvtHardForkInitiation = 1 %! 2 - , pvtCommitteeNormal = 1 %! 2 - , pvtCommitteeNoConfidence = 1 %! 2 - } - & ppuGovActionLifetimeL .~ SJust (EpochInterval 100) + .~ SJust + PoolVotingThresholds + { pvtPPSecurityGroup = 1 %! 2 + , pvtMotionNoConfidence = 1 %! 2 + , pvtHardForkInitiation = 1 %! 2 + , pvtCommitteeNormal = 1 %! 2 + , pvtCommitteeNoConfidence = 1 %! 2 + } + & ppuGovActionLifetimeL + .~ SJust (EpochInterval 100) gaidThreshold <- submitProposal $ ProposalProcedure @@ -488,7 +499,8 @@ votingSpec = ParameterChange (SJust (GovPurposeId gaidThreshold)) ( emptyPParamsUpdate - & ppuMinFeeAL .~ SJust newMinFeeA + & ppuMinFeeAL + .~ SJust newMinFeeA ) SNothing , pProcDeposit = pp ^. ppGovActionDepositL @@ -518,10 +530,10 @@ votingSpec = modifyPParams $ \pp -> pp & ppDRepVotingThresholdsL - .~ def - { dvtCommitteeNormal = 51 %! 100 - , dvtCommitteeNoConfidence = 51 %! 100 - } + .~ def + { dvtCommitteeNormal = 51 %! 100 + , dvtCommitteeNoConfidence = 51 %! 100 + } -- Setup DRep delegation #1 (drep1, KeyHashObj stakingKH1, paymentKP1) <- setupSingleDRep 1_000_000 -- Setup DRep delegation #2 @@ -548,10 +560,10 @@ votingSpec = modifyPParams $ \pp -> pp & ppDRepVotingThresholdsL - .~ def - { dvtCommitteeNormal = 51 %! 100 - , dvtCommitteeNoConfidence = 51 %! 100 - } + .~ def + { dvtCommitteeNormal = 51 %! 100 + , dvtCommitteeNoConfidence = 51 %! 100 + } -- Setup DRep delegation #1 (drep1, staking1, _) <- setupSingleDRep 1_000_000 -- Setup DRep delegation #2 @@ -569,11 +581,12 @@ votingSpec = -- Add to the rewards of the delegator to this DRep -- to barely make the threshold (51 %! 100) modifyNES $ - nesEsL . epochStateUMapL + nesEsL + . epochStateUMapL %~ UM.adjust (\(UM.RDPair r d) -> UM.RDPair (r <> UM.CompactCoin 200_000) d) staking1 - . UM.RewDepUView + . UM.RewDepUView passNEpochs 2 -- The same vote should now successfully ratify the proposal getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid) @@ -582,14 +595,18 @@ votingSpec = modifyPParams $ \pp -> pp & ppDRepVotingThresholdsL - .~ def - { dvtCommitteeNormal = 51 %! 100 - , dvtCommitteeNoConfidence = 51 %! 100 - } - & ppGovActionDepositL .~ Coin 1_000_000 - & ppPoolDepositL .~ Coin 200_000 - & ppEMaxL .~ EpochInterval 5 - & ppGovActionLifetimeL .~ EpochInterval 5 + .~ def + { dvtCommitteeNormal = 51 %! 100 + , dvtCommitteeNoConfidence = 51 %! 100 + } + & ppGovActionDepositL + .~ Coin 1_000_000 + & ppPoolDepositL + .~ Coin 200_000 + & ppEMaxL + .~ EpochInterval 5 + & ppGovActionLifetimeL + .~ EpochInterval 5 -- Setup DRep delegation #1 (drepKH1, stakingKH1) <- setupDRepWithoutStake -- Add rewards to delegation #1 @@ -630,11 +647,12 @@ votingSpec = modifyPParams $ \pp -> pp & ppPoolVotingThresholdsL - .~ def - { pvtCommitteeNormal = 51 %! 100 - , pvtCommitteeNoConfidence = 51 %! 100 - } - & ppDRepVotingThresholdsL .~ def + .~ def + { pvtCommitteeNormal = 51 %! 100 + , pvtCommitteeNoConfidence = 51 %! 100 + } + & ppDRepVotingThresholdsL + .~ def -- Setup Pool delegation #1 (poolKH1, delegatorCPayment1, delegatorCStaking1) <- setupPoolWithStake $ Coin 1_000_000 -- Setup Pool delegation #2 @@ -666,11 +684,12 @@ votingSpec = modifyPParams $ \pp -> pp & ppPoolVotingThresholdsL - .~ def - { pvtCommitteeNormal = 51 %! 100 - , pvtCommitteeNoConfidence = 51 %! 100 - } - & ppDRepVotingThresholdsL .~ def + .~ def + { pvtCommitteeNormal = 51 %! 100 + , pvtCommitteeNoConfidence = 51 %! 100 + } + & ppDRepVotingThresholdsL + .~ def -- Setup Pool delegation #1 (poolKH1, _, delegatorCStaking1) <- setupPoolWithStake $ Coin 1_000_000 -- Setup Pool delegation #2 @@ -690,11 +709,12 @@ votingSpec = -- Add to the rewards of the delegator to this SPO -- to barely make the threshold (51 %! 100) modifyNES $ - nesEsL . epochStateUMapL + nesEsL + . epochStateUMapL %~ UM.adjust (\(UM.RDPair r d) -> UM.RDPair (r <> UM.CompactCoin 200_000) d) delegatorCStaking1 - . UM.RewDepUView + . UM.RewDepUView passNEpochs 2 -- The same vote should now successfully ratify the proposal getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid) @@ -703,15 +723,20 @@ votingSpec = modifyPParams $ \pp -> pp & ppPoolVotingThresholdsL - .~ def - { pvtCommitteeNormal = 51 %! 100 - , pvtCommitteeNoConfidence = 51 %! 100 - } - & ppGovActionDepositL .~ Coin 1_000_000 - & ppPoolDepositL .~ Coin 200_000 - & ppEMaxL .~ EpochInterval 5 - & ppGovActionLifetimeL .~ EpochInterval 5 - & ppDRepVotingThresholdsL .~ def + .~ def + { pvtCommitteeNormal = 51 %! 100 + , pvtCommitteeNoConfidence = 51 %! 100 + } + & ppGovActionDepositL + .~ Coin 1_000_000 + & ppPoolDepositL + .~ Coin 200_000 + & ppEMaxL + .~ EpochInterval 5 + & ppGovActionLifetimeL + .~ EpochInterval 5 + & ppDRepVotingThresholdsL + .~ def -- Setup Pool delegation #1 (poolKH1, delegatorCStaking1) <- setupPoolWithoutStake -- Add rewards to delegation #1 diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxoSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxoSpec.hs index aae54302565..4d9650302c7 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxoSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxoSpec.hs @@ -112,7 +112,7 @@ spec = describe "UTxO" $ do submitTx . mkBasicTx $ mkBasicTxBody & outputsTxBodyL @era - .~ SSeq.fromList [mkBasicTxOut @era scriptAddr (inject (Coin 1000))] + .~ SSeq.fromList [mkBasicTxOut @era scriptAddr (inject (Coin 1000))] pure $ txInAt (0 :: Int) tx createRefScriptsUtxos :: [Script era] -> ImpTestM era (Map.Map (TxIn (EraCrypto era)) (Script era)) @@ -122,13 +122,14 @@ spec = describe "UTxO" $ do scripts <&> ( \s -> mkBasicTxOut @era (rootOut ^. addrTxOutL) (inject (Coin 100)) - & referenceScriptTxOutL @era .~ SJust s + & referenceScriptTxOutL @era + .~ SJust s ) tx <- submitTx . mkBasicTx $ mkBasicTxBody & outputsTxBodyL @era - .~ SSeq.fromList outs + .~ SSeq.fromList outs let refIns = (`txInAt` tx) <$> [0 .. length scripts - 1] pure $ Map.fromList $ refIns `zip` scripts @@ -137,8 +138,10 @@ spec = describe "UTxO" $ do spendScriptUsingRefScripts scriptIn refIns = submitTxAnn "spendScriptUsingRefScripts" . mkBasicTx $ mkBasicTxBody - & inputsTxBodyL @era .~ Set.singleton scriptIn - & referenceInputsTxBodyL @era .~ refIns + & inputsTxBodyL @era + .~ Set.singleton scriptIn + & referenceInputsTxBodyL @era + .~ refIns nativeScript :: ImpTestM era (NativeScript era) nativeScript = do diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs index 52c1b28ad37..07742b59b99 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/UtxosSpec.hs @@ -99,31 +99,39 @@ datumAndReferenceInputsSpec = do referringTx <- submitTxAnn "Transaction that refers to the script" $ mkBasicTx mkBasicTxBody - & bodyTxL . inputsTxBodyL .~ Set.singleton (mkTxInPartial producingTx 1) - & bodyTxL . referenceInputsTxBodyL .~ Set.singleton (mkTxInPartial producingTx 0) + & bodyTxL + . inputsTxBodyL + .~ Set.singleton (mkTxInPartial producingTx 1) + & bodyTxL + . referenceInputsTxBodyL + .~ Set.singleton (mkTxInPartial producingTx 0) (referringTx ^. witsTxL . scriptTxWitsL) `shouldBe` mempty it "can use regular inputs for reference" $ do producingTx <- setupRefTx referringTx <- submitTxAnn "Consuming transaction" $ mkBasicTx mkBasicTxBody - & bodyTxL . inputsTxBodyL - .~ Set.fromList - [ mkTxInPartial producingTx 0 - , mkTxInPartial producingTx 1 - ] + & bodyTxL + . inputsTxBodyL + .~ Set.fromList + [ mkTxInPartial producingTx 0 + , mkTxInPartial producingTx 1 + ] (referringTx ^. witsTxL . scriptTxWitsL) `shouldBe` mempty it "fails with same txIn in regular inputs and reference inputs" $ do producingTx <- setupRefTx let consumingTx = mkBasicTx mkBasicTxBody - & bodyTxL . inputsTxBodyL - .~ Set.fromList - [ mkTxInPartial producingTx 0 - , mkTxInPartial producingTx 1 - ] - & bodyTxL . referenceInputsTxBodyL .~ Set.singleton (mkTxInPartial producingTx 0) + & bodyTxL + . inputsTxBodyL + .~ Set.fromList + [ mkTxInPartial producingTx 0 + , mkTxInPartial producingTx 1 + ] + & bodyTxL + . referenceInputsTxBodyL + .~ Set.singleton (mkTxInPartial producingTx 0) _ <- submitFailingTx consumingTx @@ -136,19 +144,24 @@ datumAndReferenceInputsSpec = do refTxOut <- mkRefTxOut shSpending let producingTx = mkBasicTx mkBasicTxBody - & bodyTxL . outputsTxBodyL - .~ SSeq.fromList - [ refTxOut - , scriptLockedTxOut shSpending & dataTxOutL .~ SJust (Data spendDatum) - ] + & bodyTxL + . outputsTxBodyL + .~ SSeq.fromList + [ refTxOut + , scriptLockedTxOut shSpending & dataTxOutL .~ SJust (Data spendDatum) + ] logToExpr producingTx producingTxId <- txIdTx <$> submitTxAnn "Producing transaction" producingTx let lockedTxIn = mkTxInPartial producingTxId 1 consumingTx = mkBasicTx mkBasicTxBody - & bodyTxL . inputsTxBodyL .~ Set.singleton lockedTxIn - & bodyTxL . referenceInputsTxBodyL .~ Set.singleton (mkTxInPartial producingTxId 0) + & bodyTxL + . inputsTxBodyL + .~ Set.singleton lockedTxIn + & bodyTxL + . referenceInputsTxBodyL + .~ Set.singleton (mkTxInPartial producingTxId 0) impAnn "Consuming transaction" $ submitFailingTx consumingTx @@ -161,12 +174,15 @@ datumAndReferenceInputsSpec = do let consumingTx = mkBasicTx mkBasicTxBody - & bodyTxL . inputsTxBodyL - .~ Set.fromList - [ mkTxInPartial producingTx 0 - , mkTxInPartial producingTx 1 - ] - & bodyTxL . referenceInputsTxBodyL .~ Set.singleton (mkTxInPartial producingTx 0) + & bodyTxL + . inputsTxBodyL + .~ Set.fromList + [ mkTxInPartial producingTx 0 + , mkTxInPartial producingTx 1 + ] + & bodyTxL + . referenceInputsTxBodyL + .~ Set.singleton (mkTxInPartial producingTx 0) _ <- submitFailingTx consumingTx @@ -180,17 +196,22 @@ datumAndReferenceInputsSpec = do producingTx <- fmap txIdTx . submitTxAnn "Producing transaction" $ mkBasicTx mkBasicTxBody - & bodyTxL . outputsTxBodyL - .~ SSeq.fromList - [ refTxOut - , scriptLockedTxOut shSpending & dataTxOutL .~ SJust (Data spendDatum) - ] + & bodyTxL + . outputsTxBodyL + .~ SSeq.fromList + [ refTxOut + , scriptLockedTxOut shSpending & dataTxOutL .~ SJust (Data spendDatum) + ] let lockedTxIn = mkTxInPartial producingTx 1 consumingTx = mkBasicTx mkBasicTxBody - & bodyTxL . inputsTxBodyL .~ Set.singleton lockedTxIn - & bodyTxL . referenceInputsTxBodyL .~ Set.singleton (mkTxInPartial producingTx 0) + & bodyTxL + . inputsTxBodyL + .~ Set.singleton lockedTxIn + & bodyTxL + . referenceInputsTxBodyL + .~ Set.singleton (mkTxInPartial producingTx 0) impAnn "Consuming transaction" $ submitFailingTx consumingTx @@ -302,10 +323,12 @@ conwayFeaturesPlutusV1V2FailureSpec = do let testCertificateTranslated okCert tx = do submitTx_ ( mkBasicTx mkBasicTxBody - & bodyTxL . inputsTxBodyL - .~ Set.singleton (txInAt (0 :: Int) tx) - & bodyTxL . certsTxBodyL - .~ SSeq.singleton okCert + & bodyTxL + . inputsTxBodyL + .~ Set.singleton (txInAt (0 :: Int) tx) + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton okCert ) describe "RegDepositTxCert" $ do it "V1" $ do @@ -339,10 +362,12 @@ conwayFeaturesPlutusV1V2FailureSpec = do testCertificateNotSupported badCert tx = do submitFailingTx ( mkBasicTx mkBasicTxBody - & bodyTxL . inputsTxBodyL - .~ Set.singleton (txInAt (0 :: Int) tx) - & bodyTxL . certsTxBodyL - .~ SSeq.singleton badCert + & bodyTxL + . inputsTxBodyL + .~ Set.singleton (txInAt (0 :: Int) tx) + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton badCert ) ( pure . injectFailure $ CollectErrors @@ -462,8 +487,12 @@ govPolicySpec = do } let tx = mkBasicTx mkBasicTxBody - & bodyTxL . proposalProceduresTxBodyL .~ [proposal] - & bodyTxL . vldtTxBodyL .~ ValidityInterval SNothing SNothing + & bodyTxL + . proposalProceduresTxBodyL + .~ [proposal] + & bodyTxL + . vldtTxBodyL + .~ ValidityInterval SNothing SNothing submitFailingTx tx [injectFailure $ ScriptWitnessNotValidatingUTXOW [scriptHash]] impAnn "TreasuryWithdrawals" $ do @@ -479,8 +508,12 @@ govPolicySpec = do } let tx = mkBasicTx mkBasicTxBody - & bodyTxL . proposalProceduresTxBodyL .~ [proposal] - & bodyTxL . vldtTxBodyL .~ ValidityInterval SNothing SNothing + & bodyTxL + . proposalProceduresTxBodyL + .~ [proposal] + & bodyTxL + . vldtTxBodyL + .~ ValidityInterval SNothing SNothing submitFailingTx tx [injectFailure $ ScriptWitnessNotValidatingUTXOW [scriptHash]] it "alwaysSucceeds Plutus govPolicy validates" $ do @@ -671,8 +704,9 @@ txWithPlutus :: txWithPlutus sh = do submitTxAnn "Submit a Plutus" $ mkBasicTx mkBasicTxBody - & bodyTxL . outputsTxBodyL - .~ SSeq.singleton (scriptLockedTxOut sh) + & bodyTxL + . outputsTxBodyL + .~ SSeq.singleton (scriptLockedTxOut sh) scriptLockedTxOut :: forall era. @@ -683,11 +717,12 @@ scriptLockedTxOut shSpending = mkBasicTxOut (Addr Testnet (ScriptHashObj shSpending) StakeRefNull) (inject $ Coin 1_000_000) - & dataHashTxOutL .~ SJust (hashData @era $ Data spendDatum) + & dataHashTxOutL + .~ SJust (hashData @era $ Data spendDatum) mkRefTxOut :: ( BabbageEraTxOut era - , AlonzoEraImp era + , AlonzoEraImp ls era ) => ScriptHash (EraCrypto era) -> ImpTestM era (TxOut era) @@ -697,12 +732,13 @@ mkRefTxOut sh = do let mbyPlutusScript = impLookupPlutusScriptMaybe sh pure $ mkBasicTxOut (mkAddr (kpPayment, kpStaking)) (inject $ Coin 100) - & referenceScriptTxOutL .~ maybeToStrictMaybe (fromPlutusScript <$> mbyPlutusScript) + & referenceScriptTxOutL + .~ maybeToStrictMaybe (fromPlutusScript <$> mbyPlutusScript) setupRefTx :: - forall era. + forall era ls. ( BabbageEraTxOut era - , AlonzoEraImp era + , AlonzoEraImp ls era ) => ImpTestM era (TxId (EraCrypto era)) setupRefTx = do @@ -710,12 +746,13 @@ setupRefTx = do refTxOut <- mkRefTxOut shSpending fmap txIdTx . submitTxAnn "Producing transaction" $ mkBasicTx mkBasicTxBody - & bodyTxL . outputsTxBodyL - .~ SSeq.fromList - [ refTxOut - , scriptLockedTxOut shSpending - , scriptLockedTxOut shSpending - ] + & bodyTxL + . outputsTxBodyL + .~ SSeq.fromList + [ refTxOut + , scriptLockedTxOut shSpending + , scriptLockedTxOut shSpending + ] testPlutusV1V2Failure :: forall era a. @@ -732,16 +769,21 @@ testPlutusV1V2Failure sh badField lenz errorField = do tx <- txWithPlutus @era sh submitFailingTx ( mkBasicTx mkBasicTxBody - & bodyTxL . inputsTxBodyL - .~ Set.singleton (txInAt (0 :: Int) tx) - & bodyTxL . lenz - .~ badField + & bodyTxL + . inputsTxBodyL + .~ Set.singleton (txInAt (0 :: Int) tx) + & bodyTxL + . lenz + .~ badField ) ( pure . injectFailure $ CollectErrors [BadTranslation errorField] ) -expectPhase2Invalid :: ConwayEraImp era => Tx era -> ImpTestM era () +expectPhase2Invalid :: + ConwayEraImp era => + Tx era -> + ImpTestM era () expectPhase2Invalid tx = do res <- trySubmitTx tx -- TODO: find a way to check that this is a PlutusFailure @@ -758,8 +800,12 @@ mintingTokenTx tx sh = do (_, addr) <- freshKeyAddr pure $ tx - & bodyTxL . mintTxBodyL .~ ma - & bodyTxL . outputsTxBodyL <>~ [mkBasicTxOut addr (MaryValue (Coin 12345) ma)] + & bodyTxL + . mintTxBodyL + .~ ma + & bodyTxL + . outputsTxBodyL + <>~ [mkBasicTxOut addr (MaryValue (Coin 12345) ma)] enactCostModels :: ConwayEraImp era => 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 e7a215635c8..19150d97276 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs @@ -1,7 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} @@ -164,6 +166,7 @@ import Cardano.Ledger.Plutus.Language (SLanguage (..)) import qualified Cardano.Ledger.Shelley.HardForks as HardForks (bootstrapPhase) import Cardano.Ledger.Shelley.LedgerState ( IncrementalStake (..), + LedgerState, asTreasuryL, certVStateL, curPParamsEpochStateL, @@ -215,8 +218,12 @@ conwayModifyPParams :: ImpTestM era () conwayModifyPParams f = modifyNES $ \nes -> nes - & nesEsL . curPParamsEpochStateL %~ f - & newEpochStateGovStateL . drepPulsingStateGovStateL %~ modifyDRepPulser + & nesEsL + . curPParamsEpochStateL + %~ f + & newEpochStateGovStateL + . drepPulsingStateGovStateL + %~ modifyDRepPulser where modifyDRepPulser pulser = case finishDRepPulser pulser of @@ -234,7 +241,12 @@ withImpStateWithProtVer :: Spec withImpStateWithProtVer ver = do withImpStateModified $ - impNESL . nesEsL . esLStateL . lsUTxOStateL . (utxosGovStateL @era) . cgsCurPParamsL + impNESL + . nesEsL + . esLStateL + . lsUTxOStateL + . (utxosGovStateL @era) + . cgsCurPParamsL %~ ( \(PParams pp) -> PParams (pp {cppProtocolVersion = ProtVer ver 0}) ) @@ -247,7 +259,7 @@ instance , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody) , Eq (ConwayGovEvent (ConwayEra c)) ) => - ShelleyEraImp (ConwayEra c) + ShelleyEraImp LedgerState (ConwayEra c) where initImpTestState = do kh <- fst <$> freshKeyPair @@ -259,25 +271,49 @@ instance initConwayNES committee constitution nes = let newNes = (initAlonzoImpNES nes) - & nesEsL . curPParamsEpochStateL . ppDRepActivityL .~ EpochInterval 100 - & nesEsL . curPParamsEpochStateL . ppGovActionLifetimeL .~ EpochInterval 30 - & nesEsL . curPParamsEpochStateL . ppGovActionDepositL .~ Coin 123 - & nesEsL . curPParamsEpochStateL . ppCommitteeMaxTermLengthL .~ EpochInterval 20 - & nesEsL . curPParamsEpochStateL . ppCommitteeMinSizeL .~ 1 - & nesEsL . curPParamsEpochStateL . ppDRepVotingThresholdsL - %~ ( \dvt -> - dvt - { dvtCommitteeNormal = 1 %! 1 - , dvtCommitteeNoConfidence = 1 %! 2 - , dvtUpdateToConstitution = 1 %! 2 - } - ) - & nesEsL . epochStateGovStateL . committeeGovStateL .~ SJust committee - & nesEsL . epochStateGovStateL . constitutionGovStateL .~ constitution + & nesEsL + . curPParamsEpochStateL + . ppDRepActivityL + .~ EpochInterval 100 + & nesEsL + . curPParamsEpochStateL + . ppGovActionLifetimeL + .~ EpochInterval 30 + & nesEsL + . curPParamsEpochStateL + . ppGovActionDepositL + .~ Coin 123 + & nesEsL + . curPParamsEpochStateL + . ppCommitteeMaxTermLengthL + .~ EpochInterval 20 + & nesEsL + . curPParamsEpochStateL + . ppCommitteeMinSizeL + .~ 1 + & nesEsL + . curPParamsEpochStateL + . ppDRepVotingThresholdsL + %~ ( \dvt -> + dvt + { dvtCommitteeNormal = 1 %! 1 + , dvtCommitteeNoConfidence = 1 %! 2 + , dvtUpdateToConstitution = 1 %! 2 + } + ) + & nesEsL + . epochStateGovStateL + . committeeGovStateL + .~ SJust committee + & nesEsL + . epochStateGovStateL + . constitutionGovStateL + .~ constitution epochState = newNes ^. nesEsL ratifyState = def - & rsEnactStateL .~ mkEnactState (epochState ^. epochStateGovStateL) + & rsEnactStateL + .~ mkEnactState (epochState ^. epochStateGovStateL) in newNes & nesEsL .~ setCompleteDRepPulsingState def ratifyState epochState impSatisfyNativeScript = impAllegraSatisfyNativeScript @@ -293,9 +329,9 @@ instance , DSIGN c ~ Ed25519DSIGN , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody) ) => - MaryEraImp (ConwayEra c) + MaryEraImp LedgerState (ConwayEra c) -instance ShelleyEraImp (ConwayEra c) => AlonzoEraImp (ConwayEra c) where +instance ShelleyEraImp ls (ConwayEra c) => AlonzoEraImp ls (ConwayEra c) where scriptTestContexts = plutusTestScripts SPlutusV1 <> plutusTestScripts SPlutusV2 @@ -303,7 +339,7 @@ instance ShelleyEraImp (ConwayEra c) => AlonzoEraImp (ConwayEra c) where <> plutusTestScripts SPlutusV4 class - ( AlonzoEraImp era + ( AlonzoEraImp LedgerState era , ConwayEraGov era , ConwayEraTxBody era , STS (EraRule "ENACT" era) @@ -326,7 +362,9 @@ instance ConwayEraImp (ConwayEra c) registerInitialCommittee :: - (HasCallStack, ConwayEraImp era) => + ( HasCallStack + , ConwayEraImp era + ) => ImpTestM era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))) registerInitialCommittee = do committeeMembers <- Set.toList <$> getCommitteeMembers @@ -337,8 +375,8 @@ registerInitialCommittee = do -- | Submit a transaction that registers a new DRep and return the keyhash -- belonging to that DRep registerDRep :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , ConwayEraTxCert era ) => ImpTestM era (KeyHash 'DRepRole (EraCrypto era)) @@ -347,13 +385,14 @@ registerDRep = do khDRep <- freshKeyHash submitTxAnn_ "Register DRep" $ mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL - .~ SSeq.singleton - ( RegDRepTxCert - (KeyHashObj khDRep) - zero - SNothing - ) + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton + ( RegDRepTxCert + (KeyHashObj khDRep) + zero + SNothing + ) dreps <- getsNES @era $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsDRepsL dreps `shouldSatisfy` Map.member (KeyHashObj khDRep) pure khDRep @@ -362,9 +401,9 @@ registerDRep = do -- that could count as delegated stake to the DRep, so that we can test that -- rewards are also calculated nonetheless. setupDRepWithoutStake :: - forall era. + forall era ls. ( ConwayEraTxCert era - , ShelleyEraImp era + , ShelleyEraImp ls era ) => ImpTestM era @@ -389,9 +428,9 @@ setupDRepWithoutStake = do -- | Registers a new DRep and delegates the specified amount of ADA to it. setupSingleDRep :: - forall era. + forall era ls. ( ConwayEraTxCert era - , ShelleyEraImp era + , ShelleyEraImp ls era ) => Integer -> ImpTestM @@ -432,7 +471,9 @@ getsPParams f = getsNES $ nesEsL . curPParamsEpochStateL . f -- in Conway. The Shelley version of this function would have to separately -- register the staking credential and then delegate it. setupPoolWithStake :: - (ShelleyEraImp era, ConwayEraTxCert era) => + ( ShelleyEraImp ls era + , ConwayEraTxCert era + ) => Coin -> ImpTestM era @@ -462,7 +503,9 @@ setupPoolWithStake delegCoin = do pure (khPool, credDelegatorPayment, credDelegatorStaking) setupPoolWithoutStake :: - (ShelleyEraImp era, ConwayEraTxCert era) => + ( ShelleyEraImp ls era + , ConwayEraTxCert era + ) => ImpTestM era ( KeyHash 'StakePool (EraCrypto era) @@ -487,7 +530,7 @@ setupPoolWithoutStake = do -- | Submits a transaction with a Vote for the given governance action as -- some voter submitVote :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , ConwayEraTxBody era , HasCallStack ) => @@ -500,7 +543,7 @@ submitVote vote voter gaId = trySubmitVote vote voter gaId >>= expectRightDeep -- | Submits a transaction that votes "Yes" for the given governance action as -- some voter submitYesVote_ :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , ConwayEraTxBody era , HasCallStack ) => @@ -510,7 +553,7 @@ submitYesVote_ :: submitYesVote_ voter gaId = void $ submitVote VoteYes voter gaId submitVote_ :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , ConwayEraTxBody era , HasCallStack ) => @@ -521,7 +564,7 @@ submitVote_ :: submitVote_ vote voter gaId = void $ submitVote vote voter gaId submitFailingVote :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , ConwayEraTxBody era , HasCallStack ) => @@ -535,7 +578,7 @@ submitFailingVote voter gaId expectedFailure = -- | Submits a transaction that votes "Yes" for the given governance action as -- some voter, and expects an `Either` result. trySubmitVote :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , ConwayEraTxBody era ) => Vote -> @@ -551,34 +594,45 @@ trySubmitVote vote voter gaId = fmap (fmap txIdTx) $ trySubmitTx $ mkBasicTx mkBasicTxBody - & bodyTxL . votingProceduresTxBodyL - .~ VotingProcedures - ( Map.singleton - voter - ( Map.singleton - gaId - ( VotingProcedure - { vProcVote = vote - , vProcAnchor = SNothing - } - ) - ) - ) + & bodyTxL + . votingProceduresTxBodyL + .~ VotingProcedures + ( Map.singleton + voter + ( Map.singleton + gaId + ( VotingProcedure + { vProcVote = vote + , vProcAnchor = SNothing + } + ) + ) + ) submitProposal_ :: - (ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) => + ( ShelleyEraImp ls era + , ConwayEraTxBody era + , HasCallStack + ) => ProposalProcedure era -> ImpTestM era () submitProposal_ = void . submitProposal submitProposal :: - (ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) => + ( ShelleyEraImp ls era + , ConwayEraTxBody era + , HasCallStack + ) => ProposalProcedure era -> ImpTestM era (GovActionId (EraCrypto era)) submitProposal proposal = trySubmitProposal proposal >>= expectRightExpr submitProposals :: - (ShelleyEraImp era, ConwayEraGov era, ConwayEraTxBody era, HasCallStack) => + ( ShelleyEraImp ls era + , ConwayEraGov era + , ConwayEraTxBody era + , HasCallStack + ) => NE.NonEmpty (ProposalProcedure era) -> ImpTestM era (NE.NonEmpty (GovActionId (EraCrypto era))) submitProposals proposals = do @@ -604,7 +658,7 @@ submitProposals proposals = do -- | Submits a transaction that proposes the given proposal trySubmitProposal :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , ConwayEraTxBody era ) => ProposalProcedure era -> @@ -626,7 +680,7 @@ trySubmitProposal proposal = do Left err -> Left err trySubmitProposals :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , ConwayEraTxBody era ) => NE.NonEmpty (ProposalProcedure era) -> @@ -639,7 +693,7 @@ trySubmitProposals proposals = do .~ GHC.fromList (toList proposals) submitFailingProposal :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , ConwayEraTxBody era , HasCallStack ) => @@ -652,7 +706,7 @@ submitFailingProposal proposal expectedFailure = -- | Submits a transaction that proposes the given governance action. For proposing -- multiple actions in the same transaciton use `trySubmitGovActions` instead. trySubmitGovAction :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , ConwayEraTxBody era ) => GovAction era -> @@ -687,7 +741,9 @@ submitAndExpireProposalToMakeReward expectedReward stakingC = do -- | Submits a transaction that proposes the given governance action trySubmitGovActions :: - (ShelleyEraImp era, ConwayEraTxBody era) => + ( ShelleyEraImp ls era + , ConwayEraTxBody era + ) => NE.NonEmpty (GovAction era) -> ImpTestM era (Either (NonEmpty (PredicateFailure (EraRule "LEDGER" era))) (Tx era)) trySubmitGovActions gas = do @@ -704,8 +760,8 @@ trySubmitGovActions gas = do trySubmitProposals proposals submitGovAction :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , ConwayEraTxBody era , HasCallStack ) => @@ -716,8 +772,8 @@ submitGovAction ga = do pure gaId submitGovAction_ :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , ConwayEraTxBody era , HasCallStack ) => @@ -726,8 +782,8 @@ submitGovAction_ :: submitGovAction_ = void . submitGovAction submitGovActions :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , ConwayEraTxBody era , HasCallStack ) => @@ -739,7 +795,7 @@ submitGovActions gas = do pure $ NE.zipWith (\idx _ -> GovActionId txId (GovActionIx idx)) (0 NE.:| [1 ..]) gas submitTreasuryWithdrawals :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , ConwayEraTxBody era , ConwayEraGov era ) => @@ -777,8 +833,8 @@ getGovPolicy = nesEpochStateL . epochStateGovStateL . constitutionGovStateL . constitutionScriptL submitFailingGovAction :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , ConwayEraTxBody era , HasCallStack ) => @@ -1126,7 +1182,9 @@ logRatificationChecks gaId = do -- | Submits a transaction that registers a hot key for the given cold key. -- Returns the hot key hash. registerCommitteeHotKey :: - (ShelleyEraImp era, ConwayEraTxCert era) => + ( ShelleyEraImp ls era + , ConwayEraTxCert era + ) => Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era (Credential 'HotCommitteeRole (EraCrypto era)) registerCommitteeHotKey coldKey = do @@ -1140,7 +1198,9 @@ registerCommitteeHotKey coldKey = do -- | Submits a transaction that resigns the cold key resignCommitteeColdKey :: - (ShelleyEraImp era, ConwayEraTxCert era) => + ( ShelleyEraImp ls era + , ConwayEraTxCert era + ) => Credential 'ColdCommitteeRole (EraCrypto era) -> StrictMaybe (Anchor (EraCrypto era)) -> ImpTestM era () @@ -1257,7 +1317,9 @@ proposalsShowDebug ps showRoots = <> ["----- Proposals End -----"] submitConstitutionGovAction :: - (ShelleyEraImp era, ConwayEraTxBody era) => + ( ShelleyEraImp ls era + , ConwayEraTxBody era + ) => StrictMaybe (GovActionId (EraCrypto era)) -> ImpTestM era (GovActionId (EraCrypto era)) submitConstitutionGovAction gid = do diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary.hs b/eras/mary/impl/src/Cardano/Ledger/Mary.hs index 188edf9258e..7df4f97847b 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} @@ -41,7 +42,7 @@ instance instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => - ApplyBlock (MaryEra c) + ApplyBlock "LEDGERS" (MaryEra c) instance Crypto c => CanStartFromGenesis (MaryEra c) where fromShelleyPParams () = translateEra' () . fromShelleyPParams () diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp.hs index 5eef2f3d7d7..b7b203f7fb2 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp.hs +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp.hs @@ -16,13 +16,13 @@ import Test.Cardano.Ledger.Mary.ImpTest (MaryEraImp) import Test.Cardano.Ledger.Shelley.ImpTest (withImpState) spec :: - forall era. - ( MaryEraImp era + forall era ls. + ( MaryEraImp ls era , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era ) => Spec spec = do AllegraImp.spec @era - describe "MaryImpSpec" $ withImpState @era $ do - Utxo.spec @era + describe "MaryImpSpec" $ withImpState @ls @era $ do + Utxo.spec @ls @era 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 bb1b258fbf4..7fada7c2aab 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 @@ -20,7 +20,12 @@ import Test.Cardano.Ledger.Core.Utils (txInAt) import Test.Cardano.Ledger.Imp.Common import Test.Cardano.Ledger.Mary.ImpTest -mintBasicToken :: forall era. (HasCallStack, MaryEraImp era) => ImpTestM era (Tx era) +mintBasicToken :: + forall era ls. + ( HasCallStack + , MaryEraImp ls era + ) => + ImpTestM era (Tx era) mintBasicToken = do (_, addr) <- freshKeyAddr keyHash <- freshKeyHash @@ -32,13 +37,15 @@ mintBasicToken = do txValue = MaryValue txCoin txAsset txBody = mkBasicTxBody - & outputsTxBodyL .~ [mkBasicTxOut addr txValue] - & mintTxBodyL .~ txAsset + & outputsTxBodyL + .~ [mkBasicTxOut addr txValue] + & mintTxBodyL + .~ txAsset submitTx $ mkBasicTx txBody spec :: ( HasCallStack - , MaryEraImp era + , MaryEraImp ls era , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era ) => SpecWith (ImpTestState era) @@ -59,8 +66,10 @@ spec = describe "UTXO" $ do burnTooMuchProducedMultiAsset = MultiAsset (Map.map (Map.map negate) burnTooMuch) txBody = mkBasicTxBody - & inputsTxBodyL .~ [txInAt (0 :: Int) txMinted] - & mintTxBodyL .~ burnTooMuchMultiAsset + & inputsTxBodyL + .~ [txInAt (0 :: Int) txMinted] + & mintTxBodyL + .~ burnTooMuchMultiAsset (_, rootTxOut) <- lookupImpRootTxOut let rootTxOutValue = rootTxOut ^. valueTxOutL predFailures <- expectLeftDeep =<< trySubmitTx (mkBasicTx txBody) diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs index 2cc134bd217..e703b827960 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs +++ b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/ImpTest.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -17,6 +18,7 @@ import Cardano.Ledger.Crypto (Crypto (..)) import Cardano.Ledger.Mary (MaryEra) import Cardano.Ledger.Mary.Core import Cardano.Ledger.Mary.Value +import Cardano.Ledger.Shelley.LedgerState (LedgerState) import Test.Cardano.Ledger.Allegra.ImpTest import Test.Cardano.Ledger.Common import Test.Cardano.Ledger.Mary.TreeDiff () @@ -28,19 +30,19 @@ instance , DSIGN c ~ Ed25519DSIGN , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody) ) => - ShelleyEraImp (MaryEra c) + ShelleyEraImp LedgerState (MaryEra c) where initImpTestState = pure () impSatisfyNativeScript = impAllegraSatisfyNativeScript fixupTx = shelleyFixupTx class - ( ShelleyEraImp era + ( ShelleyEraImp ls era , MaryEraTxBody era , NativeScript era ~ Timelock era , Value era ~ MaryValue (EraCrypto era) ) => - MaryEraImp era + MaryEraImp ls era instance ( Crypto c @@ -49,4 +51,4 @@ instance , DSIGN c ~ Ed25519DSIGN , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody) ) => - MaryEraImp (MaryEra c) + MaryEraImp LedgerState (MaryEra c) 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 b996bfd05d4..84c7a7e7d08 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Mempool.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Mempool.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -52,6 +53,7 @@ import Cardano.Ledger.Shelley (ShelleyEra) 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.LedgerState.Types (HasLedgerState (..)) import Cardano.Ledger.Shelley.Rules () import Cardano.Ledger.Shelley.Rules.Ledger (LedgerEnv) import qualified Cardano.Ledger.Shelley.Rules.Ledger as Ledger @@ -115,7 +117,6 @@ class , STS (EraRule "LEDGER" era) , BaseM (EraRule "LEDGER" era) ~ ShelleyBase , Environment (EraRule "LEDGER" era) ~ LedgerEnv era - , State (EraRule "LEDGER" era) ~ MempoolState era , Signal (EraRule "LEDGER" era) ~ Tx era ) => ApplyTx era @@ -127,10 +128,13 @@ class -- 'TxInBlock' has had all checks run, and can now only fail due to checks -- which depend on the state; most notably, that UTxO inputs disappear. applyTx :: - MonadError (ApplyTxError era) m => + ( MonadError (ApplyTxError era) m + , State (EraRule "LEDGER" era) ~ st era + , HasLedgerState st era + ) => Globals -> MempoolEnv era -> - MempoolState era -> + st era -> Tx era -> m (MempoolState era, Validated (Tx era)) applyTx globals env state tx = @@ -140,7 +144,7 @@ class $ TRC (env, state, tx) in liftEither . left ApplyTxError - . right (,Validated tx) + . right (\st -> (from st, Validated tx)) $ res -- | Reapply a previously validated 'Tx'. @@ -161,6 +165,15 @@ class MempoolState era -> Validated (Tx era) -> m (MempoolState era) + default reapplyTx :: + ( MonadError (ApplyTxError era) m + , State (EraRule "LEDGER" era) ~ MempoolState era + ) => + Globals -> + MempoolEnv era -> + MempoolState era -> + Validated (Tx era) -> + m (MempoolState era) reapplyTx globals env state (Validated tx) = let res = flip runReader globals @@ -273,7 +286,11 @@ instance -- | Old 'applyTxs' applyTxs :: - (ApplyTx era, MonadError (ApplyTxError era) m, EraGov era) => + ( ApplyTx era + , MonadError (ApplyTxError era) m + , EraGov era + , State (EraRule "LEDGER" era) ~ LedgerState.LedgerState era + ) => Globals -> SlotNo -> Seq (Tx era) -> @@ -292,6 +309,7 @@ applyTxsTransition :: forall era m. ( ApplyTx era , MonadError (ApplyTxError era) m + , State (EraRule "LEDGER" era) ~ LedgerState.LedgerState era ) => Globals -> MempoolEnv era -> diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs index 66be58dfb3a..3a3e45b8373 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} @@ -68,12 +69,12 @@ class , STS (EraRule "BBODY" era) , BaseM (EraRule "BBODY" era) ~ ShelleyBase , Environment (EraRule "BBODY" era) ~ STS.BbodyEnv era - , State (EraRule "BBODY" era) ~ STS.ShelleyBbodyState era + , State (EraRule "BBODY" era) ~ STS.ShelleyBbodyState firstRule era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , EncCBORGroup (TxZones era) - , State (EraRule "LEDGERS" era) ~ LedgerState era + , State (EraRule firstRule era) ~ LedgerState era ) => - ApplyBlock era + ApplyBlock firstRule era where -- | Apply the header level ledger transition. -- @@ -116,7 +117,7 @@ class . left BlockTransitionError . right ( mapEventReturn @ep @(EraRule "BBODY" era) $ - updateNewEpochState state + updateNewEpochState @era @firstRule state ) $ res where @@ -158,7 +159,7 @@ class (LedgerState.nesBcur state) applyTick :: - ApplyBlock era => + ApplyBlock firstRule era => Globals -> NewEpochState era -> SlotNo -> @@ -172,7 +173,7 @@ applyTick = } applyBlock :: - ( ApplyBlock era + ( ApplyBlock firstRule era , MonadError (BlockTransitionError era) m ) => Globals -> @@ -198,7 +199,7 @@ instance ( Crypto c , DSignable c (Hash c EraIndependentTxBody) ) => - ApplyBlock (ShelleyEra c) + ApplyBlock "LEDGERS" (ShelleyEra c) {------------------------------------------------------------------------------- CHAIN Transition checks @@ -232,9 +233,9 @@ mkBbodyEnv } updateNewEpochState :: - (LedgerState era ~ State (EraRule "LEDGERS" era), EraGov era) => + (LedgerState era ~ State (EraRule firstRule era), EraGov era) => NewEpochState era -> - STS.ShelleyBbodyState era -> + STS.ShelleyBbodyState firstRule era -> NewEpochState era updateNewEpochState ss (STS.BbodyState ls bcur) = LedgerState.updateNES ss bcur ls diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs index 1a0289a57c6..221f1b3166e 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs @@ -23,6 +23,7 @@ module Cardano.Ledger.Shelley.LedgerState ( InstantaneousRewards (..), KeyPairs, -- deprecated LedgerState (..), + HasLedgerState (..), PState (..), PPUPPredFailure, RewardAccounts, diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs index 37ec726f69d..f19b5ac12c4 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs @@ -72,6 +72,7 @@ import Cardano.Ledger.Shelley.PoolRank (NonMyopic (..)) import Cardano.Ledger.Shelley.RewardUpdate (PulsingRewUpdate (..)) import Cardano.Ledger.UMap (UMap (..)) import Cardano.Ledger.UTxO (UTxO (..)) +import Control.Arrow ((&&&)) import Control.DeepSeq (NFData) import Control.Monad.State.Strict (evalStateT) import Control.Monad.Trans (MonadTrans (lift)) @@ -83,6 +84,7 @@ import qualified Data.Map.Strict as Map import Data.VMap (VB, VMap, VP) import GHC.Generics (Generic) import Lens.Micro +import Lens.Micro.Extras (view) import NoThunks.Class (AllowThunksIn (..), NoThunks (..)) import Numeric.Natural (Natural) @@ -495,6 +497,18 @@ data LedgerState era = LedgerState } deriving (Generic) +class HasLedgerState st era where + hlsUtxoStateL :: Lens' (st era) (UTxOState era) + hlsCertStateL :: Lens' (st era) (CertState era) + from :: HasLedgerState st' era => st era -> st' era + from = uncurry mkLedgerState . (view hlsUtxoStateL &&& view hlsCertStateL) + mkLedgerState :: UTxOState era -> CertState era -> st era + +instance HasLedgerState LedgerState era where + hlsUtxoStateL = lsUTxOStateL + hlsCertStateL = lsCertStateL + mkLedgerState = LedgerState + deriving stock instance ( EraTxOut era , Show (GovState era) 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 aadc095de14..f241d721507 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs @@ -55,15 +55,17 @@ import Control.State.Transition ( import Data.Sequence (Seq) import qualified Data.Sequence.Strict as StrictSeq import GHC.Generics (Generic) +import GHC.TypeLits (Symbol) import Lens.Micro ((^.)) import NoThunks.Class (NoThunks (..)) -data ShelleyBbodyState era - = BbodyState !(State (EraRule "LEDGERS" era)) !(BlocksMade (EraCrypto era)) +data ShelleyBbodyState (firstRule :: Symbol) era + = BbodyState !(State (EraRule firstRule era)) !(BlocksMade (EraCrypto era)) -deriving stock instance Show (State (EraRule "LEDGERS" era)) => Show (ShelleyBbodyState era) +deriving stock instance + Show (State (EraRule firstRule era)) => Show (ShelleyBbodyState firstRule era) -deriving stock instance Eq (State (EraRule "LEDGERS" era)) => Eq (ShelleyBbodyState era) +deriving stock instance Eq (State (EraRule firstRule era)) => Eq (ShelleyBbodyState firstRule era) data BbodyEnv era = BbodyEnv { bbodyPp :: PParams era @@ -143,7 +145,7 @@ instance where type State (ShelleyBBODY era) = - ShelleyBbodyState era + ShelleyBbodyState "LEDGERS" era type Signal (ShelleyBBODY era) = diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs index 2180f84cd8c..90e967a5984 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Test.Cardano.Ledger.Shelley.Imp (spec) where @@ -17,17 +18,17 @@ import Test.Cardano.Ledger.Shelley.ImpTest (ShelleyEraImp, withImpState) import qualified Test.Cardano.Ledger.Shelley.UnitTests.IncrementalStakeTest as Incremental spec :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era ) => Spec spec = do - describe "ShelleyImpSpec" $ withImpState @era $ do + describe "ShelleyImpSpec" $ withImpState @ls @era $ do Ledger.spec @era Epoch.spec @era - Utxow.spec @era - Utxo.spec @era + Utxow.spec @ls @era + Utxo.spec @ls @era describe "ShelleyPureTests" $ do Incremental.spec @era diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/EpochSpec.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/EpochSpec.hs index f48e5fe154d..f260c646c0e 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/EpochSpec.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/EpochSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Test.Cardano.Ledger.Shelley.Imp.EpochSpec ( spec, @@ -26,8 +27,8 @@ import Test.Cardano.Ledger.Shelley.ImpTest ( ) spec :: - forall era. - ShelleyEraImp era => + forall era ls. + ShelleyEraImp ls era => SpecWith (ImpTestState era) spec = describe "EPOCH" $ do it "Runs basic transaction" $ do diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/LedgerSpec.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/LedgerSpec.hs index 7b783463909..bdae54776cf 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/LedgerSpec.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/LedgerSpec.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Test.Cardano.Ledger.Shelley.Imp.LedgerSpec ( spec, @@ -19,8 +20,8 @@ import Test.Cardano.Ledger.Imp.Common import Test.Cardano.Ledger.Shelley.ImpTest spec :: - forall era. - ShelleyEraImp era => + forall era ls. + ShelleyEraImp ls era => SpecWith (ImpTestState era) spec = describe "LEDGER" $ do it "Transactions update UTxO" $ do @@ -31,8 +32,8 @@ spec = describe "LEDGER" $ do submitTxAnn "First transaction" . mkBasicTx $ mkBasicTxBody & outputsTxBodyL @era - .~ SSeq.singleton - (mkBasicTxOut (mkAddr (kpPayment1, kpStaking1)) $ inject coin1) + .~ SSeq.singleton + (mkBasicTxOut (mkAddr (kpPayment1, kpStaking1)) $ inject coin1) UTxO utxo1 <- getUTxO case Map.lookup (txInAt (0 :: Int) tx1) utxo1 of Just out1 -> out1 ^. coinTxOutL `shouldBe` coin1 @@ -44,11 +45,11 @@ spec = describe "LEDGER" $ do submitTxAnn "Second transaction" . mkBasicTx $ mkBasicTxBody & inputsTxBodyL - .~ Set.singleton - (txInAt (0 :: Int) tx1) + .~ Set.singleton + (txInAt (0 :: Int) tx1) & outputsTxBodyL @era - .~ SSeq.singleton - (mkBasicTxOut (mkAddr (kpPayment2, kpStaking2)) $ inject coin2) + .~ SSeq.singleton + (mkBasicTxOut (mkAddr (kpPayment2, kpStaking2)) $ inject coin2) UTxO utxo2 <- getUTxO case Map.lookup (txInAt (0 :: Int) tx2) utxo2 of Just out1 -> do 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 a396f60cca6..264e180f7a2 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 @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeFamilies #-} module Test.Cardano.Ledger.Shelley.Imp.UtxoSpec (spec) where @@ -15,7 +16,7 @@ import Test.Cardano.Ledger.Imp.Common import Test.Cardano.Ledger.Shelley.ImpTest spec :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era ) => SpecWith (ImpTestState era) @@ -31,15 +32,20 @@ spec = describe "UTXO" $ do rootTxOutValue = rootTxOut ^. valueTxOutL txBody = mkBasicTxBody - & inputsTxBodyL .~ [txIn] - & outputsTxBodyL .~ [mkBasicTxOut addr2 (inject (Coin 200000))] + & inputsTxBodyL + .~ [txIn] + & outputsTxBodyL + .~ [mkBasicTxOut addr2 (inject (Coin 200000))] adjustTxOut = \case Empty -> error "Unexpected empty sequence of outputs" txOut :<| outs -> (txOut & coinTxOutL %~ (<> extra)) :<| outs adjustFirstTxOut tx = tx - & bodyTxL . outputsTxBodyL %~ adjustTxOut - & witsTxL .~ mkBasicTxWits + & bodyTxL + . outputsTxBodyL + %~ adjustTxOut + & witsTxL + .~ mkBasicTxWits res <- withPostFixup (updateAddrTxWits . adjustFirstTxOut) $ trySubmitTx (mkBasicTx txBody) predFailures <- expectLeftDeep res diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/UtxowSpec.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/UtxowSpec.hs index a6ca83c9103..911431a7a2b 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/UtxowSpec.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/UtxowSpec.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeFamilies #-} module Test.Cardano.Ledger.Shelley.Imp.UtxowSpec (spec) where @@ -17,7 +18,7 @@ import Test.Cardano.Ledger.Imp.Common import Test.Cardano.Ledger.Shelley.ImpTest spec :: - ( ShelleyEraImp era + ( ShelleyEraImp ls era , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era ) => SpecWith (ImpTestState era) diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs index 342eab8acbb..df9334103d6 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -12,6 +12,7 @@ {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -144,6 +145,7 @@ import Cardano.Ledger.Shelley.Core import Cardano.Ledger.Shelley.LedgerState ( AccountState (..), EpochState (..), + HasLedgerState, LedgerState (..), NewEpochState (..), StashedAVVMAddresses, @@ -154,6 +156,7 @@ import Cardano.Ledger.Shelley.LedgerState ( epochStateUMapL, esAccountStateL, esLStateL, + from, lsCertStateL, lsUTxOStateL, nesELL, @@ -330,7 +333,8 @@ class STS (EraRule "LEDGER" era) , BaseM (EraRule "LEDGER" era) ~ ShelleyBase , Signal (EraRule "LEDGER" era) ~ Tx era - , State (EraRule "LEDGER" era) ~ LedgerState era + , HasLedgerState ls era + , State (EraRule "LEDGER" era) ~ ls era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , Eq (PredicateFailure (EraRule "LEDGER" era)) , Show (PredicateFailure (EraRule "LEDGER" era)) @@ -364,7 +368,7 @@ class , DSIGNAlgorithm (DSIGN (EraCrypto era)) , Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentTxBody) ) => - ShelleyEraImp era + ShelleyEraImp ls era where initImpTestState :: (MonadState (ImpTestState era) m, MonadGen m) => m () @@ -413,8 +417,8 @@ logStakeDistr = do logEntry $ "Stake distr: " <> showExpr stakeDistr mkHashVerKeyVRF :: - forall era. - ShelleyEraImp era => + forall era ls. + ShelleyEraImp ls era => Integer -> Hash (HASH (EraCrypto era)) (VerKeyVRF (EraCrypto era)) mkHashVerKeyVRF = @@ -430,7 +434,7 @@ testKeyHash :: Crypto c => KeyHash kd c testKeyHash = mkKeyHash (-1) initShelleyImpNES :: - forall era. ShelleyEraImp era => NewEpochState era + forall era ls. ShelleyEraImp ls era => NewEpochState era initShelleyImpNES = NewEpochState { stashedAVVMAddresses = def @@ -461,8 +465,10 @@ initShelleyImpNES = where pp = emptyPParams - & ppMinFeeAL .~ Coin 44 - & ppMinFeeBL .~ Coin 155_381 + & ppMinFeeAL + .~ Coin 44 + & ppMinFeeBL + .~ Coin 155_381 epochState = EpochState { esAccountState = @@ -485,8 +491,10 @@ initShelleyImpNES = } , esNonMyopic = def } - & prevPParamsEpochStateL .~ pp - & curPParamsEpochStateL .~ pp + & prevPParamsEpochStateL + .~ pp + & curPParamsEpochStateL + .~ pp utxo = mempty mkTxId :: Crypto c => Int -> TxId c @@ -499,7 +507,7 @@ instance , DSIGN c ~ Ed25519DSIGN , Signable (DSIGN c) (Hash (HASH c) EraIndependentTxBody) ) => - ShelleyEraImp (ShelleyEra c) + ShelleyEraImp LedgerState (ShelleyEra c) where initImpTestState = pure () @@ -591,13 +599,13 @@ instance MonadState (ImpTestState era) (ImpTestM era) where put x = ImpTestM $ do liftIO . flip writeIORef x . iteState =<< ask -instance ShelleyEraImp era => Example (ImpTestM era ()) where +instance ShelleyEraImp ls era => Example (ImpTestM era ()) where type Arg (ImpTestM era ()) = ImpTestState era evaluateExample impTest params = evaluateExample (\s -> uncurry evalImpTestM (applyParamsQCGen params s) impTest) params -instance (ShelleyEraImp era, Arbitrary a, Show a) => Example (a -> ImpTestM era ()) where +instance (ShelleyEraImp ls era, Arbitrary a, Show a) => Example (a -> ImpTestM era ()) where type Arg (a -> ImpTestM era ()) = ImpTestState era evaluateExample impTest params = @@ -637,39 +645,43 @@ mixinCurrentGen :: ImpTestState era -> QCGen -> ImpTestState era mixinCurrentGen impTestState qcGen = impTestState {impGen = integerVariant (fst (Random.random (impGen impTestState))) qcGen} -evalImpTestGenM :: ShelleyEraImp era => ImpTestState era -> ImpTestM era b -> Gen (IO b) +evalImpTestGenM :: ShelleyEraImp ls era => ImpTestState era -> ImpTestM era b -> Gen (IO b) evalImpTestGenM impState = fmap (fmap fst) . runImpTestGenM impState evalImpTestM :: - ShelleyEraImp era => Maybe Int -> ImpTestState era -> ImpTestM era b -> IO b + ShelleyEraImp ls era => Maybe Int -> ImpTestState era -> ImpTestM era b -> IO b evalImpTestM qc impState = fmap fst . runImpTestM qc impState execImpTestGenM :: - ShelleyEraImp era => ImpTestState era -> ImpTestM era b -> Gen (IO (ImpTestState era)) + ShelleyEraImp ls era => ImpTestState era -> ImpTestM era b -> Gen (IO (ImpTestState era)) execImpTestGenM impState = fmap (fmap snd) . runImpTestGenM impState execImpTestM :: - ShelleyEraImp era => + ShelleyEraImp ls era => Maybe Int -> ImpTestState era -> ImpTestM era b -> IO (ImpTestState era) execImpTestM qcSize impState = fmap snd . runImpTestM qcSize impState -runImpTestGenM_ :: ShelleyEraImp era => ImpTestState era -> ImpTestM era b -> Gen (IO ()) +runImpTestGenM_ :: + ShelleyEraImp ls era => ImpTestState era -> ImpTestM era b -> Gen (IO ()) runImpTestGenM_ impState = fmap void . runImpTestGenM impState runImpTestM_ :: - ShelleyEraImp era => Maybe Int -> ImpTestState era -> ImpTestM era b -> IO () + ShelleyEraImp ls era => Maybe Int -> ImpTestState era -> ImpTestM era b -> IO () runImpTestM_ qcSize impState = void . runImpTestM qcSize impState runImpTestGenM :: - ShelleyEraImp era => ImpTestState era -> ImpTestM era b -> Gen (IO (b, ImpTestState era)) + ShelleyEraImp ls era => + ImpTestState era -> + ImpTestM era b -> + Gen (IO (b, ImpTestState era)) runImpTestGenM impState m = MkGen $ \qcGen qcSz -> runImpTestM (Just qcSz) (mixinCurrentGen impState qcGen) m runImpTestM :: - ShelleyEraImp era => + ShelleyEraImp ls era => Maybe Int -> ImpTestState era -> ImpTestM era b -> @@ -753,7 +765,7 @@ impNativeScriptsRequired tx = do -- | Modifies transaction by adding necessary scripts addNativeScriptTxWits :: - ShelleyEraImp era => + ShelleyEraImp ls era => Tx era -> ImpTestM era (Tx era) addNativeScriptTxWits tx = impAnn "addNativeScriptTxWits" $ do @@ -763,12 +775,14 @@ addNativeScriptTxWits tx = impAnn "addNativeScriptTxWits" $ do scriptsToAdd = scriptsRequired Map.\\ provided pure $ tx - & witsTxL . scriptTxWitsL <>~ fmap fromNativeScript scriptsToAdd + & witsTxL + . scriptTxWitsL + <>~ fmap fromNativeScript scriptsToAdd -- | Adds @TxWits@ that will satisfy all of the required key witnesses updateAddrTxWits :: ( HasCallStack - , ShelleyEraImp era + , ShelleyEraImp ls era ) => Tx era -> ImpTestM era (Tx era) @@ -799,22 +813,29 @@ updateAddrTxWits tx = impAnn "updateAddrTxWits" $ do pure $ makeBootstrapWitness (extractHash txBodyHash) signingKey attrs pure $ tx - & witsTxL . addrTxWitsL <>~ extraAddrVKeyWits <> extraNativeScriptVKeyWits - & witsTxL . bootAddrTxWitsL <>~ Set.fromList extraBootAddrWits + & witsTxL + . addrTxWitsL + <>~ extraAddrVKeyWits + <> extraNativeScriptVKeyWits + & witsTxL + . bootAddrTxWitsL + <>~ Set.fromList extraBootAddrWits -- | This fixup step ensures that there are enough funds in the transaction. addRootTxIn :: - ShelleyEraImp era => + ShelleyEraImp ls era => Tx era -> ImpTestM era (Tx era) addRootTxIn tx = impAnn "addRootTxIn" $ do rootTxIn <- fst <$> lookupImpRootTxOut pure $ tx - & bodyTxL . inputsTxBodyL %~ Set.insert rootTxIn + & bodyTxL + . inputsTxBodyL + %~ Set.insert rootTxIn impNativeScriptKeyPairs :: - ShelleyEraImp era => + ShelleyEraImp ls era => Tx era -> ImpTestM era @@ -827,7 +848,7 @@ impNativeScriptKeyPairs tx = do pure . mconcat $ catMaybes keyPairs fixupFees :: - (ShelleyEraImp era, HasCallStack) => + (ShelleyEraImp ls era, HasCallStack) => Tx era -> ImpTestM era (Tx era) fixupFees tx = impAnn "fixupFees" $ do @@ -867,17 +888,25 @@ fixupFees tx = impAnn "fixupFees" $ do txWithFee | change >= getMinCoinTxOut pp changeTxOut = txNoWits - & bodyTxL . outputsTxBodyL .~ (outsBeforeFee :|> changeTxOut) - & bodyTxL . feeTxBodyL .~ fee + & bodyTxL + . outputsTxBodyL + .~ (outsBeforeFee :|> changeTxOut) + & bodyTxL + . feeTxBodyL + .~ fee | otherwise = txNoWits - & bodyTxL . outputsTxBodyL .~ outsBeforeFee - & bodyTxL . feeTxBodyL .~ (fee <> change) + & bodyTxL + . outputsTxBodyL + .~ outsBeforeFee + & bodyTxL + . feeTxBodyL + .~ (fee <> change) pure txWithFee shelleyFixupTx :: - forall era. - (ShelleyEraImp era, HasCallStack) => + forall era ls. + (ShelleyEraImp ls era, HasCallStack) => Tx era -> ImpTestM era (Tx era) shelleyFixupTx = @@ -897,15 +926,25 @@ logFeeMismatch tx = do logEntry $ "Estimated fee " <> show feeUsed <> " while required fee is " <> show feeMin -submitTx_ :: (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era () +submitTx_ :: + ( HasCallStack + , ShelleyEraImp ls era + ) => + Tx era -> + ImpTestM era () submitTx_ = void . submitTx -submitTx :: (HasCallStack, ShelleyEraImp era) => Tx era -> ImpTestM era (Tx era) +submitTx :: + ( HasCallStack + , ShelleyEraImp ls era + ) => + Tx era -> + ImpTestM era (Tx era) submitTx tx = trySubmitTx tx >>= expectRightDeepExpr trySubmitTx :: - forall era. - ( ShelleyEraImp era + forall era ls. + ( ShelleyEraImp ls era , HasCallStack ) => Tx era -> @@ -916,7 +955,7 @@ trySubmitTx tx = do st <- gets impNES lEnv <- impLedgerEnv st ImpTestState {impRootTxIn} <- get - res <- tryRunImpRule @"LEDGER" lEnv (st ^. nesEsL . esLStateL) txFixed + res <- tryRunImpRule @"LEDGER" lEnv (from $ st ^. nesEsL . esLStateL) txFixed case res of Left predFailures -> do -- Verify that produced predicate failures are ready for the node-to-client protocol @@ -929,7 +968,7 @@ trySubmitTx tx = do | outsSize > 0 = outsSize - 1 | otherwise = error ("Expected at least 1 output after submitting tx: " <> show txId) tell $ fmap (SomeSTSEvent @era @"LEDGER") events - modify $ impNESL . nesEsL . esLStateL .~ st' + modify $ impNESL . nesEsL . esLStateL .~ from st' UTxO utxo <- getUTxO -- This TxIn is in the utxo, and thus can be the new root, only if the transaction -- was phase2-valid. Otherwise, no utxo with this id would have been created, and @@ -946,7 +985,7 @@ trySubmitTx tx = do -- outputs are automatically balanced. submitFailingTx :: ( HasCallStack - , ShelleyEraImp era + , ShelleyEraImp ls era ) => Tx era -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)) -> @@ -1007,9 +1046,9 @@ runImpRule stsEnv stsState stsSignal = do -- | Runs the TICK rule once passTick :: - forall era. + forall era ls. ( HasCallStack - , ShelleyEraImp era + , ShelleyEraImp ls era ) => ImpTestM era () passTick = do @@ -1021,8 +1060,8 @@ passTick = do -- | Runs the TICK rule until the next epoch is reached passEpoch :: - forall era. - ShelleyEraImp era => + forall era ls. + ShelleyEraImp ls era => ImpTestM era () passEpoch = do startEpoch <- getsNES nesELL @@ -1058,8 +1097,8 @@ epochBoundaryCheck preNES postNES = do -- | Runs the TICK rule until the `n` epochs are passed passNEpochs :: - forall era. - ShelleyEraImp era => + forall era ls. + ShelleyEraImp ls era => Natural -> ImpTestM era () passNEpochs n = when (n > 0) $ passEpoch >> passNEpochs (n - 1) @@ -1108,13 +1147,13 @@ logToExpr :: (HasCallStack, ToExpr a) => a -> ImpTestM era () logToExpr e = logEntry (showExpr e) withImpState :: - ShelleyEraImp era => + ShelleyEraImp ls era => SpecWith (ImpTestState era) -> Spec withImpState = withImpStateModified id withImpStateModified :: - ShelleyEraImp era => + ShelleyEraImp ls era => (ImpTestState era -> ImpTestState era) -> SpecWith (ImpTestState era) -> Spec @@ -1142,7 +1181,11 @@ withImpStateModified f = (rootKeyHash, _) <- freshKeyPair let rootAddr = Addr Testnet (KeyHashObj rootKeyHash) StakeRefNull rootTxOut = mkBasicTxOut rootAddr $ inject rootCoin - impNESL . nesEsL . esLStateL . lsUTxOStateL . utxosUtxoL + impNESL + . nesEsL + . esLStateL + . lsUTxOStateL + . utxosUtxoL %= (<> UTxO (Map.singleton rootTxIn rootTxOut)) -- | Creates a fresh @SafeHash@ @@ -1242,14 +1285,18 @@ freshBootstapAddress = do pure bootAddr sendCoinTo :: - (ShelleyEraImp era, HasCallStack) => + ( ShelleyEraImp ls era + , HasCallStack + ) => Addr (EraCrypto era) -> Coin -> ImpTestM era (TxIn (EraCrypto era)) sendCoinTo addr = sendValueTo addr . inject sendValueTo :: - (ShelleyEraImp era, HasCallStack) => + ( ShelleyEraImp ls era + , HasCallStack + ) => Addr (EraCrypto era) -> Value era -> ImpTestM era (TxIn (EraCrypto era)) @@ -1258,7 +1305,9 @@ sendValueTo addr amount = do submitTxAnn ("Giving " <> show amount <> " to " <> show addr) $ mkBasicTx mkBasicTxBody - & bodyTxL . outputsTxBodyL .~ SSeq.singleton (mkBasicTxOut addr amount) + & bodyTxL + . outputsTxBodyL + .~ SSeq.singleton (mkBasicTxOut addr amount) pure $ txInAt (0 :: Int) tx -- | Modify the current new epoch state with a function @@ -1276,14 +1325,21 @@ getProtVer :: EraGov era => ImpTestM era ProtVer getProtVer = getsNES $ nesEsL . curPParamsEpochStateL . ppProtocolVersionL submitTxAnn :: - (HasCallStack, ShelleyEraImp era) => + ( HasCallStack + , ShelleyEraImp ls era + ) => String -> Tx era -> ImpTestM era (Tx era) submitTxAnn msg tx = impAnn msg (trySubmitTx tx >>= expectRightDeepExpr) submitTxAnn_ :: - (HasCallStack, ShelleyEraImp era) => String -> Tx era -> ImpTestM era () + ( HasCallStack + , ShelleyEraImp ls era + ) => + String -> + Tx era -> + ImpTestM era () submitTxAnn_ msg = void . submitTxAnn msg getRewardAccountFor :: @@ -1294,9 +1350,9 @@ getRewardAccountFor stakingC = do pure $ RewardAccount networkId stakingC registerRewardAccount :: - forall era. + forall era ls. ( HasCallStack - , ShelleyEraImp era + , ShelleyEraImp ls era ) => ImpTestM era (RewardAccount (EraCrypto era)) registerRewardAccount = do @@ -1306,14 +1362,16 @@ registerRewardAccount = do let stakingCredential = KeyHashObj khDelegator submitTxAnn_ ("Register Reward Account: " <> T.unpack (credToText stakingCredential)) $ mkBasicTx mkBasicTxBody - & bodyTxL . outputsTxBodyL - .~ SSeq.fromList - [ mkBasicTxOut - (mkAddr (kpSpending, kpDelegator)) - (inject $ Coin 10_000_000) - ] - & bodyTxL . certsTxBodyL - .~ SSeq.fromList [RegTxCert @era stakingCredential] + & bodyTxL + . outputsTxBodyL + .~ SSeq.fromList + [ mkBasicTxOut + (mkAddr (kpSpending, kpDelegator)) + (inject $ Coin 10_000_000) + ] + & bodyTxL + . certsTxBodyL + .~ SSeq.fromList [RegTxCert @era stakingCredential] networkId <- use (to impGlobals . to networkId) pure $ RewardAccount networkId stakingCredential @@ -1329,7 +1387,9 @@ lookupReward stakingCredential = do <> "or by some other means." Just rd -> pure $ fromCompact (rdReward rd) -registerPool :: ShelleyEraImp era => ImpTestM era (KeyHash 'StakePool (EraCrypto era)) +registerPool :: + ShelleyEraImp ls era => + ImpTestM era (KeyHash 'StakePool (EraCrypto era)) registerPool = do khPool <- freshKeyHash rewardAccount <- registerRewardAccount @@ -1349,11 +1409,13 @@ registerPool = do } submitTxAnn_ "Registering a new stake pool" $ mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL .~ SSeq.singleton (RegPoolTxCert poolParams) + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton (RegPoolTxCert poolParams) pure khPool registerAndRetirePoolToMakeReward :: - ShelleyEraImp era => + ShelleyEraImp ls era => Credential 'Staking (EraCrypto era) -> ImpTestM era () registerAndRetirePoolToMakeReward stakingC = do @@ -1376,13 +1438,16 @@ registerAndRetirePoolToMakeReward stakingC = do } submitTxAnn_ "Registering a temporary stake pool" $ mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL .~ SSeq.singleton (RegPoolTxCert poolParams) + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton (RegPoolTxCert poolParams) passEpoch currentEpochNo <- getsNES nesELL submitTxAnn_ "Retiring the temporary stake pool" $ mkBasicTx mkBasicTxBody - & bodyTxL . certsTxBodyL - .~ SSeq.singleton (RetirePoolTxCert poolKH $ addEpochInterval currentEpochNo $ EpochInterval 2) + & bodyTxL + . certsTxBodyL + .~ SSeq.singleton (RetirePoolTxCert poolKH $ addEpochInterval currentEpochNo $ EpochInterval 2) passEpoch -- | Compose given function with the configured fixup @@ -1436,7 +1501,7 @@ expectTreasury c = impGetNativeScript :: ScriptHash (EraCrypto era) -> ImpTestM era (Maybe (NativeScript era)) impGetNativeScript sh = Map.lookup sh <$> gets impNativeScripts -impLookupUTxO :: ShelleyEraImp era => TxIn (EraCrypto era) -> ImpTestM era (TxOut era) +impLookupUTxO :: ShelleyEraImp ls era => TxIn (EraCrypto era) -> ImpTestM era (TxOut era) impLookupUTxO txIn = impAnn "Looking up TxOut" $ do utxo <- getUTxO case txinLookup txIn utxo of diff --git a/eras/shelley/test-suite/bench/BenchValidation.hs b/eras/shelley/test-suite/bench/BenchValidation.hs index 725bbb31e3e..9d3d28efc45 100644 --- a/eras/shelley/test-suite/bench/BenchValidation.hs +++ b/eras/shelley/test-suite/bench/BenchValidation.hs @@ -81,7 +81,7 @@ validateInput :: , Mock (EraCrypto era) , EraRule "LEDGERS" era ~ API.ShelleyLEDGERS era , QC.HasTrace (API.ShelleyLEDGERS era) (GenEnv era) - , API.ApplyBlock era + , API.ApplyBlock "LEDGERS" era , GetLedgerView era , MinLEDGER_STS era ) => @@ -95,7 +95,7 @@ genValidateInput :: , Mock (EraCrypto era) , EraRule "LEDGERS" era ~ API.ShelleyLEDGERS era , QC.HasTrace (API.ShelleyLEDGERS era) (GenEnv era) - , API.ApplyBlock era + , API.ApplyBlock "LEDGERS" era , GetLedgerView era , MinLEDGER_STS era ) => @@ -109,18 +109,18 @@ genValidateInput n = do benchValidate :: forall era. - (API.ApplyBlock era, Era era) => + (API.ApplyBlock "LEDGERS" era, Era era) => ValidateInput era -> IO (NewEpochState era) benchValidate (ValidateInput globals state (Block bh txs)) = - case API.applyBlock @era globals state (UnsafeUnserialisedBlock (makeHeaderView bh) txs) of + case API.applyBlock @"LEDGERS" @era globals state (UnsafeUnserialisedBlock (makeHeaderView bh) txs) of Right x -> pure x Left x -> error (show x) applyBlock :: forall era. ( EraTxOut era - , API.ApplyBlock era + , API.ApplyBlock "LEDGERS" era , NFData (StashedAVVMAddresses era) , GovState era ~ ShelleyGovState era ) => @@ -128,12 +128,12 @@ applyBlock :: Int -> Int applyBlock (ValidateInput globals state (Block bh txs)) n = - case API.applyBlock @era globals state (UnsafeUnserialisedBlock (makeHeaderView bh) txs) of + case API.applyBlock @"LEDGERS" @era globals state (UnsafeUnserialisedBlock (makeHeaderView bh) txs) of Right x -> seq (rnf x) (n + 1) Left x -> error (show x) benchreValidate :: - (API.ApplyBlock era, Era era) => + (API.ApplyBlock "LEDGERS" era, Era era) => ValidateInput era -> NewEpochState era benchreValidate (ValidateInput globals state (Block bh txs)) = @@ -177,7 +177,7 @@ genUpdateInputs :: , GetLedgerView era , EraRule "LEDGERS" era ~ API.ShelleyLEDGERS era , QC.HasTrace (API.ShelleyLEDGERS era) (GenEnv era) - , API.ApplyBlock era + , API.ApplyBlock "LEDGERS" era ) => Int -> IO (UpdateInputs (EraCrypto era)) diff --git a/eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs b/eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs index b0132cf68de..13d6b6eb14c 100644 --- a/eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs +++ b/eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs @@ -90,7 +90,7 @@ genBlock :: , GetLedgerView era , EraRule "LEDGERS" era ~ ShelleyLEDGERS era , QC.HasTrace (ShelleyLEDGERS era) (GenEnv era) - , ApplyBlock era + , ApplyBlock "LEDGERS" era ) => GenEnv era -> ChainState era -> diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs index 6f1548f006d..c70e176669f 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs @@ -92,7 +92,7 @@ genBlock :: forall era. ( TxStructure era ~ StrictSeq.StrictSeq , MinLEDGER_STS era - , ApplyBlock era + , ApplyBlock "LEDGERS" era , Mock (EraCrypto era) , GetLedgerView era , QC.HasTrace (EraRule "LEDGERS" era) (GenEnv era) @@ -114,7 +114,7 @@ genBlockWithTxGen :: ( TxStructure era ~ StrictSeq.StrictSeq , Mock (EraCrypto era) , GetLedgerView era - , ApplyBlock era + , ApplyBlock "LEDGERS" era , EraGen era ) => TxGen era -> @@ -196,7 +196,7 @@ selectNextSlotWithLeader :: ( Mock (EraCrypto era) , EraGen era , GetLedgerView era - , ApplyBlock era + , ApplyBlock "LEDGERS" era ) => GenEnv era -> ChainState era -> @@ -271,7 +271,7 @@ selectNextSlotWithLeader -- | The chain state is a composite of the new epoch state and the chain dep -- state. We tick both. tickChainState :: - (GetLedgerView era, ApplyBlock era) => + (GetLedgerView era, ApplyBlock "LEDGERS" era) => SlotNo -> ChainState era -> ChainState era diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs index de5a0446c43..a8441f3d6d7 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs @@ -90,13 +90,13 @@ instance , EraGen era , EraSegWits era , Mock (EraCrypto era) - , ApplyBlock era + , ApplyBlock "LEDGERS" era , GetLedgerView era , MinLEDGER_STS era , MinCHAIN_STS era , Embed (EraRule "BBODY" era) (CHAIN era) , Environment (EraRule "BBODY" era) ~ BbodyEnv era - , State (EraRule "BBODY" era) ~ ShelleyBbodyState era + , State (EraRule "BBODY" era) ~ ShelleyBbodyState "LEDGERS" era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , Embed (EraRule "TICKN" era) (CHAIN era) , Environment (EraRule "TICKN" era) ~ TicknEnv diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs index 35f9c97c1ac..1baf9fdc3bc 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs @@ -263,7 +263,7 @@ instance ( EraGov era , Embed (EraRule "BBODY" era) (CHAIN era) , Environment (EraRule "BBODY" era) ~ BbodyEnv era - , State (EraRule "BBODY" era) ~ ShelleyBbodyState era + , State (EraRule "BBODY" era) ~ ShelleyBbodyState "LEDGERS" era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , Embed (EraRule "TICKN" era) (CHAIN era) , Environment (EraRule "TICKN" era) ~ TicknEnv @@ -302,7 +302,7 @@ chainTransition :: ( STS (CHAIN era) , Embed (EraRule "BBODY" era) (CHAIN era) , Environment (EraRule "BBODY" era) ~ BbodyEnv era - , State (EraRule "BBODY" era) ~ ShelleyBbodyState era + , State (EraRule "BBODY" era) ~ ShelleyBbodyState "LEDGERS" era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , Embed (EraRule "TICKN" era) (CHAIN era) , Environment (EraRule "TICKN" era) ~ TicknEnv diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs index 2307526032d..b6bfb6d848a 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs @@ -243,7 +243,7 @@ ledgerTraceBase :: forall era. ( EraSegWits era , GetLedgerView era - , ApplyBlock era + , ApplyBlock "LEDGERS" era ) => ChainState era -> Block (BHeader (EraCrypto era)) era -> diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Utils.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Utils.hs index a6d3a551bed..ac887606c96 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Utils.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Utils.hs @@ -111,7 +111,7 @@ import Test.Tasty.HUnit ( type ChainProperty era = ( Mock (EraCrypto era) - , ApplyBlock era + , ApplyBlock "LEDGERS" era , GetLedgerView era , EraTx era ) diff --git a/libs/cardano-ledger-api/test/Tests.hs b/libs/cardano-ledger-api/test/Tests.hs index f5b9471d6ea..a7197bff8a4 100644 --- a/libs/cardano-ledger-api/test/Tests.hs +++ b/libs/cardano-ledger-api/test/Tests.hs @@ -3,6 +3,7 @@ module Main where import Cardano.Ledger.Conway (Conway) +import Cardano.Ledger.Shelley.LedgerState import qualified Test.Cardano.Ledger.Api.State.Imp.QuerySpec as ImpQuery (spec) import qualified Test.Cardano.Ledger.Api.State.QuerySpec as StateQuery (spec) import qualified Test.Cardano.Ledger.Api.Tx as Tx (spec) @@ -22,7 +23,7 @@ apiSpec = TxBody.spec describe "State" $ do StateQuery.spec - describe "Imp" $ withImpState @Conway $ do + describe "Imp" $ withImpState @LedgerState @Conway $ do ImpQuery.spec @Conway main :: IO () diff --git a/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/Spec/Conway.hs b/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/Spec/Conway.hs index b51c8166923..6e5498b7f9e 100644 --- a/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/Spec/Conway.hs +++ b/libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/Spec/Conway.hs @@ -4,6 +4,7 @@ module Test.Cardano.Ledger.Conformance.Spec.Conway (spec) where import Cardano.Ledger.Conway (Conway) +import Cardano.Ledger.Shelley.LedgerState (LedgerState) import Test.Cardano.Ledger.Conformance (conformsToImpl) import Test.Cardano.Ledger.Conformance.ExecSpecRule.Conway () import Test.Cardano.Ledger.Constrained.Conway @@ -12,6 +13,6 @@ import Test.Cardano.Ledger.Imp.Common spec :: Spec spec = describe "Conway conformance tests" $ do - withImpState @Conway $ do + withImpState @LedgerState @Conway $ do xit "UTXO" . replicateM_ 100 $ conformsToImpl @"UTXO" @ConwayFn xit "GOV" . replicateM_ 100 $ conformsToImpl @"GOV" @ConwayFn diff --git a/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx.hs b/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx.hs index 6ebec57a735..1024067944a 100644 --- a/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx.hs +++ b/libs/cardano-ledger-test/bench/Bench/Cardano/Ledger/ApplyTx.hs @@ -89,6 +89,7 @@ benchApplyTx :: , ApplyTx era , HasTrace (EraRule "LEDGER" era) (GenEnv era) , BaseEnv (EraRule "LEDGER" era) ~ Globals + , State (EraRule "LEDGER" era) ~ LedgerState era , EraGov era ) => Proxy era -> diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs index 1ca7e12c333..927101d9ee8 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs @@ -169,7 +169,7 @@ initialBBodyState :: ) => Proof era -> UTxO era -> - ShelleyBbodyState era + ShelleyBbodyState "LEDGERS" era initialBBodyState pf utxo = BbodyState (LedgerState initialUtxoSt dpstate) (BlocksMade mempty) where @@ -614,7 +614,7 @@ testBBodyState :: , ShelleyEraTxCert era ) => Proof era -> - ShelleyBbodyState era + ShelleyBbodyState "LEDGERS" era testBBodyState pf = let utxo = UTxO $ diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs index d5e7ca33dca..25e67d27e8f 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs @@ -250,9 +250,9 @@ trustMeP _ _ tx = tx testBBODY :: (Reflect era, HasCallStack) => WitRule "BBODY" era -> - ShelleyBbodyState era -> + ShelleyBbodyState "LEDGERS" era -> Block (BHeaderView (EraCrypto era)) era -> - Either (NonEmpty (PredicateFailure (AlonzoBBODY era))) (ShelleyBbodyState era) -> + Either (NonEmpty (PredicateFailure (AlonzoBBODY era))) (ShelleyBbodyState "LEDGERS" era) -> PParams era -> Assertion testBBODY wit@(BBODY proof) initialSt block expected pparams = 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 755439ac2a0..d2bfb32fc5c 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 @@ -2226,7 +2226,7 @@ instance Reflect era => PrettyA (AllegraUtxoPredFailure era) where -- LedgerState objects -- ========================================== -ppBbodyState :: forall era. Reflect era => ShelleyBbodyState era -> PDoc +ppBbodyState :: forall era. Reflect era => ShelleyBbodyState "LEDGERS" era -> PDoc ppBbodyState (BbodyState ls (BlocksMade mp)) = ppRecord "BbodyState" @@ -2234,7 +2234,7 @@ ppBbodyState (BbodyState ls (BlocksMade mp)) = , ("blocks made", ppMap pcKeyHash ppNatural mp) ] -instance Reflect era => PrettyA (ShelleyBbodyState era) where +instance Reflect era => PrettyA (ShelleyBbodyState "LEDGERS" era) where prettyA = ppBbodyState -- ======================================================= diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/TestableEra.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/TestableEra.hs index fa320bb5c34..bf9fd616322 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/TestableEra.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/TestableEra.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableSuperClasses #-} -- | Defines the requirements on an era to be testable @@ -7,7 +9,7 @@ import Cardano.Ledger.Shelley.API import Cardano.Protocol.TPraos.API class - ( ApplyBlock era + ( ApplyBlock "LEDGERS" era , ApplyTx era , GetLedgerView era ) => diff --git a/libs/ledger-state/bench/Performance.hs b/libs/ledger-state/bench/Performance.hs index 283ab7eacc1..da7d119d7d8 100644 --- a/libs/ledger-state/bench/Performance.hs +++ b/libs/ledger-state/bench/Performance.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Main where From 32d9f550ba42ca266a0826d9e1ecc7411bb4cb75 Mon Sep 17 00:00:00 2001 From: Will Gould Date: Wed, 3 Jul 2024 16:17:06 +0100 Subject: [PATCH 11/19] Use type family to avoid parameterising ApplyBlock --- .../impl/src/Cardano/Ledger/Allegra.hs | 2 +- .../impl/src/Cardano/Ledger/Allegra/Era.hs | 4 +++- eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs | 2 +- .../impl/src/Cardano/Ledger/Alonzo/Era.hs | 3 +++ .../src/Cardano/Ledger/Alonzo/Rules/Bbody.hs | 9 ++++++--- .../impl/src/Cardano/Ledger/Babbage.hs | 2 +- .../impl/src/Cardano/Ledger/Babbage/Era.hs | 3 +++ eras/babel/impl/src/Cardano/Ledger/Babel.hs | 2 +- .../impl/src/Cardano/Ledger/Babel/Era.hs | 3 +++ .../src/Cardano/Ledger/Babel/Rules/Bbody.hs | 5 ++++- .../Test/Cardano/Ledger/Babel/Rules/Chain.hs | 8 +++++--- .../src/Test/Cardano/Ledger/Babel/Utils.hs | 4 ++-- eras/conway/impl/src/Cardano/Ledger/Conway.hs | 2 +- .../impl/src/Cardano/Ledger/Conway/Era.hs | 3 +++ eras/mary/impl/src/Cardano/Ledger/Mary.hs | 2 +- eras/mary/impl/src/Cardano/Ledger/Mary/Era.hs | 3 +++ .../impl/src/Cardano/Ledger/Shelley.hs | 3 ++- .../Cardano/Ledger/Shelley/API/Validation.hs | 19 ++++++++++--------- .../impl/src/Cardano/Ledger/Shelley/Era.hs | 5 +++++ .../src/Cardano/Ledger/Shelley/Rules/Bbody.hs | 15 ++++++++------- .../test-suite/bench/BenchValidation.hs | 16 ++++++++-------- .../bench/Cardano/Ledger/Shelley/Bench/Gen.hs | 2 +- .../Cardano/Ledger/Shelley/Generator/Block.hs | 8 ++++---- .../Ledger/Shelley/Generator/Trace/Chain.hs | 4 ++-- .../Cardano/Ledger/Shelley/Rules/Chain.hs | 8 +++++--- .../Cardano/Ledger/Shelley/Rules/TestChain.hs | 2 +- .../src/Test/Cardano/Ledger/Shelley/Utils.hs | 2 +- .../Cardano/Ledger/Examples/AlonzoBBODY.hs | 11 ++++++----- .../Cardano/Ledger/Examples/STSTestUtils.hs | 4 ++-- .../Test/Cardano/Ledger/Generic/PrettyCore.hs | 17 +++++++++++++++-- .../src/Test/Cardano/Ledger/TestableEra.hs | 2 +- 31 files changed, 112 insertions(+), 63 deletions(-) diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs index 85a70a64d7b..39493ac7a1b 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra.hs @@ -44,7 +44,7 @@ instance instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => - ApplyBlock "LEDGERS" (AllegraEra c) + ApplyBlock (AllegraEra c) instance Crypto c => CanStartFromGenesis (AllegraEra c) where fromShelleyPParams _ = translateEra' () diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Era.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Era.hs index 93f318e34d5..fd2daa312d6 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Era.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Era.hs @@ -13,7 +13,7 @@ module Cardano.Ledger.Allegra.Era ( import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Crypto (Crypto) -import Cardano.Ledger.Shelley (ShelleyEra) +import Cardano.Ledger.Shelley (EraFirstRule, ShelleyEra) import Cardano.Ledger.Shelley.Core import Cardano.Ledger.Shelley.Rules @@ -27,6 +27,8 @@ instance Crypto c => Era (AllegraEra c) where eraName = "Allegra" +type instance EraFirstRule (AllegraEra c) = "LEDGERS" + -------------------------------------------------------------------------------- -- Core instances -------------------------------------------------------------------------------- diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs index 86a03caba7b..fe4d3d11e42 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo.hs @@ -75,7 +75,7 @@ reapplyAlonzoTx globals env state vtx = instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyTx (AlonzoEra c) where reapplyTx = reapplyAlonzoTx -instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock "LEDGERS" (AlonzoEra c) +instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock (AlonzoEra c) instance Crypto c => API.CanStartFromGenesis (AlonzoEra c) where type AdditionalGenesisConfig (AlonzoEra c) = AlonzoGenesis diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Era.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Era.hs index 287206df049..7ea15b450a5 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Era.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Era.hs @@ -13,6 +13,7 @@ where import Cardano.Ledger.Crypto (Crypto) import Cardano.Ledger.Mary (MaryEra, MaryValue) +import Cardano.Ledger.Shelley (EraFirstRule) import Cardano.Ledger.Shelley.Core import Cardano.Ledger.Shelley.Rules @@ -31,6 +32,8 @@ instance Crypto c => Era (AlonzoEra c) where type instance Value (AlonzoEra c) = MaryValue c +type instance EraFirstRule (AlonzoEra c) = "LEDGERS" + ------------------------------------------------------------------------------- -- Era Mapping ------------------------------------------------------------------------------- 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 b5d98ba9d07..5bb8181074d 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Bbody.hs @@ -40,6 +40,7 @@ import Cardano.Ledger.Block (Block (..)) import Cardano.Ledger.Core import qualified Cardano.Ledger.Era as Era import Cardano.Ledger.Keys (DSignable, Hash, coerceKeyRole) +import Cardano.Ledger.Shelley (EraFirstRule) import Cardano.Ledger.Shelley.BlockChain (incrBlocks) import Cardano.Ledger.Shelley.LedgerState (LedgerState) import Cardano.Ledger.Shelley.Rules ( @@ -181,11 +182,12 @@ bbodyTransition :: , Signal (someBBODY era) ~ Block (BHeaderView (EraCrypto era)) era , PredicateFailure (someBBODY era) ~ AlonzoBbodyPredFailure era , BaseM (someBBODY era) ~ ShelleyBase - , State (someBBODY era) ~ ShelleyBbodyState "LEDGERS" era + , State (someBBODY era) ~ ShelleyBbodyState era , Environment (someBBODY era) ~ BbodyEnv era , Embed (EraRule "LEDGERS" era) (someBBODY era) , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era , State (EraRule "LEDGERS" era) ~ LedgerState era + , State (EraRule (EraFirstRule era) era) ~ LedgerState era , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) , EraSegWits era , AlonzoEraTxWits era @@ -244,7 +246,7 @@ bbodyTransition = pointWiseExUnits (<=) txTotal ppMax ?! TooManyExUnits txTotal ppMax pure $ - BbodyState @"LEDGERS" @era + BbodyState @era ls' ( incrBlocks (isOverlaySlot firstSlotNo (pp ^. ppDG) slot) @@ -257,6 +259,7 @@ instance , Embed (EraRule "LEDGERS" era) (AlonzoBBODY era) , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era , State (EraRule "LEDGERS" era) ~ LedgerState era + , State (EraRule (EraFirstRule era) era) ~ LedgerState era , Signal (EraRule "LEDGERS" era) ~ Seq (AlonzoTx era) , AlonzoEraTxWits era , Tx era ~ AlonzoTx era @@ -269,7 +272,7 @@ instance where type State (AlonzoBBODY era) = - ShelleyBbodyState "LEDGERS" era + ShelleyBbodyState era type Signal (AlonzoBBODY era) = diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs index f62b062b9da..87b4a4b2260 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage.hs @@ -45,7 +45,7 @@ type Babbage = BabbageEra StandardCrypto instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyTx (BabbageEra c) where reapplyTx = reapplyAlonzoTx -instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock "LEDGERS" (BabbageEra c) +instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => API.ApplyBlock (BabbageEra c) instance Crypto c => API.CanStartFromGenesis (BabbageEra c) where type AdditionalGenesisConfig (BabbageEra c) = AlonzoGenesis diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Era.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Era.hs index e8e3d6150e4..4d361e4a94f 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Era.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Era.hs @@ -15,6 +15,7 @@ import Cardano.Ledger.Alonzo.Rules (AlonzoBBODY) import Cardano.Ledger.Core import Cardano.Ledger.Crypto import Cardano.Ledger.Mary.Value (MaryValue) +import Cardano.Ledger.Shelley (EraFirstRule) import qualified Cardano.Ledger.Shelley.API as API import Cardano.Ledger.Shelley.Rules ( ShelleyEPOCH, @@ -42,6 +43,8 @@ instance Crypto c => Era (BabbageEra c) where type instance Value (BabbageEra c) = MaryValue c +type instance EraFirstRule (BabbageEra c) = "LEDGERS" + ------------------------------------------------------------------------------- -- Era Mapping ------------------------------------------------------------------------------- diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel.hs b/eras/babel/impl/src/Cardano/Ledger/Babel.hs index 02434e43506..2abb96c1835 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel.hs @@ -69,7 +69,7 @@ instance Signable (DSIGN c) (Cardano.Crypto.Hash.Class.Hash c EraIndependentTxBody) , Default (LedgerStateTemp (BabelEra c)) ) => - ApplyBlock "ZONES" (BabelEra c) + ApplyBlock (BabelEra c) instance ( Crypto c diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Era.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Era.hs index 92d4de8aeaf..2525bd184a3 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Era.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Era.hs @@ -29,6 +29,7 @@ import Cardano.Ledger.Conway.Rules ( import Cardano.Ledger.Core import Cardano.Ledger.Crypto (Crypto) import Cardano.Ledger.Mary.Value (MaryValue) +import Cardano.Ledger.Shelley (EraFirstRule) import qualified Cardano.Ledger.Shelley.API as API import Cardano.Ledger.Shelley.Rules ( ShelleyPOOL, @@ -52,6 +53,8 @@ instance Crypto c => Era (BabelEra c) where type instance Value (BabelEra c) = MaryValue c +type instance EraFirstRule (BabelEra c) = "ZONES" + ------------------------------------------------------------------------------- -- Deprecated rules ------------------------------------------------------------------------------- diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs index b3c98d8d7f3..397c29f923e 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Bbody.hs @@ -31,6 +31,7 @@ import Cardano.Ledger.Babel.Rules.Zones (BabelZonesPredFailure) import Cardano.Ledger.BaseTypes (ShelleyBase, epochInfoPure) import Cardano.Ledger.Core import Cardano.Ledger.Keys (DSignable, HasKeyRole (coerceKeyRole), Hash) +import Cardano.Ledger.Shelley (EraFirstRule) import Cardano.Ledger.Shelley.API ( Block (UnserialisedBlock), ShelleyLedgersEnv (LedgersEnv), @@ -127,12 +128,13 @@ instance , Embed (EraRule "ZONES" era) (BabelBBODY era) , Environment (EraRule "ZONES" era) ~ ShelleyLedgersEnv era , Signal (EraRule "ZONES" era) ~ Seq (Seq (Tx era)) + , State (EraRule (EraFirstRule era) era) ~ State (EraRule "ZONES" era) , Eq (PredicateFailure (EraRule "LEDGERS" era)) , Show (PredicateFailure (EraRule "LEDGERS" era)) ) => STS (BabelBBODY era) where - type State (BabelBBODY era) = ShelleyBbodyState "ZONES" era + type State (BabelBBODY era) = ShelleyBbodyState era type Signal (BabelBBODY era) = Block (BHeaderView (EraCrypto era)) era @@ -155,6 +157,7 @@ bbodyTransition :: , Embed (EraRule "ZONES" era) (BabelBBODY era) , Environment (EraRule "ZONES" era) ~ ShelleyLedgersEnv era , Signal (EraRule "ZONES" era) ~ Seq (Seq (Tx era)) + , State (EraRule (EraFirstRule era) era) ~ State (EraRule "ZONES" era) ) => TransitionRule (BabelBBODY era) bbodyTransition = diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Rules/Chain.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Rules/Chain.hs index 8ede5d346e9..f862f4d701d 100644 --- a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Rules/Chain.hs +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Rules/Chain.hs @@ -55,6 +55,7 @@ import Cardano.Ledger.Keys ( coerceKeyRole, ) import Cardano.Ledger.PoolDistr (PoolDistr (..)) +import Cardano.Ledger.Shelley (EraFirstRule) import Cardano.Ledger.Shelley.AdaPots ( AdaPots (..), totalAdaES, @@ -264,7 +265,7 @@ instance ( EraGov era , Embed (EraRule "BBODY" era) (CHAIN era) , Environment (EraRule "BBODY" era) ~ BbodyEnv era - , State (EraRule "BBODY" era) ~ ShelleyBbodyState "ZONES" era + , State (EraRule "BBODY" era) ~ ShelleyBbodyState era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , Embed (EraRule "TICKN" era) (CHAIN era) , Environment (EraRule "TICKN" era) ~ TicknEnv @@ -278,6 +279,7 @@ instance , EncCBORGroup (TxZones era) , ProtVerAtMost era 10 , State (EraRule "ZONES" era) ~ LedgerState era + , State (EraRule (EraFirstRule era) era) ~ LedgerState era , State (Core.EraRule "LEDGERS" era) ~ LedgerStateTemp era ) => STS (CHAIN era) @@ -304,7 +306,7 @@ chainTransition :: ( STS (CHAIN era) , Embed (EraRule "BBODY" era) (CHAIN era) , Environment (EraRule "BBODY" era) ~ BbodyEnv era - , State (EraRule "BBODY" era) ~ ShelleyBbodyState "ZONES" era + , State (EraRule "BBODY" era) ~ ShelleyBbodyState era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , Embed (EraRule "TICKN" era) (CHAIN era) , Environment (EraRule "TICKN" era) ~ TicknEnv @@ -316,7 +318,7 @@ chainTransition :: , Signal (EraRule "TICK" era) ~ SlotNo , Embed (PRTCL (EraCrypto era)) (CHAIN era) , EncCBORGroup (TxZones era) - , State (EraRule "ZONES" era) ~ LedgerState era + , State (EraRule (EraFirstRule era) era) ~ LedgerState era , EraGov era ) => TransitionRule (CHAIN era) diff --git a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Utils.hs b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Utils.hs index def5fb93537..41e0f9fc7a9 100644 --- a/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Utils.hs +++ b/eras/babel/test-suite/src/Test/Cardano/Ledger/Babel/Utils.hs @@ -74,10 +74,10 @@ import Cardano.Ledger.BaseTypes ( import Cardano.Ledger.Binary (EncCBOR (..), hashWithEncoder, shelleyProtVer) import Cardano.Ledger.Block (Block, bheader) import Cardano.Ledger.Coin (Coin (..)) -import Cardano.Ledger.Shelley.API.Validation (ApplyBlock) import Cardano.Ledger.Crypto (Crypto (DSIGN)) import Cardano.Ledger.Mary.Value (MultiAsset (MultiAsset)) import Cardano.Ledger.Shelley.API (KeyRole (..), VKey (..)) +import Cardano.Ledger.Shelley.API.Validation (ApplyBlock) import Cardano.Ledger.Shelley.Core import Cardano.Ledger.Slot (EpochNo, EpochSize (..), SlotNo) import Cardano.Protocol.TPraos.API (GetLedgerView) @@ -116,7 +116,7 @@ import Test.Tasty.HUnit ( type ChainProperty era = ( Mock (EraCrypto era) - , ApplyBlock "LEDGERS" era + , ApplyBlock era , GetLedgerView era , EraTx era ) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway.hs b/eras/conway/impl/src/Cardano/Ledger/Conway.hs index 22c3eb3712a..620a0c74dea 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway.hs @@ -49,7 +49,7 @@ instance ( Crypto c , DSignable c (Hash c EraIndependentTxBody) ) => - API.ApplyBlock "LEDGERS" (ConwayEra c) + API.ApplyBlock (ConwayEra c) instance Crypto c => API.CanStartFromGenesis (ConwayEra c) where type AdditionalGenesisConfig (ConwayEra c) = ConwayGenesis c diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs index 014cf7722d1..c385be465fd 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs @@ -24,6 +24,7 @@ import Cardano.Ledger.Babbage (BabbageEra) import Cardano.Ledger.Core import Cardano.Ledger.Crypto (Crypto) import Cardano.Ledger.Mary.Value (MaryValue) +import Cardano.Ledger.Shelley (EraFirstRule) import qualified Cardano.Ledger.Shelley.API as API import Cardano.Ledger.Shelley.Rules ( ShelleyPOOL, @@ -47,6 +48,8 @@ instance Crypto c => Era (ConwayEra c) where type instance Value (ConwayEra c) = MaryValue c +type instance EraFirstRule (ConwayEra c) = "LEDGERS" + ------------------------------------------------------------------------------- -- Deprecated rules ------------------------------------------------------------------------------- diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary.hs b/eras/mary/impl/src/Cardano/Ledger/Mary.hs index 7df4f97847b..33f330c3e30 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary.hs @@ -42,7 +42,7 @@ instance instance (Crypto c, DSignable c (Hash c EraIndependentTxBody)) => - ApplyBlock "LEDGERS" (MaryEra c) + ApplyBlock (MaryEra c) instance Crypto c => CanStartFromGenesis (MaryEra c) where fromShelleyPParams () = translateEra' () . fromShelleyPParams () diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/Era.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/Era.hs index 382776e3c29..28507ef1391 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/Era.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/Era.hs @@ -11,6 +11,7 @@ import Cardano.Ledger.Allegra (AllegraEra) import Cardano.Ledger.Allegra.Rules (AllegraUTXO, AllegraUTXOW) import Cardano.Ledger.Crypto (Crypto) import Cardano.Ledger.Mary.Value (MaryValue) +import Cardano.Ledger.Shelley (EraFirstRule) import Cardano.Ledger.Shelley.Core import Cardano.Ledger.Shelley.Rules @@ -23,6 +24,8 @@ instance Crypto c => Era (MaryEra c) where eraName = "Mary" +type instance EraFirstRule (MaryEra c) = "LEDGERS" + -------------------------------------------------------------------------------- -- Core instances -------------------------------------------------------------------------------- diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley.hs index 06cf8a2cd27..7a302fa610f 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley.hs @@ -1,6 +1,7 @@ module Cardano.Ledger.Shelley ( Shelley, ShelleyEra, + EraFirstRule, ShelleyTx, ShelleyTxOut, ShelleyTxBody, @@ -10,7 +11,7 @@ module Cardano.Ledger.Shelley ( where import Cardano.Ledger.Crypto (StandardCrypto) -import Cardano.Ledger.Shelley.Era (ShelleyEra) +import Cardano.Ledger.Shelley.Era (EraFirstRule, ShelleyEra) import Cardano.Ledger.Shelley.PParams () import Cardano.Ledger.Shelley.Rules () import Cardano.Ledger.Shelley.Scripts (nativeMultiSigTag) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs index 3a3e45b8373..ec378ce06f3 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs @@ -41,6 +41,7 @@ import Cardano.Ledger.Crypto (Crypto) import Cardano.Ledger.Keys (DSignable, Hash) import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Shelley.Core (EraGov) +import Cardano.Ledger.Shelley.Era (EraFirstRule) import Cardano.Ledger.Shelley.LedgerState (LedgerState (..), NewEpochState, curPParamsEpochStateL) import qualified Cardano.Ledger.Shelley.LedgerState as LedgerState import Cardano.Ledger.Shelley.PParams () @@ -69,12 +70,12 @@ class , STS (EraRule "BBODY" era) , BaseM (EraRule "BBODY" era) ~ ShelleyBase , Environment (EraRule "BBODY" era) ~ STS.BbodyEnv era - , State (EraRule "BBODY" era) ~ STS.ShelleyBbodyState firstRule era + , State (EraRule "BBODY" era) ~ STS.ShelleyBbodyState era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , EncCBORGroup (TxZones era) - , State (EraRule firstRule era) ~ LedgerState era + , State (EraRule (EraFirstRule era) era) ~ LedgerState era ) => - ApplyBlock firstRule era + ApplyBlock era where -- | Apply the header level ledger transition. -- @@ -117,7 +118,7 @@ class . left BlockTransitionError . right ( mapEventReturn @ep @(EraRule "BBODY" era) $ - updateNewEpochState @era @firstRule state + updateNewEpochState @era state ) $ res where @@ -159,7 +160,7 @@ class (LedgerState.nesBcur state) applyTick :: - ApplyBlock firstRule era => + ApplyBlock era => Globals -> NewEpochState era -> SlotNo -> @@ -173,7 +174,7 @@ applyTick = } applyBlock :: - ( ApplyBlock firstRule era + ( ApplyBlock era , MonadError (BlockTransitionError era) m ) => Globals -> @@ -199,7 +200,7 @@ instance ( Crypto c , DSignable c (Hash c EraIndependentTxBody) ) => - ApplyBlock "LEDGERS" (ShelleyEra c) + ApplyBlock (ShelleyEra c) {------------------------------------------------------------------------------- CHAIN Transition checks @@ -233,9 +234,9 @@ mkBbodyEnv } updateNewEpochState :: - (LedgerState era ~ State (EraRule firstRule era), EraGov era) => + (LedgerState era ~ State (EraRule (EraFirstRule era) era), EraGov era) => NewEpochState era -> - STS.ShelleyBbodyState firstRule era -> + STS.ShelleyBbodyState era -> NewEpochState era updateNewEpochState ss (STS.BbodyState ls bcur) = LedgerState.updateNES ss bcur ls diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Era.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Era.hs index 6bf75815d94..c83c1bdaf31 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Era.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Era.hs @@ -3,6 +3,7 @@ module Cardano.Ledger.Shelley.Era ( ShelleyEra, + EraFirstRule, ShelleyBBODY, ShelleyDELEG, ShelleyDELEGS, @@ -29,6 +30,7 @@ where import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Core (ByronEra, Era (..), EraRule, Value) import Cardano.Ledger.Crypto (Crypto) +import GHC.TypeLits (Symbol) data ShelleyEra c @@ -39,6 +41,9 @@ instance Crypto c => Era (ShelleyEra c) where eraName = "Shelley" +type family EraFirstRule era :: Symbol +type instance EraFirstRule (ShelleyEra c) = "LEDGERS" + type instance Value (ShelleyEra _c) = Coin data ShelleyBBODY era 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 f241d721507..83d7a424cc0 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs @@ -29,7 +29,7 @@ import Cardano.Ledger.Block (Block (..)) import Cardano.Ledger.Core import Cardano.Ledger.Keys (DSignable, Hash, coerceKeyRole) import Cardano.Ledger.Shelley.BlockChain (incrBlocks) -import Cardano.Ledger.Shelley.Era (ShelleyBBODY, ShelleyEra) +import Cardano.Ledger.Shelley.Era (EraFirstRule, ShelleyBBODY, ShelleyEra) import Cardano.Ledger.Shelley.LedgerState (AccountState) import Cardano.Ledger.Shelley.Rules.Deleg (ShelleyDelegPredFailure) import Cardano.Ledger.Shelley.Rules.Delegs (ShelleyDelegsPredFailure) @@ -55,17 +55,16 @@ import Control.State.Transition ( import Data.Sequence (Seq) import qualified Data.Sequence.Strict as StrictSeq import GHC.Generics (Generic) -import GHC.TypeLits (Symbol) import Lens.Micro ((^.)) import NoThunks.Class (NoThunks (..)) -data ShelleyBbodyState (firstRule :: Symbol) era - = BbodyState !(State (EraRule firstRule era)) !(BlocksMade (EraCrypto era)) +data ShelleyBbodyState era + = BbodyState !(State (EraRule (EraFirstRule era) era)) !(BlocksMade (EraCrypto era)) deriving stock instance - Show (State (EraRule firstRule era)) => Show (ShelleyBbodyState firstRule era) + Show (State (EraRule (EraFirstRule era) era)) => Show (ShelleyBbodyState era) -deriving stock instance Eq (State (EraRule firstRule era)) => Eq (ShelleyBbodyState firstRule era) +deriving stock instance Eq (State (EraRule (EraFirstRule era) era)) => Eq (ShelleyBbodyState era) data BbodyEnv era = BbodyEnv { bbodyPp :: PParams era @@ -140,12 +139,13 @@ instance , Embed (EraRule "LEDGERS" era) (ShelleyBBODY era) , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) + , State (EraRule (EraFirstRule era) era) ~ State (EraRule "LEDGERS" era) ) => STS (ShelleyBBODY era) where type State (ShelleyBBODY era) = - ShelleyBbodyState "LEDGERS" era + ShelleyBbodyState era type Signal (ShelleyBBODY era) = @@ -169,6 +169,7 @@ bbodyTransition :: , Embed (EraRule "LEDGERS" era) (ShelleyBBODY era) , Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era , Signal (EraRule "LEDGERS" era) ~ Seq (Tx era) + , State (EraRule (EraFirstRule era) era) ~ State (EraRule "LEDGERS" era) ) => TransitionRule (ShelleyBBODY era) bbodyTransition = diff --git a/eras/shelley/test-suite/bench/BenchValidation.hs b/eras/shelley/test-suite/bench/BenchValidation.hs index 9d3d28efc45..725bbb31e3e 100644 --- a/eras/shelley/test-suite/bench/BenchValidation.hs +++ b/eras/shelley/test-suite/bench/BenchValidation.hs @@ -81,7 +81,7 @@ validateInput :: , Mock (EraCrypto era) , EraRule "LEDGERS" era ~ API.ShelleyLEDGERS era , QC.HasTrace (API.ShelleyLEDGERS era) (GenEnv era) - , API.ApplyBlock "LEDGERS" era + , API.ApplyBlock era , GetLedgerView era , MinLEDGER_STS era ) => @@ -95,7 +95,7 @@ genValidateInput :: , Mock (EraCrypto era) , EraRule "LEDGERS" era ~ API.ShelleyLEDGERS era , QC.HasTrace (API.ShelleyLEDGERS era) (GenEnv era) - , API.ApplyBlock "LEDGERS" era + , API.ApplyBlock era , GetLedgerView era , MinLEDGER_STS era ) => @@ -109,18 +109,18 @@ genValidateInput n = do benchValidate :: forall era. - (API.ApplyBlock "LEDGERS" era, Era era) => + (API.ApplyBlock era, Era era) => ValidateInput era -> IO (NewEpochState era) benchValidate (ValidateInput globals state (Block bh txs)) = - case API.applyBlock @"LEDGERS" @era globals state (UnsafeUnserialisedBlock (makeHeaderView bh) txs) of + case API.applyBlock @era globals state (UnsafeUnserialisedBlock (makeHeaderView bh) txs) of Right x -> pure x Left x -> error (show x) applyBlock :: forall era. ( EraTxOut era - , API.ApplyBlock "LEDGERS" era + , API.ApplyBlock era , NFData (StashedAVVMAddresses era) , GovState era ~ ShelleyGovState era ) => @@ -128,12 +128,12 @@ applyBlock :: Int -> Int applyBlock (ValidateInput globals state (Block bh txs)) n = - case API.applyBlock @"LEDGERS" @era globals state (UnsafeUnserialisedBlock (makeHeaderView bh) txs) of + case API.applyBlock @era globals state (UnsafeUnserialisedBlock (makeHeaderView bh) txs) of Right x -> seq (rnf x) (n + 1) Left x -> error (show x) benchreValidate :: - (API.ApplyBlock "LEDGERS" era, Era era) => + (API.ApplyBlock era, Era era) => ValidateInput era -> NewEpochState era benchreValidate (ValidateInput globals state (Block bh txs)) = @@ -177,7 +177,7 @@ genUpdateInputs :: , GetLedgerView era , EraRule "LEDGERS" era ~ API.ShelleyLEDGERS era , QC.HasTrace (API.ShelleyLEDGERS era) (GenEnv era) - , API.ApplyBlock "LEDGERS" era + , API.ApplyBlock era ) => Int -> IO (UpdateInputs (EraCrypto era)) diff --git a/eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs b/eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs index 13d6b6eb14c..b0132cf68de 100644 --- a/eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs +++ b/eras/shelley/test-suite/bench/Cardano/Ledger/Shelley/Bench/Gen.hs @@ -90,7 +90,7 @@ genBlock :: , GetLedgerView era , EraRule "LEDGERS" era ~ ShelleyLEDGERS era , QC.HasTrace (ShelleyLEDGERS era) (GenEnv era) - , ApplyBlock "LEDGERS" era + , ApplyBlock era ) => GenEnv era -> ChainState era -> diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs index c70e176669f..6f1548f006d 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Block.hs @@ -92,7 +92,7 @@ genBlock :: forall era. ( TxStructure era ~ StrictSeq.StrictSeq , MinLEDGER_STS era - , ApplyBlock "LEDGERS" era + , ApplyBlock era , Mock (EraCrypto era) , GetLedgerView era , QC.HasTrace (EraRule "LEDGERS" era) (GenEnv era) @@ -114,7 +114,7 @@ genBlockWithTxGen :: ( TxStructure era ~ StrictSeq.StrictSeq , Mock (EraCrypto era) , GetLedgerView era - , ApplyBlock "LEDGERS" era + , ApplyBlock era , EraGen era ) => TxGen era -> @@ -196,7 +196,7 @@ selectNextSlotWithLeader :: ( Mock (EraCrypto era) , EraGen era , GetLedgerView era - , ApplyBlock "LEDGERS" era + , ApplyBlock era ) => GenEnv era -> ChainState era -> @@ -271,7 +271,7 @@ selectNextSlotWithLeader -- | The chain state is a composite of the new epoch state and the chain dep -- state. We tick both. tickChainState :: - (GetLedgerView era, ApplyBlock "LEDGERS" era) => + (GetLedgerView era, ApplyBlock era) => SlotNo -> ChainState era -> ChainState era diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs index a8441f3d6d7..de5a0446c43 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Chain.hs @@ -90,13 +90,13 @@ instance , EraGen era , EraSegWits era , Mock (EraCrypto era) - , ApplyBlock "LEDGERS" era + , ApplyBlock era , GetLedgerView era , MinLEDGER_STS era , MinCHAIN_STS era , Embed (EraRule "BBODY" era) (CHAIN era) , Environment (EraRule "BBODY" era) ~ BbodyEnv era - , State (EraRule "BBODY" era) ~ ShelleyBbodyState "LEDGERS" era + , State (EraRule "BBODY" era) ~ ShelleyBbodyState era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , Embed (EraRule "TICKN" era) (CHAIN era) , Environment (EraRule "TICKN" era) ~ TicknEnv diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs index 1baf9fdc3bc..6f403c083a6 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Chain.hs @@ -52,7 +52,7 @@ import Cardano.Ledger.Keys ( coerceKeyRole, ) import Cardano.Ledger.PoolDistr (PoolDistr (..)) -import Cardano.Ledger.Shelley (ShelleyEra) +import Cardano.Ledger.Shelley (EraFirstRule, ShelleyEra) import Cardano.Ledger.Shelley.AdaPots ( AdaPots (..), totalAdaES, @@ -263,7 +263,7 @@ instance ( EraGov era , Embed (EraRule "BBODY" era) (CHAIN era) , Environment (EraRule "BBODY" era) ~ BbodyEnv era - , State (EraRule "BBODY" era) ~ ShelleyBbodyState "LEDGERS" era + , State (EraRule "BBODY" era) ~ ShelleyBbodyState era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , Embed (EraRule "TICKN" era) (CHAIN era) , Environment (EraRule "TICKN" era) ~ TicknEnv @@ -277,6 +277,7 @@ instance , EncCBORGroup (TxZones era) , ProtVerAtMost era 6 , State (Core.EraRule "LEDGERS" era) ~ LedgerState era + , State (EraRule (EraFirstRule era) era) ~ State (EraRule "LEDGERS" era) ) => STS (CHAIN era) where @@ -302,7 +303,7 @@ chainTransition :: ( STS (CHAIN era) , Embed (EraRule "BBODY" era) (CHAIN era) , Environment (EraRule "BBODY" era) ~ BbodyEnv era - , State (EraRule "BBODY" era) ~ ShelleyBbodyState "LEDGERS" era + , State (EraRule "BBODY" era) ~ ShelleyBbodyState era , Signal (EraRule "BBODY" era) ~ Block (BHeaderView (EraCrypto era)) era , Embed (EraRule "TICKN" era) (CHAIN era) , Environment (EraRule "TICKN" era) ~ TicknEnv @@ -316,6 +317,7 @@ chainTransition :: , EncCBORGroup (TxZones era) , ProtVerAtMost era 6 , State (Core.EraRule "LEDGERS" era) ~ LedgerState era + , State (EraRule (EraFirstRule era) era) ~ State (EraRule "LEDGERS" era) , EraGov era ) => TransitionRule (CHAIN era) diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs index b6bfb6d848a..2307526032d 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/TestChain.hs @@ -243,7 +243,7 @@ ledgerTraceBase :: forall era. ( EraSegWits era , GetLedgerView era - , ApplyBlock "LEDGERS" era + , ApplyBlock era ) => ChainState era -> Block (BHeader (EraCrypto era)) era -> diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Utils.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Utils.hs index ac887606c96..a6d3a551bed 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Utils.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Utils.hs @@ -111,7 +111,7 @@ import Test.Tasty.HUnit ( type ChainProperty era = ( Mock (EraCrypto era) - , ApplyBlock "LEDGERS" era + , ApplyBlock era , GetLedgerView era , EraTx era ) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs index 927101d9ee8..b4389d348f1 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/AlonzoBBODY.hs @@ -47,6 +47,7 @@ import Cardano.Ledger.Plutus.Data (Data (..), hashData) import Cardano.Ledger.Plutus.Language (Language (..)) import Cardano.Ledger.PoolParams (PoolMetadata (..)) import Cardano.Ledger.SafeHash (hashAnnotated) +import Cardano.Ledger.Shelley (EraFirstRule) import Cardano.Ledger.Shelley.API ( CertState (..), DState (..), @@ -138,7 +139,7 @@ alonzoBBODYexamplesP :: , Value era ~ MaryValue (EraCrypto era) , EraSegWits era , Reflect era - , State (EraRule "LEDGERS" era) ~ LedgerState era + , State (EraRule (EraFirstRule era) era) ~ LedgerState era ) => Proof era -> TestTree @@ -165,11 +166,11 @@ initialBBodyState :: ( EraTxOut era , PostShelley era , EraGov era - , State (EraRule "LEDGERS" era) ~ LedgerState era + , State (EraRule (EraFirstRule era) era) ~ LedgerState era ) => Proof era -> UTxO era -> - ShelleyBbodyState "LEDGERS" era + ShelleyBbodyState era initialBBodyState pf utxo = BbodyState (LedgerState initialUtxoSt dpstate) (BlocksMade mempty) where @@ -610,11 +611,11 @@ testBBodyState :: , EraTxBody era , Value era ~ MaryValue (EraCrypto era) , EraGov era - , State (EraRule "LEDGERS" era) ~ LedgerState era + , State (EraRule (EraFirstRule era) era) ~ LedgerState era , ShelleyEraTxCert era ) => Proof era -> - ShelleyBbodyState "LEDGERS" era + ShelleyBbodyState era testBBodyState pf = let utxo = UTxO $ diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs index 25e67d27e8f..d5e7ca33dca 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/STSTestUtils.hs @@ -250,9 +250,9 @@ trustMeP _ _ tx = tx testBBODY :: (Reflect era, HasCallStack) => WitRule "BBODY" era -> - ShelleyBbodyState "LEDGERS" era -> + ShelleyBbodyState era -> Block (BHeaderView (EraCrypto era)) era -> - Either (NonEmpty (PredicateFailure (AlonzoBBODY era))) (ShelleyBbodyState "LEDGERS" era) -> + Either (NonEmpty (PredicateFailure (AlonzoBBODY era))) (ShelleyBbodyState era) -> PParams era -> Assertion testBBODY wit@(BBODY proof) initialSt block expected pparams = 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 d2bfb32fc5c..0703ed71662 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 @@ -183,6 +183,7 @@ import Cardano.Ledger.Plutus.Language (Language (..)) import Cardano.Ledger.PoolDistr (IndividualPoolStake (..), PoolDistr (..)) import Cardano.Ledger.PoolParams (PoolParams (..)) import Cardano.Ledger.SafeHash (SafeHash, extractHash, hashAnnotated) +import Cardano.Ledger.Shelley (EraFirstRule) import Cardano.Ledger.Shelley.AdaPots ( AdaPots (..), totalAdaES, @@ -2226,7 +2227,13 @@ instance Reflect era => PrettyA (AllegraUtxoPredFailure era) where -- LedgerState objects -- ========================================== -ppBbodyState :: forall era. Reflect era => ShelleyBbodyState "LEDGERS" era -> PDoc +ppBbodyState :: + forall era. + ( Reflect era + , State (EraRule (EraFirstRule era) era) ~ State (EraRule "LEDGERS" era) + ) => + ShelleyBbodyState era -> + PDoc ppBbodyState (BbodyState ls (BlocksMade mp)) = ppRecord "BbodyState" @@ -2234,7 +2241,13 @@ ppBbodyState (BbodyState ls (BlocksMade mp)) = , ("blocks made", ppMap pcKeyHash ppNatural mp) ] -instance Reflect era => PrettyA (ShelleyBbodyState "LEDGERS" era) where +instance + ( Reflect era + , State (EraRule (EraFirstRule era) era) + ~ State (EraRule "LEDGERS" era) + ) => + PrettyA (ShelleyBbodyState era) + where prettyA = ppBbodyState -- ======================================================= diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/TestableEra.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/TestableEra.hs index bf9fd616322..10a5cfaa34d 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/TestableEra.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/TestableEra.hs @@ -9,7 +9,7 @@ import Cardano.Ledger.Shelley.API import Cardano.Protocol.TPraos.API class - ( ApplyBlock "LEDGERS" era + ( ApplyBlock era , ApplyTx era , GetLedgerView era ) => From 4eb3cf268a0cec309250cd5407e4adddb1ab4497 Mon Sep 17 00:00:00 2001 From: Will Gould Date: Thu, 4 Jul 2024 12:27:18 +0100 Subject: [PATCH 12/19] Removed frxo from utxostate --- .../src/Cardano/Ledger/Allegra/Rules/Utxo.hs | 2 +- .../src/Cardano/Ledger/Allegra/Translation.hs | 1 - .../src/Cardano/Ledger/Alonzo/Rules/Utxos.hs | 4 +- .../src/Cardano/Ledger/Alonzo/Translation.hs | 1 - .../src/Cardano/Ledger/Babbage/Rules/Utxos.hs | 4 +- .../src/Cardano/Ledger/Babbage/Translation.hs | 1 - .../Cardano/Ledger/Babel/LedgerState/Types.hs | 12 +++--- .../src/Cardano/Ledger/Babel/Rules/Zone.hs | 2 +- .../src/Cardano/Ledger/Babel/Translation.hs | 1 - .../src/Cardano/Ledger/Conway/Rules/Utxos.hs | 2 +- .../src/Cardano/Ledger/Conway/Translation.hs | 1 - .../src/Cardano/Ledger/Mary/Translation.hs | 1 - .../test/Test/Cardano/Ledger/Mary/Examples.hs | 2 +- .../Ledger/Shelley/API/ByronTranslation.hs | 1 - .../src/Cardano/Ledger/Shelley/AdaPots.hs | 2 +- .../Shelley/LedgerState/IncrementalStake.hs | 1 - .../Shelley/LedgerState/NewEpochState.hs | 1 - .../Ledger/Shelley/LedgerState/Types.hs | 12 ++---- .../src/Cardano/Ledger/Shelley/Rules/Snap.hs | 2 +- .../src/Cardano/Ledger/Shelley/Rules/Utxo.hs | 3 +- .../Test/Cardano/Ledger/Shelley/Arbitrary.hs | 1 - eras/shelley/test-suite/bench/Main.hs | 2 +- .../Ledger/Shelley/BenchmarkFunctions.hs | 1 - .../Ledger/Shelley/Examples/Consensus.hs | 1 - .../Cardano/Ledger/Shelley/Generator/Utxo.hs | 2 +- .../Ledger/Shelley/Rules/IncrementalStake.hs | 2 +- .../Test/Cardano/Ledger/Shelley/UnitTests.hs | 1 - .../src/Test/Cardano/Ledger/Alonzo/Tools.hs | 42 ++++++++++++------- .../Cardano/Ledger/Constrained/Conway/Utxo.hs | 1 - .../Test/Cardano/Ledger/Generic/Functions.hs | 3 +- .../Test/Cardano/Ledger/Generic/PrettyCore.hs | 7 +--- .../Test/Cardano/Ledger/Generic/Properties.hs | 2 +- .../src/Cardano/Ledger/State/Query.hs | 12 ++++-- 33 files changed, 60 insertions(+), 73 deletions(-) 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 513620dd9ef..c136df23b4b 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs @@ -197,7 +197,7 @@ utxoTransition :: TransitionRule (EraRule "UTXO" era) utxoTransition = do TRC (Shelley.UtxoEnv slot pp certState, utxos, tx) <- judgmentContext - let Shelley.UTxOState utxo _ _ _ ppup _ _ = utxos + let Shelley.UTxOState utxo _ _ ppup _ _ = utxos txBody = tx ^. bodyTxL genDelegs = dsGenDelegs (certDState certState) diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Translation.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Translation.hs index f0d86ab7ba5..cb571e32a71 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Translation.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Translation.hs @@ -114,7 +114,6 @@ instance Crypto c => TranslateEra (AllegraEra c) UTxOState where return UTxOState { utxosUtxo = translateEra' ctxt $ utxosUtxo us - , utxosFrxo = mempty , utxosDeposited = utxosDeposited us , utxosFees = utxosFees us , utxosGovState = translateEra' ctxt $ utxosGovState us diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs index eb18fcbea4b..c33311923d7 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs @@ -254,7 +254,7 @@ alonzoEvalScriptsTxValid :: ) => TransitionRule (AlonzoUTXOS era) alonzoEvalScriptsTxValid = do - TRC (UtxoEnv slot pp certState, utxos@(UTxOState utxo _ _ _ pup _ _), tx) <- + TRC (UtxoEnv slot pp certState, utxos@(UTxOState utxo _ _ pup _ _), tx) <- judgmentContext let txBody = tx ^. bodyTxL genDelegs = dsGenDelegs (certDState certState) @@ -294,7 +294,7 @@ alonzoEvalScriptsTxInvalid :: ) => TransitionRule (AlonzoUTXOS era) alonzoEvalScriptsTxInvalid = do - TRC (UtxoEnv slot pp _, us@(UTxOState utxo _ _ fees _ _ _), tx) <- judgmentContext + TRC (UtxoEnv slot pp _, us@(UTxOState utxo _ fees _ _ _), tx) <- judgmentContext let txBody = tx ^. bodyTxL () <- pure $! traceEvent invalidBegin () diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs index dfeecc1b028..e1baf2b3620 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs @@ -133,7 +133,6 @@ instance Crypto c => TranslateEra (AlonzoEra c) UTxOState where return UTxOState { utxosUtxo = translateEra' ctxt $ utxosUtxo us - , utxosFrxo = mempty , utxosDeposited = utxosDeposited us , utxosFees = utxosFees us , utxosGovState = translateEra' ctxt $ utxosGovState us diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs index 67798709bc4..e5a1f212c69 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs @@ -218,7 +218,7 @@ babbageEvalScriptsTxValid :: ) => TransitionRule (BabbageUTXOS era) babbageEvalScriptsTxValid = do - TRC (UtxoEnv slot pp certState, utxos@(UTxOState utxo _ _ _ pup _ _), tx) <- + TRC (UtxoEnv slot pp certState, utxos@(UTxOState utxo _ _ pup _ _), tx) <- judgmentContext let txBody = tx ^. bodyTxL genDelegs = dsGenDelegs (certDState certState) @@ -260,7 +260,7 @@ babbageEvalScriptsTxInvalid :: ) => TransitionRule (EraRule "UTXOS" era) babbageEvalScriptsTxInvalid = do - TRC (UtxoEnv _ pp _, us@(UTxOState utxo _ _ fees _ _ _), tx) <- judgmentContext + TRC (UtxoEnv _ pp _, us@(UTxOState utxo _ fees _ _ _), tx) <- judgmentContext {- txb := txbody tx -} let txBody = tx ^. bodyTxL sysSt <- liftSTS $ asks systemStart diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs index 5f085a6f8f0..63aacf33586 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs @@ -139,7 +139,6 @@ instance Crypto c => TranslateEra (BabbageEra c) UTxOState where pure UTxOState { utxosUtxo = translateEra' ctxt $ utxosUtxo us - , utxosFrxo = mempty , utxosDeposited = utxosDeposited us , utxosFees = utxosFees us , utxosGovState = translateEra' ctxt $ utxosGovState us diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs index b9f3d3bf6c1..d625e2fcc92 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs @@ -22,6 +22,7 @@ module Cardano.Ledger.Babel.LedgerState.Types where import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Conway.Core (EraCrypto, EraGov, EraTxOut, GovState) +import Cardano.Ledger.Era (Era) import Cardano.Ledger.FRxO (FRxO) import Cardano.Ledger.Shelley.API (LedgerState (..), UTxOState (..)) import Cardano.Ledger.Shelley.LedgerState ( @@ -49,7 +50,7 @@ data LedgerStateTemp era = LedgerStateTemp instance Default (UTxOStateTemp era) => Default (LedgerStateTemp era) where def = LedgerStateTemp def def -instance HasLedgerState LedgerStateTemp era where +instance Era era => HasLedgerState LedgerStateTemp era where hlsUtxoStateL = lens getter setter where getter s = toUTxOState (s ^. lstUtxoStateL) @@ -72,7 +73,7 @@ deriving stock instance -- Conversion -- | Convert from LedgerState to LedgerStateTemp -fromLedgerState :: LedgerState era -> LedgerStateTemp era +fromLedgerState :: Era era => LedgerState era -> LedgerStateTemp era fromLedgerState LedgerState {lsUTxOState, lsCertState} = LedgerStateTemp { lstUTxOState = fromUTxOState lsUTxOState @@ -80,11 +81,10 @@ fromLedgerState LedgerState {lsUTxOState, lsCertState} = } -- | Convert from UTxOState to UTxOStateTemp -fromUTxOState :: UTxOState era -> UTxOStateTemp era +fromUTxOState :: Era era => UTxOState era -> UTxOStateTemp era fromUTxOState UTxOState { utxosUtxo - , utxosFrxo , utxosDeposited , utxosFees , utxosGovState @@ -93,7 +93,7 @@ fromUTxOState } = UTxOStateTemp { utxostUtxo = utxosUtxo - , utxostFrxo = utxosFrxo + , utxostFrxo = mempty , utxostDeposited = utxosDeposited , utxostFees = utxosFees , utxostGovState = utxosGovState @@ -114,7 +114,6 @@ toUTxOState :: UTxOStateTemp era -> UTxOState era toUTxOState UTxOStateTemp { utxostUtxo - , utxostFrxo , utxostDeposited , utxostFees , utxostGovState @@ -123,7 +122,6 @@ toUTxOState } = UTxOState { utxosUtxo = utxostUtxo - , utxosFrxo = utxostFrxo , utxosDeposited = utxostDeposited , utxosFees = utxostFees , utxosGovState = utxostGovState diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs index a68ce8a20db..4e604259512 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs @@ -355,7 +355,7 @@ babelEvalScriptsTxInvalid = do TRC ( BabelLedgersEnv _slotNo _ixRange pp _accountState - , LedgerState us@(UTxOState utxo _ _ fees _ _ _) certState + , LedgerState us@(UTxOState utxo _ fees _ _ _) certState , txs :: Seq (Tx era) ) <- judgmentContext diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Translation.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Translation.hs index d7882d4dbc7..83a7339ad59 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Translation.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Translation.hs @@ -187,7 +187,6 @@ instance Crypto c => TranslateEra (BabelEra c) UTxOState where pure UTxOState { API.utxosUtxo = translateEra' ctxt $ API.utxosUtxo us - , API.utxosFrxo = mempty , API.utxosDeposited = API.utxosDeposited us , API.utxosFees = API.utxosFees us , API.utxosGovState = diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxos.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxos.hs index 46dc4a5f995..bb6dec693f7 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxos.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxos.hs @@ -282,7 +282,7 @@ conwayEvalScriptsTxValid :: ) => TransitionRule (EraRule "UTXOS" era) conwayEvalScriptsTxValid = do - TRC (UtxoEnv _ pp certState, utxos@(UTxOState utxo _ _ _ govState _ _), tx) <- + TRC (UtxoEnv _ pp certState, utxos@(UTxOState utxo _ _ govState _ _), tx) <- judgmentContext let txBody = tx ^. bodyTxL diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs index 5d0d9aec636..1b3c79af50d 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs @@ -187,7 +187,6 @@ instance Crypto c => TranslateEra (ConwayEra c) UTxOState where pure UTxOState { API.utxosUtxo = translateEra' ctxt $ API.utxosUtxo us - , API.utxosFrxo = mempty , API.utxosDeposited = API.utxosDeposited us , API.utxosFees = API.utxosFees us , API.utxosGovState = diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/Translation.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/Translation.hs index fa5304695d2..e9bc69cb39e 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/Translation.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/Translation.hs @@ -137,7 +137,6 @@ instance Crypto c => TranslateEra (MaryEra c) UTxOState where return UTxOState { utxosUtxo = translateEra' ctxt $ utxosUtxo us - , utxosFrxo = mempty , utxosDeposited = utxosDeposited us , utxosFees = utxosFees us , utxosGovState = translateEra' ctxt $ utxosGovState us diff --git a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Examples.hs b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Examples.hs index 95416fa6d96..5db1c8428c3 100644 --- a/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Examples.hs +++ b/eras/shelley-ma/test-suite/test/Test/Cardano/Ledger/Mary/Examples.hs @@ -26,7 +26,7 @@ import Test.Tasty.HUnit (Assertion, (@?=)) ignoreAllButUTxO :: Either (NonEmpty (PredicateFailure (ShelleyLEDGER Mary))) (LedgerState Mary) -> Either (NonEmpty (PredicateFailure (ShelleyLEDGER Mary))) (UTxO Mary) -ignoreAllButUTxO = fmap (\(LedgerState (UTxOState utxo _ _ _ _ _ _) _) -> utxo) +ignoreAllButUTxO = fmap (\(LedgerState (UTxOState utxo _ _ _ _ _) _) -> utxo) testMaryNoDelegLEDGER :: HasCallStack => diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/ByronTranslation.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/ByronTranslation.hs index f66d876515f..9d38637bb85 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/ByronTranslation.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/ByronTranslation.hs @@ -166,7 +166,6 @@ translateToShelleyLedgerState transCtxt epochNo cvs = { lsUTxOState = UTxOState { utxosUtxo = utxoShelley - , utxosFrxo = mempty , utxosDeposited = Coin 0 , utxosFees = Coin 0 , utxosGovState = emptyGovState diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs index f4c2c15ec6f..a31e629d7a9 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs @@ -77,7 +77,7 @@ totalAdaPotsES (EpochState (AccountState treasury_ reserves_) ls _ _) = , obligationsPot = obligationCertState certState <> govStateObligations } where - UTxOState u _ _ fees_ _ _ _ = lsUTxOState ls + UTxOState u _ fees_ _ _ _ = lsUTxOState ls certState@(CertState _ _ dstate) = lsCertState ls rewards_ = fromCompact $ sumRewardsUView (rewards dstate) coins = coinBalance u diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/IncrementalStake.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/IncrementalStake.hs index 2777fbbd757..005208739dc 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/IncrementalStake.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/IncrementalStake.hs @@ -165,7 +165,6 @@ smartUTxOState :: smartUTxOState pp utxo c1 c2 st = UTxOState utxo - mempty c1 c2 st diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/NewEpochState.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/NewEpochState.hs index 115d2009216..a912570fa97 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/NewEpochState.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/NewEpochState.hs @@ -73,7 +73,6 @@ genesisState genDelegs0 utxo0 = LedgerState ( UTxOState utxo0 - mempty (Coin 0) (Coin 0) emptyGovState diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs index f19b5ac12c4..4681e6263bd 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs @@ -58,7 +58,6 @@ import Cardano.Ledger.Coin (Coin (..), CompactForm) import Cardano.Ledger.Credential (Credential (..), Ptr (..)) import Cardano.Ledger.Crypto (Crypto) import Cardano.Ledger.EpochBoundary (SnapShots (..), ssStakeDistrL, ssStakeMarkL) -import Cardano.Ledger.FRxO (FRxO) import Cardano.Ledger.Keys ( KeyHash (..), KeyPair, @@ -279,7 +278,6 @@ toIncrementalStakePairs iStake@(IStake _ _) = -- this invariant. This happens in the UTxO rule. data UTxOState era = UTxOState { utxosUtxo :: !(UTxO era) - , utxosFrxo :: !(FRxO era) , utxosDeposited :: Coin -- ^ This field is left lazy, because we only use it for assertions , utxosFees :: !Coin @@ -313,7 +311,6 @@ deriving via (UTxOState era) instance ( NoThunks (UTxO era) - , NoThunks (FRxO era) , NoThunks (GovState era) , Era era ) => @@ -325,11 +322,10 @@ instance ) => EncCBOR (UTxOState era) where - encCBOR (UTxOState ut fr dp fs us sd don) = + encCBOR (UTxOState ut dp fs us sd don) = encode $ Rec UTxOState !> To ut - !> To fr !> To dp !> To fs !> To us @@ -348,7 +344,6 @@ instance decShareCBOR credInterns = decodeRecordNamed "UTxOState" (const 6) $ do utxosUtxo <- decShareCBOR credInterns - utxosFrxo <- decShareCBOR credInterns utxosDeposited <- decCBOR utxosFees <- decCBOR -- TODO: implement proper sharing: https://github.com/intersectmbo/cardano-ledger/issues/3486 @@ -369,10 +364,9 @@ instance (EraTxOut era, EraGov era) => ToJSON (UTxOState era) where toUTxOStatePairs :: (EraTxOut era, EraGov era, KeyValue e a) => UTxOState era -> [a] -toUTxOStatePairs utxoState@(UTxOState _ _ _ _ _ _ _) = +toUTxOStatePairs utxoState@(UTxOState _ _ _ _ _ _) = let UTxOState {..} = utxoState in [ "utxo" .= utxosUtxo - , "frxo" .= utxosFrxo , "deposited" .= utxosDeposited , "fees" .= utxosFees , "ppups" .= utxosGovState @@ -586,7 +580,7 @@ toLedgerStatePairs ls@(LedgerState _ _) = -------------------------------------------------------------------------------- instance EraGov era => Default (UTxOState era) where - def = UTxOState mempty mempty mempty mempty def mempty mempty + def = UTxOState mempty mempty mempty def mempty mempty instance Default (LedgerState era) => diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs index daaed4144ba..b107c23aaa3 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Snap.hs @@ -97,7 +97,7 @@ snapTransition :: snapTransition = do TRC (snapEnv, s, _) <- judgmentContext - let SnapEnv (LedgerState (UTxOState _utxo _ _ fees _ incStake _) (CertState _ pstate dstate)) pp = snapEnv + let SnapEnv (LedgerState (UTxOState _utxo _ fees _ incStake _) (CertState _ pstate dstate)) pp = snapEnv -- per the spec: stakeSnap = stakeDistr @era utxo dstate pstate istakeSnap = incrementalStakeDistr pp incStake dstate pstate 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 0a9179c3dd0..21618639e2f 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs @@ -409,7 +409,7 @@ utxoInductive :: TransitionRule (EraRule "UTXO" era) utxoInductive = do TRC (UtxoEnv slot pp certState, utxos, tx) <- judgmentContext - let UTxOState utxo _ _ _ ppup _ _ = utxos + let UTxOState utxo _ _ ppup _ _ = utxos txBody = tx ^. bodyTxL outputs = txBody ^. outputsTxBodyL genDelegs = dsGenDelegs (certDState certState) @@ -648,7 +648,6 @@ updateUTxOState pp utxos txBody certState govState depositChangeEvent txUtxODiff pure $! UTxOState { utxosUtxo = UTxO newUTxO - , utxosFrxo = mempty , utxosDeposited = utxosDeposited <> depositChange , utxosFees = utxosFees <> txBody ^. feeTxBodyL , utxosGovState = govState 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 f261b025f52..311f1f4b1a2 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Arbitrary.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Arbitrary.hs @@ -187,7 +187,6 @@ instance <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary -- The 'genericShrink' function returns first the immediate subterms of a -- value (in case it is a recursive data-type), and then shrinks the value diff --git a/eras/shelley/test-suite/bench/Main.hs b/eras/shelley/test-suite/bench/Main.hs index b505e8aab2c..35ab5136d18 100644 --- a/eras/shelley/test-suite/bench/Main.hs +++ b/eras/shelley/test-suite/bench/Main.hs @@ -173,7 +173,7 @@ touchCertState :: CertState c -> Int touchCertState (CertState _x _y _z) = 1 touchUTxOState :: Cardano.Ledger.Shelley.LedgerState.UTxOState cryto -> Int -touchUTxOState (UTxOState _utxo _ _deposited _fees _ppups _ _) = 2 +touchUTxOState (UTxOState _utxo _deposited _fees _ppups _ _) = 2 profileCreateRegKeys :: IO () profileCreateRegKeys = do diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/BenchmarkFunctions.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/BenchmarkFunctions.hs index 7a3df8b69a3..573af269449 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/BenchmarkFunctions.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/BenchmarkFunctions.hs @@ -146,7 +146,6 @@ initUTxO :: Integer -> UTxOState B initUTxO n = UTxOState (genesisCoins genesisId (injcoins n)) - mempty (Coin 0) (Coin 0) def diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs index f3d99c95ec2..b1acd743ecc 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Examples/Consensus.hs @@ -377,7 +377,6 @@ exampleNewEpochState value ppp pp = , mkBasicTxOut addr value ) ] - , utxosFrxo = mempty , utxosDeposited = Coin 1000 , utxosFees = Coin 1 , utxosGovState = emptyGovState diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Utxo.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Utxo.hs index 0686ab86354..bd8f93521f8 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Utxo.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Utxo.hs @@ -157,7 +157,7 @@ genTx constants ) (LedgerEnv slot txIx pparams reserves) - (LedgerState utxoSt@(UTxOState utxo _ _ _ _ _ _) dpState) = + (LedgerState utxoSt@(UTxOState utxo _ _ _ _ _) dpState) = do ------------------------------------------------------------------------- -- Generate the building blocks of a TxBody diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/IncrementalStake.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/IncrementalStake.hs index 7db21934941..d08e85d6cdc 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/IncrementalStake.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/IncrementalStake.hs @@ -167,7 +167,7 @@ checkIncrementalStake :: Property checkIncrementalStake es = let - (LedgerState (UTxOState utxo _ _ _ _ incStake _) (CertState _vstate pstate dstate)) = esLState es + (LedgerState (UTxOState utxo _ _ _ incStake _) (CertState _vstate pstate dstate)) = esLState es stake = stakeDistr @era utxo dstate pstate istake = incrementalStakeDistr (es ^. curPParamsEpochStateL) incStake dstate pstate in 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 80efa299fad..e7969278cfc 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 @@ -325,7 +325,6 @@ utxoState = , ShelleyTxOut bobAddr (Coin 1000) ] ) - mempty (Coin 0) (Coin 0) def diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Alonzo/Tools.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Alonzo/Tools.hs index 0aa80e57496..c8e8a36c888 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Alonzo/Tools.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Alonzo/Tools.hs @@ -204,16 +204,19 @@ exampleTx :: Tx era exampleTx pf ptr = mkBasicTx (validatingBody pf) - & witsTxL .~ wits + & witsTxL + .~ wits where wits = mkBasicTxWits & addrTxWitsL - .~ Set.fromList [mkWitnessVKey (hashAnnotated (validatingBody pf)) (someKeys pf)] - & hashScriptTxWitsL .~ [always 3 pf] - & hashDataTxWitsL .~ [Data (PV1.I 123)] + .~ Set.fromList [mkWitnessVKey (hashAnnotated (validatingBody pf)) (someKeys pf)] + & hashScriptTxWitsL + .~ [always 3 pf] + & hashDataTxWitsL + .~ [Data (PV1.I 123)] & rdmrsTxWitsL - .~ Redeemers (Map.singleton ptr (Data (PV1.I 42), ExUnits 5000 5000)) + .~ Redeemers (Map.singleton ptr (Data (PV1.I 42), ExUnits 5000 5000)) validatingBody :: forall era. @@ -226,13 +229,16 @@ validatingBody :: TxBody era validatingBody pf = mkBasicTxBody - & inputsTxBodyL .~ Set.fromList [mkGenesisTxIn 1] - & collateralInputsTxBodyL .~ Set.fromList [mkGenesisTxIn 11] + & inputsTxBodyL + .~ Set.fromList [mkGenesisTxIn 1] + & collateralInputsTxBodyL + .~ Set.fromList [mkGenesisTxIn 11] & outputsTxBodyL - .~ SSeq.fromList [mkBasicTxOut (someAddr pf) (inject $ Coin 4995)] - & feeTxBodyL .~ Coin 5 + .~ SSeq.fromList [mkBasicTxOut (someAddr pf) (inject $ Coin 4995)] + & feeTxBodyL + .~ Coin 5 & scriptIntegrityHashTxBodyL - .~ newScriptIntegrityHash pf testPParams [PlutusV1] redeemers (mkTxDats (Data (PV1.I 123))) + .~ newScriptIntegrityHash pf testPParams [PlutusV1] redeemers (mkTxDats (Data (PV1.I 123))) where redeemers = Redeemers $ @@ -254,7 +260,6 @@ ustate :: ustate pf = UTxOState { utxosUtxo = initUTxO pf - , utxosFrxo = mempty , utxosDeposited = Coin 0 , utxosFees = Coin 0 , utxosGovState = def @@ -311,8 +316,13 @@ failLeft err (Left e) = err (show e) testPParams :: forall era. AlonzoEraPParams era => PParams era testPParams = emptyPParams - & ppCostModelsL .~ zeroTestingCostModels [PlutusV1] - & ppMaxValSizeL .~ 1000000000 - & ppMaxTxExUnitsL .~ ExUnits 100000000 100000000 - & ppMaxBlockExUnitsL .~ ExUnits 100000000 100000000 - & ppProtocolVersionL .~ ProtVer (eraProtVerHigh @era) 0 + & ppCostModelsL + .~ zeroTestingCostModels [PlutusV1] + & ppMaxValSizeL + .~ 1000000000 + & ppMaxTxExUnitsL + .~ ExUnits 100000000 100000000 + & ppMaxBlockExUnitsL + .~ ExUnits 100000000 100000000 + & ppProtocolVersionL + .~ ProtVer (eraProtVerHigh @era) 0 diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Utxo.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Utxo.hs index 01a4af8b9dd..5c89e3b6eaa 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Utxo.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Utxo.hs @@ -84,7 +84,6 @@ utxoStateSpec _env = constrained $ \utxoState -> match utxoState $ \utxosUtxo - _utxosFrxo _utxosDeposited _utxosFees _utxosGovState diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs index 55b577cbb21..c18dc88d476 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Functions.hs @@ -396,8 +396,7 @@ instance TotalAda AccountState where totalAda (AccountState treasury reserves) = treasury <+> reserves instance Reflect era => TotalAda (UTxOState era) where - -- TODO WG don't need to do anything with frxo here right? - totalAda (UTxOState utxo _ _deposits fees gs _ donations) = + totalAda (UTxOState utxo _deposits fees gs _ donations) = totalAda utxo <+> fees <+> govStateTotalAda gs <+> donations -- we don't add in the _deposits, because it is invariant that this 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 0703ed71662..104e6e77ab1 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 @@ -151,7 +151,6 @@ import Cardano.Ledger.EpochBoundary ( SnapShots (..), Stake (..), ) -import Cardano.Ledger.FRxO (FRxO (FRxO), unFRxO) import Cardano.Ledger.Keys ( GenDelegPair (..), GenDelegs (..), @@ -3257,11 +3256,10 @@ psNewEpochState proof (NewEpochState en (BlocksMade pbm) (BlocksMade cbm) es _ ( ] pcUTxOState :: Proof era -> UTxOState era -> PDoc -pcUTxOState proof (UTxOState u f dep fs gs (IStake m _) don) = +pcUTxOState proof (UTxOState u dep fs gs (IStake m _) don) = ppRecord "UTxOState" [ ("utxo", pcUTxO proof u) - , ("frxo", pcUTxO proof (UTxO . unFRxO $ f)) -- TODO WG , ("deposited", pcCoin dep) , ("fees", pcCoin fs) , ("govState", pcGovState proof gs) @@ -3274,11 +3272,10 @@ instance Reflect era => PrettyA (UTxOState era) where -- | Like pcUTxOState, except it prints only a summary of the UTxO psUTxOState :: forall era. Reflect era => Proof era -> UTxOState era -> PDoc -psUTxOState proof (UTxOState (UTxO u) (FRxO f) dep fs gs (IStake m _) don) = +psUTxOState proof (UTxOState (UTxO u) dep fs gs (IStake m _) don) = ppRecord "UTxOState" [ ("utxo", summaryMapCompact (Map.map (\x -> x ^. compactCoinTxOutL) u)) - , ("frxo", summaryMapCompact (Map.map (\x -> x ^. compactCoinTxOutL) f)) , ("deposited", pcCoin dep) , ("fees", pcCoin fs) , ("govState", pcGovState proof gs) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Properties.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Properties.hs index 9d58012d1b7..0d38a1418f4 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Properties.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Properties.hs @@ -280,7 +280,7 @@ adaIsPreservedBabbage numTx gensize = adaIsPreserved Babbage numTx gensize stakeInvariant :: EraTxOut era => MockChainState era -> MockChainState era -> Property stakeInvariant (MockChainState _ _ _ _) (MockChainState nes _ _ _) = case (lsUTxOState . esLState . nesEs) nes of - (UTxOState utxo _ _ _ _ istake _) -> istake === updateStakeDistribution def mempty mempty utxo + (UTxOState utxo _ _ _ istake _) -> istake === updateStakeDistribution def mempty mempty utxo incrementStakeInvariant :: ( Reflect era diff --git a/libs/ledger-state/src/Cardano/Ledger/State/Query.hs b/libs/ledger-state/src/Cardano/Ledger/State/Query.hs index 8f43db7d7ca..c20f6ab8caa 100644 --- a/libs/ledger-state/src/Cardano/Ledger/State/Query.hs +++ b/libs/ledger-state/src/Cardano/Ledger/State/Query.hs @@ -745,8 +745,10 @@ loadEpochState fp = runSqlite fp $ do , esSnapshots = snapshots , esNonMyopic = epochStateNonMyopic } - & curPParamsEpochStateL .~ epochStatePp - & prevPParamsEpochStateL .~ epochStatePrevPp + & curPParamsEpochStateL + .~ epochStatePp + & prevPParamsEpochStateL + .~ epochStatePrevPp loadEpochStateWithSharing :: MonadUnliftIO m => T.Text -> m (Shelley.EpochState CurrentEra) loadEpochStateWithSharing fp = runSqlite fp $ do @@ -764,8 +766,10 @@ loadEpochStateWithSharing fp = runSqlite fp $ do , esSnapshots = snapshots , esNonMyopic = epochStateNonMyopic } - & prevPParamsEpochStateL .~ epochStatePrevPp - & curPParamsEpochStateL .~ epochStatePp + & prevPParamsEpochStateL + .~ epochStatePrevPp + & curPParamsEpochStateL + .~ epochStatePp loadSnapShotsNoSharing :: MonadUnliftIO m => T.Text -> Entity EpochState -> m (EpochBoundary.SnapShots C) From 94fef72f1ad9875101200a193cfb43f066110d1f Mon Sep 17 00:00:00 2001 From: Will Gould Date: Thu, 4 Jul 2024 18:07:08 +0100 Subject: [PATCH 13/19] Intra-codebase writeup idea --- .../impl/src/Cardano/Ledger/Babel/TxBody.hs | 33 ++++++++++++++++++- .../src/Cardano/Ledger/Block.hs | 6 ++++ .../src/Cardano/Ledger/Core.hs | 15 +++++++++ 3 files changed, 53 insertions(+), 1 deletion(-) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/TxBody.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/TxBody.hs index 6b1c58e5175..36f6df75f77 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/TxBody.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/TxBody.hs @@ -160,9 +160,40 @@ data BabelTxBodyRaw era = BabelTxBodyRaw , bbtbrCurrentTreasuryValue :: !(StrictMaybe Coin) , bbtbrTreasuryDonation :: !Coin , -- Tx body fields for intents (babel-fees) + + {- CIP-0118#0-tx-body + + Here, we demonstrate the three (or two...I'll explain shortly) new fields required + for Babel fees. + + The type of `Fulfill` is equivalent to that of an input, and the type of + a `Request` is equivalent to that of an ourput. + + A `RequiredTx` is a transaction on which *this* transaction depends. + + This has certain implications when it comes to cyclic dependencies. Because the + `TxBody` must be hashed for witnessing, if two transactions are dependent on + one-another with `RequiredTxs`, it becomes impossible to hash either of them. + This is why we might not want to put `RequiredTxs` in the `TxBody`: if we want + to allow these cyclic dependencies. + + If we do, we'll need to move `RequiredTxs` up to the `Tx` level, like, for example: + + data AlonzoTx era = AlonzoTx + { body :: !(TxBody era) + , wits :: !(TxWits era) + , isValid :: !IsValid + , auxiliaryData :: !(StrictMaybe (TxAuxData era)) + , requiredTxs :: !(RequiredTxs era) + } + deriving (Generic) + + This'll allow us to calculate a composite hash...TODO explain how they can do this + + Jump to CIP-0118#1-tx-body to continue... -} bbtbrFulfills :: !(Set (Fulfill (EraCrypto era))) , bbtbrRequests :: !(StrictSeq (Sized (TxOut era))) - , bbtbrRequiredTxs :: !(Set (TxIn (EraCrypto era))) -- TODO WG You need to remove this right (for general atomic zones)? + , bbtbrRequiredTxs :: !(Set (TxIn (EraCrypto era))) } deriving (Generic, Typeable) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs index 9d3831a46ce..300bf212305 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs @@ -46,6 +46,12 @@ import GHC.Generics (Generic) import Lens.Micro ((^.)) import NoThunks.Class (NoThunks (..)) +{- CIP-0118#0-block-structure + + Firstly, we need to change the structure of the block. The name here, `TxZones`, isn't great, but it's + a replacement of the `TxSeq` type. + + Jump to CIP-0118#1-block-structure to continue... -} data Block h era = Block' !h !(TxZones era) BSL.ByteString deriving (Generic) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs index a7b42af8671..5968b1b9fb6 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs @@ -630,6 +630,21 @@ class ) => EraSegWits era where + {- CIP-0118#1-block-structure + + To support the concept of a block having a different concrete representation + depending on era, we've added a `TxStructure` type. This isn't strictly necessary; + mapping can occur in the instances instead. It does, however, demonstrate intent, + in that it allows what would be a concrete representation in the methods, + `StrictSeq (StrictSeq (Tx era))`, to be left abstract at the class level. + + Additionally, we have a (bad) name change of `TxSeq` to `TxZones`. I'd welcome + a better name in the actual implementation. + + Finally, we have a `flatten` function, as much of the existing code (tests etc) + requires a `StrictSeq`, and doesn't care about the new meaning in our `TxZones`. + + Jump to CIP-0118#2-block-structure to continue... -} type TxStructure era :: Type -> Type type TxZones era = (r :: Type) | r -> era From 3de5d2ce3080985729680bd7a4e235bc8abf9e55 Mon Sep 17 00:00:00 2001 From: Will Gould Date: Fri, 5 Jul 2024 18:44:17 +0100 Subject: [PATCH 14/19] More choose-your-own-adventure comments --- .../Cardano/Ledger/Babel/LedgerState/Types.hs | 11 ++++++ .../src/Cardano/Ledger/Babel/Rules/Ledger.hs | 3 ++ .../src/Cardano/Ledger/Babel/Rules/Ledgers.hs | 3 ++ .../src/Cardano/Ledger/Babel/Rules/Utxo.hs | 14 +++++++ .../src/Cardano/Ledger/Babel/Rules/Utxos.hs | 29 +++++++++++++-- .../src/Cardano/Ledger/Babel/Rules/Utxow.hs | 4 ++ .../src/Cardano/Ledger/Babel/Rules/Zone.hs | 37 +++++++++++++++---- .../src/Cardano/Ledger/Babel/Rules/Zones.hs | 14 ++++++- .../impl/src/Cardano/Ledger/Babel/TxBody.hs | 2 +- .../Cardano/Ledger/Shelley/API/Validation.hs | 31 ++++++++++++++++ .../impl/src/Cardano/Ledger/Shelley/Era.hs | 6 +++ .../src/Cardano/Ledger/Shelley/Rules/Bbody.hs | 1 + .../src/Cardano/Ledger/Block.hs | 4 +- .../src/Cardano/Ledger/Core.hs | 5 +-- .../src/Cardano/Ledger/Plutus/Language.hs | 31 ++++++++++++++++ 15 files changed, 176 insertions(+), 19 deletions(-) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs index d625e2fcc92..cc014ccfc68 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs @@ -39,6 +39,17 @@ import Lens.Micro.Type (Lens') -- type instance Ledger (ConwayEra c) = LedgerStateTemp (ConwayEra c) +{- CIP-0118#ledger-state-temp + +This type represents a transient state, existing within the LEDGERS rule, and +manipulated by the UTXOS rule (jump to CIP-0118#UTXOS-rule to see how). + +To see how we've made `ApplyBlock` compatible with our new +`State (EraRule "LEDGERS" era) ~ LedgerStateTemp era` requirement for Babel, +jump to CIP-0118#0-apply-block. + +Jump to ??? to continue... -} + -- | The state associated with a 'Ledger'. data LedgerStateTemp era = LedgerStateTemp { lstUTxOState :: !(UTxOStateTemp era) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledger.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledger.hs index c169becb385..1e1534b0e57 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledger.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledger.hs @@ -313,6 +313,9 @@ instance -- ======================================= +{- CIP-0118#LEDGER-rule + +Jump to CIP-0118#UTXOW-rule to continue... -} ledgerTransition :: forall (someLEDGER :: Type -> Type) era. ( AlonzoEraTx era diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledgers.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledgers.hs index 3d1e888ddf9..11c648cf9a4 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledgers.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Ledgers.hs @@ -98,6 +98,9 @@ instance transitionRules = [ledgersTransition] +{- CIP-0118#LEDGERS-rule + +Jump to CIP-0118#LEDGER-rule to continue... -} ledgersTransition :: forall era. ( Embed (EraRule "LEDGER" era) (BabelLEDGERS era) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxo.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxo.hs index 332d41d5a07..a200a13201c 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxo.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxo.hs @@ -272,6 +272,20 @@ instance -- BabelUTXO STS -------------------------------------------------------------------------------- +{- CIP-0118#UTXO-rule + +The only difference here is that the transaction max size check: + +txsize tx ≤ maxTxSize pp +runTestOnSignal $ Shelley.validateMaxTxSizeUTxO pp tx + +...has been moved to the ZONE rule (CIP-0118#ZONE-rule). This is because we now +need to ensure that the size of all transactions within a zone is within the max +size of a single transaction, and, naturally, if that condition is satisfied, it +must also be implicitly satisfied for all individual transactions. + +Jump to CIP-0118#UTXOS-rule to continue... -} + -- | The UTxO transition rule for the Babbage eras. utxoTransition :: forall era. diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs index 13eb8f563dc..0d5bf8603fe 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs @@ -118,6 +118,13 @@ data BabelUtxosEvent era (UTxO era) -- | UTxO created (UTxO era) + | -- | The FRxOs consumed and created by a signal tx + TxFRxODiff + -- | FRxO consumed + (FRxO era) + -- | FRxO created + (FRxO era) + deriving (Generic) deriving (Generic) deriving instance (Era era, Eq (TxOut era)) => Eq (BabelUtxosEvent era) @@ -264,6 +271,18 @@ instance wrapFailed = AlonzoInBabbageUtxoPredFailure . UtxosFailure wrapEvent = UtxosEvent +{- CIP-0118#UTXOS-rule + +Everything interesting here is in the `updateUTxOState` function. + +However, it's not actually all that interesting; what we do with the FRxO is identical +to what we already do with the UTxO. + +Note that I'm unsure if we actually need to do anything with `deletedFrxO`, and so +the `txFrxODiffEvent` argument, and the event it uses, `TxFRxODiff`, might be redundant. +I've included these elements to keep parity with the UTxO logic. + +Jump to ??? to continue... -} utxosTransition :: forall era. ( AlonzoEraTx era @@ -324,6 +343,7 @@ babelEvalScriptsTxValid = do govState (tellEvent . injectEvent . TotalDeposits (hashAnnotated txBody)) (\a b -> tellEvent . injectEvent $ TxUTxODiff a b) + (\a b -> tellEvent . injectEvent $ TxFRxODiff a b) pure $! utxos' & utxostDonationL <>~ txBody ^. treasuryDonationTxBodyL -- | This monadic action captures the final stages of the UTXO(S) rule. In particular it @@ -331,8 +351,6 @@ babelEvalScriptsTxValid = do -- fee pot `utxosFees` and updates the `utxosDeposited` field. Continuation supplied will -- be called on the @deposit - refund@ change, which is normally used to emit the -- `TotalDeposits` event. - --- TODO WG: This shouldn't be here. Need to figure out how to alter original without changing tons of callsites updateUTxOState :: (BabelEraTxBody era, Monad m) => PParams era -> @@ -342,8 +360,9 @@ updateUTxOState :: GovState era -> (Coin -> m ()) -> (UTxO era -> UTxO era -> m ()) -> + (FRxO era -> FRxO era -> m ()) -> m (UTxOStateTemp era) -updateUTxOState pp utxos txBody certState govState depositChangeEvent txUtxODiffEvent = do +updateUTxOState pp utxos txBody certState govState depositChangeEvent txUtxODiffEvent txFrxODiffEvent = do let UTxOStateTemp { utxostUtxo , utxostFrxo @@ -361,16 +380,18 @@ updateUTxOState pp utxos txBody certState govState depositChangeEvent txUtxODiff FRxO frxo = utxostFrxo !frxoAdd = txfrxo txBody -- These will be inserted into the FRxO {- utxoDel = txins txb ◁ utxo -} - !(frxoWithout, _frxoDel) = extractKeys frxo (txBody ^. fulfillsTxBodyL) + !(frxoWithout, frxoDel) = extractKeys frxo (txBody ^. fulfillsTxBodyL) {- newUTxO = (txins txb ⋪ utxo) ∪ outs txb -} newFRxO = frxoWithout `Map.union` unFRxO frxoAdd deletedUTxO = UTxO utxoDel + deletedFRxO = FRxO frxoDel newIncStakeDistro = updateStakeDistribution pp utxostStakeDistr deletedUTxO utxoAdd totalRefunds = certsTotalRefundsTxBody pp certState txBody totalDeposits = certsTotalDepositsTxBody pp certState txBody depositChange = totalDeposits <-> totalRefunds depositChangeEvent depositChange txUtxODiffEvent deletedUTxO utxoAdd + txFrxODiffEvent deletedFRxO frxoAdd pure $! UTxOStateTemp { utxostUtxo = UTxO newUTxO diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs index 3ae6fffc07b..49952d238ec 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs @@ -402,6 +402,10 @@ shelleyToBabelUtxowPredFailure = \case ------------ +{- CIP-0118#UTXOW-rule + +Jump to CIP-0118#UTXO-rule to continue... -} + -- | UTXOW transition rule that is used in Babbage and Babel era. babelUtxowTransition :: forall era. diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs index 4e604259512..520956cbdbb 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs @@ -209,11 +209,34 @@ instance initialRules = [] transitionRules = [zoneTransition] -{- txsize tx ≤ maxTxSize pp -} --- We've moved this to the ZONE rule. See https://github.com/IntersectMBO/formal-ledger-specifications/commit/c3e18ac1d3da92dd4894bbc32057a143f9720f52#diff-5f67369ed62c0dab01e13a73f072b664ada237d094bbea4582365264dd163bf9 --- ((totSizeZone ltx) ≤ᵇ (Γ .LEnv.pparams .PParams.maxTxSize)) ≡ true --- runTestOnSignal $ Shelley.validateMaxTxSizeUTxO pp tx +{- CIP-0118#ZONE-rule +This is an implementation of the Babel fees Agda spec for the ZONE rule. + +We check that the sum of the size of all transactions within the zone is less than +the maximum size of an individual transaction: + +`runTestOnSignal $ validateMaxTxSizeUTxO pParams (Foldable.toList txs)` + +We then check that all `RequiredTx`s of each transaction in the zone exists as a transaction +in the zone: + +`runTestOnSignal $ failureUnless (all (chkRqTx txs) txs) CheckRqTxFailure` + +Next, we check that no cycles exist within the dependencies: + +`runTestOnSignal $ failureUnless (chkLinear (Foldable.toList txs)) CheckLinearFailure` + +Finally, we check that the `ExUnit`s limit is not exceeded: + +`runTestOnSignal $ validateExUnitsTooBigUTxO pParams (Foldable.toList txs)` + +If these checks pass, we proceed to the LEDGERS rule. Note that, at this point, +we create a `LedgerStateTemp` with an empty `FRxO` set. + +Please see CIP-0118#ledger-state-temp for more information on `LedgerStateTemp`. + +Jump to CIP-0118#LEDGERS-rule to continue... -} zoneTransition :: forall era. ( EraRule "ZONE" era ~ BabelZONE era @@ -236,9 +259,8 @@ zoneTransition :: TransitionRule (BabelZONE era) zoneTransition = judgmentContext - -- I guess we want UTxOStateTemp here? >>= \( TRC - ( BabelLedgersEnv slotNo ixRange pParams accountState + ( BabelLedgersEnv slotNo ixStart pParams accountState , LedgerState utxoState certState , txs :: Seq (Tx era) ) @@ -257,7 +279,7 @@ zoneTransition = lsTemp <- -- TODO WG: Should we be checking FRxO is empty before converting? trans @(EraRule "LEDGERS" era) $ TRC - ( BabelLedgersEnv slotNo ixRange pParams accountState + ( BabelLedgersEnv slotNo ixStart pParams accountState , fromLedgerState $ LedgerState utxoState certState , txs ) @@ -282,7 +304,6 @@ zoneTransition = chkRqTx txs tx = all chk txrids where chk txrid = txrid `elem` ids - -- asd = tx ^. requiredTxsTxL txrids = fmap txInTxId $ toList $ tx ^. bodyTxL . requiredTxsTxBodyL ids :: Set (TxId (EraCrypto era)) ids = getIDs $ Foldable.toList txs diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zones.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zones.hs index a635c3e9272..16f4c9d24b1 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zones.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zones.hs @@ -154,8 +154,20 @@ instance transitionRules = [zonesTransition] +{- CIP-0118#ZONES-rule + +Previously, LEDGERS was indexing transactions by their position in the block. + +Now, LEDGERS can only see transactions in a zone, and thus can only index transactions +relative to that zone. + +To solve this, in ZONES, we index each zone by its position in the block. This +gives LEDGERS the knowledge of a "starting point" from which to derive the +absolute position of transactions in a block given its relative position in the zone. + +Jump to CIP-0118#ZONE-rule to continue... -} + -- Need to index each transaction in the list of lists by its index in the flattened list --- Do we care about zonesTransition :: forall era. ( Embed (EraRule "ZONE" era) (BabelZONES era) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/TxBody.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/TxBody.hs index 36f6df75f77..f8ce4d7fc69 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/TxBody.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/TxBody.hs @@ -190,7 +190,7 @@ data BabelTxBodyRaw era = BabelTxBodyRaw This'll allow us to calculate a composite hash...TODO explain how they can do this - Jump to CIP-0118#1-tx-body to continue... -} + Jump to CIP-0118#ZONE-rule to continue... -} bbtbrFulfills :: !(Set (Fulfill (EraCrypto era))) , bbtbrRequests :: !(StrictSeq (Sized (TxOut era))) , bbtbrRequiredTxs :: !(Set (TxIn (EraCrypto era))) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs index ec378ce06f3..1e3e10a404c 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs @@ -61,6 +61,37 @@ import NoThunks.Class (NoThunks (..)) Block validation API -------------------------------------------------------------------------------} +{- CIP-0118#0-apply-block + +(Please read CIP-0118#ledger-state-temp first) + +Since we want `State (EraRule "LEDGERS" era) ~ LedgerStateTemp era`, and since, +originally, the definition of `ShelleyBbodyState` was: + +data ShelleyBbodyState era + = BbodyState !(State (EraRule "LEDGERS" era)) !(BlocksMade (EraCrypto era)) + +...which, conceptually, states that the first rule after BBODY expects the same +state as the LEDGERS rule. This is because LEDGERS was always intended to be the +first rule after BBODY, which is no longer the case! + +There are multiple ways to solve this, of varying complexity and tradeoffs, to solve this. +This is just one way. We've introduced a new type family: `EraFirstRule (era :: Symbol)`. + +See CIP-0118#era-first-rule for more information on `EraFirstRule`. + +This family carries the rule expected after BBODY, for each era. + +Now, we can change `ShelleyBbodyState`: + +data ShelleyBbodyState era + = BbodyState !(State (EraRule (EraFirstRule era) era)) !(BlocksMade (EraCrypto era)) + +...to carry whichever state is expected (by the current era) for the first rule after BBODY. + +See CIP-0118#shelley-bbody-state for more details on the changes to `ShelleyBbodyState`. + +Jump to ??? to continue... -} class ( STS (EraRule "TICK" era) , BaseM (EraRule "TICK" era) ~ ShelleyBase diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Era.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Era.hs index c83c1bdaf31..bfcc91851a6 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Era.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Era.hs @@ -41,6 +41,12 @@ instance Crypto c => Era (ShelleyEra c) where eraName = "Shelley" +{- CIP-0118#era-first-rule + + `EraFirstRule` is a type family declaring which rule is expected immediately after BBODY. + + This is used to allow the state of whichever rule is declared to be different + to the state expected by LEDGERS. -} type family EraFirstRule era :: Symbol type instance EraFirstRule (ShelleyEra c) = "LEDGERS" 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 83d7a424cc0..dc56bde697a 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Bbody.hs @@ -58,6 +58,7 @@ import GHC.Generics (Generic) import Lens.Micro ((^.)) import NoThunks.Class (NoThunks (..)) +{- CIP-0118#shelley-bbody-state -} data ShelleyBbodyState era = BbodyState !(State (EraRule (EraFirstRule era) era)) !(BlocksMade (EraCrypto era)) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs index 300bf212305..594ff8c0d8b 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs @@ -48,8 +48,8 @@ import NoThunks.Class (NoThunks (..)) {- CIP-0118#0-block-structure - Firstly, we need to change the structure of the block. The name here, `TxZones`, isn't great, but it's - a replacement of the `TxSeq` type. + Firstly, we need to change the structure of the block. `TxZones` is an associated + type on `EraSegWits`. It replaces `TxSeq`. Jump to CIP-0118#1-block-structure to continue... -} data Block h era diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs index 5968b1b9fb6..47f9eedf6e6 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs @@ -634,9 +634,8 @@ class To support the concept of a block having a different concrete representation depending on era, we've added a `TxStructure` type. This isn't strictly necessary; - mapping can occur in the instances instead. It does, however, demonstrate intent, - in that it allows what would be a concrete representation in the methods, - `StrictSeq (StrictSeq (Tx era))`, to be left abstract at the class level. + mapping can occur in the instances instead. This does, however, demonstrate the intent: + The concrete structure of transactions in a block is decided on a per-era basis. Additionally, we have a (bad) name change of `TxSeq` to `TxZones`. I'd welcome a better name in the actual implementation. diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs index ecf2aef73a4..4bfd8a863c8 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs @@ -197,6 +197,37 @@ instance DecCBOR (Annotator PlutusBinary) where instance SafeToHash PlutusBinary where originalBytes (PlutusBinary binaryBlutus) = fromShort binaryBlutus +{- CIP-0118#0-plutusv4 + + Here, we demonstrate the three (or two...I'll explain shortly) new fields required + for Babel fees. + + The type of `Fulfill` is equivalent to that of an input, and the type of + a `Request` is equivalent to that of an ourput. + + A `RequiredTx` is a transaction on which *this* transaction depends. + + This has certain implications when it comes to cyclic dependencies. Because the + `TxBody` must be hashed for witnessing, if two transactions are dependent on + one-another with `RequiredTxs`, it becomes impossible to hash either of them. + This is why we might not want to put `RequiredTxs` in the `TxBody`: if we want + to allow these cyclic dependencies. + + If we do, we'll need to move `RequiredTxs` up to the `Tx` level, like, for example: + + data AlonzoTx era = AlonzoTx + { body :: !(TxBody era) + , wits :: !(TxWits era) + , isValid :: !IsValid + , auxiliaryData :: !(StrictMaybe (TxAuxData era)) + , requiredTxs :: !(RequiredTxs era) + } + deriving (Generic) + + This'll allow us to calculate a composite hash...TODO explain how they can do this + + Jump to CIP-0118#1-plutusv4 to continue... -} + -- | Non-Native Plutus Script language. This is expected to be an open type. We will add -- new Constuctors to this type as additional Plutus language versions as are added. We -- use an enumerated type for two reasons. From 7a5fb67fe2db075f2b2ea270641d9d0872e1c311 Mon Sep 17 00:00:00 2001 From: Will Gould Date: Mon, 8 Jul 2024 15:05:15 +0100 Subject: [PATCH 15/19] Comments, removed commented out code etc --- cabal.project | 4 +- .../impl/src/Cardano/Ledger/Alonzo/Tx.hs | 2 - .../impl/src/Cardano/Ledger/Babbage/Tx.hs | 75 -- .../Test/Cardano/Ledger/Babbage/Arbitrary.hs | 13 - .../Test/Cardano/Ledger/Babbage/TreeDiff.hs | 14 - .../Babbage/Translation/TranslatableGen.hs | 2 - eras/babel/impl/CHANGELOG.md | 777 +----------------- .../impl/src/Cardano/Ledger/Babel/FRxO.hs | 5 +- .../Cardano/Ledger/Babel/LedgerState/Types.hs | 4 +- .../src/Cardano/Ledger/Babel/Rules/Utxos.hs | 1 - .../src/Cardano/Ledger/Babel/Rules/Utxow.hs | 5 - .../babel/impl/src/Cardano/Ledger/Babel/Tx.hs | 14 - .../impl/src/Cardano/Ledger/Babel/TxBody.hs | 11 +- .../impl/src/Cardano/Ledger/Babel/TxCert.hs | 226 ----- .../impl/src/Cardano/Ledger/Babel/TxInfo.hs | 29 +- eras/babel/test-suite/CHANGELOG.md | 47 +- .../Cardano/Ledger/Shelley/API/Validation.hs | 2 +- .../src/Cardano/Ledger/Block.hs | 4 +- .../src/Cardano/Ledger/Core.hs | 4 +- .../src/Cardano/Ledger/Plutus/Language.hs | 33 +- 20 files changed, 50 insertions(+), 1222 deletions(-) diff --git a/cabal.project b/cabal.project index 3ad94545848..2aa1f697c3f 100644 --- a/cabal.project +++ b/cabal.project @@ -104,8 +104,8 @@ test-show-details: streaming source-repository-package type: git location: https://github.com/willjgould/plutus - tag: cb3dcbde537635fccd46ec40e71750ecf7cb9530 - --sha256: 10kimcrsh7fibbnq96i7fc7xv0r3vsyngqbmpnfmijaa2j4k2zha + tag: a5179ce32b3471399d35b621920901643544c200 + --sha256: 0ksz9q2j07kqf1pl3lyccjfkvxs0dyd0y6pn4ish9mfcgh6afsph subdir: plutus-ledger-api plutus-tx diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs index df0f8ffa4f9..469e35a4168 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs @@ -213,8 +213,6 @@ instance Crypto c => EraTx (AlonzoEra c) where <*> pure (IsValid True) <*> pure (fmap upgradeTxAuxData aux) --- <*> pure mempty -- TODO WG: Do I need to change this? I'm thinking not for the prototype - instance (Tx era ~ AlonzoTx era, AlonzoEraTx era) => EqRaw (AlonzoTx era) where eqRaw = alonzoEqTxRaw diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs index 0857d729e73..6de5e76e5ce 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs @@ -64,9 +64,6 @@ instance Crypto c => EraTx (BabbageEra c) where auxDataTxL = auxDataAlonzoTxL {-# INLINE auxDataTxL #-} - -- requiredTxsTxL = lens (const mempty) const - -- {-# INLINE requiredTxsTxL #-} - sizeTxF = sizeAlonzoTxF {-# INLINE sizeTxF #-} @@ -88,78 +85,6 @@ instance Crypto c => AlonzoEraTx (BabbageEra c) where isValidTxL = isValidAlonzoTxL {-# INLINE isValidTxL #-} --- newtype BabbageRequiredTxRaw era = BabbageRequiredTxRaw (Set (TxId (EraCrypto era))) --- deriving (Eq, Show, Generic) - --- instance EraScript era => NoThunks (BabbageRequiredTxRaw era) - --- deriving newtype instance Era era => EncCBOR (BabbageRequiredTxRaw era) - --- deriving newtype instance Era era => DecCBOR (BabbageRequiredTxRaw era) - --- instance Era era => DecCBOR (Annotator (BabbageRequiredTxRaw era)) where --- decCBOR = pure <$> decCBOR - --- deriving via --- (Mem BabbageRequiredTxRaw era) --- instance --- Era era => DecCBOR (Annotator (BabbageRequiredTx era)) - --- newtype BabbageRequiredTx era --- = RequiredTxBodyConstr (MemoBytes BabbageRequiredTxRaw era) --- deriving (Eq, Generic) --- deriving newtype (Plain.ToCBOR, SafeToHash) - --- deriving newtype instance EraScript era => Show (BabbageRequiredTx era) - --- instance EraScript era => NoThunks (BabbageRequiredTx era) - --- instance Memoized BabbageRequiredTx where --- type RawType BabbageRequiredTx = BabbageRequiredTxRaw - --- deriving newtype instance EraRequiredTxsData era => NFData (BabbageRequiredTxRaw era) --- deriving newtype instance EraRequiredTxsData era => NFData (BabbageRequiredTx era) - --- pattern BabbageRequiredTx :: --- forall era. --- EraScript era => --- Set (TxId (EraCrypto era)) -> --- BabbageRequiredTx era --- pattern BabbageRequiredTx {requiredTxs} <- --- (getMemoRawType -> BabbageRequiredTxRaw requiredTxs) --- where --- BabbageRequiredTx requiredTxs' = --- mkMemoized $ BabbageRequiredTxRaw requiredTxs' - --- {-# COMPLETE BabbageRequiredTx #-} - --- instance EraScript era => Semigroup (BabbageRequiredTx era) where --- (BabbageRequiredTx a) <> y | Set.null a = y --- y <> (BabbageRequiredTx a) | Set.null a = y --- (BabbageRequiredTx a) <> (BabbageRequiredTx a') = BabbageRequiredTx (a <> a') - --- instance EraScript era => Monoid (BabbageRequiredTx era) where --- mempty = BabbageRequiredTx mempty - --- instance --- (Era era, Eq (TxOut era), Eq (TxCert era), Eq (PParamsUpdate era)) => --- EqRaw (BabbageRequiredTx era) - --- -- | Encodes memoized bytes created upon construction. --- instance Era era => EncCBOR (BabbageRequiredTx era) - --- type instance MemoHashIndex BabbageRequiredTxRaw = EraIndependentRequiredTxs - --- -- deriving instance --- -- HashAlgorithm (HASH (EraCrypto era)) => --- -- Show (BabbageRequiredTx era) - --- instance c ~ EraCrypto era => HashAnnotated (BabbageRequiredTx era) EraIndependentRequiredTxs c where --- hashAnnotated = getMemoSafeHash - --- instance Crypto c => EraRequiredTxsData (BabbageEra c) where --- type RequiredTxs (BabbageEra c) = BabbageRequiredTx (BabbageEra c) - instance Crypto c => EraSegWits (BabbageEra c) where type TxStructure (BabbageEra c) = StrictSeq.StrictSeq type TxZones (BabbageEra c) = AlonzoTxSeq (BabbageEra c) 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 b8ab1494a1e..ddb71613a82 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Arbitrary.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Arbitrary.hs @@ -165,16 +165,3 @@ instance <*> arbitrary <*> arbitrary <*> arbitrary - --- Babel fees - --- instance --- ( EraScript era --- , EraTxOut era --- , EncCBOR (TxCert era) --- ) => --- Arbitrary (BabbageRequiredTx era) --- where --- arbitrary = --- BabbageRequiredTx --- <$> pure mempty -- arbitrary \ No newline at end of file diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TreeDiff.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TreeDiff.hs index dc0f0df9cbd..8a8bb66e6b7 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TreeDiff.hs +++ b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/TreeDiff.hs @@ -56,20 +56,6 @@ instance (Era era, ToExpr (TxOut era), ToExpr (TxCert era), ToExpr (PParamsUpdate era)) => ToExpr (BabbageTxBody era) --- Babel Fees - --- instance --- ( ToExpr (TxOut era) --- , ToExpr (TxCert era) --- ) => --- ToExpr (BabbageRequiredTxRaw era) - --- instance --- ( ToExpr (TxOut era) --- , ToExpr (TxCert era) --- ) => --- ToExpr (BabbageRequiredTx era) - -- Rules/Utxo instance ( ToExpr (AlonzoUtxoPredFailure era) diff --git a/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Translation/TranslatableGen.hs b/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Translation/TranslatableGen.hs index a2dd0dc6ea6..69bb4896bf7 100644 --- a/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Translation/TranslatableGen.hs +++ b/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Translation/TranslatableGen.hs @@ -92,8 +92,6 @@ genTx txbGen = <*> arbitrary <*> arbitrary --- <*> pure mempty - genTxOut :: forall era. ( EraTxOut era diff --git a/eras/babel/impl/CHANGELOG.md b/eras/babel/impl/CHANGELOG.md index 25dbbe4246d..da7e17193e0 100644 --- a/eras/babel/impl/CHANGELOG.md +++ b/eras/babel/impl/CHANGELOG.md @@ -1,776 +1,5 @@ -# Version history for `cardano-ledger-conway` +# Version history for `cardano-ledger-babel` -## 1.14.0 0 +## 0.0.0.1 -* Add lenses: - * `dvtHardForkInitiationL` - * `dvtMotionNoConfidenceL` - * `dvtTreasuryWithdrawalL` -* Add`DisallowedProposalDuringBootstrap` and `DisallowedVotesDuringBootstrap` to `ConwayGovPredFailure` -* Make `DRepDistr` calculation include rewards when no UTxO stake is delegated. #4273 - * Rename `computeDrepPulser` to `computeDRepPulser`. -* Implement `NoThunks` instance for: - * `ConwayUtxoPredFailure` - * `ConwayUtxowPredFailure` -* Add `ConwayUtxowPredFailure` era rule failure: - * Implement its `InjectRuleFailure` instances for: - * `BBODY` - * `LEDGER` - * `LEDGERS` - * `UTXOW` - * Implement instances: - * `Generic` - * `Show` - * `Eq` - * `EncCBOR` - * `DecCBOR` - * `NFData` - * Add mappings: - * `babbageToConwayUtxowPredFailure` - * `alonzoToConwayUtxowPredFailure` - * `shelleyToConwayUtxowPredFailure` - * Update `Embed (ConwayUTXO era) (ConwayUTXOW era)` instance -* Add `ConwayUtxoPredFailure` era rule failure: - * Implement its `InjectRuleFailure` instances for: - * `BBODY` - * `LEDGER` - * `LEDGERS` - * `UTXO` - * `UTXOW` - * Implement instances: - * `Generic` - * `Show` - * `Eq` - * `EncCBOR` - * `DecCBOR` - * `NFData` - * Add mappings: - * `babbageToConwayUtxoPredFailure` - * `alonzoToConwayUtxoPredFailure` - * Update `allegraToConwayUtxoPredFailure` mapping -* Add `ConwayUTXO` era rule: - * Implement instances: - * `STS` - * `Embed (ConwayUTXOS era) (ConwayUTXO era)` - * `Embed (ConwayUTXO era) (ConwayUTXOW era)` -* Add `ucppPlutusV3CostModel` to `UpgradeConwayPParams`. #4252 - * Remove the `Default` instance for `ConwayGenesis`. -* Add `foldrVotingProcedures`. - -### `testlib` - -* Add `withPostBootstrap` to Conway ImpTest -* Add `withImpStateWithProtVer` to Conway ImpTest -* Add the following utilities. #4273 - * to `Conway.ImpTest` - * `setupDRepWithoutStake` - * `setupPoolWithoutStake` - * `submitAndExpireProposalToMakeReward` - * to `Shelley.ImpTest` - * `getRewardAccountFor` - * `registerAndRetirePoolToMakeReward` -* Add `getConstitution` to Conway ImpTest -* Change return type of `setupSingleDRep` to Credential instead of KeyHash -* Add `registerInitialCommittee` and `getCommitteeMembers` to Conway ImpTest -* Implement `ConwayUtxowPredFailure` instances: - * `Arbitrary` - * `ToExpr` -* Implement `ConwayUtxoPredFailure` instances: - * `Arbitrary` - * `ToExpr` -* Updated `exampleConwayGenesis` to `conway-genesis.json`. #4252 - -## 1.13.1.0 - -* Fix typo in `ToJSON` instance of `ConwayGovState` - -### `testlib` - -* Add `ToExpr` instance for `GovProcedures` - -## 1.13.0.0 - -* Add `geCommitteeState` -* Remove `ConwayDelegEvent`, `ConwayGovCertEvent` -* Add `GovInfoEvent` -* Add `ConwayUtxosEvent` -* Add `Generic`, `Eq` and `NFData` instances for `ConwayEpochEvent` -* Add `Eq` and `NFData` instances for: - * `ConwayGovEvent` - * `ConwayCertEvent` - * `ConwayCertsEvent` - * `ConwayLedgerEvent` - * `ConwayNewEpochEvent` -* Add type `EraRuleEvent` instances for the event type of: - * `UPEC` - * `NEWPP` - * `PPUP` - * `MIR` - * `DELEGS` - * `TICK` - * `ENACT` - * `LEDGER` - * `UTXOS` -* Add `ConwayDRepIncorrectRefund` -* Stop exporting `utxosGovStateL` from `Cardano.Ledger.Conway.Governance` -* Remove deprecated `curPParamsConwayGovStateL` and `prevPParamsConwayGovStateL` -* Add `EraRuleFailure "POOL"` type instance for `ConwayEra` -* Add `ConwayUtxosPredFailure` -* Support for intra-era hard fork with `ProtVerHigh` set to `10` -* Guard Conway-specific features in transactions that use Plutus v1 or v2. #4112 - * Add `PlutusContextError` variants: - * `CurrentTreasuryValueFieldNotSupported` - * `VotingProceduresFieldNotSupported` - * `ProposalProceduresFieldNotSupported` - * `TreasuryDonationFieldNotSupported` - * Allow `RegDepositTxCert` and `UnRegDepositTxCert` to pass by ignoring the deposit or refund values, respectively. -* Switch `EPOCH` rule environment back to `()`. Start using the latest stake pool - distribution: #4115 -* Add: - * `transTxInInfoV1` - * `transTxOutV1` -* Add instances for `InjectRuleFailure` and switch to using `injectFailure` -* Remove `ConwayPOOL` rule, in favor of `ShelleyPOOL` -* Add `NFData` instance for `BabbageUtxoPredFailure` -* Rename `MinFeeRefScriptCoinsPerByte` to `MinFeeRefScriptCostPerByte` and change its type from `CoinsPerByte` to `NonNegativeInterval` #4055 -* Rename `committeeQuorum` to `committeeThreshold` #4053 -* Changed `GovActionState` to have 1 field (`gasProposalProcedure`) rather than 3 (`gasDeposit`, `gasAction`, `gasReturnAddr`) - * the old field names (`gasDeposit`, `gasAction`, `gasReturnAddr`) become functions, and the lenses - * (`gasDepositL`, `gasActionL`, `gasReturnAddrL`) have the same type, but behave differently. - * Added the lenses: `pProcDepositL`, `pProcGovActionL`, `pProcReturnAddrL`, `pProcAnchorL`, `gasProposalProcedureL`. -* Add `getDRepDistr`, `getConstitution` and `getCommitteeMembers` from `ConwayEraGov` #4033 - * Move `Constitution` to `Conway.Governance.Procedures` -* Add implementation for `getMinFeeTxUtxo` -* Add `cppMinFeeRefScriptCoinsPerByte` to `ConwayPParams` and `ppMinFeeRefScriptCoinsPerByteL` -* Add `ucppMinFeeRefScriptCoinsPerByte` to `UpgradeConwayPParams` and `ppuMinFeeRefScriptCoinsPerByteL` -* Fix `ConwayTxBody` pattern synonym, by changing its certificates arguments to `OSet` - from a `StrictSeq`. -* Add `VotingPurpose` and `ProposingPurpose` pattern synonyms -* Add `ConwayEraScript` with `toVotingPurpose`, `toProposingPurpose`, `fromVotingPurpose`, - `fromProposingPurpose`. -* Add upgrade failure: `CTBUEContainsDuplicateCerts` -* Rename `proposalsRemoveDescendentIds` to `proposalsRemoveWithDescendants` (fixed spelling too) -* Rename: - * `pfPParamUpdateL` to `grPParamUpdateL` - * `pfHardForkL` to `grHardForkL` - * `pfCommitteeL` to `grCommitteeL` - * `pfConstitutionL` to `grConstitutionL` -* Rename: - * `cgProposalsL` to `cgsProposalsL` - * `cgEnactStateL` to `cgsEnactStateL` - * `cgDRepPulsingStateL` to `cgsDRepPulsingStateL` -* Add: - * `cgsPrevPParamsL` - * `cgsCommitteeL` - * `cgsConstitutionL` - * `govStatePrevGovActionIds` - * `mkEnactState` -* Deprecated `curPParamsConwayGovStateL` and `curPParamsConwayGovStateL` -* Rename `PForest` to `GovRelation` -* Add `hoistGovRelation` and `withGovActionParent` -* Add `TreeMaybe`, `toGovRelationTree` and `toGovRelationTreeEither` -* Remove `proposalsAreConsistent` -* Remove `registerDelegs` and `registerInitialDReps` -* Modify `PParams` JSON instances to match `cardano-api` - -### `testlib` - -* Add `ToExpr` instances for: - * `ConwayNewEpochEvent` - * `ConwayEpochEvent` - * `ConwayLedgerEvent` - * `ConwayCertsEvent` - * `ConwayCertEvent` - * `ConwayGovEvent` -* Change the types of some functions in `Test.Cardano.Ledger.Conway.ImpTest` - to use `NonEmpty (PredicateFailure _)` instead of `[PredicateFailure _]` - - `submitFailingVote` - - `trySubmitVote` - - `trySubmitProposal` - - `trySubmitProposals` - - `submitFailingProposal` - - `trySubmitGovAction` - - `trySubmitGovActions` -* Add `Test.Cardano.Ledger.Conway.Imp.GovCertSpec` -* Add `RuleListEra` instance for Conway -* Rename `canGovActionBeDRepAccepted` to `isDRepAccepted` and refactor #4097 - * Add `isSPOAccepted` - * Change `setupSingleDRep` to return relevant keyhashes - * Change `setupPoolWithStake` to return relevant keyhashes - * Add `getLastEnactedCommittee` - * Add `getRatifyEnvAndState` -* Add `Test.Cardano.Ledger.Conway.Imp.UtxosSpec` -* Add `getGovPolicy` -* Add `submitGovActions` and `trySubmitGovActions` -* Add `submitProposals` and `trySubmitProposal` - -## 1.12.0.0 - -* Changed the types in `GovernanceActionsDoNotExist`, `DisallowedVoters` - and `VotingOnExpiredGovAction` to `NonEmpty` -* Add `cgDelegsL` -* Add `FromJSON`, `EncCBOR` and `DecCBOR` instances for `Delegatee` -* Add `pvtPPSecurityGroup` -* Add lenses: - * `pvtCommitteeNormalL` - * `pvtCommitteeNoConfidenceL` - * `pvtPPSecurityGroupL` - * `dvtCommitteeNoConfidenceL` -* Add `PPGroups` and `StakePoolGroup` -* Add `ToStakePoolGroup` typeclass -* Add `DRepGroup` and `ToDRepGroup` typeclass -* Modify `THKD` replacing `PPGroup` with `PPGroups` -* Add `ConwayPlutusPurpose` -* Add `unGovActionIx` -* Add `foldlVotingProcedures` -* Add a policy field to `ParameterChange` and `TreasuryWithdrawals` constructors - of `GovAction` -* Add `InvalidPolicyHash` to `ConwayGovPredFailure` -* Add `ToJSON` instance for `ConwayContextError`, `ConwayTxCert`, `ConwayDelegCert`, - `Delegatee` and `ConwayGovCert` -* Add `forceDRepPulsingState` -* Add `registerInitialDReps` and `registerDelegs` -* Add `cgDelegs`, `cgInitialDReps` to `ConwayGenesis` -* Changed the type of lenses ppCommitteeMaxTermLengthL, ppuCommitteeMaxTermLengthL -* Change 'getScriptWitnessConwayTxCert' so that DRepRegistration certificate requires a witness -* Implement `ToJSON` and `FromJSON` instances for `PoolVotingThresholds` and - `DRepVotingThreshold`, instead of deriving that doesn't handle field names - correctly. -* Hide `Cardano.Ledger.Conway.TxOut` module -* Export `ConwayEraPParams` and `ConwayEraTxBody` from `Cardano.Ledger.Conway.Core` -* Stop exporting `BabbagePParams` from `Cardano.Ledger.Conway.PParams` -* Add `transTxBodyWithdrawals`, `transTxCert`, `transDRepCred`, `transColdCommitteeCred`, - `transHotCommitteeCred`, `transDelegatee`, `transDRep`, `transScriptPurpose` -* Remove `conwayTxInfo` and `babbageScriptPrefixTag` -* Remove deprcated `translateScript` -* Add `getVoteDelegatee` -* Track and prune unreachable proposals #3855 #3919 #3978 #3981 - * Consolidate the entire proposals-tree under the `Proposals` module and expose all its operations in a convenient manner - * Move `PrevGovActionIds` from `Governance` to `Governance.Proposals` - * Add `rsEnacted` field to `RatifyState` to track enacted proposals separately from removed ones and rename `rsRemoved` to `rsExpired` in order to better represent its role - * Add `ProposalsSerializable` as an accompanying type used to correctly serialize `Proposals` in a space-efficient way - * Add the following operations to `Governance.Proposals` - * `mkProposals` as the only way to reconstruct the `Proposals` tree from, for instance, a deserialized one - * `proposalsAddAction` as the only way to add new proposals to the system - * `proposalsApplyEnactment` as the only way to replay from `ENACT` operations upon `Proposals` in the ledger state, outside of the pulser. - * Rename `PrevGovActionId purpose (EraCrypto era)` to `GovPurposeId purpose era` - * Add the following accessors and lenses, among others: - * `PForest` - * `PRoot` - * `PEdges` - * `PHierarchy` - * `pRootsL` - * `prRootL` - * `prChildrenL` - * `pnChildrenL` - * `pHierarchyL` - * `pHierarchyNodesL` - * `pfPParamUpdateL` - * `pfHardForkL` - * `pfCommitteeL` - * `pfConstitutionL` - * Add the pruning functionality and the deposit refunds in the `EPOCH` rule - * In the `Gov` rule - * Modify the rule transition implementation to accept new proposals into the `Proposals` forests based on proposal purpose - * In the `Ratify` rule - * Account for the tracking of enacted and expired proposals -* Moved `ToExpr` instances out of the main library and into the testlib. -* Changed the type of ConwayPParam's fields cppEMax, cppGovActionLifetime, cppDRepActivity -* Changed types of lenses: `ppGovActionLifetimeL`, `ppDRepActivityL`, `ppCommitteeMaxTermLengthL` and `ppuGovActionLifetimeL`, `ppuDRepActivityL`, `ppuCommitteeMaxTermLengthL` -* Implement `getNextEpochCommitteeMembers` in Conway `EraGov` -* Change argument of `validCommitteeTerm` function from `StrictMaybe Committee` to `GovAction` - -### `testlib` - -* Add the previous governance action ID to the outputs of `electBasicCommittee` -* Add `setupPoolWithStake` -* Add: - * `registerPool` - * `sendCoinTo` and `sendValueTo` -* Add `submitProposal_` -* Add `submitTreasuryWithdrawals` -* Track and prune unreachable proposals #3855 #3919 #3978 #3981 - * Add invariant-respecting `Arbitrary` generators for `Proposals` - * Add property tests for all `Proposals` operations - * Add procedural unit tests for all `Proposals` operations -* Remove `Test.Cardano.Ledger.Conway.PParamsSpec` and replace the unit test it contained - with a new property test in `Test.Cardano.Ledger.Alonzo.Binary.CostModelsSpec` - -## 1.11.0.0 - -* Switch `ppCommitteeMaxTermLength` to `EpochNo`, rather than `Natural` -* Add `conwayTotalDepositsTxBody` and `conwayProposalsDeposits` -* Add `conwayDRepDepositsTxCerts`, `conwayDRepRefundsTxCerts`, - `conwayTotalDepositsTxCerts` and `conwayTotalRefundsTxCerts` -* Rename data-type `ProposalsSnapshot` to `Proposals`. #3859 - * Rename module `Governance.Snapshots` to `Governance.Proposals`. - * Rename all the functions related to the data-type. -* Switch to using `OMap` for `ProposalsSnapshot` #3791 -* Add `VotingOnExpiredGovAction` predicate failure in `GOV` #3825 -* Rename `modifiedGroups` -> `modifiedPPGroups` and move into `ConwayEraPParams` -* Expose `pparamsUpdateThreshold` -* Fix [#3835](https://github.com/intersectmbo/cardano-ledger/issues/3835) -* Rename `PParamGroup` to `PPGroup` and `GovernanceGroup` to `GovGroup` -* Introduce `THKD` and use it for `ConwayPParams` -* Add `data ConwayGovEvent era` with constructor `GovNewProposals !(TxId (EraCrypto era)) !(ProposalsSnapshot era)`. #3856 -* Add `EpochBoundaryRatifyState (RatifyState era)` inhabitant to the `ConwayEpochEvent era` data type. - -### `testlib` - -* Provide CDDL spec files with `readConwayCddlFileNames` and `readConwayCddlFiles` from - `Test.Cardano.Ledger.Conway.Binary.Cddl` - -## 1.10.0.0 - -* Add `ToJSON` instance for `ProposalProcedure` -* Fix `NewEpochState` translation: #3801 -* Change order of arguments for `committeeAccepted` adn `spoAccepted` for consistency #3801 -* Add `spoAcceptedRatio` #3801 -* Export `snapshotGovActionStates` #3801 -* Change type for `snapshotRemoveIds` to also return the removed actions. #3801 -* Add `reDRepDistrL` #3759 -* Remove `GovSnapshots` #3759 -* Move `DRepPulser` from `cardano-ledger-core`. #3759 -* Add `DRepPulsingState` #3759: `pulseDRepPulsingState`, `completeDRepPulsingState`, - `extractDRepPulsingState`, `finishDRepPulser`, `computeDrepDistr`, `getRatifyState`, - `getPulsingStateDRepDistr`, `dormantEpoch`, `setFreshDRepPulsingState`, - `setCompleteDRepPulsingState` -* Add `PulsingSnapshot` and `psProposalsL`, `psDRepDistrL`, `psDRepStateL` #3759 -* Add `RunConwayRatify` class #3759 -* Enforce no duplicates from `certsTxBodyL` and `proposalProceduresTxBodyL` #3779 -* Remove `WrongCertificateTypeDELEG` predicate failure. -* Add `getDelegateeTxCert` and `getStakePoolDelegatee` -* Add `enactStateGovStateL` to `ConwayEraGov` -* Add `psDRepDistrG`. -* Rename `ensPParams` to `ensCurPParams`. -* Add `ToJSON` instance for `RatifyState` -* Change `ToJSON` instance for `ConwayGovState`: - * Add `"nextRatifyState"` field - * Rename `"ratify"` to `"enactState"` - * Rename `"gov"` to `"proposals"` -* Fix `ToJSON` instance for `EnactState`: - * Current PParams were wrongfully used for `"prevPParams"`. - * Remove `"treasury"` and `"withdrawals"` as those are temporary bindings needed only - for `ENACT` rule -* Add an anchor argument to `ResignCommitteeColdTxCert` -* Prevent invalid previous gov-action ids in proposals #3768 - * Also, add lenses - * `govProceduresProposalsL` - * `pProcGovActionL` - * `gasActionL` -* Add `ToExpr` instance for: - * `Voter` - * `ConwayCertPredFailure` - * `ConwayCertsPredFailure` - * `ConwayDelegPredFailure` - * `ConwayGovPredFailure` - * `ConwayGovCertPredFailure` - * `ConwayLedgerPredFailure` - * `ConwayTxBody` -* Add `Generic` and `NFData` instance for: - * `ConwayNewEpochPredFailure` -* Add `totalObligation` -* Add `utxosDepositedL` -* Add `conwayWitsVKeyNeeded` -* Add `ConwayEraPParams era` constraint to `isCommitteeVotingAllowed` and `votingCommitteeThreshold` -* Switch to using `AlonzoEraUTxO` in rules -* Change `cppProtocolVersion` to a `HKDNoUpdate` field - -### `testlib` - -* Addition of `ImpTest` interface - -## 1.9.0.0 - -* Add `ConwayEraPParams era` constraint to `isCommitteeVotingAllowed` and `votingCommitteeThreshold` -* Add `ToExpr` instance for: - * `Voter` - * `VotingProcedures` - * `VotingProcedure` - * `ProposalProcedure` - * `ConwayTxBody` -* Add `ConwayTxBodyUpgradeError`, `ConwayTxCertUpgradeError` -* Add to `Ratify`: - * `committeeAccepted` - * `committeeAcceptedRatio` -* Add `reCommitteeState` to `RatifyEnv` -* Add PredicateFailure for current treasury value mismatch in tx body in LEDGER #3749 -* Change `To/FromJSON` format for `ConwayGenesis` -* Add `EraTransition` instance and `toConwayTransitionConfigPairs`. -* Expose `toConwayGenesisPairs` and `toUpgradeConwayPParamsUpdatePairs` -* Rename `ConwayPParams` to be consistent with the Agda specification. #3739 - * `govActionExpiration` to `govActionLifetime` - * `committeeTermLimit` to `committeeMaxTermLength` - * `minCommitteeSize` to `committeeMinSize` -* Prevent `DRep` expiry when there are no active governance proposals to vote on (in - ConwayCERTS). #3729 - * Add `updateNumDormantEpochs` function in `ConwayEPOCH` to update the dormant-epochs counter - * Refactor access to `ConwayGovState` by making its lens part of `ConwayEraGov`. - * Export `gasExpiresAfterL` for use in tests -* Add `ExpirationEpochTooSmall` data constructor to `ConwayGovPredFailure` -* Add `ConflictingCommitteeUpdate` data constructor to `ConwayGovPredFailure` -* Rename `NewCommitte` to `UpdateCommittee` -* Remove `NewCommitteeSizeTooSmall` data constructor from `ConwayGovPredFailure` -* Fix invalid order in `fromGovActionStateSeq`, thus also `DecCBOR` for `ProposalsSnapshot` -* Remove `DecCBOR`/`EncCBOR` and `FromCBOR`/`ToCBOR` for `RatifyState`, since that state - is ephemeral and is never serialized. -* Add `PredicateFailure` for `Voter` - `GovAction` mismatches, with `checkVotesAreValid`. #3718 - * Add `DisallowedVoters (Map (GovActionId (EraCrypto era)) (Voter (EraCrypto era)))` - inhabitant to the `ConwayGovPredFailure` data type. - * Fix naming for `toPrevGovActionIdsParis` to `toPrevGovActionIdsPairs` -* Rename: - * `thresholdSPO` -> `votingStakePoolThreshold` - * `thresholdDRep` -> `votingDRepThreshold` - * `thresholdCC` -> `votingCommitteeThreshold` -* Add: - * `isStakePoolVotingAllowed` - * `isDRepVotingAllowed` - * `isCommitteeVotingAllowed` -* Fix `ConwayTxBodyRaw` decoder to disallow empty `Field`s #3712 - * `certsTxBodyL` - * `withdrawalsTxBodyL` - * `mintTxBodyL` - * `collateralInputsTxBodyL` - * `reqSignerHashesTxBodyL` - * `referenceInputsTxBodyL` - * `votingProceduresTxBodyL` - * `proposalProceduresTxBodyL` -* Add `reorderActions`, `actionPriority` -* Remove `ensProtVer` field from `EnactState`: #3705 -* Move `ConwayEraTxBody` to `Cardano.Ledger.Conway.TxBody` -* Move `ConwayEraPParams` to `Cardano.Ledger.Conway.PParams` -* Rename: - * `GovActionsState` to `GovSnapshots` - * `cgGovActionsStateL` to `cgGovSnapshotsL` - * `curGovActionsStateL` to `curGovSnapshotsL` - * `prevGovActionsStateL` to `prevGovSnapshotsL` -* Add: - * `ProposalsSnapshot` - * `snapshotIds` - * `snapshotAddVote` - * `snapshotInsertGovAction` - * `snapshotActions` - * `snapshotRemoveIds` - * `fromGovActionStateSeq` -* Add lenses: - * `gasCommitteeVotesL` - * `gasDRepVotesL` - * `gasStakePoolVotesL` -* Add `FromJSON` instance for `Committee` -* Add `constitution` and `committee` fields to `ConwayGenesis` - -### testlib - -* Add `Test.Cardano.Ledger.Conway.ImpTest` -* Rename `genNewCommittee` to `genUpdateCommitteee` -* Add `genNewCommittee` -* Add `genNoConfidence` -* Add `genTreasuryWithdrawals` -* Add `genHardForkInitiation` -* Add `genParameterChange` -* Add `genNewConstitution` -* Add `genGovActionStateFromAction` -* Add `govActionGenerators` - -## 1.8.1.0 - -* Apply enacted `TreasuryWithdrawals` in `ConwayEPOCH` #3748 - * Add lenses `ensWithdrawalsL` and `ensTreasuryL` - -## 1.8.0.0 - -* Add all Conway `TxCert` to consumed/produced calculations in the `UTXO` rule. #3700 -* Change `ToJSONKey` implementation of `Voter` to flat text -* Add DRep refund calculation #3688 - * Add `conwayConsumedValue` as `getConsumedValue` for Conway -* Change `PredicateFailure (ConwayENACT era)` to `Void` -* Remove `EnactPredFailure` -* Change `PredicateFailure (ConwayEPOCH era)` to `Void` -* Remove `ConwayEpochPredFailure` -* Remove `EpochFailure` and `RatifyFailure` from `ConwayNewEpochPredFailure` -* Change `PredicateFailure (ConwayRATIFY era)` to `Void` -* Add: - * `rsDelayed` - * `PParamGroup` - * `ParamGrouper` - * `pGroup` - * `pUngrouped` - * `modifiedGroups` - * `dvtPPNetworkGroupL` - * `dvtPPGovGroupL` - * `dvtPPTechnicalGroupL` - * `dvtPPEconomicGroupL` - * `threshold` - * `ensCommitteeL` -* Add `pparamsGroups` to `ConwayEraPParams` -* Add `PrevGovActionIds` -* Change `EnactState` to add `ensPrevGovActionIds` -* Add `ensPrevGovActionIdsL`, `ensPrevPParamUpdateL`, `ensPrevHardForkL` `ensPrevCommitteeL`, `ensPrevConstitutionL` -* Add `EnactSignal` and the signal of `Enact` to it -* Remove `rsFuture` from `RatifyState` -* Add to `GovActionsState`: - * `curGovActionsState` - * `prevGovActionsState` - * `prevDRepState` - * `prevCommitteeState` -* Add `ToExpr` instances to: - * `PoolVotingThresholds` - * `DRepVotingThresholds` - * `GovActionState` - * `GovActionsState` - * `EnactState` - * `RatifyState` - * `ConwayGovState` - * `GovActionIx` - * `GovActionId` - * `Vote` - * `Committee` - * `PrevGovActionId` - * `GovAction` - * `ConwayPParams` with `Identity` and `StrictMaybe` -* Add lenses: - * `cgEnactStateL` - * `curGovActionsStateL` - * `prevGovActionsStateL` - * `prevDRepStateL` - * `prevCommitteeStateL` -* Replace `cgRatifyState` with `cgEnactState` -* Deprecate `cgRatifyStateL` -* Add `ProposalDepositIncorrect` predicate failure, that is produced when `ProposalProcedure` deposit does not match `"govActionDeposit"` from `PParams` #3669 -* Add "minCommitteeSize" `PParam` validation for `NewCommittee` `GovAction` #3668 - * Add `committeeMembersL` and `committeeQuorumL` lenses for `Committee` - * Add `NewCommitteeSizeTooSmall` `PredicateFailure` in `GOV` -* Add `EqRaw` instance for `ConwayTxBody` -* Add `ToExpr` instance for `Delegatee`, `ConwayDelegCert`, `ConwayGovCert` and - `ConwayTxCert` -* Implement expiry for governance proposals #3664 - * Update `ppGovActionExpiration` to be an `EpochNo` - * Add `gasExpiresAfter :: !EpochNo` to `GovActionState` - * Add `gePParams` to `GovEnv` - * Rename `teTxId` to `geTxId` and `teEpoch` to `geEpoch` -* Add `reDRepState` to `RatifyEnv` -* Add field `gasId` to `GovActionState` -* Add `insertGovActionsState` -* Change type of `rsRemoved` in `RatifyState` to use `GovActionState` instead of a tuple -* Change `RatifySignal` to use `GovActionsState` instead of a tuple - -## 1.7.1.0 - -* Fix DRep distribution computation. - -## 1.7.0.0 - -* Add `Network` validation for `ProposalProcedure` and `TreasuryWithdrawals` in GOV #3659 -* Make `DELEG`, `POOL` and `GOVCERT` conform to spec-v0.8 #3628 - * Add `CertEnv` and `CertsEnv` to pass `EpochNo` down from `LEDGER` to sub-rules - * Add `drepDeposit` to `DRepState` to track deposits paid by `DRep`s - * Update `DRep` expiry in `LEDGER` for all `DRep`s who are voting in current `Tx` -* Add `ConwayGovCertEnv` -* Change the environment of `GOVCERT` to `ConwayGovCertEnv` -* Add `ConwayEraGov` with `constitutionGovStateL` -* Add `PrevGovActionId` and `GovActionPurpose` -* Add optional `PrevGovActionId` to `ParameterChange`, `HardForkInitiation`, - `NoConfidence`, `NewCommittee` and `NewConstitution` governance actions. -* Rename `*governance*` to `*gov*` #3607 - * `GovernanceAction` to `GovAction` - * `GovernanceActionId` to `GovActionId` - * `GovernanceActionIx` to `GovActionIx` - * `GovernanceActionState` to `GovActionState` - * `ConwayGovState` to `GovActionsState` - * `ConwayGovernance` to `ConwayGovState` -* Add `MalformedProposal` to `ConwayGovPredFailure` -* Add `ppuWellFormed` to `ConwayEraPParams` -* Filter out zero valued `TxOut`'s on Byron/Shelley boundary instead of on Babbage/Conway. -* Deprecate `translateTxOut` in favor of `upgradeTxOut` -* Deprecate `translateScript` in favor of `upgradeScript` -* Switch GovernanceActionIx to `Word32` fro `Word64` and remove `Num` and `Enum` - instances, which are dangerous due to potential overflows. -* Add `currentTreasuryValue :: !(StrictMaybe Coin)` as a new field to Conway TxBody #3586 -* Add an optional Anchor to the Conway DRep registration certificate #3576 -* Change `ConwayCommitteeCert` to allow: - * committee cold keys to be script-hashes #3581 - * committee hot keys to be script-hashes #3552 -* Change EnactState.ensConstitution #3556 - * from `SafeHash (EraCrypto era) ByteString` - * to `Constitution era` - * Use this datatype for GovernanceAction.NewConstitution -* Add `ConwayPParams` #3498 - * Add `UpgradeConwayPParams` - * Add `ConwayEraPParams` - * Add `PoolVotingThresholds` - * Add `DRepVotingThresholds` -* Rename: - * `cgTally` -> `cgGovActionsState` - * `cgTallyL` -> `cgGovActionsStateL` - * `VDelFailure` -> `GovCertFailure` - * `VDelEvent` -> `GovCertEvent` - * `certVState` -> `certGState` - * `ConwayVDelPredFailure` -> `ConwayGovCertPredFailure` - * `ConwayTallyPredFailure` -> `ConwayGovPredFailure` - * `TallyEnv` -> `GovEnv` - * `ConwayTallyState` -> `ConwayGovState` - * `TALLY` -> `GOV` - * `VDEL` -> `GOVCERT` -* Make `Anchor` required in `ProposalProcedure`. -* Add `ConwayUTXO` -* Add `indexedGovProps` -* Add `rsRemoved` to `RatifyState` -* Add `conwayProducedValue` -* Changed the superclasses of `STS (ConwayUTXOS era)` -* Add `VotingProcedures` type -* Remove `vProcGovActionId` and `vProcVoter` from `VotingProcedure` -* Change the type of `votingProceduresL` to return `VotingProcedures`, which is a nested Map - instead of a sequence, as before. -* Change `GovernanceActionDoesNotExist` to `GovernanceActionsDoNotExist`, which now - reports all actions as a set, rather than one action per each individual failure. -* Type of `gpVotingProcedures` in `GovernanceProcedures` was aslo changed to `GovernanceProcedures` -* Rename: - * `ConwayCommitteeCert` -> `ConwayGovCert` - * `ConwayTxCertCommittee` -> `ConwayTxCertGov` -* Remove `DelegStakeTxCert` from the `COMPLETE` pragma for `TxCert` -* Add `Committee` and adjust `NewCommittee` governance action -* Add `treasuryDonationTxBodyL` to `ConwayEraTxBody` -* Add `ConwayUpdateDRep` constructor to `ConwayGovCert` type and corresponding pattern `UnRegDRepTxCert` -* Update `ProposalProcedure` return address to be a `RewardAcnt` -* Add `ensPrevPParams` field to `EnactState` -* Add lenses: - * `ensPrevPParamsL` - * `ensCurPParamsL` - -## 1.6.3.0 - -* Implement stake distribution handling in the `TICKF` rule. - -## 1.6.2.0 - -* Add implementation for `spendableInputsTxBodyL` - -## 1.6.1.0 - -* Removal of TxOuts with zero `Coin` from UTxO on translation - -## 1.6.0.0 - -* Removal of `GovernanceProcedure` in favor of `GovernanceProcedures` - -## 1.5.0.0 - -* Add `ensConstitutionL` and `rsEnactStateL` to `Governance` #3506 - * Override `getConsitutionHash` for Conway to return just the hash of the constitution -* Added `ConwayWdrlNotDelegatedToDRep` to `ConwayLedgerPredFailure` -* Changed the type of voting delegatee from `Credential` to `DRep` -* Removal of `VoterRole` in favor of `Voter` -* Removal of `vProcRole` and `vProcRoleKeyHash` in favor of `vProcVoter` in `VotingProcedure` -* Removal of `cgVoterRolesL` and `cgVoterRoles` for `ConwayGovernance` as no longer needed. -* Removal of `gasVotes` in favor of `gasCommitteeVotes`, `gasDRepVotes` and - `gasStakePoolVotes` in `GovernanceActionState` -* Removal of `reRoles` from `RatifyEnv` as no longer needed -* Addition of `reStakePoolDistr` to `RatifyEnv` -* Remove `VoterDoesNotHaveRole` as no longer needed from `ConwayTallyPredFailure` -* Added `ConwayEpochPredFailure` -* Added instance for `Embed (ConwayRATIFY era) (ConwayEPOCH era)` -* Removed instance for `Embed (ConwayRATIFY era) (ConwayNEWEPOCH era)` -* Changed superclasses of `STS (ConwayEPOCH era)` and `STS (ConwayNEWEPOCH era)` - -## 1.4.0.0 - -* Added `ConwayUTXOW` rule - -### `testlib` - -* Add `Arbitrary` instances for `ConwayCertPredFailure`, `ConwayVDelPredFailure`, and `ConwayDelegPredFailure` - -## 1.3.0.0 - -* Add `VDEL` rules to Conway #3467 -* Add `EncCBOR`/`DecCBOR` for `ConwayCertPredFailure` -* Add `EncCBOR`/`DecCBOR` for `ConwayVDelPredFailure` -* Add `POOL` rules to Conway #3464 - * Make `ShelleyPOOL` rules reusable in Conway -* Add `CERT` and `DELEG` rules to Conway #3412 - * Add `domDeleteAll` to `UMap`. -* Introduction of `TxCert` and `EraTxCert` -* Add `ConwayEraTxCert` -* Add `EraTxCert`, `ShelleyEraTxCert` and `ConwayEraTxCert` instances for `ConwayEra` -* Add `EraPlutusContext 'PlutusV1` instance to `ConwayEra` -* Add `EraPlutusContext 'PlutusV2` instance to `ConwayEra` -* Add `EraPlutusContext 'PlutusV3` instance to `ConwayEra` -* Added `toShelleyDelegCert` and `fromShelleyDelegCert` -* Changed `ConwayDelegCert` structure #3408 -* Addition of `getScriptWitnessConwayTxCert` and `getVKeyWitnessConwayTxCert` -* Add `ConwayCommitteeCert` - -## 1.2.0.0 - -* Added `ConwayDelegCert` and `Delegatee` #3372 -* Removed `toShelleyDCert` and `fromShelleyDCertMaybe` #3372 -* Replace `DPState c` with `CertState era` -* Add `TranslateEra` instances for: - * `DState` - * `PState` - * `VState` -* Add `ConwayDelegsPredFailure` -* Renamed `DELPL` to `CERT` -* Added `ConwayDELEGS` rule -* Added `ConwayCERT` rule -* Added `ConwayDelegsPredFailure` rule -* Added `ConwayDelegsEvent` rule -* Change the Conway txInfo to allow Plutus V3 - NOTE - unlike V1 and V2, the ledger will no longer place the "zero ada" value - in the script context for the transaction minting field. -* Added instances for ConwayDelegsPredFailure: - `NoThunks`, `EncCBOR`, `DecCBOR`, and `Arbitrary` -* Added `GovernanceActionMetadata` -* Added `RatifyEnv` and `RatifySignal` - -## 1.1.0.0 - -* Added `RATIFY` rule -* Added `ConwayGovernance` -* Added lenses: - * `cgTallyL` - * `cgRatifyL` - * `cgVoterRolesL` -* Removed `GovernanceActionInfo` -* Replaced `ctbrVotes` and `ctbrGovActions` with `ctbrGovProcedure` -* Renamed `ENACTMENT` to `ENACT` -* Add `ToJSON` instance for: #3323 - * `ConwayGovernance` - * `ConwayTallyState` - * `GovernanceAction` - * `GovernanceActionState` - * `GovernanceActionIx` - * `GovernanceActionId` -* Add `ToJSONKey` instance for `GovernanceActionId` #3323 -* Fix `EncCBOR`/`DecCBOR` and `ToCBOR`/`FromCBOR` for `ConwayTallyState` #3323 -* Add `Anchor` and `AnchorDataHash` types. #3323 -* Rename `transDCert` to `toShelleyDCert` -* Add `fromShelleyDCertMaybe` -* Renamed `Vote` type to `VotingProcedure` -* Add `ProposalProcedure` -* Use `VotingProcedure` and `ProposalProcedure` in `GovernanceProcedure` -* Rename `VoteDecision` to `Vote`. Rename `No`/`Yes` -> `VoteNo`/`VoteYes`. -* Export `govActionIdToText` -* Export constructors for `ConwayTallyPredFailure` -* Add `ensTreasury` and `ensWithdrawals` to `EnactState` #3339 -* Add `EnactPredFailure` as the failure for `ENACT` and `RATIFY` #3339 -* Add `RatifyFailure` to `ConwayNewEpochPredFailure` #3339 -* Add `EncCBOR`/`DecCBOR` and `ToCBOR`/`FromCBOR` for `ConwayTallyPredFailure` -* Add `ToCBOR`/`FromCBOR` for `ConwayGovernance` -* Remove `cgAlonzoGenesis` from `ConwayGenesis`. -* Set `ConwayGenesis` as `TranslationContext` - -### `testlib` - -* Fix `Arbitrary` for `ConwayTallyState`. #3323 -* Consolidate all `Arbitrary` instances from the test package to under a new `testlib`. #3285 -* Add `Arbitrary` instances for: - * `ConwayTallyPredFailure` - * `EnactState` - * `RatifyState` - * `ConwayGovernance` -* Fix `Arbitrary` for `ConwayTxBody`. - -## 1.0.0.0 - -* First properly versioned release. +* Babel fees prototype. diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/FRxO.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/FRxO.hs index 661832b00e7..3ab26462fe3 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/FRxO.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/FRxO.hs @@ -20,7 +20,6 @@ module Cardano.Ledger.Babel.FRxO where import Cardano.Ledger.Babel.TxBody ( BabelEraTxBody (fulfillsTxBodyL, requestsTxBodyL, requiredTxsTxBodyL), ) -import Cardano.Ledger.Binary (sizedValue) import Cardano.Ledger.Core ( Era (EraCrypto), EraTxBody (TxBody), @@ -49,14 +48,14 @@ txfrxo txBody = [ (TxIn transId idx, out) | (out, idx) <- zip - (toList $ fmap sizedValue $ txBody ^. requestsTxBodyL) + (toList $ txBody ^. requestsTxBodyL) [minBound ..] ] where transId = txIdTxBody txBody txrequests :: BabelEraTxBody era => TxBody era -> SSeq.StrictSeq (TxOut era) -txrequests = fmap sizedValue . (^. requestsTxBodyL) +txrequests = (^. requestsTxBodyL) txrequired :: BabelEraTxBody era => TxBody era -> Set (TxIn (EraCrypto era)) txrequired = (^. requiredTxsTxBodyL) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs index cc014ccfc68..5d845f7114c 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/LedgerState/Types.hs @@ -37,8 +37,6 @@ import GHC.Generics (Generic) import Lens.Micro (lens, (&), (.~), (^.)) import Lens.Micro.Type (Lens') --- type instance Ledger (ConwayEra c) = LedgerStateTemp (ConwayEra c) - {- CIP-0118#ledger-state-temp This type represents a transient state, existing within the LEDGERS rule, and @@ -46,7 +44,7 @@ manipulated by the UTXOS rule (jump to CIP-0118#UTXOS-rule to see how). To see how we've made `ApplyBlock` compatible with our new `State (EraRule "LEDGERS" era) ~ LedgerStateTemp era` requirement for Babel, -jump to CIP-0118#0-apply-block. +jump to CIP-0118#apply-block-1. Jump to ??? to continue... -} diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs index 0d5bf8603fe..ad28e0abe92 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs @@ -125,7 +125,6 @@ data BabelUtxosEvent era -- | FRxO created (FRxO era) deriving (Generic) - deriving (Generic) deriving instance (Era era, Eq (TxOut era)) => Eq (BabelUtxosEvent era) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs index 49952d238ec..b7fe2a416ef 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs @@ -46,8 +46,6 @@ import Cardano.Ledger.AuxiliaryData (AuxiliaryDataHash) import Cardano.Ledger.Babbage.Rules ( BabbageUtxoPredFailure, BabbageUtxowPredFailure, - -- babbageUtxowTransition, - babbageMissingScripts, validateFailedBabbageScripts, validateScriptsWellFormed, @@ -58,9 +56,6 @@ import qualified Cardano.Ledger.Babbage.Rules as Babbage ( import Cardano.Ledger.Babbage.UTxO (getReferenceScripts) import Cardano.Ledger.Babel.Core import Cardano.Ledger.Babel.Era (BabelEra, BabelUTXO, BabelUTXOW) - --- verifyBootstrapWitRequiredTxs, - import Cardano.Ledger.Babel.LedgerState.Types (UTxOStateTemp (..)) import Cardano.Ledger.Babel.Rules.Utxo (BabelUtxoPredFailure) import Cardano.Ledger.Babel.Rules.Utxos (BabelUtxosPredFailure) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Tx.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Tx.hs index 2e83c11dc46..cad00bfe642 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Tx.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Tx.hs @@ -137,9 +137,6 @@ instance Crypto c => AlonzoEraTx (BabelEra c) where isValidTxL = isValidAlonzoTxL {-# INLINE isValidTxL #-} --- instance Crypto c => Core.EraRequiredTxsData (BabelEra c) where --- type RequiredTxs (BabelEra c) = ShelleyRequiredTx (BabelEra c) - instance Crypto c => Core.EraSegWits (BabelEra c) where type TxStructure (BabelEra c) = Compose StrictSeq StrictSeq type TxZones (BabelEra c) = BabelTxZones (BabelEra c) @@ -149,17 +146,6 @@ instance Crypto c => Core.EraSegWits (BabelEra c) where hashTxZones = hashBabelTxZones numSegComponents = 4 --- hashAlonzoTxSeq :: forall era. --- Era era => --- AlonzoTxSeq era -> Hash (EraCrypto era) EraIndependentBlockBody --- Defined at /home/will/git/cardano-ledger/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxSeq.hs:177:1 - --- _ :: TxZones (AlonzoEra c) --- -> Hash (HASH (EraCrypto (AlonzoEra c))) EraIndependentBlockBody --- _ :: forall era. --- Era era => --- AlonzoTxSeq era -> Hash (EraCrypto era) EraIndependentBlockBody - -------------------------------------------------------------------------------- -- Serialisation and hashing -------------------------------------------------------------------------------- diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/TxBody.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/TxBody.hs index f8ce4d7fc69..3c2ec766965 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/TxBody.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/TxBody.hs @@ -161,7 +161,7 @@ data BabelTxBodyRaw era = BabelTxBodyRaw , bbtbrTreasuryDonation :: !Coin , -- Tx body fields for intents (babel-fees) - {- CIP-0118#0-tx-body + {- CIP-0118#tx-body-0 Here, we demonstrate the three (or two...I'll explain shortly) new fields required for Babel fees. @@ -571,8 +571,13 @@ instance Crypto c => ConwayEraTxBody (BabelEra c) where instance (Crypto c, ConwayEraTxBody (BabelEra c)) => BabelEraTxBody (BabelEra c) where fulfillsTxBodyL = lensMemoRawType bbtbrFulfills (\txb x -> txb {bbtbrFulfills = x}) {-# INLINE fulfillsTxBodyL #-} - requestsTxBodyL = lensMemoRawType bbtbrRequests (\txb x -> txb {bbtbrRequests = x}) + + requestsTxBodyL = + lensMemoRawType + (fmap sizedValue . bbtbrRequests) + (\txb x -> txb {bbtbrRequests = mkSized (eraProtVerLow @(BabelEra c)) <$> x}) {-# INLINE requestsTxBodyL #-} + requiredTxsTxBodyL = lensMemoRawType bbtbrRequiredTxs (\txb x -> txb {bbtbrRequiredTxs = x}) {-# INLINE requiredTxsTxBodyL #-} @@ -756,7 +761,7 @@ class where fulfillsTxBodyL :: Lens' (TxBody era) (Set (Fulfill (EraCrypto era))) - requestsTxBodyL :: Lens' (TxBody era) (StrictSeq (Sized (TxOut era))) + requestsTxBodyL :: Lens' (TxBody era) (StrictSeq (TxOut era)) requiredTxsTxBodyL :: Lens' (TxBody era) (Set (TxIn (EraCrypto era))) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/TxCert.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/TxCert.hs index 64ee54793a7..abeb000441b 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/TxCert.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/TxCert.hs @@ -388,182 +388,6 @@ instance Crypto c => ToJSON (BabelGovCert c) where , "anchor" .= toJSON anchor ] --- data BabelTxCert era --- = BabelTxCertDeleg !(BabelDelegCert (EraCrypto era)) --- | BabelTxCertPool !(PoolCert (EraCrypto era)) --- | BabelTxCertGov !(BabelGovCert (EraCrypto era)) --- deriving (Show, Generic, Eq, Ord) - --- instance Crypto (EraCrypto era) => NFData (BabelTxCert era) - --- instance NoThunks (BabelTxCert era) - --- instance Era era => ToJSON (BabelTxCert era) where --- toJSON = \case --- BabelTxCertDeleg delegCert -> toJSON delegCert --- BabelTxCertPool poolCert -> toJSON poolCert --- BabelTxCertGov govCert -> toJSON govCert - --- instance --- ( ShelleyEraTxCert era --- , TxCert era ~ BabelTxCert era --- ) => --- FromCBOR (BabelTxCert era) --- where --- fromCBOR = toPlainDecoder (eraProtVerLow @era) decCBOR - --- instance --- ( BabelEraTxCert era --- , TxCert era ~ BabelTxCert era --- ) => --- DecCBOR (BabelTxCert era) --- where --- decCBOR = decodeRecordSum "BabelTxCert" $ \case --- t --- | 0 <= t && t < 3 -> shelleyTxCertDelegDecoder t --- | 3 <= t && t < 5 -> poolTxCertDecoder t --- | t == 5 -> fail "Genesis delegation certificates are no longer supported" --- | t == 6 -> fail "MIR certificates are no longer supported" --- | 7 <= t -> babelTxCertDelegDecoder t --- t -> invalidKey t - --- babelTxCertDelegDecoder :: BabelEraTxCert era => Word -> Decoder s (Int, TxCert era) --- babelTxCertDelegDecoder = \case --- 7 -> do --- cred <- decCBOR --- deposit <- decCBOR --- pure (3, RegDepositTxCert cred deposit) --- 8 -> do --- cred <- decCBOR --- deposit <- decCBOR --- pure (3, UnRegDepositTxCert cred deposit) --- 9 -> delegCertDecoder 3 (DelegVote <$> decCBOR) --- 10 -> delegCertDecoder 4 (DelegStakeVote <$> decCBOR <*> decCBOR) --- 11 -> regDelegCertDecoder 4 (DelegStake <$> decCBOR) --- 12 -> regDelegCertDecoder 4 (DelegVote <$> decCBOR) --- 13 -> regDelegCertDecoder 5 (DelegStakeVote <$> decCBOR <*> decCBOR) --- 14 -> do --- cred <- decCBOR --- key <- decCBOR --- pure (3, AuthCommitteeHotKeyTxCert cred key) --- 15 -> do --- cred <- decCBOR --- a <- decodeNullStrictMaybe decCBOR --- pure (3, ResignCommitteeColdTxCert cred a) --- 16 -> do --- cred <- decCBOR --- deposit <- decCBOR --- mAnchor <- decodeNullStrictMaybe decCBOR --- pure (4, RegDRepTxCert cred deposit mAnchor) --- 17 -> do --- cred <- decCBOR --- deposit <- decCBOR --- pure (3, UnRegDRepTxCert cred deposit) --- 18 -> do --- cred <- decCBOR --- mAnchor <- decodeNullStrictMaybe decCBOR --- pure (3, UpdateDRepTxCert cred mAnchor) --- k -> invalidKey k --- where --- delegCertDecoder n decodeDelegatee = do --- cred <- decCBOR --- delegatee <- decodeDelegatee --- pure (n, DelegTxCert cred delegatee) --- {-# INLINE delegCertDecoder #-} --- regDelegCertDecoder n decodeDelegatee = do --- cred <- decCBOR --- delegatee <- decodeDelegatee --- deposit <- decCBOR --- pure (n, RegDepositDelegTxCert cred delegatee deposit) --- {-# INLINE regDelegCertDecoder #-} --- {-# INLINE babelTxCertDelegDecoder #-} - --- instance (Era era, Val (Value era)) => ToCBOR (BabelTxCert era) where --- toCBOR = toPlainEncoding (eraProtVerLow @era) . encCBOR - --- instance (Era era, Val (Value era)) => EncCBOR (BabelTxCert era) where --- encCBOR = \case --- BabelTxCertDeleg delegCert -> encodeBabelDelegCert delegCert --- BabelTxCertPool poolCert -> encodePoolCert poolCert --- BabelTxCertGov govCert -> encodeGovCert govCert - --- encodeBabelDelegCert :: Crypto c => BabelDelegCert c -> Encoding --- encodeBabelDelegCert = \case --- -- Shelley backwards compatibility --- BabelRegCert cred SNothing -> encodeShelleyDelegCert $ ShelleyRegCert cred --- BabelUnRegCert cred SNothing -> encodeShelleyDelegCert $ ShelleyUnRegCert cred --- BabelDelegCert cred (DelegStake poolId) -> encodeShelleyDelegCert $ ShelleyDelegCert cred poolId --- -- New in Babel --- BabelRegCert cred (SJust deposit) -> --- encodeListLen 3 --- <> encodeWord8 7 --- <> encCBOR cred --- <> encCBOR deposit --- BabelUnRegCert cred (SJust deposit) -> --- encodeListLen 3 --- <> encodeWord8 8 --- <> encCBOR cred --- <> encCBOR deposit --- BabelDelegCert cred (DelegVote drep) -> --- encodeListLen 3 --- <> encodeWord8 9 --- <> encCBOR cred --- <> encCBOR drep --- BabelDelegCert cred (DelegStakeVote poolId dRep) -> --- encodeListLen 4 --- <> encodeWord8 10 --- <> encCBOR cred --- <> encCBOR poolId --- <> encCBOR dRep --- BabelRegDelegCert cred (DelegStake poolId) deposit -> --- encodeListLen 4 --- <> encodeWord8 11 --- <> encCBOR cred --- <> encCBOR poolId --- <> encCBOR deposit --- BabelRegDelegCert cred (DelegVote drep) deposit -> --- encodeListLen 4 --- <> encodeWord8 12 --- <> encCBOR cred --- <> encCBOR drep --- <> encCBOR deposit --- BabelRegDelegCert cred (DelegStakeVote poolId dRep) deposit -> --- encodeListLen 5 --- <> encodeWord8 13 --- <> encCBOR cred --- <> encCBOR poolId --- <> encCBOR dRep --- <> encCBOR deposit - --- encodeGovCert :: Crypto c => BabelGovCert c -> Encoding --- encodeGovCert = \case --- BabelAuthCommitteeHotKey cred key -> --- encodeListLen 3 --- <> encodeWord8 14 --- <> encCBOR cred --- <> encCBOR key --- BabelResignCommitteeColdKey cred a -> --- encodeListLen 3 --- <> encodeWord8 15 --- <> encCBOR cred --- <> encodeNullStrictMaybe encCBOR a --- BabelRegDRep cred deposit mAnchor -> --- encodeListLen 4 --- <> encodeWord8 16 --- <> encCBOR cred --- <> encCBOR deposit --- <> encodeNullStrictMaybe encCBOR mAnchor --- BabelUnRegDRep cred deposit -> --- encodeListLen 3 --- <> encodeWord8 17 --- <> encCBOR cred --- <> encCBOR deposit --- BabelUpdateDRep cred mAnchor -> --- encodeListLen 3 --- <> encodeWord8 18 --- <> encCBOR cred --- <> encodeNullStrictMaybe encCBOR mAnchor - fromShelleyDelegCert :: ShelleyDelegCert c -> BabelDelegCert c fromShelleyDelegCert = \case ShelleyRegCert cred -> BabelRegCert cred SNothing @@ -577,56 +401,6 @@ toShelleyDelegCert = \case BabelDelegCert cred (DelegStake poolId) -> Just $ ShelleyDelegCert cred poolId _ -> Nothing --- For both of the functions `getScriptWitnessBabelTxCert` and --- `getVKeyWitnessBabelTxCert` we preserve the old behavior of not requiring a witness --- for staking credential registration, but only during the transitional period of Babel --- era and only for staking credential registration certificates without a deposit. Future --- eras will require a witness for registration certificates, because the one without a --- deposit will be removed. - --- getScriptWitnessBabelTxCert :: --- BabelTxCert era -> --- Maybe (ScriptHash (EraCrypto era)) --- getScriptWitnessBabelTxCert = \case --- BabelTxCertDeleg delegCert -> --- case delegCert of --- BabelRegCert _ SNothing -> Nothing --- BabelRegCert cred (SJust _) -> credScriptHash cred --- BabelUnRegCert cred _ -> credScriptHash cred --- BabelDelegCert cred _ -> credScriptHash cred --- BabelRegDelegCert cred _ _ -> credScriptHash cred --- -- PoolIds can't be Scripts --- BabelTxCertPool {} -> Nothing --- BabelTxCertGov govCert -> govWitness govCert --- where --- govWitness :: BabelGovCert c -> Maybe (ScriptHash c) --- govWitness = \case --- BabelAuthCommitteeHotKey coldCred _hotCred -> credScriptHash coldCred --- BabelResignCommitteeColdKey coldCred _ -> credScriptHash coldCred --- BabelRegDRep cred _ _ -> credScriptHash cred --- BabelUnRegDRep cred _ -> credScriptHash cred --- BabelUpdateDRep cred _ -> credScriptHash cred - --- getVKeyWitnessBabelTxCert :: BabelTxCert era -> Maybe (KeyHash 'Witness (EraCrypto era)) --- getVKeyWitnessBabelTxCert = \case --- BabelTxCertDeleg delegCert -> --- case delegCert of --- BabelRegCert _ SNothing -> Nothing --- BabelRegCert cred (SJust _) -> credKeyHashWitness cred --- BabelUnRegCert cred _ -> credKeyHashWitness cred --- BabelDelegCert cred _ -> credKeyHashWitness cred --- BabelRegDelegCert cred _ _ -> credKeyHashWitness cred --- BabelTxCertPool poolCert -> Just $ poolCertKeyHashWitness poolCert --- BabelTxCertGov govCert -> govWitness govCert --- where --- govWitness :: BabelGovCert c -> Maybe (KeyHash 'Witness c) --- govWitness = \case --- BabelAuthCommitteeHotKey coldCred _hotCred -> credKeyHashWitness coldCred --- BabelResignCommitteeColdKey coldCred _ -> credKeyHashWitness coldCred --- BabelRegDRep cred _ _ -> credKeyHashWitness cred --- BabelUnRegDRep cred _ -> credKeyHashWitness cred --- BabelUpdateDRep cred _ -> credKeyHashWitness cred - -- | Determine the total deposit amount needed from a TxBody. -- The block may (legitimately) contain multiple registration certificates -- for the same pool, where the first will be treated as a registration and diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/TxInfo.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/TxInfo.hs index 7a1a9fe78db..eece027889d 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/TxInfo.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/TxInfo.hs @@ -672,6 +672,12 @@ transProtVer :: ProtVer -> PV3.ProtocolVersion transProtVer (ProtVer major minor) = PV3.ProtocolVersion (toInteger (getVersion64 major)) (toInteger minor) +{- CIP-0118#plutusv4-1 + + Here, we demonstrate the first change we need to reflect the necessary changes to + PlutusV4: the addition of our new fields to `TxInfo`. + + Jump to CIP-0118#plutusv4-2 to continue... -} instance Crypto c => EraPlutusTxInfo 'PlutusV4 (BabelEra c) where toPlutusTxCert _ = pure . transTxCertV4 @@ -679,14 +685,19 @@ instance Crypto c => EraPlutusTxInfo 'PlutusV4 (BabelEra c) where toPlutusTxInfo proxy pp epochInfo systemStart utxo tx = do timeRange <- Alonzo.transValidityInterval pp epochInfo systemStart (txBody ^. vldtTxBodyL) - -- TODO WG: realizedInputs. Add realizedFulfills here. Put them in PV4 TxInfo. inputs <- mapM (transTxInInfoV4 utxo) (Set.toList (txBody ^. inputsTxBodyL)) - refInputs <- mapM (transTxInInfoV4 utxo) (Set.toList (txBody ^. referenceInputsTxBodyL)) + refInputs <- mapM (transTxInInfoV4 utxo) (Set.toList (txBody ^. referenceInputsTxBodyL)) outputs <- zipWithM (Babbage.transTxOutV2 . TxOutFromOutput) [minBound ..] (F.toList (txBody ^. outputsTxBodyL)) + fulfills <- mapM (transTxInInfoV4 utxo) (Set.toList (txBody ^. fulfillsTxBodyL)) + requests <- zipWithM + (Babbage.transTxOutV2 . TxOutFromOutput) + [minBound ..] + (F.toList (txBody ^. requestsTxBodyL)) + requiredTxs <- mapM (transTxInInfoV4 utxo) (Set.toList (txBody ^. requiredTxsTxBodyL)) txCerts <- Alonzo.transTxBodyCerts proxy txBody plutusRedeemers <- Babbage.transTxRedeemers proxy tx pure @@ -712,9 +723,9 @@ instance Crypto c => EraPlutusTxInfo 'PlutusV4 (BabelEra c) where case txBody ^. treasuryDonationTxBodyL of Coin 0 -> Nothing coin -> Just $ transCoinToLovelace coin - , PV4.txInfoFulfills = undefined - , PV4.txInfoRequests = undefined - , PV4.txInfoRequiredTxs = undefined + , PV4.txInfoFulfills = fulfills + , PV4.txInfoRequests = requests + , PV4.txInfoRequiredTxs = requiredTxs } where txBody = tx ^. bodyTxL @@ -740,6 +751,11 @@ transTxInInfoV4 utxo txIn = do plutusTxOut <- transTxOutV2 (TxOutFromInput txIn) txOut Right (PV4.TxInInfo (transTxIn txIn) plutusTxOut) +{- CIP-0118#plutusv4-2 + + This is the second important change. We've need to reflect the new `ScriptPurpose` case. + + Jump to CIP-0118#plutusv4-3 to continue... -} fromScriptPurposeV4 :: PV4.ScriptPurpose -> PV4.ScriptInfo fromScriptPurposeV4 = \case PV4.Minting cs -> PV4.MintingScript cs @@ -748,8 +764,7 @@ fromScriptPurposeV4 = \case PV4.Certifying index txCert -> PV4.CertifyingScript index txCert PV4.Voting voter -> PV4.VotingScript voter PV4.Proposing index proposal -> PV4.ProposingScript index proposal - --- TODO WG: Add Fulfills + PV4.Fulfills fulfills -> PV4.FulfillsScript fulfills transTxCertV4 :: BabelEraTxCert era => TxCert era -> PV4.TxCert transTxCertV4 = \case diff --git a/eras/babel/test-suite/CHANGELOG.md b/eras/babel/test-suite/CHANGELOG.md index db817db75e6..7adc616cfc1 100644 --- a/eras/babel/test-suite/CHANGELOG.md +++ b/eras/babel/test-suite/CHANGELOG.md @@ -1,46 +1 @@ -# Version history for `cardano-ledger-conway-test` - -## 1.2.1.5 - -* - -## 1.2.1.4 - -* - -## 1.2.1.3 - -* - -## 1.2.1.2 - -* Move `cddl-files` to `cardano-ledger-alonzo` - -## 1.2.1.1 - -* Update CDDL files to reflect the change in header structure in - cardano-protocol-praos. - -## 1.2.1.0 - -* Add `Crypto c` constraint to `exampleBabelGenesis` - -## 1.2.0.5 - -* - -## 1.2.0.4 - -* - -## 1.2.0.3 - -* - -## 1.2.0.2 - -* - -## 1.2.0.1 - -* +# Version history for `cardano-ledger-conway-babel` diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs index 1e3e10a404c..8af2f41f1ed 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/API/Validation.hs @@ -61,7 +61,7 @@ import NoThunks.Class (NoThunks (..)) Block validation API -------------------------------------------------------------------------------} -{- CIP-0118#0-apply-block +{- CIP-0118#apply-block-0 (Please read CIP-0118#ledger-state-temp first) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs index 594ff8c0d8b..38e39111849 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Block.hs @@ -46,12 +46,12 @@ import GHC.Generics (Generic) import Lens.Micro ((^.)) import NoThunks.Class (NoThunks (..)) -{- CIP-0118#0-block-structure +{- CIP-0118#block-structure-0 Firstly, we need to change the structure of the block. `TxZones` is an associated type on `EraSegWits`. It replaces `TxSeq`. - Jump to CIP-0118#1-block-structure to continue... -} + Jump to CIP-0118#block-structure-1 to continue... -} data Block h era = Block' !h !(TxZones era) BSL.ByteString deriving (Generic) diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs index 47f9eedf6e6..1aa4735d8df 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core.hs @@ -630,7 +630,7 @@ class ) => EraSegWits era where - {- CIP-0118#1-block-structure + {- CIP-0118#block-structure-1 To support the concept of a block having a different concrete representation depending on era, we've added a `TxStructure` type. This isn't strictly necessary; @@ -643,7 +643,7 @@ class Finally, we have a `flatten` function, as much of the existing code (tests etc) requires a `StrictSeq`, and doesn't care about the new meaning in our `TxZones`. - Jump to CIP-0118#2-block-structure to continue... -} + Jump to CIP-0118#block-structure-2 to continue... -} type TxStructure era :: Type -> Type type TxZones era = (r :: Type) | r -> era diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs index 4bfd8a863c8..437e03a28eb 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Plutus/Language.hs @@ -197,36 +197,15 @@ instance DecCBOR (Annotator PlutusBinary) where instance SafeToHash PlutusBinary where originalBytes (PlutusBinary binaryBlutus) = fromShort binaryBlutus -{- CIP-0118#0-plutusv4 +{- CIP-0118#plutusv4-0 - Here, we demonstrate the three (or two...I'll explain shortly) new fields required - for Babel fees. + To support the new fields in Plutus, we need to create a new version. The only + difference is the addition of our new Tx fields. - The type of `Fulfill` is equivalent to that of an input, and the type of - a `Request` is equivalent to that of an ourput. + You can see an example of a new version of Plutus (on the Plutus side) here: + https://github.com/IntersectMBO/plutus/compare/master...willjgould:plutus:wg/babel-fees-prototyping - A `RequiredTx` is a transaction on which *this* transaction depends. - - This has certain implications when it comes to cyclic dependencies. Because the - `TxBody` must be hashed for witnessing, if two transactions are dependent on - one-another with `RequiredTxs`, it becomes impossible to hash either of them. - This is why we might not want to put `RequiredTxs` in the `TxBody`: if we want - to allow these cyclic dependencies. - - If we do, we'll need to move `RequiredTxs` up to the `Tx` level, like, for example: - - data AlonzoTx era = AlonzoTx - { body :: !(TxBody era) - , wits :: !(TxWits era) - , isValid :: !IsValid - , auxiliaryData :: !(StrictMaybe (TxAuxData era)) - , requiredTxs :: !(RequiredTxs era) - } - deriving (Generic) - - This'll allow us to calculate a composite hash...TODO explain how they can do this - - Jump to CIP-0118#1-plutusv4 to continue... -} + Jump to CIP-0118#plutusv4-1 to continue... -} -- | Non-Native Plutus Script language. This is expected to be an open type. We will add -- new Constuctors to this type as additional Plutus language versions as are added. We From 3c71151f05b3742ba36376875f173c2a9651613d Mon Sep 17 00:00:00 2001 From: Will Gould Date: Mon, 8 Jul 2024 16:03:35 +0100 Subject: [PATCH 16/19] Another commented out code pass --- .../src/Cardano/Ledger/Alonzo/Translation.hs | 2 +- .../alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs | 17 ++--------------- .../Test/Cardano/Ledger/Alonzo/Arbitrary.hs | 3 --- .../Test/Cardano/Ledger/Alonzo/TreeDiff.hs | 3 +-- .../Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs | 2 +- .../Cardano/Ledger/Alonzo/Examples/Consensus.hs | 2 +- .../test/Test/Cardano/Ledger/Alonzo/TxInfo.hs | 2 +- .../src/Cardano/Ledger/Babbage/Translation.hs | 2 +- .../impl/src/Cardano/Ledger/Babbage/Tx.hs | 5 ----- .../Ledger/Babbage/Examples/Consensus.hs | 2 +- .../src/Cardano/Ledger/Babel/Rules/Utxow.hs | 4 +--- .../impl/src/Cardano/Ledger/Babel/Rules/Zone.hs | 16 +--------------- .../impl/src/Cardano/Ledger/Babel/TxInfo.hs | 1 - 13 files changed, 11 insertions(+), 50 deletions(-) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs index e1baf2b3620..58ba3bc90c9 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Translation.hs @@ -81,7 +81,7 @@ instance Crypto c => TranslateEra (AlonzoEra c) Tx where txAuxData <- mapM (translateEraThroughCBOR "TxAuxData") (tx ^. auxDataTxL) -- transactions from Mary era always pass script ("phase 2") validation let validating = IsValid True - pure $ Tx $ AlonzoTx txBody txWits validating txAuxData -- mempty + pure $ Tx $ AlonzoTx txBody txWits validating txAuxData -------------------------------------------------------------------------------- -- Auxiliary instances and functions diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs index 469e35a4168..d1776985d58 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tx.hs @@ -131,7 +131,6 @@ import Cardano.Ledger.Plutus.Data (Data, hashData) import Cardano.Ledger.Plutus.Language (nonNativeLanguages) import Cardano.Ledger.SafeHash (HashAnnotated, SafeToHash (..), hashAnnotated) import Cardano.Ledger.Shelley.Tx ( - -- ShelleyRequiredTx, ShelleyTx (ShelleyTx), shelleyEqTxRaw, ) @@ -167,16 +166,12 @@ data AlonzoTx era = AlonzoTx , wits :: !(TxWits era) , isValid :: !IsValid , auxiliaryData :: !(StrictMaybe (TxAuxData era)) - -- , requiredTxs :: !(RequiredTxs era) } deriving (Generic) newtype AlonzoTxUpgradeError = ATUEBodyUpgradeError AlonzoTxBodyUpgradeError deriving (Show) --- instance Crypto c => EraRequiredTxsData (AlonzoEra c) where --- type RequiredTxs (AlonzoEra c) = ShelleyRequiredTx (AlonzoEra c) - instance Crypto c => EraTx (AlonzoEra c) where {-# SPECIALIZE instance EraTx (AlonzoEra StandardCrypto) #-} @@ -194,9 +189,6 @@ instance Crypto c => EraTx (AlonzoEra c) where auxDataTxL = auxDataAlonzoTxL {-# INLINE auxDataTxL #-} - -- requiredTxsTxL = lens (const mempty) const - -- {-# INLINE requiredTxsTxL #-} - sizeTxF = sizeAlonzoTxF {-# INLINE sizeTxF #-} @@ -232,7 +224,7 @@ mkBasicAlonzoTx :: Monoid (TxWits era) => TxBody era -> AlonzoTx era -mkBasicAlonzoTx txBody = AlonzoTx txBody mempty (IsValid True) SNothing -- mempty +mkBasicAlonzoTx txBody = AlonzoTx txBody mempty (IsValid True) SNothing -- | `TxBody` setter and getter for `AlonzoTx`. bodyAlonzoTxL :: Lens' (AlonzoTx era) (TxBody era) @@ -267,7 +259,7 @@ deriving instance ( Era era , Eq (TxBody era) , Eq (TxWits era) - , Eq (TxAuxData era) -- Eq (RequiredTxs era) + , Eq (TxAuxData era) ) => Eq (AlonzoTx era) @@ -277,7 +269,6 @@ deriving instance , Show (TxAuxData era) , Show (Script era) , Show (TxWits era) - -- , Show (RequiredTxs era) ) => Show (AlonzoTx era) @@ -286,7 +277,6 @@ instance , NoThunks (TxWits era) , NoThunks (TxAuxData era) , NoThunks (TxBody era) - -- , NoThunks (RequiredTxs era) ) => NoThunks (AlonzoTx era) @@ -295,7 +285,6 @@ instance , NFData (TxWits era) , NFData (TxAuxData era) , NFData (TxBody era) - -- , NFData (RequiredTxs era) ) => NFData (AlonzoTx era) @@ -501,7 +490,6 @@ instance , DecCBOR (Annotator (TxBody era)) , DecCBOR (Annotator (TxWits era)) , DecCBOR (Annotator (TxAuxData era)) - -- , DecCBOR (Annotator (RequiredTxs era)) ) => DecCBOR (Annotator (AlonzoTx era)) where @@ -515,7 +503,6 @@ instance ( sequence . maybeToStrictMaybe <$> decodeNullMaybe decCBOR ) - -- <*! From {-# INLINE decCBOR #-} -- ======================================================================= 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 9837e16f753..59d54eef179 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Arbitrary.hs @@ -206,7 +206,6 @@ instance ( Arbitrary (TxBody era) , Arbitrary (TxWits era) , Arbitrary (TxAuxData era) - -- , Arbitrary (RequiredTxs era) ) => Arbitrary (AlonzoTx era) where @@ -217,8 +216,6 @@ instance <*> arbitrary <*> arbitrary --- <*> arbitrary - instance (AlonzoEraScript era, Script era ~ AlonzoScript era) => Arbitrary (AlonzoScript era) where arbitrary = do lang <- elements [minBound .. eraMaxLanguage @era] diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs index 7830516688c..dd3f6cdb0b3 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs +++ b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/TreeDiff.hs @@ -102,7 +102,6 @@ instance , ToExpr (TxOut era) , ToExpr (TxCert era) , ToExpr (PParamsUpdate era) - -- , ToExpr (RequiredTxs era) ) => ToExpr (AlonzoTxBody era) @@ -112,7 +111,7 @@ instance ToExpr IsValid instance ( ToExpr (TxBody era) , ToExpr (TxWits era) - , ToExpr (TxAuxData era) -- ToExpr (RequiredTxs era)) => + , ToExpr (TxAuxData era) ) => ToExpr (AlonzoTx era) diff --git a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs index 0373340c947..4195d910d93 100644 --- a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs +++ b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/AlonzoEraGen.hs @@ -405,7 +405,7 @@ instance Mock c => EraGen (AlonzoEra c) where Just info -> addRedeemMap (getRedeemer2 info) purpose ans -- Add it to the redeemer map Nothing -> ans - constructTx bod wit auxdata = AlonzoTx bod wit (IsValid v) auxdata -- mempty + constructTx bod wit auxdata = AlonzoTx bod wit (IsValid v) auxdata where v = all twoPhaseValidates (txscripts' wit) twoPhaseValidates script = diff --git a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Examples/Consensus.hs b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Examples/Consensus.hs index e73008904f7..cefa5adcd55 100644 --- a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Examples/Consensus.hs +++ b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Examples/Consensus.hs @@ -161,7 +161,7 @@ exampleTx = ) exampleTransactionInBlock :: AlonzoTx Alonzo -exampleTransactionInBlock = AlonzoTx b w (IsValid True) a -- mempty +exampleTransactionInBlock = AlonzoTx b w (IsValid True) a where ShelleyTx b w a = exampleTx diff --git a/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/TxInfo.hs b/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/TxInfo.hs index 8f5334804d1..c650875edf5 100644 --- a/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/TxInfo.hs +++ b/eras/alonzo/test-suite/test/Test/Cardano/Ledger/Alonzo/TxInfo.hs @@ -87,7 +87,7 @@ txb i o = SNothing -- network ID txEx :: TxIn StandardCrypto -> TxOut Alonzo -> Tx Alonzo -txEx i o = AlonzoTx (txb i o) mempty (IsValid True) SNothing -- mempty +txEx i o = AlonzoTx (txb i o) mempty (IsValid True) SNothing silentlyIgnore :: Tx Alonzo -> Assertion silentlyIgnore tx = diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs index 63aacf33586..4973530a053 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Translation.hs @@ -84,7 +84,7 @@ instance Crypto c => TranslateEra (BabbageEra c) Tx where SNothing -> pure SNothing SJust auxData -> SJust <$> translateEraThroughCBOR "AuxData" auxData let validating = tx ^. Alonzo.isValidTxL - pure $ Tx $ AlonzoTx txBody txWits validating auxData -- mempty + pure $ Tx $ AlonzoTx txBody txWits validating auxData -------------------------------------------------------------------------------- -- Auxiliary instances and functions diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs index 6de5e76e5ce..a062332ac3a 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Tx.hs @@ -17,11 +17,6 @@ module Cardano.Ledger.Babbage.Tx ( AlonzoTx (..), BabbageTxBody (..), module X, - -- Babel Fees - -- pattern BabbageRequiredTx, - -- requiredTxs, - -- BabbageRequiredTx (..), - -- BabbageRequiredTxRaw (..), ) where diff --git a/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Examples/Consensus.hs b/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Examples/Consensus.hs index 520f848a031..b1f9422aa21 100644 --- a/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Examples/Consensus.hs +++ b/eras/babbage/test-suite/src/Test/Cardano/Ledger/Babbage/Examples/Consensus.hs @@ -175,7 +175,7 @@ exampleTx = ) exampleTransactionInBlock :: AlonzoTx Babbage -exampleTransactionInBlock = AlonzoTx b w (IsValid True) a -- mempty +exampleTransactionInBlock = AlonzoTx b w (IsValid True) a where ShelleyTx b w a = exampleTx diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs index b7fe2a416ef..7e08e38bde6 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs @@ -409,8 +409,7 @@ babelUtxowTransition :: , ScriptsNeeded era ~ AlonzoScriptsNeeded era , BabbageEraTxBody era , Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentTxBody) - , -- , Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentRequiredTxs) - Environment (EraRule "UTXOW" era) ~ Shelley.UtxoEnv era + , Environment (EraRule "UTXOW" era) ~ Shelley.UtxoEnv era , Signal (EraRule "UTXOW" era) ~ Tx era , State (EraRule "UTXOW" era) ~ UTxOStateTemp era , InjectRuleFailure "UTXOW" ShelleyUtxowPredFailure era @@ -493,7 +492,6 @@ validateVerifiedWits :: forall era. ( EraTx era , Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentTxBody) - -- , Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentRequiredTxs) ) => Tx era -> Test (ShelleyUtxowPredFailure era) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs index 520956cbdbb..8d8825f9ff4 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs @@ -122,8 +122,7 @@ import Validation (failureUnless) data BabelZonePredFailure era = LedgersFailure (PredicateFailure (BabelLEDGERS era)) -- Subtransition Failures - | -- | ShelleyInBabelPredFailure (ShelleyLedgersPredFailure era) -- Subtransition Failures - ShelleyInBabelPredFailure (ShelleyLedgersPredFailure era) -- Subtransition Failures + | ShelleyInBabelPredFailure (ShelleyLedgersPredFailure era) -- Subtransition Failures deriving (Generic) data BabelZoneEvent era @@ -340,18 +339,6 @@ zoneTransition = (l : txs') -> (l ^. isValidTxL == IsValid False) && all ((== IsValid True) . (^. isValidTxL)) txs' [] -> True --- data BabelUtxosEvent era --- = TotalDeposits (SafeHash (EraCrypto era) EraIndependentTxBody) Coin --- | SuccessfulPlutusScriptsEvent (NonEmpty (PlutusWithContext (EraCrypto era))) --- | FailedPlutusScriptsEvent (NonEmpty (PlutusWithContext (EraCrypto era))) --- | -- | The UTxOs consumed and created by a signal tx --- TxUTxODiff --- -- | UTxO consumed --- (UTxO era) --- -- | UTxO created --- (UTxO era) --- deriving (Generic) - babelEvalScriptsTxInvalid :: forall era. ( EraRule "ZONE" era ~ BabelZONE era @@ -384,7 +371,6 @@ babelEvalScriptsTxInvalid = let tx = last (Foldable.toList txs) -- TODO WG use safe head txBody = tx ^. bodyTxL - -- TRC (UtxoEnv _ pp _, us@(UTxOState utxo _ _ fees _ _ _), tx) <- judgmentContext -- {- txb := txbody tx -} sysSt <- liftSTS $ asks systemStart ei <- liftSTS $ asks epochInfo diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/TxInfo.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/TxInfo.hs index eece027889d..10d6749cfd3 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/TxInfo.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/TxInfo.hs @@ -437,7 +437,6 @@ instance Crypto c => EraPlutusTxInfo 'PlutusV3 (BabelEra c) where toPlutusTxInfo proxy pp epochInfo systemStart utxo tx = do timeRange <- Alonzo.transValidityInterval pp epochInfo systemStart (txBody ^. vldtTxBodyL) - -- TODO WG: realizedInputs. Add realizedFulfills here. Put them in PV4 TxInfo. inputs <- mapM (transTxInInfoV3 utxo) (Set.toList (txBody ^. inputsTxBodyL)) refInputs <- mapM (transTxInInfoV3 utxo) (Set.toList (txBody ^. referenceInputsTxBodyL)) outputs <- From 3617b40b209a529167a214faace17d707ed814dd Mon Sep 17 00:00:00 2001 From: Will Gould Date: Mon, 8 Jul 2024 16:13:57 +0100 Subject: [PATCH 17/19] Typo --- eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zones.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zones.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zones.hs index 16f4c9d24b1..259bcf1149b 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zones.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zones.hs @@ -68,7 +68,7 @@ import Cardano.Ledger.Babel.Rules.Utxow (BabelUtxowPredFailure) import Cardano.Ledger.Babel.Rules.Zone (BabelZonePredFailure) import Cardano.Ledger.Shelley.LedgerState (LedgerState) import Control.Monad (foldM) -import qualified Data.Foldable as Foldale +import qualified Data.Foldable as Foldable import Data.Maybe (fromJust) import NoThunks.Class (NoThunks) @@ -178,7 +178,7 @@ zonesTransition :: TransitionRule (BabelZONES era) zonesTransition = do TRC (LedgersEnv slot pp account, ls, txwits) <- judgmentContext - let indexedList = indexLists $ Foldale.toList (txwits :: Seq (Seq (Tx era))) + let indexedList = indexLists $ Foldable.toList (txwits :: Seq (Seq (Tx era))) case indexedList of Nothing -> undefined -- fail From 1a42075ad0865bd6335b8754c057ce3d643ffd47 Mon Sep 17 00:00:00 2001 From: Will Gould Date: Wed, 10 Jul 2024 18:55:09 +0100 Subject: [PATCH 18/19] A bunch of missed stuff in rules for UTxOTemp --- eras/babel/impl/cardano-ledger-babel.cabal | 3 + eras/babel/impl/cddl-files/babel.cddl | 15 +- .../impl/src/Cardano/Ledger/Babel/FRxO.hs | 300 +++++++++++++++++- .../src/Cardano/Ledger/Babel/Rules/Utxo.hs | 178 ++++++++++- .../src/Cardano/Ledger/Babel/Rules/Utxos.hs | 118 ++++++- .../src/Cardano/Ledger/Babel/Rules/Utxow.hs | 96 +++--- .../src/Cardano/Ledger/Babel/Rules/Zone.hs | 22 +- .../impl/src/Cardano/Ledger/Babel/UTxO.hs | 1 + eras/mary/impl/src/Cardano/Ledger/Mary.hs | 4 +- .../src/Cardano/Ledger/UTxO.hs | 2 +- 10 files changed, 639 insertions(+), 100 deletions(-) diff --git a/eras/babel/impl/cardano-ledger-babel.cabal b/eras/babel/impl/cardano-ledger-babel.cabal index 0a75c506746..d773ce4404e 100644 --- a/eras/babel/impl/cardano-ledger-babel.cabal +++ b/eras/babel/impl/cardano-ledger-babel.cabal @@ -90,13 +90,16 @@ library cardano-ledger-core >=1.12, cardano-ledger-mary >=1.6, cardano-ledger-shelley >=1.11, + cardano-slotting, cardano-strict-containers, containers, + text, deepseq, microlens, mtl, nothunks, plutus-ledger-api ^>=1.30.0.0, + set-algebra, small-steps >=1.1, transformers, validation-selective, diff --git a/eras/babel/impl/cddl-files/babel.cddl b/eras/babel/impl/cddl-files/babel.cddl index 73a831726e3..c6450b93d3e 100644 --- a/eras/babel/impl/cddl-files/babel.cddl +++ b/eras/babel/impl/cddl-files/babel.cddl @@ -67,12 +67,19 @@ transaction_body = , ? 16 : transaction_output ; collateral return , ? 17 : coin ; total collateral , ? 18 : nonempty_set ; reference inputs - , ? 19 : voting_procedures ; New; Voting procedures - , ? 20 : proposal_procedures ; New; Proposal procedures - , ? 21 : coin ; New; current treasury value - , ? 22 : positive_coin ; New; donation + , ? 19 : voting_procedures ; Voting procedures + , ? 20 : proposal_procedures ; Proposal procedures + , ? 21 : coin ; current treasury value + , ? 22 : positive_coin ; donation + , ? 23 : set ; New; Intent fulfillments + , ? 24 : [* intent_request] ; New; Intent asks/ requests + , ? 25 : set ; New; Required transactions } +intent_fulfill = transaction_input +intent_request = transaction_output +fulfillment_request_transaction_output = [(intent_fulfill, intent_request)] + voting_procedures = { + voter => { + gov_action_id => voting_procedure } } voting_procedure = diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/FRxO.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/FRxO.hs index 3ab26462fe3..fcd9141947a 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/FRxO.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/FRxO.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} @@ -6,9 +7,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE TypeOperators #-} @@ -17,22 +21,61 @@ module Cardano.Ledger.Babel.FRxO where -import Cardano.Ledger.Babel.TxBody ( - BabelEraTxBody (fulfillsTxBodyL, requestsTxBodyL, requiredTxsTxBodyL), +import Cardano.Ledger.Address (Addr (..), RewardAccount (..), bootstrapKeyHash) +import Cardano.Ledger.Alonzo.Rules ( + AlonzoUtxowPredFailure ( + MissingRequiredDatums, + NotAllowedSupplementalDatums, + UnspendableUTxONoDatumHash + ), ) -import Cardano.Ledger.Core ( - Era (EraCrypto), - EraTxBody (TxBody), - EraTxOut (TxOut), - txIdTxBody, +import Cardano.Ledger.Alonzo.TxWits (unTxDats) +import Cardano.Ledger.Alonzo.UTxO ( + AlonzoScriptsNeeded (AlonzoScriptsNeeded), + getInputDataHashesTxBody, + getMintingScriptsNeeded, + getRewardingScriptsNeeded, + getSpendingScriptsNeeded, + zipAsIxItem, ) +import Cardano.Ledger.Babbage.Tx (isTwoPhaseScriptAddressFromMap) +import Cardano.Ledger.Babel.Core +import Cardano.Ledger.Binary (Sized (..)) +import Cardano.Ledger.CertState (CertState) +import Cardano.Ledger.Conway.Core (ConwayEraTxBody (..)) +import Cardano.Ledger.Conway.Governance ( + GovAction (..), + ProposalProcedure (..), + Voter (..), + VotingProcedures (unVotingProcedures), + ) +import Cardano.Ledger.Credential (Credential (..), credKeyHashWitness, credScriptHash) import Cardano.Ledger.FRxO (FRxO (FRxO)) +import Cardano.Ledger.Keys (KeyHash, KeyRole (..), asWitness) +import Cardano.Ledger.Plutus.Data (Datum (..)) +import Cardano.Ledger.PoolParams (PoolParams (..)) +import Cardano.Ledger.Rules.ValidationMode (Test) +import Cardano.Ledger.Shelley.UTxO (txinLookup) import Cardano.Ledger.TxIn (TxIn (TxIn)) -import Data.Foldable (toList) +import Cardano.Ledger.UTxO ( + EraUTxO, + ScriptsProvided (ScriptsProvided), + UTxO (..), + getScriptHash, + getScriptsProvided, + ) +import Control.Iterate.Exp ((➖)) +import Control.SetAlgebra (Basic (..), eval, (◁)) +import Data.Foldable (Foldable (..), sequenceA_, toList) import qualified Data.Map as Map +import Data.Maybe (catMaybes) +import Data.Maybe.Strict (StrictMaybe (..)) import qualified Data.Sequence.Strict as SSeq import Data.Set (Set) +import qualified Data.Set as Set import Lens.Micro ((^.)) +import Lens.Micro.Extras (view) +import Validation (failureUnless) -- | The unspent transaction outputs. -- | Compute the transaction requests of a transaction. @@ -62,3 +105,244 @@ txrequired = (^. requiredTxsTxBodyL) txfulfills :: BabelEraTxBody era => TxBody era -> Set (TxIn (EraCrypto era)) txfulfills = (^. fulfillsTxBodyL) + +-- To Babel Fees implementers: These functions are NOT in the right place. +-- Given more time, I'd do something with the EraUTxO class. +getScriptsProvidedFrxo :: + ( EraTx era + , BabelEraTxBody era + ) => + FRxO era -> + Tx era -> + ScriptsProvided era +getScriptsProvidedFrxo frxo tx = ScriptsProvided ans + where + txBody = tx ^. bodyTxL + ins = txBody ^. fulfillsTxBodyL + ans = getReferenceScriptsFrxo frxo ins + +getReferenceScriptsFrxo :: + BabbageEraTxOut era => + FRxO era -> + Set (TxIn (EraCrypto era)) -> + Map.Map (ScriptHash (EraCrypto era)) (Script era) +getReferenceScriptsFrxo frxo ins = Map.fromList (getReferenceScriptsNonDistinctFrxo frxo ins) + +getReferenceScriptsNonDistinctFrxo :: + BabbageEraTxOut era => + FRxO era -> + Set (TxIn (EraCrypto era)) -> + [(ScriptHash (EraCrypto era), Script era)] +getReferenceScriptsNonDistinctFrxo (FRxO mp) inputs = + [ (hashScript script, script) + | txOut <- Map.elems (eval (inputs ◁ mp)) + , SJust script <- [txOut ^. referenceScriptTxOutL] + ] + +getWitsVKeyNeededFrxo :: + (EraTx era, BabelEraTxBody era) => + CertState era -> + UTxO era -> + FRxO era -> + TxBody era -> + Set.Set (KeyHash 'Witness (EraCrypto era)) +getWitsVKeyNeededFrxo _ utxo frxo txBody = + getWitsVKeyNeededNoGovFrxo utxo frxo txBody + `Set.union` (txBody ^. reqSignerHashesTxBodyL) + `Set.union` voterWitnesses txBody + +voterWitnesses :: + ConwayEraTxBody era => + TxBody era -> + Set.Set (KeyHash 'Witness (EraCrypto era)) +voterWitnesses txb = + Map.foldrWithKey' accum mempty (unVotingProcedures (txb ^. votingProceduresTxBodyL)) + where + accum voter _ khs = + maybe khs (`Set.insert` khs) $ + case voter of + CommitteeVoter cred -> credKeyHashWitness cred + DRepVoter cred -> credKeyHashWitness cred + StakePoolVoter poolId -> Just $ asWitness poolId + +getWitsVKeyNeededNoGovFrxo :: + forall era. + EraTx era => + UTxO era -> + FRxO era -> + TxBody era -> + Set (KeyHash 'Witness (EraCrypto era)) +getWitsVKeyNeededNoGovFrxo utxo' _frxo' txBody = + -- TODO WG what do I do? + certAuthors + `Set.union` inputAuthors + `Set.union` owners + `Set.union` wdrlAuthors + where + inputAuthors :: Set (KeyHash 'Witness (EraCrypto era)) + inputAuthors = foldr' accum Set.empty (txBody ^. spendableInputsTxBodyF) + where + accum txin !ans = + case txinLookup txin utxo' of + Just txOut -> + case txOut ^. addrTxOutL of + Addr _ (KeyHashObj pay) _ -> Set.insert (asWitness pay) ans + AddrBootstrap bootAddr -> + Set.insert (asWitness (bootstrapKeyHash bootAddr)) ans + _ -> ans + Nothing -> ans + wdrlAuthors :: Set (KeyHash 'Witness (EraCrypto era)) + wdrlAuthors = Map.foldrWithKey' accum Set.empty (unWithdrawals (txBody ^. withdrawalsTxBodyL)) + where + accum key _ !ans = + case credKeyHashWitness (raCredential key) of + Nothing -> ans + Just vkeyWit -> Set.insert vkeyWit ans + owners :: Set (KeyHash 'Witness (EraCrypto era)) + owners = foldr' accum Set.empty (txBody ^. certsTxBodyL) + where + accum (RegPoolTxCert pool) !ans = + Set.union + (Set.map asWitness (ppOwners pool)) + ans + accum _cert ans = ans + certAuthors :: Set (KeyHash 'Witness (EraCrypto era)) + certAuthors = foldr' accum Set.empty (txBody ^. certsTxBodyL) + where + accum cert !ans = + case getVKeyWitnessTxCert cert of + Nothing -> ans + Just vkeyWit -> Set.insert vkeyWit ans + +getBabelScriptsNeededFrxo :: + BabelEraTxBody era => + UTxO era -> + FRxO era -> + TxBody era -> + AlonzoScriptsNeeded era +getBabelScriptsNeededFrxo utxo frxo txBody = + getSpendingScriptsNeeded utxo txBody + <> getSpendingScriptsNeededFrxo frxo txBody + <> getRewardingScriptsNeeded txBody + <> certifyingScriptsNeeded + <> getMintingScriptsNeeded txBody + <> votingScriptsNeeded + <> proposingScriptsNeeded + where + certifyingScriptsNeeded = + AlonzoScriptsNeeded $ + catMaybes $ + zipAsIxItem (txBody ^. certsTxBodyL) $ + \asIxItem@(AsIxItem _ txCert) -> + (CertifyingPurpose asIxItem,) <$> getScriptWitnessTxCert txCert + + votingScriptsNeeded = + AlonzoScriptsNeeded $ + catMaybes $ + zipAsIxItem (Map.keys (unVotingProcedures (txBody ^. votingProceduresTxBodyL))) $ + \asIxItem@(AsIxItem _ voter) -> + (VotingPurpose asIxItem,) <$> getVoterScriptHash voter + where + getVoterScriptHash = \case + CommitteeVoter cred -> credScriptHash cred + DRepVoter cred -> credScriptHash cred + StakePoolVoter _ -> Nothing + + proposingScriptsNeeded = + AlonzoScriptsNeeded $ + catMaybes $ + zipAsIxItem (txBody ^. proposalProceduresTxBodyL) $ + \asIxItem@(AsIxItem _ proposal) -> + (ProposingPurpose asIxItem,) <$> getProposalScriptHash proposal + where + getProposalScriptHash ProposalProcedure {pProcGovAction} = + case pProcGovAction of + ParameterChange _ _ (SJust govPolicyHash) -> Just govPolicyHash + TreasuryWithdrawals _ (SJust govPolicyHash) -> Just govPolicyHash + _ -> Nothing + +getSpendingScriptsNeededFrxo :: + BabelEraTxBody era => + FRxO era -> + TxBody era -> + AlonzoScriptsNeeded era +getSpendingScriptsNeededFrxo (FRxO frxo) txBody = + AlonzoScriptsNeeded $ + catMaybes $ + zipAsIxItem (txBody ^. fulfillsTxBodyL) $ + \asIxItem@(AsIxItem _ txIn) -> do + addr <- view addrTxOutL <$> Map.lookup txIn frxo + hash <- getScriptHash addr + return (SpendingPurpose asIxItem, hash) +{-# INLINEABLE getSpendingScriptsNeededFrxo #-} + +missingRequiredDatumsFrxo :: + forall era. + (AlonzoEraTx era, BabelEraTxBody era, EraUTxO era) => + UTxO era -> + FRxO era -> + Tx era -> + Test (AlonzoUtxowPredFailure era) +missingRequiredDatumsFrxo utxo frxo tx = do + let txBody = tx ^. bodyTxL + scriptsProvided = getScriptsProvided utxo tx <> getScriptsProvidedFrxo frxo tx + (inputHashes, txInsNoDataHash) = + getInputDataHashesTxBody utxo txBody scriptsProvided + <> getFulfillDataHashesTxBody frxo txBody scriptsProvided + txHashes = domain (unTxDats $ tx ^. witsTxL . datsTxWitsL) + unmatchedDatumHashes = eval (inputHashes ➖ txHashes) + allowedSupplementalDataHashes = getSupplementalDataHashes utxo frxo txBody + supplimentalDatumHashes = eval (txHashes ➖ inputHashes) + (okSupplimentalDHs, notOkSupplimentalDHs) = + Set.partition (`Set.member` allowedSupplementalDataHashes) supplimentalDatumHashes + sequenceA_ + [ failureUnless + (Set.null txInsNoDataHash) + (UnspendableUTxONoDatumHash txInsNoDataHash) + , failureUnless + (Set.null unmatchedDatumHashes) + (MissingRequiredDatums unmatchedDatumHashes txHashes) + , failureUnless + (Set.null notOkSupplimentalDHs) + (NotAllowedSupplementalDatums notOkSupplimentalDHs okSupplimentalDHs) + ] + +getFulfillDataHashesTxBody :: + BabelEraTxBody era => + FRxO era -> + TxBody era -> + ScriptsProvided era -> + (Set.Set (DataHash (EraCrypto era)), Set.Set (TxIn (EraCrypto era))) +getFulfillDataHashesTxBody (FRxO mp) txBody (ScriptsProvided scriptsProvided) = + Map.foldlWithKey' accum (Set.empty, Set.empty) spendUTxO + where + fInputs = txBody ^. fulfillsTxBodyL + spendUTxO = eval (fInputs ◁ mp) + accum ans@(!hashSet, !inputSet) txIn txOut = + let addr = txOut ^. addrTxOutL + isTwoPhaseScriptAddress = isTwoPhaseScriptAddressFromMap scriptsProvided addr + in case txOut ^. datumTxOutF of + NoDatum + | isTwoPhaseScriptAddress -> (hashSet, Set.insert txIn inputSet) + DatumHash dataHash + | isTwoPhaseScriptAddress -> (Set.insert dataHash hashSet, inputSet) + -- Though it is somewhat odd to allow non-two-phase-scripts to include a datum, + -- the Alonzo era already set the precedent with datum hashes, and several dapp + -- developers see this as a helpful feature. + _ -> ans + +getSupplementalDataHashes :: + BabbageEraTxBody era => + UTxO era -> + FRxO era -> + TxBody era -> + Set.Set (DataHash (EraCrypto era)) +getSupplementalDataHashes (UTxO utxo) (FRxO frxo) txBody = + Set.fromList [dh | txOut <- outs, SJust dh <- [txOut ^. dataHashTxOutL]] + where + newOuts = map sizedValue $ toList $ txBody ^. allSizedOutputsTxBodyF + referencedOuts = + -- TODO WG this is DEFINITELY wrong + Map.elems (Map.restrictKeys utxo (txBody ^. referenceInputsTxBodyL)) + <> Map.elems (Map.restrictKeys frxo (txBody ^. referenceInputsTxBodyL)) + outs = newOuts <> referencedOuts \ No newline at end of file diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxo.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxo.hs index a200a13201c..8c640fb7d41 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxo.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxo.hs @@ -35,26 +35,34 @@ import Cardano.Ledger.Alonzo.Rules ( import qualified Cardano.Ledger.Alonzo.Rules as Alonzo ( AlonzoUtxoEvent (UtxosEvent), AlonzoUtxoPredFailure (..), - validateExUnitsTooBigUTxO, validateOutputTooBigUTxO, validateOutsideForecast, validateTooManyCollateralInputs, validateWrongNetworkInTxBody, ) import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..)) +import Cardano.Ledger.Alonzo.TxWits (nullRedeemers) import Cardano.Ledger.Babbage (BabbageEra) -import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, feesOK, validateOutputTooSmallUTxO) +import Cardano.Ledger.Babbage.Rules ( + BabbageUtxoPredFailure, + validateOutputTooSmallUTxO, + validateTotalCollateral, + ) import qualified Cardano.Ledger.Babbage.Rules as Babbage ( BabbageUtxoPredFailure (..), ) +import Cardano.Ledger.Babbage.UTxO (getReferenceScriptsNonDistinct) import Cardano.Ledger.Babel.Core import Cardano.Ledger.Babel.Era (BabelEra, BabelUTXO, BabelUTXOS) +import Cardano.Ledger.Babel.FRxO (getReferenceScriptsNonDistinctFrxo) import Cardano.Ledger.Babel.LedgerState.Types (UTxOStateTemp (..)) import Cardano.Ledger.Babel.Rules.Utxos ( BabelUtxosPredFailure (..), ) +import Cardano.Ledger.Babel.UTxO (babelProducedValue) import Cardano.Ledger.BaseTypes ( Globals (epochInfo, networkId, systemStart), + Inject (..), Network, ProtVer (pvMajor), ShelleyBase, @@ -69,24 +77,40 @@ import Cardano.Ledger.Binary.Coders ( (!>), ()) import Control.DeepSeq (NFData) -import Control.Monad (when) +import Control.Monad (unless, when) import Control.Monad.Trans.Reader (asks) +import Control.SetAlgebra (eval, (◁)) import Control.State.Transition.Extended ( Embed (..), STS (..), @@ -99,13 +123,18 @@ import Control.State.Transition.Extended ( validate, ) import Data.Coerce (coerce) +import Data.Foldable (Foldable (fold), sequenceA_) import Data.List.NonEmpty (NonEmpty) -import Data.Set (Set) +import Data.Map (keysSet) +import qualified Data.Map as Map +import qualified Data.Monoid as Monoid +import Data.Set (Set, isSubsetOf) import qualified Data.Set as Set import GHC.Generics (Generic) import GHC.Natural (Natural) import Lens.Micro ((^.)) import NoThunks.Class (InspectHeapNamed (..), NoThunks (..)) +import Validation (failureUnless) -- ====================================================== @@ -290,7 +319,6 @@ Jump to CIP-0118#UTXOS-rule to continue... -} utxoTransition :: forall era. ( EraUTxO era - , BabbageEraTxBody era , AlonzoEraTxWits era , Tx era ~ AlonzoTx era , InjectRuleFailure "UTXO" ShelleyUtxoPredFailure era @@ -308,11 +336,14 @@ utxoTransition :: , State (EraRule "UTXOS" era) ~ UTxOStateTemp era , Signal (EraRule "UTXOS" era) ~ Tx era , InjectRuleFailure "UTXO" BabelUtxoPredFailure era + , BabelEraTxBody era + , Value era ~ MaryValue (EraCrypto era) ) => TransitionRule (EraRule "UTXO" era) utxoTransition = do TRC (Shelley.UtxoEnv slot pp certState, utxos, tx) <- judgmentContext let utxo = utxostUtxo utxos + frxo = utxostFrxo utxos {- txb := txbody tx -} let txBody = body tx @@ -331,6 +362,9 @@ utxoTransition = do sysSt <- liftSTS $ asks systemStart ei <- liftSTS $ asks epochInfo + runTestOnSignal $ + failureUnless ((txBody ^. fulfillsTxBodyL) `isSubsetOf` keysSet (unFRxO frxo)) CheckLinearFailure -- TODO WG obviously nonsense error + {- epochInfoSlotToUTCTime epochInfo systemTime i_f ≠ ◇ -} runTest $ Alonzo.validateOutsideForecast ei slot sysSt tx @@ -338,14 +372,15 @@ utxoTransition = do runTestOnSignal $ Shelley.validateInputSetEmptyUTxO txBody {- feesOK pp tx utxo -} - validate $ feesOK pp tx utxo -- Generalizes the fee to small from earlier Era's + validate $ feesOK pp tx utxo frxo -- Generalizes the fee to small from earlier Era's {- allInputs = spendInputs txb ∪ collInputs txb ∪ refInputs txb -} {- (spendInputs txb ∪ collInputs txb ∪ refInputs txb) ⊆ dom utxo -} + -- TODO WG: I don't THINK this needs to do anything with FRXO but make sure runTest $ Shelley.validateBadInputsUTxO utxo allInputs {- consumed pp utxo txb = produced pp poolParams txb -} - runTest $ Shelley.validateValueNotConservedUTxO pp utxo certState txBody + runTest $ validateValueNotConservedUTxO pp utxo frxo certState txBody {- adaID ∉ supp mint tx - check not needed because mint field of type MultiAsset cannot contain ada -} @@ -376,8 +411,9 @@ utxoTransition = do -- We've moved this to the ZONE rule. See https://github.com/IntersectMBO/formal-ledger-specifications/commit/c3e18ac1d3da92dd4894bbc32057a143f9720f52#diff-5f67369ed62c0dab01e13a73f072b664ada237d094bbea4582365264dd163bf9 -- runTestOnSignal $ Shelley.validateMaxTxSizeUTxO pp tx + -- Don't need this either since we're applying it to the whole zone in ZONE {- totExunits tx ≤ maxTxExUnits pp -} - runTest $ Alonzo.validateExUnitsTooBigUTxO pp tx + -- runTest $ Alonzo.validateExUnitsTooBigUTxO pp tx {- ‖collateral tx‖ ≤ maxCollInputs pp -} runTest $ Alonzo.validateTooManyCollateralInputs pp txBody @@ -417,6 +453,7 @@ instance , State (EraRule "UTXOS" era) ~ UTxOStateTemp era , Signal (EraRule "UTXOS" era) ~ Tx era , PredicateFailure (EraRule "UTXO" era) ~ BabelUtxoPredFailure era + , Value era ~ MaryValue (EraCrypto era) ) => STS (BabelUTXO era) where @@ -588,3 +625,124 @@ allegraToBabelUtxoPredFailure = \case error "Impossible case, soon to be removed. See: https://github.com/IntersectMBO/cardano-ledger/issues/4085" Allegra.OutputTooBigUTxO xs -> OutputTooBigUTxO (map (0,0,) xs) + +-- To Babel Fees implementers: These functions are NOT in the right place. +-- Given more time, I'd do something with the EraUTxO class. +feesOK :: + forall era rule. + ( EraUTxO era + , AlonzoEraTxWits era + , InjectRuleFailure rule AlonzoUtxoPredFailure era + , InjectRuleFailure rule BabbageUtxoPredFailure era + , InjectRuleFailure rule BabelUtxoPredFailure era + , BabelEraTxBody era + ) => + PParams era -> + Tx era -> + UTxO era -> + FRxO era -> + Test (EraRuleFailure rule era) +feesOK pp tx u@(UTxO utxo) frxo = + let txBody = tx ^. bodyTxL + collateral' = txBody ^. collateralInputsTxBodyL -- Inputs allocated to pay txfee + -- restrict Utxo to those inputs we use to pay fees. + utxoCollateral = eval (collateral' ◁ utxo) + theFee = txBody ^. feeTxBodyL -- Coin supplied to pay fees + minFee = getMinFeeTxUtxoFrxo pp tx u frxo + in sequenceA_ + [ -- Part 1: minfee pp tx ≤ txfee txBody + failureUnless (minFee <= theFee) (injectFailure $ FeeTooSmallUTxO minFee theFee) + , -- Part 2: (txrdmrs tx ≠ ∅ ⇒ validateCollateral) + unless (nullRedeemers $ tx ^. witsTxL . rdmrsTxWitsL) $ + validateTotalCollateral pp txBody utxoCollateral + ] + +getMinFeeTxUtxoFrxo :: + ( EraTx era + , BabelEraTxBody era + ) => + PParams era -> + Tx era -> + UTxO era -> + FRxO era -> + Coin +getMinFeeTxUtxoFrxo pparams tx utxo frxo = + getMinFeeTx pparams tx refScriptsSize + where + ins = + (tx ^. bodyTxL . referenceInputsTxBodyL) + `Set.union` (tx ^. bodyTxL . inputsTxBodyL) + `Set.union` (tx ^. bodyTxL . fulfillsTxBodyL) + refScripts = getReferenceScriptsNonDistinct utxo ins <> getReferenceScriptsNonDistinctFrxo frxo ins + refScriptsSize = Monoid.getSum $ foldMap (Monoid.Sum . originalBytesSize . snd) refScripts + +validateValueNotConservedUTxO :: + (EraUTxO era, Value era ~ MaryValue (EraCrypto era), BabelEraTxBody era) => + PParams era -> + UTxO era -> + FRxO era -> + CertState era -> + TxBody era -> + Test (BabelUtxoPredFailure era) +validateValueNotConservedUTxO pp utxo frxo certState txBody = + failureUnless (consumedValue == producedValue) $ ValueNotConservedUTxO consumedValue producedValue + where + consumedValue = consumed pp certState utxo frxo txBody + producedValue = produced pp certState txBody frxo + +-- | For eras before Conway, VState is expected to have an empty Map for vsDReps, and so deposit summed up is zero. +consumed :: + (Value era ~ MaryValue (EraCrypto era), MaryEraTxBody era) => + PParams era -> + CertState era -> + UTxO era -> + FRxO era -> + TxBody era -> + Value era +consumed pp certState = + getConsumedBabelValue + pp + (lookupDepositDState $ certState ^. certDStateL) + (lookupDepositVState $ certState ^. certVStateL) + +getConsumedBabelValue :: + (MaryEraTxBody era, Value era ~ MaryValue (EraCrypto era)) => + PParams era -> + (Credential 'Staking (EraCrypto era) -> Maybe Coin) -> + (Credential 'DRepRole (EraCrypto era) -> Maybe Coin) -> + UTxO era -> + FRxO era -> + TxBody era -> + MaryValue (EraCrypto era) +getConsumedBabelValue pp lookupStakingDeposit lookupDRepDeposit utxo _frxo txBody = + consumedValue <> MaryValue mempty mintedMultiAsset + where + mintedMultiAsset = filterMultiAsset (\_ _ -> (> 0)) $ txBody ^. mintTxBodyL + {- balance (txins tx ◁ u) + wbalance (txwdrls tx) + keyRefunds pp tx -} + consumedValue = + balance (txInsFilter utxo (txBody ^. inputsTxBodyL)) + <> inject (refunds <> withdrawals) + refunds = getTotalRefundsTxBody pp lookupStakingDeposit lookupDRepDeposit txBody + withdrawals = fold . unWithdrawals $ txBody ^. withdrawalsTxBodyL + +-- | Compute the lovelace which are created by the transaction +-- For eras before Conway, VState is expected to have an empty Map for vsDReps, and so deposit summed up is zero. +produced :: + (Value era ~ MaryValue (EraCrypto era), BabelEraTxBody era) => + PParams era -> + CertState era -> + TxBody era -> + FRxO era -> + Value era +produced pp certState = babelProducedValueFrxo pp (flip Map.member $ certState ^. certPStateL . psStakePoolParamsL) + +babelProducedValueFrxo :: + (BabelEraTxBody era, Value era ~ MaryValue (EraCrypto era)) => + PParams era -> + (KeyHash 'StakePool (EraCrypto era) -> Bool) -> + TxBody era -> + FRxO era -> + Value era +babelProducedValueFrxo pp isStakePool txBody _frxo = + babelProducedValue pp isStakePool txBody + <+> undefined -- TODO WG ????? balance (frxo (st .utxoTemp) ∣ txb .fulfills) \ No newline at end of file diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs index ad28e0abe92..8b74c95ab59 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs @@ -23,11 +23,11 @@ module Cardano.Ledger.Babel.Rules.Utxos ( BabelUtxosEvent (..), ) where -import Cardano.Ledger.Alonzo.Plutus.Context (ContextError, EraPlutusContext) +import Cardano.Ledger.Alonzo.Plutus.Context (ContextError, EraPlutusContext (..)) import Cardano.Ledger.Alonzo.Plutus.Evaluate ( CollectError (..), - collectPlutusScriptsWithContext, evalPlutusScripts, + lookupPlutusScript, ) import Cardano.Ledger.Alonzo.Rules ( AlonzoUtxoEvent (..), @@ -45,9 +45,11 @@ import qualified Cardano.Ledger.Alonzo.Rules as Alonzo ( AlonzoUtxosEvent (..), AlonzoUtxosPredFailure (..), ) +import Cardano.Ledger.Alonzo.Scripts (plutusScriptLanguage, toAsItem, toAsIx) +import Cardano.Ledger.Alonzo.TxWits (lookupRedeemer) import Cardano.Ledger.Alonzo.UTxO ( - AlonzoEraUTxO, - AlonzoScriptsNeeded, + AlonzoEraUTxO (..), + AlonzoScriptsNeeded (..), ) import Cardano.Ledger.Babbage.Collateral (collAdaBalance, collOuts) import Cardano.Ledger.Babbage.Rules ( @@ -58,10 +60,10 @@ import Cardano.Ledger.Babbage.Rules ( import Cardano.Ledger.Babbage.Tx import Cardano.Ledger.Babel.Core import Cardano.Ledger.Babel.Era (BabelEra, BabelUTXOS) -import Cardano.Ledger.Babel.FRxO (txfrxo) +import Cardano.Ledger.Babel.FRxO (getBabelScriptsNeededFrxo, getScriptsProvidedFrxo, txfrxo) import Cardano.Ledger.Babel.LedgerState.Types (UTxOStateTemp (..), utxostDonationL) import Cardano.Ledger.Babel.TxInfo () -import Cardano.Ledger.BaseTypes (Globals (..), ShelleyBase) +import Cardano.Ledger.BaseTypes import Cardano.Ledger.Binary ( DecCBOR (..), EncCBOR (..), @@ -72,8 +74,13 @@ import Cardano.Ledger.Coin (Coin (Coin), DeltaCoin (..)) import Cardano.Ledger.Conway.Core (ConwayEraPParams, ConwayEraTxBody (treasuryDonationTxBodyL)) import Cardano.Ledger.Conway.Governance (ConwayGovState (..)) import Cardano.Ledger.FRxO (FRxO (FRxO, unFRxO)) -import Cardano.Ledger.Plutus (PlutusWithContext, ScriptFailure (..)) -import Cardano.Ledger.Plutus.Evaluate (ScriptResult (..)) +import Cardano.Ledger.Plutus ( + PlutusWithContext (..), + ScriptFailure (..), + costModelsValid, + getPlutusData, + ) +import Cardano.Ledger.Plutus.Evaluate (PlutusDatums (..), ScriptResult (..)) import Cardano.Ledger.SafeHash (SafeHash, hashAnnotated) import Cardano.Ledger.Shelley.LedgerState ( CertState, @@ -81,18 +88,25 @@ import Cardano.Ledger.Shelley.LedgerState ( updateStakeDistribution, ) import Cardano.Ledger.Shelley.Rules (UtxoEnv (..)) -import Cardano.Ledger.UTxO (EraUTxO (..), UTxO (UTxO, unUTxO)) +import Cardano.Ledger.Slot (EpochInfo) +import Cardano.Ledger.UTxO (EraUTxO (..), ScriptsProvided (..), UTxO (UTxO, unUTxO)) import Cardano.Ledger.Val ((<->)) +import Cardano.Slotting.Time (SystemStart) import Control.DeepSeq (NFData) +import Control.Monad (guard) import Control.Monad.Trans.Reader (asks) import Control.State.Transition.Extended import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.Map as Map import Data.MapExtras (extractKeys) +import Data.Maybe (mapMaybe) +import qualified Data.Set as Set +import Data.Text (Text) import Debug.Trace (traceEvent) import GHC.Generics (Generic) import Lens.Micro import NoThunks.Class (NoThunks) +import PlutusLedgerApi.V4 () data BabelUtxosPredFailure era = -- | The 'isValid' tag on the transaction is incorrect. The tag given @@ -405,10 +419,8 @@ updateUTxOState pp utxos txBody certState govState depositChangeEvent txUtxODiff babelEvalScriptsTxInvalid :: forall era. ( AlonzoEraTx era - , BabbageEraTxBody era , EraPlutusContext era , AlonzoEraUTxO era - , ScriptsNeeded era ~ AlonzoScriptsNeeded era , STS (EraRule "UTXOS" era) , Environment (EraRule "UTXOS" era) ~ UtxoEnv era , Signal (EraRule "UTXOS" era) ~ Tx era @@ -416,10 +428,11 @@ babelEvalScriptsTxInvalid :: , BaseM (EraRule "UTXOS" era) ~ ShelleyBase , Event (EraRule "UTXOS" era) ~ BabelUtxosEvent era , PredicateFailure (EraRule "UTXOS" era) ~ BabelUtxosPredFailure era + , BabelEraTxBody era ) => TransitionRule (EraRule "UTXOS" era) babelEvalScriptsTxInvalid = do - TRC (UtxoEnv _ pp _, us@(UTxOStateTemp utxo _ _ fees _ _ _), tx) <- judgmentContext + TRC (UtxoEnv _ pp _, us@(UTxOStateTemp utxo frxo _ fees _ _ _), tx) <- judgmentContext {- txb := txbody tx -} let txBody = tx ^. bodyTxL sysSt <- liftSTS $ asks systemStart @@ -427,7 +440,7 @@ babelEvalScriptsTxInvalid = do () <- pure $! traceEvent invalidBegin () - case collectPlutusScriptsWithContext ei sysSt pp tx utxo of + case collectPlutusScriptsWithContextFrxo ei sysSt pp tx utxo frxo of Right sLst -> {- sLst := collectTwoPhaseScriptInputs pp tx utxo -} {- isValid tx = evalScripts tx sLst = False -} @@ -455,3 +468,82 @@ babelEvalScriptsTxInvalid = do , utxostFees = fees <> Coin collateralFees -- NEW to Babbage , utxostStakeDistr = updateStakeDistribution pp (utxostStakeDistr us) (UTxO utxoDel) (UTxO collouts) } + +-- To Babel Fees implementers: This function is NOT in the right place. +-- Given more time, I'd do something with the EraUTxO class. +collectPlutusScriptsWithContextFrxo :: + forall era. + ( AlonzoEraTxWits era + , AlonzoEraUTxO era + , EraPlutusContext era + , BabelEraTxBody era + ) => + EpochInfo (Either Text) -> + SystemStart -> + PParams era -> + Tx era -> + UTxO era -> + FRxO era -> + Either [CollectError era] [PlutusWithContext (EraCrypto era)] +collectPlutusScriptsWithContextFrxo epochInfo sysStart pp tx utxo frxo = + -- TODO: remove this whole complicated check when we get into Conway. It is much simpler + -- to fail on a CostModel lookup in the `apply` function (already implemented). + let missingCostModels = Set.filter (`Map.notMember` costModels) usedLanguages + in case guard (protVerMajor < natVersion @9) >> Set.lookupMin missingCostModels of + Just l -> Left [NoCostModel l] + Nothing -> + merge + apply + (map getScriptWithRedeemer neededPlutusScripts) + (Right []) + where + -- Check on a protocol version to preserve failure mode (a single NoCostModel failure + -- for languages with missing cost models) until we are in Conway era. After we hard + -- fork into Conway it will be safe to remove this check together with the + -- `missingCostModels` lookup + -- + -- We also need to pass major protocol version to the script for script evaluation + protVerMajor = pvMajor (pp ^. ppProtocolVersionL) + costModels = costModelsValid $ pp ^. ppCostModelsL + + ScriptsProvided scriptsProvided = getScriptsProvided utxo tx <> getScriptsProvidedFrxo frxo tx + AlonzoScriptsNeeded scriptsNeeded = getBabelScriptsNeededFrxo utxo frxo (tx ^. bodyTxL) + neededPlutusScripts = + mapMaybe (\(sp, sh) -> (,) (sh, sp) <$> lookupPlutusScript scriptsProvided sh) scriptsNeeded + usedLanguages = Set.fromList $ map (plutusScriptLanguage . snd) neededPlutusScripts + + getScriptWithRedeemer ((plutusScriptHash, plutusPurpose), plutusScript) = + let redeemerIndex = hoistPlutusPurpose toAsIx plutusPurpose + in case lookupRedeemer redeemerIndex $ tx ^. witsTxL . rdmrsTxWitsL of + Just (d, exUnits) -> Right (plutusScript, plutusPurpose, d, exUnits, plutusScriptHash) + Nothing -> Left (NoRedeemer (hoistPlutusPurpose toAsItem plutusPurpose)) + apply (plutusScript, plutusPurpose, d, exUnits, plutusScriptHash) = do + let lang = plutusScriptLanguage plutusScript + costModel <- maybe (Left (NoCostModel lang)) Right $ Map.lookup lang costModels + case mkPlutusScriptContext plutusScript plutusPurpose pp epochInfo sysStart utxo tx of + Right scriptContext -> + let spendingDatum = getSpendingDatum utxo tx $ hoistPlutusPurpose toAsItem plutusPurpose + datums = maybe id (:) spendingDatum [d, scriptContext] + in Right $ + withPlutusScript plutusScript $ \plutus -> + PlutusWithContext + { pwcProtocolVersion = protVerMajor + , pwcScript = Left plutus + , pwcScriptHash = plutusScriptHash + , pwcDatums = PlutusDatums (getPlutusData <$> datums) + , pwcExUnits = exUnits + , pwcCostModel = costModel + } + Left te -> Left $ BadTranslation te + merge :: forall t b a. (t -> Either a b) -> [Either a t] -> Either [a] [b] -> Either [a] [b] + merge _f [] answer = answer + merge f (x : xs) zs = merge f xs (gg x zs) + where + gg :: Either a t -> Either [a] [b] -> Either [a] [b] + gg (Right t) (Right cs) = + case f t of + Right c -> Right $ c : cs + Left e -> Left [e] + gg (Left a) (Right _) = Left [a] + gg (Right _) (Left cs) = Left cs + gg (Left a) (Left cs) = Left (a : cs) \ No newline at end of file diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs index 7e08e38bde6..c4c5247ab2b 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxow.hs @@ -37,7 +37,6 @@ import Cardano.Ledger.Alonzo.Rules ( AlonzoUtxowEvent (WrappedShelleyEraEvent), AlonzoUtxowPredFailure, hasExactSetOfRedeemers, - missingRequiredDatums, ppViewHashesMatch, ) import qualified Cardano.Ledger.Alonzo.Rules as Alonzo (AlonzoUtxowPredFailure (..)) @@ -56,6 +55,7 @@ import qualified Cardano.Ledger.Babbage.Rules as Babbage ( import Cardano.Ledger.Babbage.UTxO (getReferenceScripts) import Cardano.Ledger.Babel.Core import Cardano.Ledger.Babel.Era (BabelEra, BabelUTXO, BabelUTXOW) +import Cardano.Ledger.Babel.FRxO import Cardano.Ledger.Babel.LedgerState.Types (UTxOStateTemp (..)) import Cardano.Ledger.Babel.Rules.Utxo (BabelUtxoPredFailure) import Cardano.Ledger.Babel.Rules.Utxos (BabelUtxosPredFailure) @@ -70,23 +70,21 @@ import Cardano.Ledger.Binary.Coders ( (!>), ( @@ -401,13 +400,13 @@ shelleyToBabelUtxowPredFailure = \case Jump to CIP-0118#UTXO-rule to continue... -} --- | UTXOW transition rule that is used in Babbage and Babel era. +-- | UTXOW transition rule that is used in Babel era. babelUtxowTransition :: forall era. ( AlonzoEraTx era , AlonzoEraUTxO era , ScriptsNeeded era ~ AlonzoScriptsNeeded era - , BabbageEraTxBody era + , BabelEraTxBody era , Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentTxBody) , Environment (EraRule "UTXOW" era) ~ Shelley.UtxoEnv era , Signal (EraRule "UTXOW" era) ~ Tx era @@ -430,15 +429,20 @@ babelUtxowTransition = do {- txw := txwits tx -} {- witsKeyHashes := { hashKey vk | vk ∈ dom(txwitsVKey txw) } -} let utxo = utxostUtxo u + frxo = utxostFrxo u txBody = tx ^. bodyTxL witsKeyHashes = witsFromTxWitnesses tx - inputs = (txBody ^. referenceInputsTxBodyL) `Set.union` (txBody ^. inputsTxBodyL) + inputs = + (txBody ^. referenceInputsTxBodyL) + `Set.union` (txBody ^. inputsTxBodyL) + `Set.union` (txBody ^. fulfillsTxBodyL) + `Set.union` (txBody ^. requiredTxsTxBodyL) -- check scripts {- neededHashes := {h | ( , h) ∈ scriptsNeeded utxo txb} -} {- neededHashes − dom(refScripts tx utxo) = dom(txwitscripts txw) -} - let scriptsNeeded = getScriptsNeeded utxo txBody - scriptsProvided = getScriptsProvided utxo tx + let scriptsNeeded = getBabelScriptsNeededFrxo utxo frxo txBody + scriptsProvided = getScriptsProvided utxo tx <> getScriptsProvidedFrxo frxo tx scriptHashesNeeded = getScriptsHashesNeeded scriptsNeeded {- ∀s ∈ (txscripts txw utxo neededHashes ) ∩ Scriptph1 , validateScript s tx -} -- CHANGED In BABBAGE txscripts depends on UTxO @@ -446,11 +450,13 @@ babelUtxowTransition = do {- neededHashes − dom(refScripts tx utxo) = dom(txwitscripts txw) -} let sReceived = Map.keysSet $ tx ^. witsTxL . scriptTxWitsL - sRefs = Map.keysSet $ getReferenceScripts utxo inputs + sRefs = + Map.keysSet (getReferenceScripts utxo inputs) + <> Map.keysSet (getReferenceScriptsFrxo frxo inputs) runTest $ babbageMissingScripts pp scriptHashesNeeded sRefs sReceived {- inputHashes ⊆ dom(txdats txw) ⊆ allowed -} - runTest $ missingRequiredDatums utxo tx + runTest $ missingRequiredDatumsFrxo utxo frxo tx {- dom (txrdmrs tx) = { rdptr txb sp | (sp, h) ∈ scriptsNeeded utxo tx, h ↦ s ∈ txscripts txw, s ∈ Scriptph2} -} @@ -464,7 +470,7 @@ babelUtxowTransition = do runTestOnSignal $ validateVerifiedWits tx {- witsVKeyNeeded utxo tx genDelegs ⊆ witsKeyHashes -} - runTest $ validateNeededWitnesses witsKeyHashes certState utxo txBody + runTestOnSignal $ validateNeededWitnessesFrxo witsKeyHashes certState utxo frxo txBody -- TODO WG what should this actually do differently? -- check metadata hash {- adh := txADhash txb; ad := auxiliaryData tx -} @@ -487,44 +493,20 @@ babelUtxowTransition = do trans @(EraRule "UTXO" era) $ TRC (utxoEnv, u, tx) --- | Determine if the UTxO witnesses in a given transaction are correct. -validateVerifiedWits :: +-- To Babel Fees implementers: This function is NOT in the right place. +-- Given more time, I'd do something with the EraUTxO class. +validateNeededWitnessesFrxo :: forall era. - ( EraTx era - , Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentTxBody) - ) => - Tx era -> - Test (ShelleyUtxowPredFailure era) -validateVerifiedWits tx = - case failed of - [] -> pure () - nonEmpty -> failure $ Shelley.InvalidWitnessesUTXOW nonEmpty - where - txBody = tx ^. bodyTxL - -- txRequiredTxs = tx ^. requiredTxsTxL - failed = - failed' witVKeyVerifier - <> failedBootstrap bootstrapWitVerifier - (witVKeyVerifier, bootstrapWitVerifier) = - -- case txRequiredTxs == mempty of - -- True -> - let txBodyHash = extractHash (hashAnnotated txBody) - in (verifyWitVKey txBodyHash, verifyBootstrapWit txBodyHash) - -- False -> - -- let _a = extractHash (hashAnnotated txBody) - -- _b = extractHash (hashAnnotated txRequiredTxs) - -- in undefined - -- let compositeHash = extractHash (hashAnnotated (txBody, txs)) - -- in (verifyWitVKeyRequiredTxs compositeHash, verifyBootstrapWitRequiredTxs compositeHash) - wvkKey (WitVKey k _) = k - - failed' witnessVerification = - wvkKey - <$> filter - (not . witnessVerification) - (Set.toList $ tx ^. witsTxL . addrTxWitsL) - failedBootstrap witnessVerification = - bwKey - <$> filter - (not . witnessVerification) - (Set.toList $ tx ^. witsTxL . bootAddrTxWitsL) \ No newline at end of file + (EraUTxO era, BabelEraTxBody era) => + -- | Provided witness + Set (KeyHash 'Witness (EraCrypto era)) -> + CertState era -> + UTxO era -> + FRxO era -> + TxBody era -> + Validation (NonEmpty (ShelleyUtxowPredFailure era)) () +validateNeededWitnessesFrxo witsKeyHashes certState utxo frxo txBody = + let needed = getWitsVKeyNeededFrxo certState utxo frxo txBody + missingWitnesses = Set.difference needed witsKeyHashes + in failureUnless (Set.null missingWitnesses) $ + Shelley.MissingVKeyWitnessesUTXOW @era missingWitnesses diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs index 8d8825f9ff4..899ce2685ff 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Zone.hs @@ -75,6 +75,7 @@ import GHC.Generics (Generic) import Lens.Micro ((^.)) import Lens.Micro.Type (Lens') +import Cardano.Ledger.Alonzo.Core (ppCollateralPercentageL) import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext) import Cardano.Ledger.Alonzo.Plutus.Evaluate (collectPlutusScriptsWithContext, evalPlutusScripts) import Cardano.Ledger.Alonzo.Rules ( @@ -86,7 +87,7 @@ import Cardano.Ledger.Alonzo.Rules ( ) import Cardano.Ledger.Alonzo.UTxO (AlonzoEraUTxO, AlonzoScriptsNeeded) import Cardano.Ledger.Babbage.Collateral (collAdaBalance, collOuts) -import Cardano.Ledger.Babel.Core (ppMaxTxExUnitsL) +import Cardano.Ledger.Babel.Core (BabbageEraTxBody (totalCollateralTxBodyL), ppMaxTxExUnitsL) import Cardano.Ledger.Babel.LedgerState.Types ( LedgerStateTemp, fromLedgerState, @@ -98,7 +99,7 @@ import Cardano.Ledger.Babel.Rules.Utxo (BabelUtxoPredFailure (..)) import Cardano.Ledger.Babel.Rules.Utxos (BabelUtxosPredFailure (CollectErrors)) import Cardano.Ledger.Babel.Rules.Utxow (BabelUtxowPredFailure) import Cardano.Ledger.Coin (Coin (..), DeltaCoin (DeltaCoin)) -import Cardano.Ledger.Core (PParams, ppMaxTxSizeL, sizeTxF) +import Cardano.Ledger.Core (PParams, feeTxBodyL, ppMaxTxSizeL, sizeTxF) import Cardano.Ledger.Plutus ( PlutusWithContext, ScriptFailure (scriptFailurePlutus), @@ -264,8 +265,13 @@ zoneTransition = , txs :: Seq (Tx era) ) ) -> do + let tx = last (Foldable.toList txs) -- TODO WG use safe head {- ((totSizeZone ltx) ≤ᵇ (Γ .LEnv.pparams .PParams.maxTxSize)) ≡ true -} runTestOnSignal $ validateMaxTxSizeUTxO pParams (Foldable.toList txs) + -- ((coin (balance (utxo ∣ tx .body .collateral)) * 100) ≥ᵇ sumCol ltx (Γ .LEnv.pparams .PParams.collateralPercentage)) ≡ true + runTestOnSignal $ + failureUnless (all (checkCollateral pParams txs) (tx ^. bodyTxL . totalCollateralTxBodyL)) $ + InsufficientCollateral undefined undefined -- TODO WG figure the error args out if you have time if all chkIsValid txs -- ZONE-V then do -- TODO WG: make sure `runTestOnSignal` is correct rather than `runTest` @@ -338,6 +344,11 @@ zoneTransition = chkExactlyLastInvalid txs = case reverse txs of (l : txs') -> (l ^. isValidTxL == IsValid False) && all ((== IsValid True) . (^. isValidTxL)) txs' [] -> True + checkCollateral txs pParams c = unCoin c * 100 >= requiredCollateral txs pParams + requiredCollateral pParams txs = unCoin $ sumCol (Foldable.toList txs) (collateralPercentage pParams) + collateralPercentage pParams = toInteger $ pParams ^. ppCollateralPercentageL + sumCol :: [Tx era] -> Integer -> Coin + sumCol tb cp = Coin $ foldr (\tx c -> c + (unCoin (tx ^. bodyTxL . feeTxBodyL) * cp)) 0 tb babelEvalScriptsTxInvalid :: forall era. @@ -377,6 +388,7 @@ babelEvalScriptsTxInvalid = () <- pure $! traceEvent invalidBegin () + -- TODO WG Should this script collection even happen here (obviously collat needs collecting but is this too much?)? {- TODO WG: I think you actually need a different function that collects Plutus scripts from ALL transactions, but just using the collateral for the last one? Or evals scripts from ALL txs? Or something like that? @@ -488,9 +500,9 @@ updateRES tx1 ((tx, tx') : em) s = then (fst (updateRES tx1 em (ifNoEdgeRemove tx em s)), ifNoEdgeRemove tx em s) else ((tx, tx') : fst (updateRES tx1 em s), s) --- -- topologically sorts a tx list --- -- arguments : tracking edges for agda termination check, remaining edges, remaining txs with no incoming edge (S), current sorted list (L) --- -- returns nothing if there are remaining edges the graph, but S is empty +-- topologically sorts a tx list +-- arguments : tracking edges for agda termination check, remaining edges, remaining txs with no incoming edge (S), current sorted list (L) +-- returns nothing if there are remaining edges the graph, but S is empty topSortTxs :: EraTx era => [(Tx era, Tx era)] -> [(Tx era, Tx era)] -> [Tx era] -> [Tx era] -> Maybe [Tx era] topSortTxs _ [] _ srtd = Just srtd diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/UTxO.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/UTxO.hs index 48af478772b..482d3ea3e1e 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/UTxO.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/UTxO.hs @@ -5,6 +5,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary.hs b/eras/mary/impl/src/Cardano/Ledger/Mary.hs index 33f330c3e30..c68666e3ab0 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary.hs @@ -13,7 +13,7 @@ module Cardano.Ledger.Mary ( MaryEra, ShelleyTx, ShelleyTxOut, - MaryValue, + MaryValue (MaryValue), MaryTxBody, ) where @@ -31,7 +31,7 @@ import Cardano.Ledger.Mary.TxAuxData () import Cardano.Ledger.Mary.TxBody (MaryTxBody) import Cardano.Ledger.Mary.TxSeq () import Cardano.Ledger.Mary.UTxO () -import Cardano.Ledger.Mary.Value (MaryValue) +import Cardano.Ledger.Mary.Value (MaryValue (MaryValue)) import Cardano.Ledger.Shelley.API type Mary = MaryEra StandardCrypto diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/UTxO.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/UTxO.hs index 8acaa3714f9..bead23fbf86 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/UTxO.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/UTxO.hs @@ -229,7 +229,7 @@ getScriptHash _ = Nothing newtype ScriptsProvided era = ScriptsProvided { unScriptsProvided :: Map.Map (ScriptHash (EraCrypto era)) (Script era) } - deriving (Generic) + deriving (Generic, Semigroup) deriving instance (Era era, Eq (Script era)) => Eq (ScriptsProvided era) deriving instance (Era era, Ord (Script era)) => Ord (ScriptsProvided era) From 327e5ac11a41484a7ff1868c163b1c03e68a3931 Mon Sep 17 00:00:00 2001 From: Will Gould Date: Thu, 11 Jul 2024 16:07:23 +0100 Subject: [PATCH 19/19] Comment chain change --- eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs index 8b74c95ab59..f33c1d4a2a1 100644 --- a/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs +++ b/eras/babel/impl/src/Cardano/Ledger/Babel/Rules/Utxos.hs @@ -293,9 +293,7 @@ to what we already do with the UTxO. Note that I'm unsure if we actually need to do anything with `deletedFrxO`, and so the `txFrxODiffEvent` argument, and the event it uses, `TxFRxODiff`, might be redundant. -I've included these elements to keep parity with the UTxO logic. - -Jump to ??? to continue... -} +I've included these elements to keep parity with the UTxO logic. -} utxosTransition :: forall era. ( AlonzoEraTx era