diff --git a/cabal.project b/cabal.project index 3d76c4cc97..39635feaae 100644 --- a/cabal.project +++ b/cabal.project @@ -14,16 +14,52 @@ repository cardano-haskell-packages -- update either of these. index-state: -- Bump this if you need newer packages from Hackage - , hackage.haskell.org 2026-05-18T17:14:36Z + , hackage.haskell.org 2026-06-29T22:49:53Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2026-05-18T13:56:34Z - -active-repositories: - , :rest - , cardano-haskell-packages:override + , cardano-haskell-packages 2026-07-02T10:10:00Z packages: . +-- kes-agent on branch f-f/allow-crypto-class-2.5 +source-repository-package + type: git + location: https://github.com/f-f/kes-agent.git + tag: 32c1ed675d22a30735d9f22f7afa436a3ef3e64a + --sha256: sha256-o7hFX1JnraS6Xq0WoXQwd9Z8GsPPv0Ls2DWvZ08o0ZU= + subdir: + kes-agent + kes-agent-crypto + +-- cardano-ledger on master 2026-06-30 +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-ledger.git + tag: e9827fdc3def69c02fe826fdf46e2a412620ef98 + --sha256: sha256-bVR1ZFs1VDc7ag2QEpSf5rVj1mdBCB/Ag7nhj00UXQE= + subdir: + eras/allegra/impl + eras/alonzo/impl + eras/babbage/impl + eras/byron/chain/executable-spec + eras/byron/crypto + eras/byron/ledger/executable-spec + eras/byron/ledger/impl + eras/conway/impl + eras/dijkstra/impl + eras/mary/impl + eras/shelley/impl + eras/shelley/test-suite + eras/shelley-ma/test-suite + libs/cardano-data + libs/cardano-ledger-api + libs/cardano-ledger-binary + libs/cardano-ledger-core + libs/cardano-protocol + libs/cardano-protocol-tpraos + libs/non-integral + libs/small-steps + libs/vector-map + -- We want to always build the test-suites and benchmarks tests: true benchmarks: true @@ -47,13 +83,24 @@ if os (windows) constraints: tasty <1.5.4, --- ouroboros-network dependency after introducing `bracketKeepAlive` (PR#5371) +-- on latest main branch source-repository-package type: git - location: https://github.com/IntersectMBO/ouroboros-network - tag: e8d59d8a219563760fc21ba5bc86fab77d886742 - --sha256: sha256-ElgaE5JeDTPfyDQnyZs5ZlOdzlnZYl7z1OgkzCBJjek= + location: https://github.com/IntersectMBO/ouroboros-network.git + tag: 0a614a36c8969e53fd6a1c3890b36da5aff3b0a2 + --sha256: sha256-p32/Y6jXwiSwa0yVspdx246KHaCBmqe2zB+UpxudeJc= subdir: ouroboros-network cardano-diffusion network-mux + +-- plutus on branch master +source-repository-package + type: git + location: https://github.com/IntersectMBO/plutus.git + tag: b1db04cc425fab303ac3b79d7140dc2a17f29e6d + --sha256: sha256-XtYzjNVx4+IGWpgm+p/YTf56DrJtK0I98umZCTE3U80= + subdir: + plutus-core + plutus-ledger-api + plutus-tx diff --git a/cabal/newer-ghcs.cabal b/cabal/newer-ghcs.cabal index 8e21339dee..efd06abdf5 100644 --- a/cabal/newer-ghcs.cabal +++ b/cabal/newer-ghcs.cabal @@ -24,4 +24,5 @@ if impl (ghc >= 9.14) , serialise:base , serialise:containers , serialise:time + , tdigest:base , with-utf8:base diff --git a/changelog.d/20260528_154230_fabrizio.ferrai_node_11.1_praos_ledgerview_and_envelope_checks.md b/changelog.d/20260528_154230_fabrizio.ferrai_node_11.1_praos_ledgerview_and_envelope_checks.md new file mode 100644 index 0000000000..6a32babddc --- /dev/null +++ b/changelog.d/20260528_154230_fabrizio.ferrai_node_11.1_praos_ledgerview_and_envelope_checks.md @@ -0,0 +1,15 @@ +### Breaking + +- Renamed `Ouroboros.Consensus.Protocol.Praos.Views.LedgerView` to `PraosLedgerView`, + with the fields renamed from `lv*` to `plv*`. +- Removed `PraosEnvelopeError` from the exports of `Ouroboros.Consensus.Shelley.Protocol.Praos`. +- `EnvelopeCheckError (Praos c)` and `EnvelopeCheckError (TPraos c)` are both now + `Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks.EnvelopeError`. +- Removed modules `Ouroboros.Consensus.Protocol.Praos.Header` and + `Ouroboros.Consensus.Protocol.Praos.VRF`. They are now provided by the `cardano-protocol` package (as `Cardano.Protocol.Praos.BlockHeader` and `Cardano.Protocol.Praos.VRF`); import from there instead. + +### Non-Breaking + +- Add module `Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks`; consolidates + envelope-check logic previously inlined in `Ouroboros.Consensus.Shelley.Protocol.{Praos,TPraos}`. +- Add `forecastToPraosLedgerView` to `Ouroboros.Consensus.Protocol.Praos.Views`. diff --git a/changelog.d/20260528_154231_fabrizio.ferrai_node_11.1_ledger_forecast_api.md b/changelog.d/20260528_154231_fabrizio.ferrai_node_11.1_ledger_forecast_api.md new file mode 100644 index 0000000000..5db90e84c9 --- /dev/null +++ b/changelog.d/20260528_154231_fabrizio.ferrai_node_11.1_ledger_forecast_api.md @@ -0,0 +1,17 @@ +### Breaking + +- Change `ShelleyBasedEra` class superclass constraints: + - change `SL.ApplyBlock era` to `SL.ApplyTick era`. + - change `SL.GetLedgerView era` to `SL.EraForecast era`. + - remove `NoThunks (PredicateFailure (EraRule "BBODY" era))`. +- `ShelleyCompatible proto era` has three new superclass constraints: + - `EncCBORGroup (SL.BlockBody era)`, + - `SL.EraBlockHeader (ShelleyProtocolHeader proto) era`, + - `SL.ApplyBlock (ShelleyProtocolHeader proto) era`. +- Remove `ShelleyCompatible (TPraos c) BabbageEra`, `ShelleyCompatible (TPraos c) ConwayEra`, + and `ShelleyCompatible (TPraos c) DijkstraEra` instances from `Ouroboros.Consensus.Shelley.HFEras`. + These eras now run under Praos only. +- Remove the `ProtocolHeaderSupportsLedger` class from `Ouroboros.Consensus.Shelley.Protocol.Abstract`. +- `LedgerSupportsProtocol (ShelleyBlock (TPraos crypto) era)` instance now requires `SL.ShelleyEraForecast era`. +- `LedgerSupportsProtocol (ShelleyBlock (Praos crypto) era)` instance no longer requires + `ShelleyCompatible (TPraos crypto) era` and instead requires `SL.EraForecast era`. diff --git a/changelog.d/20260528_154232_fabrizio.ferrai_node_11.1_monadic_genesis_data.md b/changelog.d/20260528_154232_fabrizio.ferrai_node_11.1_monadic_genesis_data.md new file mode 100644 index 0000000000..30d378c244 --- /dev/null +++ b/changelog.d/20260528_154232_fabrizio.ferrai_node_11.1_monadic_genesis_data.md @@ -0,0 +1,5 @@ +### Breaking + +- `protocolInfoCardano`, `protocolInfoShelley` and `protocolInfoTPraosShelleyBased` + now take an additional initial argument `SomeHasFS m` and returns + inside `m`. Their callback for creating blocks also returns values in `m`. diff --git a/changelog.d/20260528_154233_fabrizio.ferrai_node_11.1_bump_lower_bounds.md b/changelog.d/20260528_154233_fabrizio.ferrai_node_11.1_bump_lower_bounds.md new file mode 100644 index 0000000000..906d66604e --- /dev/null +++ b/changelog.d/20260528_154233_fabrizio.ferrai_node_11.1_bump_lower_bounds.md @@ -0,0 +1,36 @@ +### Breaking + +- The constraint on the following functions tightens from `Applicative m` to `Monad m`: + - `Ouroboros.Consensus.Storage.ImmutableDB.Impl.defaultArgs` + - `Ouroboros.Consensus.Storage.LedgerDB.Args.defaultArgs` + - `Ouroboros.Consensus.Storage.VolatileDB.Impl.defaultArgs` + - `Ouroboros.Consensus.Storage.PerasCertDB.Impl.defaultArgs` + - `Ouroboros.Consensus.Storage.PerasVoteDB.Impl.defaultArgs` + - `Ouroboros.Consensus.Storage.ChainDB.Impl.Args.updateTracer` + - `Ouroboros.Consensus.Storage.ChainDB.Impl.fromChainDbEnv` + - `Ouroboros.Consensus.Util.Enclose.encloseWith` + - `Ouroboros.Consensus.Storage.LedgerDB.decorateReplayTracerWithGoal` + - `Ouroboros.Consensus.Storage.LedgerDB.decorateReplayTracerWithStart` +- `Ouroboros.Consensus.Network.NodeToClient.showTracers`, + `Ouroboros.Consensus.Network.NodeToNode.showTracers`, and + `Ouroboros.Consensus.Node.Tracers.showTracers` now require `Monad m`. +- Remove the `NoThunks FsPath` orphan instance from `Ouroboros.Consensus.Util.Orphans`; + it is now provided upstream by `cardano-ledger` (`Cardano.Ledger.Orphans` in + `cardano-ledger-core`). +- Remove the orphan `Measure ()` instance from + `Ouroboros.Consensus.Ledger.SupportsMempool`. +- `HasBLSContext` instances for `SIGN` and `VRF` now use `minSigPoPDST` as their base context. +- Upgrade lower bounds for Node 11.1 integration of upstream packages `cardano-base`, + `cardano-ledger`, `kes-agent`, `ouroboros-network`, `validation` + +### Non-Breaking + +- Add `Ouroboros.Network.Tx.HasRawTxId` instances for the transaction-id type of every block: + `ByronBlock`, `ShelleyBlock`, `HardForkBlock`, `DualBlock`, and `SimpleBlock`. + To match, the `RunNode` class now has a `HasRawTxId (TxId (GenTx blk))` superclass. +- The Shelley ledger queries `GetFilteredDelegationsAndRewardAccounts`, + `GetStakeDelegDeposits`, `GetFilteredVoteDelegatees` and `GetPoolDistr2` are now + answered by the corresponding `cardano-ledger` functions + (`queryStakePoolDelegsAndRewards`, `queryAccountsDeposits`, `queryDRepDelegatees`, + `querySetSnapshotStakePoolDistr`) instead of being implemented in consensus. The + query results have not changed. diff --git a/flake.lock b/flake.lock index 2c6157e936..182949c86c 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1779114033, - "narHash": "sha256-68Yi51Ps5hwP80M0UXw4GTROmyzRL02PEXDEYfVEB4M=", + "lastModified": 1782990451, + "narHash": "sha256-U0o77JuGp6ADqym7TtGV3AwzRn5SFuiTRyCOR6qfxGA=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "b20f09de9ba3099e0981a3bb9145847e7e2cfc24", + "rev": "def6ba6e0324e451802f5a17b12a00bd64639e14", "type": "github" }, "original": { @@ -236,11 +236,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1782396942, - "narHash": "sha256-EC5JVXFFPAtegqXpE7Vwx+NcqyDPGxdZrpmiXXssWhY=", + "lastModified": 1782820878, + "narHash": "sha256-Wwlo+XhShyLwZYAzgmOOTne18AjyLQKoqIcium4O2AI=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "5aa8be7d65a3faba7d279b47c48998244f54d4f3", + "rev": "cae1dbea78d3870bb7e318a046baa206ac38c0f5", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index f585742c6f..9a7d882671 100644 --- a/flake.nix +++ b/flake.nix @@ -76,11 +76,18 @@ { devShells = rec { default = ghc96; - ghc96 = hydraJobs.native.haskell96.devShell; - # Disabled because Plutus panics on it - # ghc96-ipe = hydraJobs.native.haskell96.devShellIPE; - ghc914 = hydraJobs.native.haskell914.devShell; - ghc914-ipe = hydraJobs.native.haskell914.devShellIPE; + ghc96 = import ./nix/shell.nix { + inherit inputs pkgs; + hsPkgs = pkgs.hsPkgs; + }; + ghc914 = import ./nix/shell.nix { + inherit inputs pkgs; + hsPkgs = pkgs.hsPkgs.projectVariants.ghc914; + }; + ghc914-ipe = import ./nix/shell.nix { + inherit inputs pkgs; + hsPkgs = pkgs.hsPkgs.projectVariants.ghc914.projectVariants.ipe; + }; agda-spec = pkgs.agda-spec.shell; diff --git a/ouroboros-consensus-cardano/app/check-tx-upgrade.hs b/ouroboros-consensus-cardano/app/check-tx-upgrade.hs new file mode 100644 index 0000000000..4934115811 --- /dev/null +++ b/ouroboros-consensus-cardano/app/check-tx-upgrade.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | A minimal executable that probes the transaction-id fidelity of the +-- Babbage->Conway era /upgrade/, to explain the following report: +-- +-- * The node's ledger is in Conway. +-- * A transaction submitted over LocalTxSubmission tagged as __Babbage__ is +-- rejected. +-- * The /same/ transaction submitted tagged as __Conway__ is accepted. +-- +-- A Babbage-tagged transaction is upgraded to Conway inside the mempool by +-- @hardForkInjectTxs@ (the Babbage->Conway 'InjectTx', reproduced verbatim as +-- 'babbageToConwayInjection'); a Conway-tagged transaction skips that step and +-- is validated directly. So any difference between the two paths comes entirely +-- from the upgrade. +-- +-- The mempool and consensus assume the upgrade is /transaction-id preserving/ +-- (see the invariant on @OneEraGenTxId@ in +-- 'Ouroboros.Consensus.HardFork.Combinator.AcrossEras'): a client signs the +-- transaction id of the era it built for, so if the upgrade changed the id, the +-- witnesses a client signed for the Babbage id would no longer match the id the +-- Conway ledger derives — which is exactly the shape of the report. +-- +-- This program builds one transaction body (with a non-empty input set, so that +-- any set/encoding differences between the eras are exercised) and prints three +-- transaction ids: +-- +-- 1. the Babbage-tagged tx id (what a client signs on the Babbage path) +-- 2. the id after Babbage->Conway upgrade (what the Conway ledger checks against) +-- 3. the native Conway-tagged tx id (what a client signs on the Conway path) +-- +-- If (1) and (2) differ, the upgrade is not id-preserving and witnesses signed +-- on the Babbage path cannot verify after the upgrade — a concrete root cause +-- for the report. If all three agree, the id is stable and the cause lies +-- elsewhere. +module Main (main) where + +import Cardano.Ledger.BaseTypes (TxIx (..)) +import qualified Cardano.Ledger.Core as SL +import Cardano.Ledger.TxIn (TxIn (..)) +import Control.Monad (when) +import Control.Monad.Except (runExcept) +import Data.SOP.BasicFunctors ((:.:) (Comp), unComp) +import qualified Data.Set as Set +import Lens.Micro ((&), (.~)) +import Ouroboros.Consensus.HardFork.Combinator.InjectTxs + ( InjectTx + , injectTxWith + , pattern InjectTx + ) +import Ouroboros.Consensus.Shelley.Eras (BabbageEra, ConwayEra) +import Ouroboros.Consensus.Shelley.HFEras + ( StandardBabbageBlock + , StandardConwayBlock + ) +import Ouroboros.Consensus.Shelley.Ledger.Mempool + ( GenTx (ShelleyTx) + , mkShelleyTx + ) +import Ouroboros.Consensus.Shelley.ShelleyHFC () +import System.Exit (exitFailure) + +-- | The Babbage->Conway transaction injection. +-- +-- This is a copy of @translateTxBabbageToConwayWrapper@ from +-- 'Ouroboros.Consensus.Cardano.CanHardFork' (which is not exported). It is one +-- link of the @InPairs InjectTx@ chain returned by @hardForkInjectTxs@; the +-- mempool walks that chain to step a transaction forward, one era at a time, +-- until it reaches the era the ledger currently sits in. +-- +-- The @'SL.TranslationContext' ConwayEra@ (a @ConwayGenesis@) is threaded +-- through only to match the shape of the real node code: the transaction-level +-- Conway translation is a pure CBOR round-trip and never forces it. We +-- therefore leave it 'undefined' — see 'main'. +babbageToConwayInjection :: + SL.TranslationContext ConwayEra -> + InjectTx StandardBabbageBlock StandardConwayBlock +babbageToConwayInjection ctxt = + InjectTx $ fmap unComp . eitherToMaybe . runExcept . SL.translateEra ctxt . Comp + where + eitherToMaybe = either (const Nothing) Just + +-- | Build a basic (invalid) transaction carrying a single input. The input's tx +-- id is stable and era-independent, so the Babbage and Conway transactions below +-- have identical /content/. +mkTxWithInput :: + forall era. + SL.EraTx era => + TxIn -> + SL.Tx SL.TopTx era +mkTxWithInput input = + SL.mkBasicTx (SL.mkBasicTxBody & SL.inputsTxBodyL .~ Set.singleton input) + +main :: IO () +main = do + let -- A single synthetic input, reusing the id of a basic empty tx. + dummyInput :: TxIn + dummyInput = + TxIn + (SL.txIdTx (SL.mkBasicTx SL.mkBasicTxBody :: SL.Tx SL.TopTx BabbageEra)) + (TxIx 0) + + babbageGenTx :: GenTx StandardBabbageBlock + babbageGenTx = mkShelleyTx (mkTxWithInput dummyInput) + + conwayNativeGenTx :: GenTx StandardConwayBlock + conwayNativeGenTx = mkShelleyTx (mkTxWithInput dummyInput) + + -- A minimal (empty) body, for comparison. Note this still contains the + -- always-present (here empty) inputs set, so it does not isolate set + -- encoding; it shows the Babbage and Conway body encoders differ even at + -- their smallest. + emptyBabbageId = case mkShelleyTx (SL.mkBasicTx SL.mkBasicTxBody) :: GenTx StandardBabbageBlock of + ShelleyTx i _ -> i + emptyConwayId = case mkShelleyTx (SL.mkBasicTx SL.mkBasicTxBody) :: GenTx StandardConwayBlock of + ShelleyTx i _ -> i + + -- Never forced by the transaction-level translation (see the haddock on + -- 'babbageToConwayInjection'). + conwayCtxt :: SL.TranslationContext ConwayEra + conwayCtxt = undefined + + case injectTxWith (babbageToConwayInjection conwayCtxt) babbageGenTx of + Nothing -> do + putStrLn "NOT UPGRADEABLE: the Babbage tx cannot be upgraded to Conway." + exitFailure + Just upgradedGenTx -> do + let ShelleyTx babbageId _ = babbageGenTx + ShelleyTx upgradedId _ = upgradedGenTx + ShelleyTx nativeId _ = conwayNativeGenTx + + putStrLn "Transaction ids (identical body content, one input, differing only in era tag / path):" + putStrLn $ " 1. Babbage-tagged : " ++ show babbageId + putStrLn $ " 2. after Babbage->Conway : " ++ show upgradedId + putStrLn $ " 3. native Conway-tagged : " ++ show nativeId + putStrLn "" + putStrLn "Minimal empty body, for comparison:" + putStrLn $ " Babbage-tagged : " ++ show emptyBabbageId + putStrLn $ " native Conway-tagged : " ++ show emptyConwayId + putStrLn "" + putStrLn $ " upgrade preserves tx id (1 == 2) : " ++ show (babbageId == upgradedId) + putStrLn $ " upgraded == native Conway (2 == 3) : " ++ show (upgradedId == nativeId) + putStrLn $ " empty body id agrees across eras : " ++ show (emptyBabbageId == emptyConwayId) + putStrLn "" + if babbageId /= upgradedId + then + putStrLn $ + "ID-CHANGING UPGRADE: the upgrade changes the tx id; witnesses signed over the " + ++ "Babbage id (1) cannot verify against the Conway-derived id (2)." + else + if upgradedId == nativeId + then + putStrLn $ + "FULLY STABLE: the upgrade preserves the id AND matches a native Conway tx. " + ++ "The report's cause lies elsewhere." + else + putStrLn $ + "SPLIT ENCODING: the upgrade preserves the Babbage bytes/id (1 == 2), but a " + ++ "native Conway tx of identical content has a different id (2 /= 3): the " + ++ "Babbage and Conway CBOR encodings of a transaction differ. So the " + ++ "Babbage-tagged and Conway-tagged submissions are byte-different " + ++ "transactions, and the upgraded tx carries legacy Babbage-format bytes. Any " + ++ "Conway validation or downstream check sensitive to that encoding will treat " + ++ "them differently -- the likely root of the report." + when (upgradedId == nativeId && babbageId == upgradedId) $ + putStrLn "(No path divergence observed for this transaction.)" diff --git a/ouroboros-consensus-cardano/golden/byron/disk/LedgerTables b/ouroboros-consensus-cardano/golden/byron/disk/LedgerTables deleted file mode 100644 index 874fe2c986..0000000000 --- a/ouroboros-consensus-cardano/golden/byron/disk/LedgerTables +++ /dev/null @@ -1 +0,0 @@ - \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Allegra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Allegra index b525fa7868..75b07c7040 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Allegra and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Allegra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Alonzo b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Alonzo index dc3903d3a6..630347c534 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Alonzo and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Alonzo differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Babbage b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Babbage index 279d590c81..3e9bb492c1 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Babbage and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Conway b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Conway index 5ae5c5065d..8ece780c1a 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Conway and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Mary b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Mary index 14d8281f93..30c2cb3540 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Mary and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Mary differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Shelley b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Shelley index 7d900c96a8..b141b2f792 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Shelley and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Block_Shelley differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Allegra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Allegra index 61ec98ae96..4e3092f3e8 100644 --- a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Allegra +++ b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Allegra @@ -1,3 +1 @@ -X cA:^D d -uS| ] -q \ No newline at end of file +X 6hfר=="yL9z6 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Alonzo b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Alonzo index 6e6d3158a7..6901f04b4d 100644 --- a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Alonzo +++ b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Alonzo @@ -1 +1 @@ -X 3? GCa\ո1%Eg# +X 6hfר=="yL9z6 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Babbage b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Babbage index 3c56b72b00..f63ee35806 100644 --- a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Babbage +++ b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Babbage @@ -1 +1 @@ -X M~@)_ur7WH5O2$h h \ No newline at end of file +X 6hfר=="yL9z6 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Conway b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Conway index 8f2268ce3f..11662fb6c0 100644 --- a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Conway +++ b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Conway @@ -1 +1 @@ -X K8aLs,а^"5J \ No newline at end of file +X =J2ǩpϚ$uv \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Dijkstra index 58cd6ad898..9a54c951c5 100644 --- a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Dijkstra +++ b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Dijkstra @@ -1 +1 @@ -X #NDB~Dpa1Ux1 \ No newline at end of file +X =J2ǩpϚ$uv \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Mary b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Mary index 1235567289..e5a4aa816d 100644 --- a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Mary +++ b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Mary @@ -1 +1 @@ -X Ճ(x.x_GFߖ} Ԉh+ ޢ \ No newline at end of file +X 6hfר=="yL9z6 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Shelley b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Shelley index 667dbef8ea..5693f6535d 100644 --- a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Shelley +++ b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTxId_Shelley @@ -1 +1 @@ -X np+t3NUe<Ҷ= \ No newline at end of file +X H )ȥas lh} ~63 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Allegra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Allegra index 786e482302..7d4d691d90 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Allegra and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Allegra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Alonzo b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Alonzo index 558dfbcca8..aa6d5fda5c 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Alonzo and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Alonzo differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Babbage b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Babbage index 0be195e3f1..4b8ed5f503 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Babbage and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Conway b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Conway index 9d1ce51c81..3cd66766a8 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Conway and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Dijkstra index 8a87201536..227ccd7125 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Dijkstra and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Dijkstra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Mary b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Mary index 1d7d61fa77..daa05ca1be 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Mary and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Mary differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Shelley b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Shelley index d41c1aacc8..6f9626dadd 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Shelley and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/GenTx_Shelley differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Allegra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Allegra index 2d2c467c6f..7039458506 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Allegra and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Allegra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Alonzo b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Alonzo index a446de19eb..0b47c7e01a 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Alonzo and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Alonzo differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Babbage b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Babbage index 91d4f95385..53f5d8706d 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Babbage and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Conway b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Conway index 7bea7230e7..0f8b86ceed 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Conway and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Dijkstra index cffb0066af..c98cec8bf4 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Dijkstra and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Dijkstra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Mary b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Mary index b07156aa39..caaded6c87 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Mary and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Mary differ diff --git a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Shelley b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Shelley index 2aad81040d..27625a11c5 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Shelley and b/ouroboros-consensus-cardano/golden/cardano/CardanoNodeToNodeVersion2/Header_Shelley differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/ApplyTxErr_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/ApplyTxErr_Dijkstra index 3be88ce625..ad599a2cab 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/ApplyTxErr_Dijkstra and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/ApplyTxErr_Dijkstra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Allegra b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Allegra index b525fa7868..75b07c7040 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Allegra and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Allegra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Alonzo b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Alonzo index dc3903d3a6..630347c534 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Alonzo and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Alonzo differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Babbage b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Babbage index 279d590c81..3e9bb492c1 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Babbage and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Conway b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Conway index 5ae5c5065d..8ece780c1a 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Conway and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Mary b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Mary index 14d8281f93..30c2cb3540 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Mary and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Mary differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Shelley b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Shelley index 7d900c96a8..b141b2f792 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Shelley and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Block_Shelley differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Allegra b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Allegra index 61ec98ae96..4e3092f3e8 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Allegra +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Allegra @@ -1,3 +1 @@ -X cA:^D d -uS| ] -q \ No newline at end of file +X 6hfר=="yL9z6 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Alonzo b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Alonzo index 6e6d3158a7..6901f04b4d 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Alonzo +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Alonzo @@ -1 +1 @@ -X 3? GCa\ո1%Eg# +X 6hfר=="yL9z6 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Babbage b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Babbage index 3c56b72b00..f63ee35806 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Babbage +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Babbage @@ -1 +1 @@ -X M~@)_ur7WH5O2$h h \ No newline at end of file +X 6hfר=="yL9z6 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Conway b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Conway index 8f2268ce3f..11662fb6c0 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Conway +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Conway @@ -1 +1 @@ -X K8aLs,а^"5J \ No newline at end of file +X =J2ǩpϚ$uv \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Dijkstra index 58cd6ad898..9a54c951c5 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Dijkstra +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Dijkstra @@ -1 +1 @@ -X #NDB~Dpa1Ux1 \ No newline at end of file +X =J2ǩpϚ$uv \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Mary b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Mary index 1235567289..e5a4aa816d 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Mary +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Mary @@ -1 +1 @@ -X Ճ(x.x_GFߖ} Ԉh+ ޢ \ No newline at end of file +X 6hfר=="yL9z6 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Shelley b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Shelley index 667dbef8ea..5693f6535d 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Shelley +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTxId_Shelley @@ -1 +1 @@ -X np+t3NUe<Ҷ= \ No newline at end of file +X H )ȥas lh} ~63 \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Allegra b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Allegra index 786e482302..7d4d691d90 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Allegra and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Allegra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Alonzo b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Alonzo index 558dfbcca8..aa6d5fda5c 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Alonzo and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Alonzo differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Babbage b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Babbage index 0be195e3f1..4b8ed5f503 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Babbage and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Conway b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Conway index 9d1ce51c81..3cd66766a8 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Conway and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Dijkstra index 8a87201536..227ccd7125 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Dijkstra and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Dijkstra differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Mary b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Mary index 1d7d61fa77..daa05ca1be 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Mary and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Mary differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Shelley b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Shelley index d41c1aacc8..6f9626dadd 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Shelley and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/GenTx_Shelley differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/LedgerConfig b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/LedgerConfig index 586bf617ce..8eae272e43 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/LedgerConfig and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/LedgerConfig differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Allegra_LedgerTip b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Allegra_LedgerTip index e64ffada5d..447c219f10 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Allegra_LedgerTip +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Allegra_LedgerTip @@ -1 +1 @@ - X B!)k8 Pl"5^ \ No newline at end of file + X Cul?ͥU'H&l|IQl \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Alonzo_LedgerTip b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Alonzo_LedgerTip index a8d3ebca89..b79d075a8b 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Alonzo_LedgerTip +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Alonzo_LedgerTip @@ -1 +1 @@ - X 8ofo&&&nss$& \ No newline at end of file + X x^MBܘ7)XADDBhW \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Babbage_LedgerTip b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Babbage_LedgerTip index c36241968e..276c5d96c4 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Babbage_LedgerTip and b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Babbage_LedgerTip differ diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Conway_LedgerTip b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Conway_LedgerTip index 2eeba1fbba..9d362d47b6 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Conway_LedgerTip +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Conway_LedgerTip @@ -1 +1 @@ - X M7!SYǭdGfp; \ No newline at end of file + X F /6om|zj3dJM \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Dijkstra_LedgerTip b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Dijkstra_LedgerTip index e323f98e36..e1f62fc0f1 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Dijkstra_LedgerTip +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Dijkstra_LedgerTip @@ -1 +1 @@ - X h֐re0F*E8fy} \ No newline at end of file + X <5B^Ԅ <̈g6^ z \ No newline at end of file diff --git a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Mary_LedgerTip b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Mary_LedgerTip index 6ec12660a7..a0245f9ab1 100644 --- a/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Mary_LedgerTip +++ b/ouroboros-consensus-cardano/golden/cardano/QueryVersion2/CardanoNodeToClientVersion12/Result_Mary_LedgerTip @@ -1 +1 @@ - X E maxTxSize then throwError err else @@ -183,6 +189,8 @@ instance TxLimits ByronBlock where Utxo.UTxOValidationTxValidationError $ Utxo.TxValidationTxTooLarge txszNat maxTxSize + txMeasurePhase2 _ _ _ = pure TrivialTxMeasurePhase2 + data instance TxId (GenTx ByronBlock) = ByronTxId !Utxo.TxId | ByronDlgId !Delegation.CertificateId @@ -205,6 +213,10 @@ instance ConvertRawTxId (GenTx ByronBlock) where toRawTxIdHash (ByronUpdateProposalId i) = CC.abstractHashToShort i toRawTxIdHash (ByronUpdateVoteId i) = CC.abstractHashToShort i +instance HasRawTxId (TxId (GenTx ByronBlock)) where + type RawTxId (TxId (GenTx ByronBlock)) = ShortByteString + getRawTxId = toRawTxIdHash + instance HasTxs ByronBlock where extractTxs blk = case byronBlockRaw blk of -- EBBs don't contain transactions diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs index 28bfc9b767..59b04ec155 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs @@ -11,6 +11,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +-- TODO: Ledger has a few deprecations that we are ignoring for now +{-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_GHC -Wno-orphans -Wno-x-ord-preserving-coercions #-} #if __GLASGOW_HASKELL__ < 908 {-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-} @@ -72,7 +74,9 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool ( ByteSize32 , IgnoringOverflow - , TxMeasure + , TrivialTxMeasurePhase2 (..) + , TxMeasurePhase1 + , TxMeasurePhase2 ) import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol @@ -124,7 +128,8 @@ type CardanoHardForkConstraints c = -- the calculation of later rewards. In this transition, we consume the -- 'shelleyToAllegraAVVMsToDelete' as deletions in the ledger tables. instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where - type HardForkTxMeasure (CardanoEras c) = DijkstraMeasure + type HardForkTxMeasurePhase1 (CardanoEras c) = AlonzoMeasure + type HardForkTxMeasurePhase2 (CardanoEras c) = RefScriptSize hardForkEraTranslation = EraTranslation @@ -215,15 +220,15 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where ) $ PNil - hardForkInjTxMeasure = + hardForkInjTxMeasurePhase1 = fromByteSize `o` fromByteSize `o` fromByteSize `o` fromByteSize - `o` fromAlonzo - `o` fromAlonzo - `o` fromConway - `o` fromDijkstra + `o` id + `o` id + `o` id + `o` id `o` nil where nil :: SOP.NS f '[] -> a @@ -231,19 +236,43 @@ instance CardanoHardForkConstraints c => CanHardFork (CardanoEras c) where infixr 9 `o` o :: - (TxMeasure x -> a) -> - (SOP.NS WrapTxMeasure xs -> a) -> - SOP.NS WrapTxMeasure (x : xs) -> + (TxMeasurePhase1 x -> a) -> + (SOP.NS WrapTxMeasurePhase1 xs -> a) -> + SOP.NS WrapTxMeasurePhase1 (x : xs) -> a o f g = \case - SOP.Z (WrapTxMeasure x) -> f x + SOP.Z (WrapTxMeasurePhase1 x) -> f x SOP.S y -> g y - fromByteSize :: IgnoringOverflow ByteSize32 -> DijkstraMeasure - fromByteSize x = fromAlonzo $ AlonzoMeasure x mempty - fromAlonzo x = fromConway $ ConwayMeasure x mempty - fromConway x = fromDijkstra $ DijkstraMeasure x - fromDijkstra x = x + fromByteSize :: IgnoringOverflow ByteSize32 -> AlonzoMeasure + fromByteSize x = AlonzoMeasure x mempty + + hardForkInjTxMeasurePhase2 = + fromTrivial + `o` fromTrivial + `o` fromTrivial + `o` fromTrivial + `o` fromTrivial + `o` fromTrivial + `o` id + `o` id + `o` nil + where + nil :: SOP.NS f '[] -> a + nil = \case {} + + infixr 9 `o` + o :: + (TxMeasurePhase2 x -> a) -> + (SOP.NS WrapTxMeasurePhase2 xs -> a) -> + SOP.NS WrapTxMeasurePhase2 (x : xs) -> + a + o f g = \case + SOP.Z (WrapTxMeasurePhase2 x) -> f x + SOP.S y -> g y + + fromTrivial :: TrivialTxMeasurePhase2 -> RefScriptSize + fromTrivial TrivialTxMeasurePhase2 = mempty class TiebreakerView (BlockProtocol blk) ~ PraosTiebreakerView c => HasPraosTiebreakerView c blk instance TiebreakerView (BlockProtocol blk) ~ PraosTiebreakerView c => HasPraosTiebreakerView c blk @@ -404,8 +433,9 @@ crossEraForecastByronToShelleyWrapper = | forecastFor < maxFor = return $ WrapLedgerView $ - SL.mkInitialShelleyLedgerView - (toFromByronTranslationContext (shelleyLedgerGenesis cfgShelley)) + SL.forecastToTPraosLedgerView $ + SL.mkInitialShelleyForecast + (toFromByronTranslationContext (shelleyLedgerGenesis cfgShelley)) | otherwise = throwError $ OutsideForecastRange diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index a964daa928..344f1d6b7e 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs @@ -87,7 +87,6 @@ import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Tables -import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables) import Ouroboros.Consensus.Node.NetworkProtocolVersion import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Node.Run @@ -114,6 +113,7 @@ import qualified Ouroboros.Consensus.Shelley.Node.TPraos as TPraos import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Assert +import System.FS.API (SomeHasFS (..)) {------------------------------------------------------------------------------- SerialiseHFC @@ -580,23 +580,27 @@ protocolInfoCardano :: ( CardanoHardForkConstraints c , KESAgentContext c m ) => + SomeHasFS m -> CardanoProtocolParams c -> - ( ProtocolInfo (CardanoBlock c) - , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (CardanoBlock c)] - ) -protocolInfoCardano paramsCardano + m + ( ProtocolInfo (CardanoBlock c) + , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (CardanoBlock c)] + ) +protocolInfoCardano (SomeHasFS hasFS) paramsCardano | SL.Mainnet <- SL.sgNetworkId genesisShelley , length credssShelleyBased > 1 = error "Multiple Shelley-based credentials not allowed for mainnet" - | otherwise = - assertWithMsg - (validateGenesis genesisShelley) - ( ProtocolInfo - { pInfoConfig = cfg - , pInfoInitLedger = initExtLedgerStateCardano - } - , pure . mkBlockForgings - ) + | otherwise = do + initExtLedgerStateCardano <- mkInitExtLedgerStateCardano + pure $ + assertWithMsg + (validateGenesis genesisShelley) + ( ProtocolInfo + { pInfoConfig = cfg + , pInfoInitLedger = initExtLedgerStateCardano + } + , pure . mkBlockForgings + ) where CardanoProtocolParams { byronProtocolParams @@ -930,49 +934,56 @@ protocolInfoCardano paramsCardano -- data from the genesis config (if provided) in the ledger state. For -- example, this includes initial staking and initial funds (useful for -- testing/benchmarking). - initExtLedgerStateCardano :: ExtLedgerState (CardanoBlock c) ValuesMK - initExtLedgerStateCardano = - ExtLedgerState - { headerState = initHeaderState - , ledgerState = overShelleyBasedLedgerState initLedgerState - } + mkInitExtLedgerStateCardano :: m (ExtLedgerState (CardanoBlock c) ValuesMK) + mkInitExtLedgerStateCardano = do + let HardForkLedgerState st = initLedgerState + st' <- hsequence' (hap perEraInjections st) + pure + ExtLedgerState + { headerState = initHeaderState + , ledgerState = HardForkLedgerState st' + } where - overShelleyBasedLedgerState (HardForkLedgerState st) = - HardForkLedgerState $ hap (fn id :* registerAny) st - initHeaderState :: HeaderState (CardanoBlock c) initLedgerState :: LedgerState (CardanoBlock c) ValuesMK ExtLedgerState initLedgerState initHeaderState = injectInitialExtLedgerState cfg $ initExtLedgerStateByron - registerAny :: NP (Flip LedgerState ValuesMK -.-> Flip LedgerState ValuesMK) (CardanoShelleyEras c) - registerAny = - hcmap (Proxy @IsShelleyBlock) injectIntoTestState $ - WrapTransitionConfig transitionConfigShelley - :* WrapTransitionConfig transitionConfigAllegra - :* WrapTransitionConfig transitionConfigMary - :* WrapTransitionConfig transitionConfigAlonzo - :* WrapTransitionConfig transitionConfigBabbage - :* WrapTransitionConfig transitionConfigConway - :* WrapTransitionConfig transitionConfigDijkstra - :* Nil - - injectIntoTestState :: - ShelleyBasedEra era => + perEraInjections :: + NP + (Flip LedgerState ValuesMK -.-> (m :.: Flip LedgerState ValuesMK)) + (CardanoEras c) + perEraInjections = + fn (Comp . pure) + :* hcmap (Proxy @IsShelleyBlock) shelleyInjection shelleyTcfgs + + shelleyInjection :: + forall proto era. + Shelley.ShelleyCompatible proto era => WrapTransitionConfig (ShelleyBlock proto era) -> - (Flip LedgerState ValuesMK -.-> Flip LedgerState ValuesMK) (ShelleyBlock proto era) - injectIntoTestState (WrapTransitionConfig tcfg) = fn $ \(Flip st) -> - -- We need to unstow the injected values - Flip $ - unstowLedgerTables $ - forgetLedgerTables $ - st - { Shelley.shelleyLedgerState = - L.injectIntoTestState - tcfg - (Shelley.shelleyLedgerState $ stowLedgerTables st) - } + (Flip LedgerState ValuesMK -.-> (m :.: Flip LedgerState ValuesMK)) + (ShelleyBlock proto era) + shelleyInjection (WrapTransitionConfig tcfg) = fn $ \(Flip stIn) -> Comp $ do + let stowed = stowLedgerTables stIn + newNES <- + L.injectIntoTestState + hasFS + tcfg + (Shelley.shelleyLedgerState stowed) + pure . Flip . unstowLedgerTables $ + stowed{Shelley.shelleyLedgerState = newNES} + + shelleyTcfgs :: NP WrapTransitionConfig (CardanoShelleyEras c) + shelleyTcfgs = + WrapTransitionConfig transitionConfigShelley + :* WrapTransitionConfig transitionConfigAllegra + :* WrapTransitionConfig transitionConfigMary + :* WrapTransitionConfig transitionConfigAlonzo + :* WrapTransitionConfig transitionConfigBabbage + :* WrapTransitionConfig transitionConfigConway + :* WrapTransitionConfig transitionConfigDijkstra + :* Nil -- \| For each element in the list, a block forging thread will be started. -- diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs index 9ef2642934..5331a8f1d5 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs @@ -4,6 +4,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableSuperClasses #-} +-- TODO: Ledger has a few deprecations that we are ignoring for now +{-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Shelley.Eras @@ -27,7 +29,7 @@ module Ouroboros.Consensus.Shelley.Eras , StandardCrypto ) where -import Cardano.Binary +import Cardano.Binary (FromCBOR, ToCBOR) import Cardano.Ledger.Allegra (AllegraEra) import Cardano.Ledger.Allegra.Translation () import Cardano.Ledger.Alonzo (AlonzoEra, ApplyTxError (AlonzoApplyTxError)) @@ -57,7 +59,6 @@ import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.Shelley.LedgerState as SL import qualified Cardano.Ledger.Shelley.Rules as SL import qualified Cardano.Ledger.Shelley.Transition as SL -import qualified Cardano.Protocol.TPraos.API as SL import Control.Monad.Except import Control.State.Transition (PredicateFailure) import Data.Data (Proxy (Proxy)) @@ -95,11 +96,9 @@ class ( Core.EraBlockBody era , Core.EraGov era , SL.ApplyTx era - , SL.ApplyBlock era + , SL.ApplyTick era , SL.EraTransition era - , -- TODO This constraint is quite tight, since it fixes things to the - -- original TPraos ledger view. We would like to ultimately remove it. - SL.GetLedgerView era + , SL.EraForecast era , NoThunks (SL.StashedAVVMAddresses era) , EncCBOR (SL.StashedAVVMAddresses era) , DecCBOR (SL.StashedAVVMAddresses era) @@ -111,7 +110,6 @@ class , EncCBOR (PredicateFailure (EraRule "UTXOW" era)) , Eq (PredicateFailure (EraRule "BBODY" era)) , Show (PredicateFailure (EraRule "BBODY" era)) - , NoThunks (PredicateFailure (EraRule "BBODY" era)) , NoThunks (Core.TranslationContext era) , ToCBOR (Core.TranslationContext era) , FromCBOR (Core.TranslationContext era) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs index 566d5c3f60..0a3d66a2e6 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs @@ -16,7 +16,9 @@ module Ouroboros.Consensus.Shelley.HFEras , StandardShelleyBlock ) where +import Cardano.Ledger.Dijkstra.Era (DijkstraEraBlockHeader (..)) import Cardano.Protocol.Crypto +import Cardano.Protocol.Praos.BlockHeader (Header) import Ouroboros.Consensus.Protocol.Praos (Praos) import qualified Ouroboros.Consensus.Protocol.Praos as Praos import Ouroboros.Consensus.Protocol.TPraos (TPraos) @@ -77,29 +79,11 @@ instance TPraos.PraosCrypto c => ShelleyCompatible (TPraos c) AlonzoEra --- This instance is required since the ledger view forecast function for --- Praos/Babbage still goes through the forecast for TPraos. Once this is --- addressed, we could remove this instance. -instance - (Praos.PraosCrypto c, TPraos.PraosCrypto c) => - ShelleyCompatible (TPraos c) BabbageEra - instance Praos.PraosCrypto c => ShelleyCompatible (Praos c) BabbageEra --- This instance is required since the ledger view forecast function for --- Praos/Conway still goes through the forecast for TPraos. Once this is --- addressed, we could remove this instance. -instance - (Praos.PraosCrypto c, TPraos.PraosCrypto c) => - ShelleyCompatible (TPraos c) ConwayEra - instance Praos.PraosCrypto c => ShelleyCompatible (Praos c) ConwayEra --- This instance is required since the ledger view forecast function for --- Praos/Dijkstra still goes through the forecast for TPraos. Once this is --- addressed, we could remove this instance. -instance - (Praos.PraosCrypto c, TPraos.PraosCrypto c) => - ShelleyCompatible (TPraos c) DijkstraEra - instance Praos.PraosCrypto c => ShelleyCompatible (Praos c) DijkstraEra + +instance Crypto c => DijkstraEraBlockHeader (Header c) DijkstraEra where + prevNonceBlockHeaderL = error "Not implemented. Peras placeholder" diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs index 2a122cb8ac..e03cb0294e 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Block.hs @@ -46,17 +46,19 @@ import Cardano.Ledger.Binary , FullByteString (..) , serialize ) +import Cardano.Ledger.Binary.Group (EncCBORGroup) import qualified Cardano.Ledger.Binary.Plain as Plain +import qualified Cardano.Ledger.Block as SL (EraBlockHeader) import Cardano.Ledger.Core as SL ( eraDecoder , eraProtVerLow , toEraCBOR ) -import qualified Cardano.Ledger.Core as SL (TranslationContext, hashBlockBody) +import qualified Cardano.Ledger.Core as SL (BlockBody, TranslationContext, hashBlockBody) import Cardano.Ledger.Hashes (HASH) import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Protocol.Crypto (Crypto) -import qualified Cardano.Protocol.TPraos.BHeader as SL +import qualified Cardano.Protocol.TPraos.BlockHeader as SL import qualified Data.ByteString.Lazy as Lazy import Data.Coerce (coerce) import Data.Typeable (Typeable) @@ -103,12 +105,15 @@ type instance BlockProtocol (ShelleyBlock proto era) = proto class ( ShelleyBasedEra era , ShelleyProtocol proto + , EncCBORGroup (SL.BlockBody era) , -- Header constraints Eq (ShelleyProtocolHeader proto) , Show (ShelleyProtocolHeader proto) , NoThunks (ShelleyProtocolHeader proto) , EncCBOR (ShelleyProtocolHeader proto) , DecCBOR (Annotator (ShelleyProtocolHeader proto)) + , SL.EraBlockHeader (ShelleyProtocolHeader proto) era + , SL.ApplyBlock (ShelleyProtocolHeader proto) era , Show (CannotForgeError proto) , Show (SL.TranslationContext era) , -- Currently the chain select view is identical diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Config.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Config.hs index b660170620..b9cf4cc14f 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Config.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Config.hs @@ -139,4 +139,5 @@ compactGenesis genesis = genesis { SL.sgInitialFunds = mempty , SL.sgStaking = SL.emptyGenesisStaking + , SL.sgExtraConfig = SL.SNothing } diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs index 6e6c81bf20..9fb6008286 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs @@ -1,13 +1,19 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +-- TODO: Ledger has a few deprecations that we are ignoring for now +{-# OPTIONS_GHC -Wno-deprecations #-} module Ouroboros.Consensus.Shelley.Ledger.Forge (forgeShelleyBlock) where import qualified Cardano.Ledger.Core as Core (TopTx, Tx) -import qualified Cardano.Ledger.Core as SL (hashBlockBody, mkBasicBlockBody, txSeqBlockBodyL) +import qualified Cardano.Ledger.Core as SL + ( blockBodySize + , hashBlockBody + , mkBasicBlockBody + , txSeqBlockBodyL + ) import qualified Cardano.Ledger.Shelley.API as SL (Block (..), extractTx) -import qualified Cardano.Ledger.Shelley.BlockBody as SL (bBodySize) -import qualified Cardano.Protocol.TPraos.BHeader as SL +import qualified Cardano.Protocol.TPraos.BlockHeader as SL import Control.Exception import qualified Data.Sequence.Strict as Seq import Lens.Micro ((&), (.~)) @@ -80,7 +86,7 @@ forgeShelleyBlock SL.mkBasicBlockBody & SL.txSeqBlockBodyL .~ Seq.fromList (fmap extractTx txs) - actualBodySize = SL.bBodySize protocolVersion body + actualBodySize = SL.blockBodySize protocolVersion body extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Core.Tx Core.TopTx era extractTx (ShelleyValidatedTx _txid vtx) = SL.extractTx vtx diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index f3cfcc4eca..5df48eac50 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -58,7 +58,6 @@ module Ouroboros.Consensus.Shelley.Ledger.Ledger , BigEndianTxIn (..) ) where -import qualified Cardano.Ledger.BHeaderView as SL (BHeaderView) import qualified Cardano.Ledger.BaseTypes as SL (TxIx (..), epochInfoPure) import Cardano.Ledger.BaseTypes.NonZero (unNonZero) import Cardano.Ledger.Binary.Decoding @@ -131,8 +130,8 @@ import Ouroboros.Consensus.Shelley.Ledger.Config import Ouroboros.Consensus.Shelley.Ledger.Protocol () import Ouroboros.Consensus.Shelley.Protocol.Abstract ( EnvelopeCheckError + , ShelleyProtocolHeader , envelopeChecks - , mkHeaderView ) import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.CBOR @@ -660,7 +659,7 @@ applyHelper :: ShelleyCompatible proto era => ( SL.Globals -> SL.NewEpochState era -> - SL.Block SL.BHeaderView era -> + SL.Block (ShelleyProtocolHeader proto) era -> Either (SL.BlockTransitionError era) ( LedgerResult @@ -687,10 +686,7 @@ applyHelper f cfg blk stBefore = do f globals tickedShelleyLedgerState - ( let b = shelleyBlockRaw blk - h' = mkHeaderView (SL.blockHeader b) - in SL.Block h' (SL.blockBody b) - ) + (shelleyBlockRaw blk) let track :: LedgerState (ShelleyBlock proto era) ValuesMK -> diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs index 464ceb63ad..edd56e1124 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs @@ -13,6 +13,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +-- TODO: Ledger has a few deprecations that we are ignoring for now +{-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_GHC -Wno-orphans -Wno-x-ord-preserving-coercions #-} #if __GLASGOW_HASKELL__ < 908 {-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-} @@ -34,8 +36,7 @@ module Ouroboros.Consensus.Shelley.Ledger.Mempool -- * Exported for tests , AlonzoMeasure (..) - , ConwayMeasure (..) - , DijkstraMeasure (..) + , RefScriptSize (..) , fromExUnits ) where @@ -92,6 +93,7 @@ import Control.Arrow ((+++)) import Control.Monad (guard) import Control.Monad.Except (Except, liftEither) import Control.Monad.Identity (Identity (..)) +import Data.ByteString.Short (ShortByteString) import Data.DerivingVia (InstantiatedAt (..)) import Data.Foldable (toList) import Data.Measure (Measure) @@ -116,10 +118,11 @@ import Ouroboros.Consensus.Shelley.Ledger.Ledger , getPParams ) import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto) -import Ouroboros.Consensus.Util (ShowProxy (..), coerceSet) +import Ouroboros.Consensus.Util (ShowProxy (..), coerceMapKeys, coerceSet) import Ouroboros.Consensus.Util.Condense import Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR) import Ouroboros.Network.SizeInBytes +import Ouroboros.Network.Tx (HasRawTxId (..)) data instance GenTx (ShelleyBlock proto era) = ShelleyTx !SL.TxId !(Tx TopTx era) deriving stock Generic @@ -232,6 +235,10 @@ instance ShelleyBasedEra era => ConvertRawTxId (GenTx (ShelleyBlock proto era)) toRawTxIdHash (ShelleyTxId i) = Hash.hashToBytesShort . SL.extractHash . SL.unTxId $ i +instance ShelleyBasedEra era => HasRawTxId (TxId (GenTx (ShelleyBlock proto era))) where + type RawTxId (TxId (GenTx (ShelleyBlock proto era))) = ShortByteString + getRawTxId = toRawTxIdHash + instance ShelleyBasedEra era => HasTxs (ShelleyBlock proto era) where extractTxs = map mkShelleyTx @@ -513,22 +520,28 @@ wrapCBORinCBOROverhead size = + fromIntegral size instance ShelleyCompatible p ShelleyEra => TxLimits (ShelleyBlock p ShelleyEra) where - type TxMeasure (ShelleyBlock p ShelleyEra) = IgnoringOverflow ByteSize32 + type TxMeasurePhase1 (ShelleyBlock p ShelleyEra) = IgnoringOverflow ByteSize32 + type TxMeasurePhase2 (ShelleyBlock p ShelleyEra) = TrivialTxMeasurePhase2 txWireSize (ShelleyTx _ tx) = wrapCBORinCBOROverhead (tx ^. wireSizeTxF) - txMeasure _cfg st tx = runValidation $ txInBlockSize st tx - blockCapacityTxMeasure _cfg = txsMaxBytes + txMeasurePhase1 _cfg st tx = runValidation $ txInBlockSize st tx + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 + blockCapacityTxMeasure _cfg = flip TxMeasure TrivialTxMeasurePhase2 . txsMaxBytes instance ShelleyCompatible p AllegraEra => TxLimits (ShelleyBlock p AllegraEra) where - type TxMeasure (ShelleyBlock p AllegraEra) = IgnoringOverflow ByteSize32 + type TxMeasurePhase1 (ShelleyBlock p AllegraEra) = IgnoringOverflow ByteSize32 + type TxMeasurePhase2 (ShelleyBlock p AllegraEra) = TrivialTxMeasurePhase2 txWireSize (ShelleyTx _ tx) = wrapCBORinCBOROverhead (tx ^. wireSizeTxF) - txMeasure _cfg st tx = runValidation $ txInBlockSize st tx - blockCapacityTxMeasure _cfg = txsMaxBytes + txMeasurePhase1 _cfg st tx = runValidation $ txInBlockSize st tx + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 + blockCapacityTxMeasure _cfg = flip TxMeasure TrivialTxMeasurePhase2 . txsMaxBytes instance ShelleyCompatible p MaryEra => TxLimits (ShelleyBlock p MaryEra) where - type TxMeasure (ShelleyBlock p MaryEra) = IgnoringOverflow ByteSize32 + type TxMeasurePhase1 (ShelleyBlock p MaryEra) = IgnoringOverflow ByteSize32 + type TxMeasurePhase2 (ShelleyBlock p MaryEra) = TrivialTxMeasurePhase2 txWireSize (ShelleyTx _ tx) = wrapCBORinCBOROverhead (tx ^. wireSizeTxF) - txMeasure _cfg st tx = runValidation $ txInBlockSize st tx - blockCapacityTxMeasure _cfg = txsMaxBytes + txMeasurePhase1 _cfg st tx = runValidation $ txInBlockSize st tx + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 + blockCapacityTxMeasure _cfg = flip TxMeasure TrivialTxMeasurePhase2 . txsMaxBytes ----- @@ -553,11 +566,10 @@ instance Monoid AlonzoMeasure where mappend = (<>) mempty = AlonzoMeasure mempty mempty -instance TxMeasureMetrics AlonzoMeasure where +instance TxMeasurePhase1Metrics AlonzoMeasure where txMeasureMetricTxSizeBytes = txMeasureMetricTxSizeBytes . byteSize txMeasureMetricExUnitsMemory = exUnitsMem' . exUnits txMeasureMetricExUnitsSteps = exUnitsSteps' . exUnits - txMeasureMetricRefScriptsSizeBytes _ = mempty fromExUnits :: ExUnits -> ExUnits' Natural fromExUnits = unWrapExUnits @@ -583,7 +595,7 @@ txMeasureAlonzo :: , ExUnitsTooBigUTxO era , MaxTxSizeUTxO era ) => - TickedLedgerState (ShelleyBlock proto era) ValuesMK -> + TickedLedgerState (ShelleyBlock proto era) EmptyMK -> GenTx (ShelleyBlock proto era) -> V.Validation (TxErrorSG era) AlonzoMeasure txMeasureAlonzo st tx@(ShelleyTx _txid tx') = @@ -657,76 +669,21 @@ instance ShelleyCompatible p AlonzoEra => TxLimits (ShelleyBlock p AlonzoEra) where - type TxMeasure (ShelleyBlock p AlonzoEra) = AlonzoMeasure + type TxMeasurePhase1 (ShelleyBlock p AlonzoEra) = AlonzoMeasure + type TxMeasurePhase2 (ShelleyBlock p AlonzoEra) = TrivialTxMeasurePhase2 txWireSize (ShelleyTx _ tx) = wrapCBORinCBOROverhead (tx ^. wireSizeTxF) - txMeasure _cfg st tx = runValidation $ txMeasureAlonzo st tx - blockCapacityTxMeasure _cfg = blockCapacityAlonzoMeasure - ------ - -newtype DijkstraMeasure = DijkstraMeasure - { conwayMeasure :: ConwayMeasure - } - deriving stock (Eq, Generic, Show) - deriving anyclass NoThunks - deriving newtype (Semigroup, Monoid, HasByteSize, TxMeasureMetrics) - deriving - Measure - via (InstantiatedAt Generic DijkstraMeasure) - -blockCapacityDijkstraMeasure :: - forall proto era mk. - ( ShelleyCompatible proto era - , SL.ConwayEraPParams era - ) => - TickedLedgerState (ShelleyBlock proto era) mk -> - DijkstraMeasure -blockCapacityDijkstraMeasure = DijkstraMeasure . blockCapacityConwayMeasure - -txMeasureDijkstra :: - forall proto era. - ( ShelleyCompatible proto era - , L.AlonzoEraTxWits era - , L.BabbageEraTxBody era - , SL.ConwayEraPParams era - , ExUnitsTooBigUTxO era - , MaxTxSizeUTxO era - , TxRefScriptsSizeTooBig era - ) => - TickedLedgerState (ShelleyBlock proto era) ValuesMK -> - GenTx (ShelleyBlock proto era) -> - V.Validation (TxErrorSG era) DijkstraMeasure -txMeasureDijkstra st = fmap DijkstraMeasure . txMeasureConway st + txMeasurePhase1 _cfg st tx = runValidation $ txMeasureAlonzo st tx + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 + blockCapacityTxMeasure _cfg = flip TxMeasure TrivialTxMeasurePhase2 . blockCapacityAlonzoMeasure ----- -data ConwayMeasure = ConwayMeasure - { alonzoMeasure :: !AlonzoMeasure - , refScriptsSize :: !(IgnoringOverflow ByteSize32) - } - deriving stock (Eq, Generic, Show) - deriving anyclass NoThunks - deriving - Measure - via (InstantiatedAt Generic ConwayMeasure) - -instance Semigroup ConwayMeasure where - ConwayMeasure a1 r1 <> ConwayMeasure a2 r2 = - ConwayMeasure (a1 <> a2) (r1 <> r2) - -instance Monoid ConwayMeasure where - mappend = (<>) - mempty = ConwayMeasure mempty mempty - -instance HasByteSize ConwayMeasure where - txMeasureByteSize = txMeasureByteSize . alonzoMeasure +newtype RefScriptSize = RefScriptSize {refScriptsSize :: IgnoringOverflow ByteSize32} + deriving (Eq, Generic, Show) + deriving newtype (NoThunks, Measure, Semigroup, Monoid) -instance TxMeasureMetrics ConwayMeasure where - txMeasureMetricTxSizeBytes = txMeasureMetricTxSizeBytes . alonzoMeasure - txMeasureMetricExUnitsMemory = txMeasureMetricExUnitsMemory . alonzoMeasure - txMeasureMetricExUnitsSteps = txMeasureMetricExUnitsSteps . alonzoMeasure - txMeasureMetricRefScriptsSizeBytes = - unIgnoringOverflow . refScriptsSize +instance TxMeasurePhase2Metrics RefScriptSize where + txMeasureMetricRefScriptsSizeBytes = unIgnoringOverflow . refScriptsSize blockCapacityConwayMeasure :: forall proto era mk. @@ -734,35 +691,31 @@ blockCapacityConwayMeasure :: , SL.ConwayEraPParams era ) => TickedLedgerState (ShelleyBlock proto era) mk -> - ConwayMeasure + (AlonzoMeasure, RefScriptSize) blockCapacityConwayMeasure st = - ConwayMeasure - { alonzoMeasure = blockCapacityAlonzoMeasure st - , refScriptsSize = - IgnoringOverflow $ - ByteSize32 (pparams ^. SL.ppMaxRefScriptSizePerBlockG) - } + ( blockCapacityAlonzoMeasure st + , RefScriptSize $ + IgnoringOverflow $ + ByteSize32 (pparams ^. SL.ppMaxRefScriptSizePerBlockG) + ) where pparams = getPParams $ tickedShelleyLedgerState st -txMeasureConway :: +txMeasureRefScripts :: forall proto era. ( ShelleyCompatible proto era - , L.AlonzoEraTxWits era , L.BabbageEraTxBody era - , ExUnitsTooBigUTxO era - , MaxTxSizeUTxO era , TxRefScriptsSizeTooBig era , SL.ConwayEraPParams era ) => TickedLedgerState (ShelleyBlock proto era) ValuesMK -> GenTx (ShelleyBlock proto era) -> - V.Validation (TxErrorSG era) ConwayMeasure -txMeasureConway st tx@(ShelleyTx _txid tx') = - ConwayMeasure <$> txMeasureAlonzo st tx <*> refScriptBytes + V.Validation (TxErrorSG era) RefScriptSize +txMeasureRefScripts st (ShelleyTx _txid tx') = + RefScriptSize <$> refScriptBytes where - utxo = SL.getUTxO . tickedShelleyLedgerState $ st - txsz = SL.txNonDistinctRefScriptsSize utxo tx' :: Int + ValuesMK utxo = getLedgerTables $ projectLedgerTables st + txsz = SL.txNonDistinctRefScriptsSize (SL.UTxO $ coerceMapKeys utxo) tx' :: Int pparams = getPParams $ tickedShelleyLedgerState st @@ -800,25 +753,31 @@ instance ShelleyCompatible p BabbageEra => TxLimits (ShelleyBlock p BabbageEra) where - type TxMeasure (ShelleyBlock p BabbageEra) = AlonzoMeasure + type TxMeasurePhase1 (ShelleyBlock p BabbageEra) = AlonzoMeasure + type TxMeasurePhase2 (ShelleyBlock p BabbageEra) = TrivialTxMeasurePhase2 txWireSize (ShelleyTx _ tx) = wrapCBORinCBOROverhead (tx ^. wireSizeTxF) - txMeasure _cfg st tx = runValidation $ txMeasureAlonzo st tx - blockCapacityTxMeasure _cfg = blockCapacityAlonzoMeasure + txMeasurePhase1 _cfg st tx = runValidation $ txMeasureAlonzo st tx + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 + blockCapacityTxMeasure _cfg = flip TxMeasure TrivialTxMeasurePhase2 . blockCapacityAlonzoMeasure instance ShelleyCompatible p ConwayEra => TxLimits (ShelleyBlock p ConwayEra) where - type TxMeasure (ShelleyBlock p ConwayEra) = ConwayMeasure + type TxMeasurePhase1 (ShelleyBlock p ConwayEra) = AlonzoMeasure + type TxMeasurePhase2 (ShelleyBlock p ConwayEra) = RefScriptSize txWireSize (ShelleyTx _ tx) = wrapCBORinCBOROverhead (tx ^. wireSizeTxF) - txMeasure _cfg st tx = runValidation $ txMeasureConway st tx - blockCapacityTxMeasure _cfg = blockCapacityConwayMeasure + txMeasurePhase1 _cfg st tx = runValidation $ txMeasureAlonzo st tx + txMeasurePhase2 _cfg st tx = runValidation $ txMeasureRefScripts st tx + blockCapacityTxMeasure _cfg = uncurry TxMeasure . blockCapacityConwayMeasure instance ShelleyCompatible p DijkstraEra => TxLimits (ShelleyBlock p DijkstraEra) where - type TxMeasure (ShelleyBlock p DijkstraEra) = DijkstraMeasure - txMeasure _cfg st tx = runValidation $ txMeasureDijkstra st tx - blockCapacityTxMeasure _cfg = blockCapacityDijkstraMeasure + type TxMeasurePhase1 (ShelleyBlock p DijkstraEra) = AlonzoMeasure + type TxMeasurePhase2 (ShelleyBlock p DijkstraEra) = RefScriptSize + blockCapacityTxMeasure _cfg = uncurry TxMeasure . blockCapacityConwayMeasure + txMeasurePhase1 _cfg st tx = runValidation $ txMeasureAlonzo st tx + txMeasurePhase2 _cfg st tx = runValidation $ txMeasureRefScripts st tx txWireSize (ShelleyTx _ tx) = wrapCBORinCBOROverhead (tx ^. wireSizeTxF) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs index 6584bf196f..d4aec71134 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/PeerSelection.hs @@ -5,23 +5,20 @@ module Ouroboros.Consensus.Shelley.Ledger.PeerSelection () where +import Cardano.Base.IP (unIPv4, unIPv6) +import qualified Cardano.Ledger.Api.State.Query as SL import Cardano.Ledger.BaseTypes -import qualified Cardano.Ledger.Keys as SL import qualified Cardano.Ledger.Shelley.API as SL -import qualified Cardano.Ledger.State as SL import Control.DeepSeq (force) -import Data.Bifunctor (second) import Data.Foldable (toList) import Data.List (sortOn) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE -import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, mapMaybe) import Data.Ord (Down (..)) import Data.Sequence.Strict (StrictSeq) import Data.Text.Encoding (encodeUtf8) -import Lens.Micro.Extras (view) import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Ledger @@ -29,39 +26,24 @@ import Ouroboros.Consensus.Shelley.Ledger.Ledger instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto era) where getPeers ShelleyLedgerState{shelleyLedgerState} = catMaybes - [ (poolStake,) <$> Map.lookup stakePool poolLedgerRelayAccessPoints - | (stakePool, poolStake) <- orderByStake poolDistr + [ (PoolStake stake,) <$> ledgerRelayAccessPoints relays + | (_stakePool, (stake, relays)) <- stakeOrdered ] where - poolDistr :: SL.PoolDistr - poolDistr = SL.nesPd shelleyLedgerState - - futurePoolParams :: Map (SL.KeyHash SL.StakePool) SL.StakePoolParams - futurePoolParams = SL.psFutureStakePoolParams pstate - - stakePoolsState :: Map (SL.KeyHash SL.StakePool) SL.StakePoolState - stakePoolsState = SL.psStakePools pstate - - -- Sort stake pools by descending stake - orderByStake :: - SL.PoolDistr -> - [(SL.KeyHash SL.StakePool, PoolStake)] - orderByStake = - sortOn (Down . snd) - . map (second (PoolStake . SL.individualPoolStake)) - . Map.toList - . SL.unPoolDistr + stakeOrdered = + sortOn (Down . fst . snd) . Map.toList $ + SL.queryStakePoolRelays shelleyLedgerState relayToLedgerRelayAccessPoint :: SL.StakePoolRelay -> Maybe LedgerRelayAccessPoint relayToLedgerRelayAccessPoint (SL.SingleHostAddr (SJust (Port port)) (SJust ipv4) _) = - Just $ LedgerRelayAccessAddress (IPv4 ipv4) (fromIntegral port) + Just $ LedgerRelayAccessAddress (IPv4 (unIPv4 ipv4)) (fromIntegral port) relayToLedgerRelayAccessPoint ( SL.SingleHostAddr (SJust (Port port)) SNothing (SJust ipv6) ) = - Just $ LedgerRelayAccessAddress (IPv6 ipv6) (fromIntegral port) + Just $ LedgerRelayAccessAddress (IPv6 (unIPv6 ipv6)) (fromIntegral port) -- no IP address or no port number relayToLedgerRelayAccessPoint (SL.SingleHostAddr SNothing _ _) = Nothing relayToLedgerRelayAccessPoint (SL.SingleHostAddr _ SNothing _) = Nothing @@ -74,31 +56,11 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto relayToLedgerRelayAccessPoint (SL.MultiHostName dnsName) = Just $ LedgerRelayAccessSRVDomain (encodeUtf8 $ dnsToText dnsName) - -- Note that a stake pool can have multiple registered relays ledgerRelayAccessPoints :: - (LedgerRelayAccessPoint -> StakePoolRelay) -> StrictSeq SL.StakePoolRelay -> Maybe (NonEmpty StakePoolRelay) - ledgerRelayAccessPoints injStakePoolRelay = + ledgerRelayAccessPoints = NE.nonEmpty . force - . mapMaybe (fmap injStakePoolRelay . relayToLedgerRelayAccessPoint) + . mapMaybe (fmap CurrentRelay . relayToLedgerRelayAccessPoint) . toList - - -- Combine the stake pools registered in the future and the current pool - -- parameters, and remove duplicates. - poolLedgerRelayAccessPoints :: - Map (SL.KeyHash SL.StakePool) (NonEmpty StakePoolRelay) - poolLedgerRelayAccessPoints = - Map.unionWith - (\futureRelays currentRelays -> NE.nub (futureRelays <> currentRelays)) - (Map.mapMaybe (ledgerRelayAccessPoints FutureRelay . SL.sppRelays) futurePoolParams) - (Map.mapMaybe (ledgerRelayAccessPoints CurrentRelay . SL.spsRelays) stakePoolsState) - - pstate :: SL.PState era - pstate = - view SL.certPStateL - . SL.lsCertState - . SL.esLState - . SL.nesEs - $ shelleyLedgerState diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs index a25d1315bb..e36d0e098d 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs @@ -67,7 +67,6 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Typeable (Typeable) import Lens.Micro -import Lens.Micro.Extras (view) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Combinator.Basics @@ -429,7 +428,7 @@ instance mkSerialised (encodeShelleyResult maxBound query') $ answerPureBlockQuery cfg query' ext GetFilteredDelegationsAndRewardAccounts creds -> - getFilteredDelegationsAndRewardAccounts st creds + SL.queryStakePoolDelegsAndRewards st creds GetGenesisConfig -> shelleyLedgerCompactGenesis lcfg DebugNewEpochState -> @@ -451,13 +450,7 @@ instance GetPoolDistr mPoolIds -> fromLedgerPoolDistr $ answerPureBlockQuery cfg (GetPoolDistr2 mPoolIds) ext GetStakeDelegDeposits stakeCreds -> - let lookupDeposit = - SL.lookupDepositDState (view SL.certDStateL $ SL.lsCertState $ SL.esLState $ SL.nesEs st) - lookupInsert acc cred = - case lookupDeposit cred of - Nothing -> acc - Just deposit -> Map.insert cred deposit acc - in Set.foldl' lookupInsert Map.empty stakeCreds + SL.queryAccountsDeposits st stakeCreds GetConstitution -> SL.queryConstitution st GetGovState -> @@ -469,7 +462,7 @@ instance GetCommitteeMembersState coldCreds hotCreds statuses -> SL.queryCommitteeMembersState coldCreds hotCreds statuses st GetFilteredVoteDelegatees stakeCreds -> - getFilteredVoteDelegatees st stakeCreds + SL.queryDRepDelegatees st stakeCreds GetAccountState -> SL.queryChainAccountState st GetSPOStakeDistr keys -> @@ -516,8 +509,7 @@ instance QueryStakePoolDefaultVote stakePool -> SL.queryStakePoolDefaultVote st stakePool GetPoolDistr2 mPoolIds -> - let stakeSet = SL.ssStakeSet . SL.esSnapshots $ getEpochState st - in SL.calculatePoolDistr' (maybe (const True) (flip Set.member) mPoolIds) stakeSet + SL.querySetSnapshotStakePoolDistr st (maybe Set.empty id mPoolIds) GetStakeDistribution2 -> SL.poolsByTotalStakeFraction globals st GetMaxMajorProtocolVersion -> @@ -820,30 +812,6 @@ instance ShelleyCompatible proto era => ShowQuery (BlockQuery (ShelleyBlock prot getEpochState :: SL.NewEpochState era -> SL.EpochState era getEpochState = SL.nesEs -getDState :: SL.EraCertState era => SL.NewEpochState era -> SL.DState era -getDState = view SL.certDStateL . SL.lsCertState . SL.esLState . SL.nesEs - -getFilteredDelegationsAndRewardAccounts :: - SL.EraCertState era => - SL.NewEpochState era -> - Set (SL.Credential SL.Staking) -> - (Delegations, Map (SL.Credential SL.Staking) Coin) -getFilteredDelegationsAndRewardAccounts = SL.queryStakePoolDelegsAndRewards - -getFilteredVoteDelegatees :: - (SL.EraCertState era, CG.ConwayEraAccounts era) => - SL.NewEpochState era -> - Set (SL.Credential SL.Staking) -> - VoteDelegatees -getFilteredVoteDelegatees ss creds - | Set.null creds = - Map.mapMaybe (^. CG.dRepDelegationAccountStateL) accountsMap - | otherwise = - Map.mapMaybe (^. CG.dRepDelegationAccountStateL) accountsMapRestricted - where - accountsMap = getDState ss ^. SL.accountsL . SL.accountsMapL - accountsMapRestricted = Map.restrictKeys accountsMap creds - {------------------------------------------------------------------------------- Serialisation -------------------------------------------------------------------------------} @@ -1072,7 +1040,7 @@ encodeShelleyResult v query = case query of GetRatifyState{} -> LC.toEraCBOR @era GetFuturePParams{} -> LC.toEraCBOR @era GetLedgerPeerSnapshot'{} -> encodeLedgerPeerSnapshot (ledgerPeerSnapshotSupportsSRV v) - QueryStakePoolDefaultVote{} -> toCBOR + QueryStakePoolDefaultVote{} -> LC.toEraCBOR @era GetPoolDistr2{} -> LC.toEraCBOR @era GetStakeDistribution2{} -> LC.toEraCBOR @era GetMaxMajorProtocolVersion -> toCBOR @@ -1121,7 +1089,7 @@ decodeShelleyResult v query = case query of GetRatifyState{} -> LC.fromEraCBOR @era GetFuturePParams{} -> LC.fromEraCBOR @era GetLedgerPeerSnapshot' _ ledgerPeersKind -> decodeLedgerPeerSnapshot ledgerPeersKind - QueryStakePoolDefaultVote{} -> fromCBOR + QueryStakePoolDefaultVote{} -> LC.fromEraCBOR @era GetPoolDistr2{} -> LC.fromEraCBOR @era GetStakeDistribution2 -> LC.fromEraCBOR @era GetMaxMajorProtocolVersion -> fromCBOR diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query/LegacyShelleyGenesis.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query/LegacyShelleyGenesis.hs index fdbd91fbf1..d3f24f2343 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query/LegacyShelleyGenesis.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query/LegacyShelleyGenesis.hs @@ -88,6 +88,7 @@ instance FromCBOR LegacyShelleyGenesis where sgGenDelegs sgInitialFunds sgStaking + SNothing activeSlotsCoeffEncCBOR :: PositiveUnitInterval -> Encoding activeSlotsCoeffEncCBOR = enforceEncodingVersion shelleyProtVer . encCBOR . unboundRational diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs index 2a53ef71b0..00f15b7209 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs @@ -5,7 +5,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | This module contains 'SupportsProtocol' instances tying the ledger and @@ -18,7 +17,6 @@ import qualified Cardano.Ledger.Core as LedgerCore import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Protocol.TPraos.API as SL import Control.Monad.Except (MonadError (throwError)) -import Data.Coerce (coerce) import qualified Lens.Micro import Ouroboros.Consensus.Block import Ouroboros.Consensus.Forecast @@ -27,9 +25,8 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol (..) ) -import Ouroboros.Consensus.Ledger.Tables.Utils -import Ouroboros.Consensus.Protocol.Abstract (translateLedgerView) import Ouroboros.Consensus.Protocol.Praos (Praos) +import qualified Ouroboros.Consensus.Protocol.Praos as Praos (PraosCrypto) import qualified Ouroboros.Consensus.Protocol.Praos.Views as Praos import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Ledger.Block @@ -40,17 +37,21 @@ import Ouroboros.Consensus.Shelley.Protocol.Praos () import Ouroboros.Consensus.Shelley.Protocol.TPraos () instance - (SL.PraosCrypto crypto, ShelleyCompatible (TPraos crypto) era) => + ( ShelleyCompatible (TPraos crypto) era + , SL.ShelleyEraForecast era + , SL.PraosCrypto crypto + ) => LedgerSupportsProtocol (ShelleyBlock (TPraos crypto) era) where - protocolLedgerView _cfg = SL.currentLedgerView . tickedShelleyLedgerState + protocolLedgerView _cfg = + SL.forecastToTPraosLedgerView . SL.currentForecast . tickedShelleyLedgerState -- Extra context available in -- https://github.com/IntersectMBO/ouroboros-consensus/blob/main/docs/website/contents/for-developers/HardWonWisdom.md#why-doesnt-ledger-code-ever-return-pasthorizonexception ledgerViewForecastAt cfg ledgerState = Forecast at $ \for -> if | NotOrigin for == at -> - return $ SL.currentLedgerView shelleyLedgerState + return $ SL.forecastToTPraosLedgerView (SL.currentForecast shelleyLedgerState) | for < maxFor -> return $ futureLedgerView for | otherwise -> @@ -66,12 +67,10 @@ instance swindow = SL.stabilityWindow globals at = ledgerTipSlot ledgerState - futureLedgerView :: SlotNo -> SL.LedgerView - futureLedgerView = - either - (\e -> error ("futureLedgerView failed: " <> show e)) - id - . SL.futureLedgerView globals shelleyLedgerState + futureLedgerView :: SlotNo -> SL.TPraosLedgerView + futureLedgerView for = + SL.forecastToTPraosLedgerView $ + SL.futureForecast globals for shelleyLedgerState -- Exclusive upper bound maxFor :: SlotNo @@ -79,8 +78,8 @@ instance instance ( ShelleyCompatible (Praos crypto) era - , ShelleyCompatible (TPraos crypto) era - , SL.PraosCrypto crypto + , SL.EraForecast era + , Praos.PraosCrypto crypto ) => LedgerSupportsProtocol (ShelleyBlock (Praos crypto) era) where @@ -91,28 +90,38 @@ instance pparam :: forall a. Lens.Micro.Lens' (LedgerCore.PParams era) a -> a pparam lens = getPParams nes Lens.Micro.^. lens - in Praos.LedgerView - { Praos.lvPoolDistr = nesPd - , Praos.lvMaxBodySize = pparam LedgerCore.ppMaxBBSizeL - , Praos.lvMaxHeaderSize = pparam LedgerCore.ppMaxBHSizeL - , Praos.lvProtocolVersion = pparam LedgerCore.ppProtocolVersionL + in Praos.PraosLedgerView + { Praos.plvPoolDistr = nesPd + , Praos.plvMaxBodySize = pparam LedgerCore.ppMaxBBSizeL + , Praos.plvMaxHeaderSize = pparam LedgerCore.ppMaxBHSizeL + , Praos.plvProtocolVersion = pparam LedgerCore.ppProtocolVersionL } - -- \| Currently the Shelley+ ledger is hard-coded to produce a TPraos ledger - -- view. Since we can convert them, we piggy-back on this to get a Praos - -- ledger view. Ultimately, we will want to liberalise the ledger code - -- slightly. - ledgerViewForecastAt cfg st = - mapForecast (translateLedgerView (Proxy @(TPraos crypto, Praos crypto))) $ - ledgerViewForecastAt @(ShelleyBlock (TPraos crypto) era) cfg st' + ledgerViewForecastAt cfg ledgerState = Forecast at $ \for -> + if + | NotOrigin for == at -> + return $ + Praos.forecastToPraosLedgerView (SL.currentForecast shelleyLedgerState) + | for < maxFor -> + return $ futureLedgerView for + | otherwise -> + throwError $ + OutsideForecastRange + { outsideForecastAt = at + , outsideForecastMaxFor = maxFor + , outsideForecastFor = for + } where - st' :: LedgerState (ShelleyBlock (TPraos crypto) era) EmptyMK - st' = - ShelleyLedgerState - { shelleyLedgerTip = coerceTip <$> shelleyLedgerTip st - , shelleyLedgerState = shelleyLedgerState st - , shelleyLedgerTransition = shelleyLedgerTransition st - , shelleyLedgerTables = emptyLedgerTables - , shelleyLedgerLatestPerasCertRound = shelleyLedgerLatestPerasCertRound st - } - coerceTip (ShelleyTip slot block hash) = ShelleyTip slot block (coerce hash) + ShelleyLedgerState{shelleyLedgerState} = ledgerState + globals = shelleyLedgerGlobals cfg + swindow = SL.stabilityWindow globals + at = ledgerTipSlot ledgerState + + futureLedgerView :: SlotNo -> Praos.PraosLedgerView + futureLedgerView for = + Praos.forecastToPraosLedgerView $ + SL.futureForecast globals for shelleyLedgerState + + -- Exclusive upper bound + maxFor :: SlotNo + maxFor = addSlots swindow $ succWithOrigin at diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs index 65fc57fa7a..cf9c67372a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Node/TPraos.hs @@ -67,6 +67,7 @@ import Ouroboros.Consensus.Shelley.Node.Serialisation () import Ouroboros.Consensus.Shelley.Protocol.TPraos () import Ouroboros.Consensus.Util.Assert import Ouroboros.Consensus.Util.IOLike +import System.FS.API (SomeHasFS (..)) {------------------------------------------------------------------------------- BlockForging @@ -161,17 +162,21 @@ protocolInfoShelley :: , ShelleyCompatible (TPraos c) ShelleyEra , MonadKESAgent m ) => + SomeHasFS m -> SL.ShelleyGenesis -> ProtocolParamsShelleyBased c -> SL.ProtVer -> - ( ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra) - , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock (TPraos c) ShelleyEra)] - ) + m + ( ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra) + , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock (TPraos c) ShelleyEra)] + ) protocolInfoShelley + fs shelleyGenesis protocolParamsShelleyBased protVer = protocolInfoTPraosShelleyBased + fs protocolParamsShelleyBased (L.mkShelleyTransitionConfig shelleyGenesis) protVer @@ -181,27 +186,37 @@ protocolInfoTPraosShelleyBased :: ( ShelleyCompatible (TPraos c) era , KESAgentContext c m ) => + SomeHasFS m -> ProtocolParamsShelleyBased c -> L.TransitionConfig era -> -- | see 'shelleyProtVer', mutatis mutandi SL.ProtVer -> - ( ProtocolInfo (ShelleyBlock (TPraos c) era) - , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock (TPraos c) era)] - ) + m + ( ProtocolInfo (ShelleyBlock (TPraos c) era) + , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock (TPraos c) era)] + ) protocolInfoTPraosShelleyBased + (SomeHasFS hasFS) ProtocolParamsShelleyBased { shelleyBasedInitialNonce = initialNonce , shelleyBasedLeaderCredentials = credentialss } transitionCfg protVer = - assertWithMsg (validateGenesis genesis) $ - ( ProtocolInfo - { pInfoConfig = topLevelConfig - , pInfoInitLedger = initExtLedgerState - } - , \tr -> pure $ mkBlockForging tr <$> credentialss - ) + assertWithMsg (validateGenesis genesis) $ do + initLedgerState <- mkInitLedgerState + let initExtLedgerState = + ExtLedgerState + { ledgerState = initLedgerState + , headerState = genesisHeaderState initChainDepState + } + pure + ( ProtocolInfo + { pInfoConfig = topLevelConfig + , pInfoInitLedger = initExtLedgerState + } + , \tr -> pure $ mkBlockForging tr <$> credentialss + ) where mkBlockForging :: Tracer.Tracer m KESAgentClientTrace -> @@ -272,27 +287,24 @@ protocolInfoTPraosShelleyBased , shelleyStorageConfigSecurityParam = tpraosSecurityParam tpraosParams } - initLedgerState :: LedgerState (ShelleyBlock (TPraos c) era) ValuesMK - initLedgerState = - unstowLedgerTables - ShelleyLedgerState - { shelleyLedgerTip = Origin - , shelleyLedgerState = - L.injectIntoTestState transitionCfg $ - L.createInitialState transitionCfg - , shelleyLedgerTransition = ShelleyTransitionInfo{shelleyAfterVoting = 0} - , shelleyLedgerTables = emptyLedgerTables - , shelleyLedgerLatestPerasCertRound = SNothing - } + mkInitLedgerState :: m (LedgerState (ShelleyBlock (TPraos c) era) ValuesMK) + mkInitLedgerState = do + injected <- + L.injectIntoTestState + hasFS + transitionCfg + (L.createInitialState transitionCfg) + pure $ + unstowLedgerTables + ShelleyLedgerState + { shelleyLedgerTip = Origin + , shelleyLedgerState = injected + , shelleyLedgerTransition = ShelleyTransitionInfo{shelleyAfterVoting = 0} + , shelleyLedgerTables = emptyLedgerTables + , shelleyLedgerLatestPerasCertRound = SNothing + } initChainDepState :: TPraosState initChainDepState = TPraosState Origin $ SL.initialChainDepState initialNonce (SL.sgGenDelegs genesis) - - initExtLedgerState :: ExtLedgerState (ShelleyBlock (TPraos c) era) ValuesMK - initExtLedgerState = - ExtLedgerState - { ledgerState = initLedgerState - , headerState = genesisHeaderState initChainDepState - } diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs index 6c60e92e49..b603019dff 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Abstract.hs @@ -17,7 +17,6 @@ module Ouroboros.Consensus.Shelley.Protocol.Abstract ( ProtoCrypto , ProtocolHeaderSupportsEnvelope (..) , ProtocolHeaderSupportsKES (..) - , ProtocolHeaderSupportsLedger (..) , ProtocolHeaderSupportsProtocol (..) , ShelleyHash (..) , ShelleyProtocol @@ -27,7 +26,6 @@ module Ouroboros.Consensus.Shelley.Protocol.Abstract import Cardano.Binary (FromCBOR (fromCBOR), ToCBOR (toCBOR)) import qualified Cardano.Crypto.Hash as Hash import Cardano.Crypto.VRF (OutputVRF) -import Cardano.Ledger.BHeaderView (BHeaderView) import Cardano.Ledger.BaseTypes (ProtVer) import Cardano.Ledger.Hashes ( EraIndependentBlockBody @@ -36,7 +34,7 @@ import Cardano.Ledger.Hashes ) import Cardano.Ledger.Keys (KeyRole (BlockIssuer), VKey) import Cardano.Protocol.Crypto (Crypto, VRF) -import Cardano.Protocol.TPraos.BHeader (PrevHash) +import Cardano.Protocol.TPraos.BlockHeader (PrevHash) import Cardano.Slotting.Block (BlockNo) import Cardano.Slotting.Slot (SlotNo) import Codec.Serialise (Serialise (..)) @@ -182,12 +180,6 @@ class ProtocolHeaderSupportsProtocol proto where pTieBreakVRFValue :: ShelleyProtocolHeader proto -> OutputVRF (VRF (ProtoCrypto proto)) --- | Indicates that the protocol header supports the Shelley ledger. We may need --- to generalise this if, in the future, the ledger requires different things --- from the protocol. -class ProtocolHeaderSupportsLedger proto where - mkHeaderView :: ShelleyProtocolHeader proto -> BHeaderView - {------------------------------------------------------------------------------- Key constraints -------------------------------------------------------------------------------} @@ -198,7 +190,6 @@ class , ProtocolHeaderSupportsEnvelope proto , ProtocolHeaderSupportsKES proto , ProtocolHeaderSupportsProtocol proto - , ProtocolHeaderSupportsLedger proto , Serialise (ChainDepState proto) , SignedHeader (ShelleyProtocolHeader proto) , HasMaxMajorProtVer proto diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/EnvelopeChecks.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/EnvelopeChecks.hs new file mode 100644 index 0000000000..e08ea857d1 --- /dev/null +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/EnvelopeChecks.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} + +module Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks + ( EnvelopeError (..) + , EnvelopeHeaderView (..) + , envelopeCheck + ) where + +import Cardano.Ledger.BaseTypes (Version) +import Cardano.Ledger.Chain (ChainChecksPParams (ccMaxBBSize, ccMaxBHSize)) +import Control.Monad (unless) +import Control.Monad.Except (Except, throwError) +import Data.Word (Word16, Word32) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) + +data EnvelopeError + = -- | This is a subtle case. + -- + -- This node is explicitly rejecting the header, but the header isn't + -- necessarily _directly_ at fault. + -- + -- This rejection specifically happens when the ticked ledger state being + -- used to validate this header contains a protocol major version (the + -- first 'Version') that exceeds the maximum major protocol version allowed + -- for this era this specific node's configuration (the second 'Version'). + -- The only thing the header did "wrong" was extend such a ledger state. + -- + -- Note that the ChainSync client ensures that that ledger state is ticked + -- starting from one of the latest k+1 ledger states on the node's current + -- chain (modulo STM scheduling). + -- + -- For Cardano and for now at least, this max major prot ver is typically + -- hardcoded in the source code (subject only to whether or not the + -- run-time config files enable "experimental" eras). + -- + -- Hence, most likely, the appropriate rectifying action is for the node + -- operator to update their node software and/or config; hence the name + -- 'ObsoleteNode'. (Or if they're intentionally testing an experimental + -- era, they forgot to set the appropriate config flag.) + -- + -- TODO Would it be more intuitive to instead enforce this when validating + -- the block that results in a ledger state with a major prot ver that + -- violates the config's limit? Would the errors the user sees be more or + -- less helpful? Etc. + -- + -- TODO (cont'd) It's not even obviously that specific ledger + -- state's/block's fault, since the protocol version is the consequence of + -- on-chain governance. Is it the voters' fault? Is the fault of the first + -- block that was after the voting deadline? So "extending the ledger state + -- that resulting from ticking after applying the block after the epoch + -- that extended the ancestor block that was after the voting deadline that + -- ..." is merely one step more removed. And this 'envelopeChecks' approach + -- does avoid the surprise (since the rejection doesn't even depend on the + -- block's non-header content either) where the header could be validated + -- but its underlying block could not. See + -- . + ObsoleteNode !Version !Version + | HeaderSizeTooLarge !Int !Word16 + | BlockSizeTooLarge !Word32 !Word32 + deriving (Eq, Generic, Show) + +instance NoThunks EnvelopeError + +data EnvelopeHeaderView = EnvelopeHeaderView + { ehvProtVer :: !Version + -- ^ The version against which to compare the node's max. + , ehvHeaderSize :: !Int + , ehvBodySize :: !Word32 + } + +-- | Shared envelope-check logic between Praos and TPraos. +-- 'ehvProtVer' is the block header declared protocol version in TPraos, and +-- the ledger view's protocol version in Praos - see docs for EnvelopeError +envelopeCheck :: + Version -> + ChainChecksPParams -> + EnvelopeHeaderView -> + Except EnvelopeError () +envelopeCheck maxpv ccd EnvelopeHeaderView{ehvProtVer, ehvHeaderSize, ehvBodySize} = do + unless (ehvProtVer <= maxpv) $ + throwError $ + ObsoleteNode ehvProtVer maxpv + unless (ehvHeaderSize <= fromIntegral @Word16 @Int (ccMaxBHSize ccd)) $ + throwError $ + HeaderSizeTooLarge ehvHeaderSize (ccMaxBHSize ccd) + unless (ehvBodySize <= ccMaxBBSize ccd) $ + throwError $ + BlockSizeTooLarge ehvBodySize (ccMaxBBSize ccd) diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs index da514a421f..86fb9fccd6 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/Praos.hs @@ -1,102 +1,50 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Ouroboros.Consensus.Shelley.Protocol.Praos (PraosEnvelopeError (..)) where +module Ouroboros.Consensus.Shelley.Protocol.Praos () where import qualified Cardano.Crypto.KES as KES import Cardano.Crypto.VRF (certifiedOutput) -import Cardano.Ledger.BHeaderView -import Cardano.Ledger.BaseTypes (ProtVer (ProtVer), Version) -import Cardano.Ledger.Keys (hashKey) +import Cardano.Ledger.BaseTypes (ProtVer (ProtVer)) +import Cardano.Ledger.Chain (ChainChecksPParams (..)) import Cardano.Ledger.Slot (SlotNo (unSlotNo)) +import Cardano.Protocol.Praos.BlockHeader + ( Header (..) + , HeaderBody (..) + , headerHash + , headerSize + ) import Cardano.Protocol.TPraos.OCert ( OCert (ocertKESPeriod, ocertVkHot) ) import qualified Cardano.Protocol.TPraos.OCert as SL -import Control.Monad (unless) -import Control.Monad.Except (throwError) import Data.Either (isRight) -import Data.Word (Word16, Word32) -import GHC.Generics (Generic) -import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Protocol.Praos import Ouroboros.Consensus.Protocol.Praos.Common ( MaxMajorProtVer (MaxMajorProtVer) ) -import Ouroboros.Consensus.Protocol.Praos.Header - ( Header (..) - , HeaderBody (..) - , headerHash - , headerSize - ) import Ouroboros.Consensus.Protocol.Praos.Views import Ouroboros.Consensus.Protocol.Signed import Ouroboros.Consensus.Shelley.Protocol.Abstract ( ProtoCrypto , ProtocolHeaderSupportsEnvelope (..) , ProtocolHeaderSupportsKES (..) - , ProtocolHeaderSupportsLedger (..) , ProtocolHeaderSupportsProtocol (..) , ShelleyHash (ShelleyHash) , ShelleyProtocol , ShelleyProtocolHeader ) +import Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks + ( EnvelopeError + , EnvelopeHeaderView (..) + , envelopeCheck + ) type instance ProtoCrypto (Praos c) = c type instance ShelleyProtocolHeader (Praos c) = Header c -data PraosEnvelopeError - = -- | This is a subtle case. - -- - -- This node is explicitly rejecting the header, but the header isn't - -- necessarily _directly_ at fault. - -- - -- This rejection specifically happens when the ticked ledger state being - -- used to validate this header contains a protocol major version (the - -- first 'Version') that exceeds the maximum major protocol version allowed - -- for this era this specific node's configuration (the second 'Version'). - -- The only thing the header did "wrong" was extend such a ledger state. - -- - -- Note that the ChainSync client ensures that that ledger state is ticked - -- starting from one of the latest k+1 ledger states on the node's current - -- chain (modulo STM scheduling). - -- - -- For Cardano and for now at least, this max major prot ver is typically - -- hardcoded in the source code (subject only to whether or not the - -- run-time config files enable "experimental" eras). - -- - -- Hence, most likely, the appropriate rectifying action is for the node - -- operator to update their node software and/or config; hence the name - -- 'ObsoleteNode'. (Or if they're intentionally testing an experimental - -- era, they forgot to set the appropriate config flag.) - -- - -- TODO Would it be more intuitive to instead enforce this when validating - -- the block that results in a ledger state with a major prot ver that - -- violates the config's limit? Would the errors the user sees be more or - -- less helpful? Etc. - -- - -- TODO (cont'd) It's not even obviously that specific ledger - -- state's/block's fault, since the protocol version is the consequence of - -- on-chain governance. Is it the voters' fault? Is the fault of the first - -- block that was after the voting deadline? So "extending the ledger state - -- that resulting from ticking after applying the block after the epoch - -- that extended the ancestor block that was after the voting deadline that - -- ..." is merely one step more removed. And this 'envelopeChecks' approach - -- does avoid the surprise (since the rejection doesn't even depend on the - -- block's non-header content either) where the header could be validated - -- but its underlying block could not. See - -- . - ObsoleteNode Version Version - | HeaderSizeTooLarge Int Word16 - | BlockSizeTooLarge Word32 Word32 - deriving (Eq, Generic, Show) - -instance NoThunks PraosEnvelopeError - instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (Praos c) where pHeaderHash hdr = ShelleyHash $ headerHash hdr pHeaderPrevHash (Header body _) = hbPrev body @@ -106,23 +54,25 @@ instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (Praos c) where pHeaderSize hdr = fromIntegral $ headerSize hdr pHeaderBlockSize (Header body _) = fromIntegral $ hbBodySize body - type EnvelopeCheckError _ = PraosEnvelopeError + type EnvelopeCheckError _ = EnvelopeError - envelopeChecks cfg lv hdr = do - unless (m <= maxpv) $ throwError (ObsoleteNode m maxpv) - unless (bhviewHSize bhv <= fromIntegral @Word16 @Int maxHeaderSize) $ - throwError $ - HeaderSizeTooLarge (bhviewHSize bhv) maxHeaderSize - unless (bhviewBSize bhv <= maxBodySize) $ - throwError $ - BlockSizeTooLarge (bhviewBSize bhv) maxBodySize + envelopeChecks cfg lv hdr = + envelopeCheck maxpv ccd $ + EnvelopeHeaderView + { ehvProtVer = m + , ehvHeaderSize = headerSize hdr + , ehvBodySize = hbBodySize body + } where - pp = praosParams cfg - (MaxMajorProtVer maxpv) = praosMaxMajorPV pp - (ProtVer m _) = lvProtocolVersion lv - maxHeaderSize = lvMaxHeaderSize lv - maxBodySize = lvMaxBodySize lv - bhv = mkHeaderView hdr + Header body _ = hdr + MaxMajorProtVer maxpv = praosMaxMajorPV (praosParams cfg) + ProtVer m _ = plvProtocolVersion lv + ccd = + ChainChecksPParams + { ccMaxBHSize = plvMaxHeaderSize lv + , ccMaxBBSize = plvMaxBodySize lv + , ccProtocolVersion = plvProtocolVersion lv + } instance PraosCrypto c => ProtocolHeaderSupportsKES (Praos c) where configSlotsPerKESPeriod cfg = praosSlotsPerKESPeriod $ praosParams cfg @@ -191,19 +141,6 @@ instance PraosCrypto c => ProtocolHeaderSupportsProtocol (Praos c) where -- here instead. pTieBreakVRFValue = certifiedOutput . hbVrfRes . headerBody -instance PraosCrypto c => ProtocolHeaderSupportsLedger (Praos c) where - mkHeaderView hdr@Header{headerBody} = - BHeaderView - { bhviewID = hashKey $ hbVk headerBody - , bhviewBSize = hbBodySize headerBody - , bhviewHSize = headerSize hdr - , bhviewBHash = hbBodyHash headerBody - , bhviewSlot = hbSlotNo headerBody - , bhviewProtVer = hbProtVer headerBody - , -- TODO(Peras): instantiate this for Peras when needed - bhviewPrevEpochNonce = Nothing - } - type instance Signed (Header c) = HeaderBody c instance PraosCrypto c => SignedHeader (Header c) where headerSigned = headerBody diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs index b881e05ddf..45c71bc3a5 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/TPraos.hs @@ -1,5 +1,4 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -8,12 +7,11 @@ module Ouroboros.Consensus.Shelley.Protocol.TPraos () where import qualified Cardano.Crypto.KES as SL import Cardano.Crypto.VRF (certifiedOutput) -import Cardano.Ledger.Chain (ChainPredicateFailure) +import Cardano.Ledger.BaseTypes (ProtVer (ProtVer)) import Cardano.Ledger.Hashes (originalBytesSize) -import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Protocol.TPraos.API (PraosCrypto) import qualified Cardano.Protocol.TPraos.API as SL -import qualified Cardano.Protocol.TPraos.BHeader as SL +import qualified Cardano.Protocol.TPraos.BlockHeader as SL import Cardano.Protocol.TPraos.OCert (ocertKESPeriod, ocertVkHot) import qualified Cardano.Protocol.TPraos.OCert as SL import Cardano.Slotting.Slot (unSlotNo) @@ -39,12 +37,15 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract ( ProtoCrypto , ProtocolHeaderSupportsEnvelope (..) , ProtocolHeaderSupportsKES (..) - , ProtocolHeaderSupportsLedger (..) , ProtocolHeaderSupportsProtocol (..) , ShelleyHash (..) , ShelleyProtocol , ShelleyProtocolHeader - , protocolHeaderView + ) +import Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks + ( EnvelopeError + , EnvelopeHeaderView (..) + , envelopeCheck ) type instance ProtoCrypto (TPraos c) = c @@ -60,15 +61,20 @@ instance PraosCrypto c => ProtocolHeaderSupportsEnvelope (TPraos c) where pHeaderSize = fromIntegral . originalBytesSize pHeaderBlockSize = fromIntegral @Word32 @Natural . SL.bsize . SL.bhbody - type EnvelopeCheckError _ = ChainPredicateFailure + type EnvelopeCheckError _ = EnvelopeError envelopeChecks cfg lv hdr = - SL.chainChecks - maxPV - (SL.lvChainChecks lv) - (SL.makeHeaderView (protocolHeaderView @(TPraos c) hdr) Nothing) + envelopeCheck maxPV ccd $ + EnvelopeHeaderView + { ehvProtVer = m + , ehvHeaderSize = originalBytesSize hdr + , ehvBodySize = SL.bsize bhb + } where - MaxMajorProtVer maxPV = tpraosMaxMajorPV $ tpraosParams cfg + bhb = SL.bhbody hdr + ccd = SL.tplvChainChecks lv + ProtVer m _ = SL.bprotver bhb + MaxMajorProtVer maxPV = tpraosMaxMajorPV (tpraosParams cfg) instance PraosCrypto c => ProtocolHeaderSupportsKES (TPraos c) where configSlotsPerKESPeriod cfg = tpraosSlotsPerKESPeriod $ tpraosParams cfg @@ -132,9 +138,6 @@ instance PraosCrypto c => ProtocolHeaderSupportsProtocol (TPraos c) where -- detailed discussion. pTieBreakVRFValue = certifiedOutput . SL.bheaderL . SL.bhbody -instance PraosCrypto c => ProtocolHeaderSupportsLedger (TPraos c) where - mkHeaderView = (flip SL.makeHeaderView) Nothing - type instance Signed (SL.BHeader c) = SL.BHBody c instance PraosCrypto c => SignedHeader (SL.BHeader c) where diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs index 4e045bfd84..2cb85d1a3c 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -13,6 +13,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +-- TODO: Ledger has a few deprecations that we are ignoring for now +{-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_GHC -Wno-orphans #-} -- | This module is the Shelley Hard Fork Combinator diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs index 9fd2804588..9f89caaac3 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs @@ -120,7 +120,6 @@ examples = , exampleChainDepState = unlabelled exampleChainDepState , exampleExtLedgerState = unlabelled $ forgetLedgerTables exampleExtLedgerState , exampleSlotNo = unlabelled exampleSlotNo - , exampleLedgerTables = unlabelled emptyLedgerTables } where regularAndEBB :: a -> a -> Labelled a diff --git a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs index 5d71e3a09b..5d80d83799 100644 --- a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Mempool.hs @@ -61,10 +61,12 @@ instance LedgerSupportsMempool ByronSpecBlock where mkMempoolApplyTxError = nothingMkMempoolApplyTxError instance TxLimits ByronSpecBlock where - type TxMeasure ByronSpecBlock = IgnoringOverflow ByteSize32 + type TxMeasurePhase1 ByronSpecBlock = IgnoringOverflow ByteSize32 + type TxMeasurePhase2 ByronSpecBlock = TrivialTxMeasurePhase2 -- Dummy values, as these are not used in practice. txWireSize = const . fromIntegral $ (0 :: Int) - blockCapacityTxMeasure _cfg _st = IgnoringOverflow $ ByteSize32 1 + blockCapacityTxMeasure _cfg _st = TxMeasure (IgnoringOverflow $ ByteSize32 1) TrivialTxMeasurePhase2 - txMeasure _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0 + txMeasurePhase1 _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0 + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Examples.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Examples.hs index 99a0bdcf53..7b77aedaf0 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/Examples.hs @@ -52,10 +52,7 @@ import Ouroboros.Consensus.HeaderValidation (AnnTip) import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr) -import Ouroboros.Consensus.Ledger.Tables - ( EmptyMK - , ValuesMK - ) +import Ouroboros.Consensus.Ledger.Tables (EmptyMK) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley @@ -112,7 +109,6 @@ combineEras perEraExamples = fmap (second unFlip) $ viaInject (fmap (second Flip) . exampleExtLedgerState) , exampleSlotNo = coerce $ viaInject @(K SlotNo) (coerce exampleSlotNo) , exampleLedgerConfig = exampleLedgerConfigCardano - , exampleLedgerTables = exampleLedgerTablesCardano } where viaInject :: @@ -136,13 +132,6 @@ combineEras perEraExamples = where eraName = singleEraName $ singleEraInfo es - exampleLedgerTablesCardano :: - Labelled (LedgerTables (HardForkBlock (CardanoEras Crypto)) ValuesMK) - exampleLedgerTablesCardano = - mconcat $ - hcollapse $ - himap (\ix -> K . map (second (injectLedgerTables ix)) . exampleLedgerTables) perEraExamplesPrefixed - exampleLedgerConfigCardano :: Labelled (HardForkLedgerConfig (CardanoEras Crypto)) exampleLedgerConfigCardano = @@ -224,7 +213,6 @@ instance Inject Examples where , exampleChainDepState = inj (Proxy @WrapChainDepState) exampleChainDepState , exampleExtLedgerState = inj (Proxy @(Flip ExtLedgerState EmptyMK)) exampleExtLedgerState , exampleSlotNo = exampleSlotNo - , exampleLedgerTables = inj (Proxy @WrapLedgerTables) exampleLedgerTables , -- We cannot create a HF Ledger Config out of just one of the eras exampleLedgerConfig = mempty } @@ -238,15 +226,6 @@ instance Inject Examples where Proxy f -> Labelled a -> Labelled b inj p = map (fmap (inject' p iidx)) --- | This wrapper is used only in the 'Example' instance of 'Inject' so that we --- can use a type that matches the kind expected by 'inj'. -newtype WrapLedgerTables blk = WrapLedgerTables (LedgerTables blk ValuesMK) - -instance Inject WrapLedgerTables where - inject idx (WrapLedgerTables lt) = - WrapLedgerTables $ - injectLedgerTables (forgetInjectionIndex idx) lt - {------------------------------------------------------------------------------- Setup -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/ProtocolInfo.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/ProtocolInfo.hs index b21722da90..bb112f0fb7 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/ProtocolInfo.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/Consensus/Cardano/ProtocolInfo.hs @@ -70,6 +70,9 @@ import Ouroboros.Consensus.Shelley.Node , ShelleyGenesis , ShelleyLeaderCredentials ) +import System.FS.API (SomeHasFS (..)) +import qualified System.FS.Sim.MockFS as MockFS +import qualified System.FS.Sim.STM as Sim import qualified Test.Cardano.Ledger.Alonzo.Examples as Alonzo import qualified Test.Cardano.Ledger.Conway.Examples as Conway import qualified Test.Cardano.Ledger.Dijkstra.Examples as Dijkstra @@ -179,16 +182,18 @@ mkSimpleTestProtocolInfo :: ShelleySlotLengthInSeconds -> SL.ProtVer -> CardanoHardForkTriggers -> - ProtocolInfo (CardanoBlock c) + IO (ProtocolInfo (CardanoBlock c)) mkSimpleTestProtocolInfo decentralizationParam securityParam byronSlotLenghtInSeconds shelleySlotLengthInSeconds protocolVersion - hardForkTriggers = - fst $ - mkTestProtocolInfo @IO + hardForkTriggers = do + fs <- SomeHasFS <$> Sim.simHasFS' MockFS.empty + fst + <$> mkTestProtocolInfo @IO + fs (CoreNodeId 0, coreNodeShelley) shelleyGenesis aByronProtocolVersion @@ -243,6 +248,7 @@ mkTestProtocolInfo :: ( CardanoHardForkConstraints c , KESAgentContext c m ) => + SomeHasFS m -> -- | Id of the node for which the protocol info will be elaborated. (CoreNodeId, Shelley.CoreNode c) -> -- | These nodes will be part of the initial delegation mapping, and funds @@ -260,10 +266,12 @@ mkTestProtocolInfo :: SL.ProtVer -> -- | Specification of the era to which the initial state should hard-fork to. CardanoHardForkTriggers -> - ( ProtocolInfo (CardanoBlock c) - , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (CardanoBlock c)] - ) + m + ( ProtocolInfo (CardanoBlock c) + , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (CardanoBlock c)] + ) mkTestProtocolInfo + fs (coreNodeId, coreNode) shelleyGenesis aByronProtocolVersion @@ -274,6 +282,7 @@ mkTestProtocolInfo protocolVersion hardForkTriggers = protocolInfoCardano + fs ( CardanoProtocolParams ProtocolParamsByron { byronGenesis = genesisByron diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs index aad2db579e..fd2b9b48b5 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs @@ -67,7 +67,7 @@ import Data.SOP.Strict import qualified Data.SOP.Tails as Tails import qualified Data.SOP.Telescope as Telescope import Data.Void (Void) -import Lens.Micro ((^.)) +import Lens.Micro ((%~), (&), (.~), (^.)) import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Forging (MkBlockForging) import Ouroboros.Consensus.Cardano.CanHardFork @@ -102,6 +102,7 @@ import Ouroboros.Consensus.Storage.LedgerDB import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util (eitherToMaybe) import Ouroboros.Consensus.Util.IndexedMemPack +import System.FS.API (SomeHasFS) import Test.ThreadNet.TxGen import Test.ThreadNet.TxGen.Shelley () @@ -188,7 +189,12 @@ type ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 = , LedgerSupportsPeras (ShelleyBlock proto2 era2) , TxLimits (ShelleyBlock proto1 era1) , TxLimits (ShelleyBlock proto2 era2) - , TranslateTxMeasure (TxMeasure (ShelleyBlock proto1 era1)) (TxMeasure (ShelleyBlock proto2 era2)) + , TranslateTxMeasure + (TxMeasurePhase1 (ShelleyBlock proto1 era1)) + (TxMeasurePhase1 (ShelleyBlock proto2 era2)) + , TranslateTxMeasure + (TxMeasurePhase2 (ShelleyBlock proto1 era1)) + (TxMeasurePhase2 (ShelleyBlock proto2 era2)) , SL.PreviousEra era2 ~ era1 , SL.TranslateEra era2 SL.NewEpochState , SL.TranslateEra era2 (SL.Tx SL.TopTx) @@ -205,23 +211,26 @@ type ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 = class TranslateTxMeasure a b where translateTxMeasure :: a -> b +-- Phase 1 measures + instance TranslateTxMeasure (IgnoringOverflow ByteSize32) (IgnoringOverflow ByteSize32) where translateTxMeasure = id instance TranslateTxMeasure (IgnoringOverflow ByteSize32) AlonzoMeasure where translateTxMeasure x = AlonzoMeasure x mempty -instance TranslateTxMeasure (IgnoringOverflow ByteSize32) ConwayMeasure where - translateTxMeasure = - translateTxMeasure . (\x -> x :: AlonzoMeasure) . translateTxMeasure - instance TranslateTxMeasure AlonzoMeasure AlonzoMeasure where translateTxMeasure = id -instance TranslateTxMeasure AlonzoMeasure ConwayMeasure where - translateTxMeasure x = ConwayMeasure x mempty +-- Phase 2 measures + +instance TranslateTxMeasure TrivialTxMeasurePhase2 TrivialTxMeasurePhase2 where + translateTxMeasure = id + +instance TranslateTxMeasure TrivialTxMeasurePhase2 RefScriptSize where + translateTxMeasure TrivialTxMeasurePhase2 = mempty -instance TranslateTxMeasure ConwayMeasure ConwayMeasure where +instance TranslateTxMeasure RefScriptSize RefScriptSize where translateTxMeasure = id instance @@ -235,8 +244,11 @@ instance CanHardFork (ShelleyBasedHardForkEras proto1 era1 proto2 era2) where type - HardForkTxMeasure (ShelleyBasedHardForkEras proto1 era1 proto2 era2) = - TxMeasure (ShelleyBlock proto2 era2) + HardForkTxMeasurePhase1 (ShelleyBasedHardForkEras proto1 era1 proto2 era2) = + TxMeasurePhase1 (ShelleyBlock proto2 era2) + type + HardForkTxMeasurePhase2 (ShelleyBasedHardForkEras proto1 era1 proto2 era2) = + TxMeasurePhase2 (ShelleyBlock proto2 era2) hardForkEraTranslation = EraTranslation @@ -308,9 +320,13 @@ instance . SL.translateEra transCtxt . Comp - hardForkInjTxMeasure = \case - (Z (WrapTxMeasure x)) -> translateTxMeasure x - S (Z (WrapTxMeasure x)) -> x + hardForkInjTxMeasurePhase1 = \case + (Z (WrapTxMeasurePhase1 x)) -> translateTxMeasure x + S (Z (WrapTxMeasurePhase1 x)) -> x + + hardForkInjTxMeasurePhase2 = \case + (Z (WrapTxMeasurePhase2 x)) -> translateTxMeasure x + S (Z (WrapTxMeasurePhase2 x)) -> x instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 => @@ -393,54 +409,84 @@ protocolInfoShelleyBasedHardFork :: ( KESAgentContext (ProtoCrypto proto2) m , ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 ) => + SomeHasFS m -> ProtocolParamsShelleyBased (ProtoCrypto proto1) -> SL.ProtVer -> SL.ProtVer -> L.TransitionConfig era2 -> TriggerHardFork -> - ( ProtocolInfo (ShelleyBasedHardForkBlock proto1 era1 proto2 era2) - , Tracer.Tracer m KESAgentClientTrace -> - m [MkBlockForging m (ShelleyBasedHardForkBlock proto1 era1 proto2 era2)] - ) + m + ( ProtocolInfo (ShelleyBasedHardForkBlock proto1 era1 proto2 era2) + , Tracer.Tracer m KESAgentClientTrace -> + m [MkBlockForging m (ShelleyBasedHardForkBlock proto1 era1 proto2 era2)] + ) protocolInfoShelleyBasedHardFork + fs protocolParamsShelleyBased protVer1 protVer2 transCfg2 - hardForkTrigger = - protocolInfoBinary - -- Era 1 - protocolInfo1 - blockForging1 - eraParams1 - tpraosParams - toPartialLedgerConfig1 - -- Era 2 - protocolInfo2 - blockForging2 - eraParams2 - tpraosParams - toPartialLedgerConfig2 + hardForkTrigger = do + (protocolInfo1, blockForging1) <- + protocolInfoTPraosShelleyBased + fs + protocolParamsShelleyBased + transCfgEra1 + protVer1 + (protocolInfo2, blockForging2) <- + protocolInfoTPraosShelleyBased + fs + ProtocolParamsShelleyBased + { shelleyBasedInitialNonce + , shelleyBasedLeaderCredentials + } + transCfgEra2 + protVer2 + pure $ + protocolInfoBinary + -- Era 1 + protocolInfo1 + blockForging1 + eraParams1 + tpraosParams + toPartialLedgerConfig1 + -- Era 2 + protocolInfo2 + blockForging2 + eraParams2 + tpraosParams + toPartialLedgerConfig2 where ProtocolParamsShelleyBased { shelleyBasedInitialNonce , shelleyBasedLeaderCredentials } = protocolParamsShelleyBased + -- Override the protocol version inside the Shelley genesis carried by a + -- transition config. Each era's 'createInitialState' enforces + -- 'eraProtVerLow <= curProtVer <= eraProtVerHigh', so a single shared + -- genesis PV cannot satisfy both era1 and era2; we derive a per-era copy. + overrideGenesisPV :: + forall era. + L.EraTransition era => + SL.ProtVer -> + L.TransitionConfig era -> + L.TransitionConfig era + overrideGenesisPV pv = + L.tcShelleyGenesisL %~ \sg -> + sg{SL.sgProtocolParams = SL.sgProtocolParams sg & SL.ppProtocolVersionL .~ pv} + + transCfgEra1 :: L.TransitionConfig era1 + transCfgEra1 = (transCfg2 ^. L.tcPreviousEraConfigL) & overrideGenesisPV protVer1 + + transCfgEra2 :: L.TransitionConfig era2 + transCfgEra2 = transCfg2 & overrideGenesisPV protVer2 + -- Era 1 genesis :: SL.ShelleyGenesis genesis = transCfg2 ^. L.tcShelleyGenesisL - protocolInfo1 :: ProtocolInfo (ShelleyBlock proto1 era1) - blockForging1 :: - Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock proto1 era1)] - (protocolInfo1, blockForging1) = - protocolInfoTPraosShelleyBased - protocolParamsShelleyBased - (transCfg2 ^. L.tcPreviousEraConfigL) - protVer1 - eraParams1 :: History.EraParams eraParams1 = shelleyEraParams genesis @@ -455,18 +501,6 @@ protocolInfoShelleyBasedHardFork -- Era 2 - protocolInfo2 :: ProtocolInfo (ShelleyBlock proto2 era2) - blockForging2 :: - Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock proto2 era2)] - (protocolInfo2, blockForging2) = - protocolInfoTPraosShelleyBased - ProtocolParamsShelleyBased - { shelleyBasedInitialNonce - , shelleyBasedLeaderCredentials - } - transCfg2 - protVer2 - eraParams2 :: History.EraParams eraParams2 = shelleyEraParams genesis diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs index 3b4c9e2596..10ea879125 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/KeysPraos.hs @@ -29,6 +29,7 @@ import qualified Cardano.Crypto.DSIGN.Class as Crypto import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Crypto.KES.Class as Crypto import qualified Cardano.Crypto.VRF.Class as Crypto +import Cardano.Ledger.Binary (fromPlainDecoder) import Cardano.Ledger.Hashes (HASH) import Cardano.Protocol.Crypto (Crypto (..), StandardCrypto) import Data.String (IsString (..)) @@ -55,7 +56,7 @@ instance Key UnsoundPureKesKey where = KesSigningKey (Crypto.UnsoundPureSignKeyKES (KES StandardCrypto)) deriving (Show, IsString) via UsingRawBytesHex (SigningKey UnsoundPureKesKey) deriving newtype (ToCBOR, FromCBOR) - deriving anyclass (EncCBOR, DecCBOR, SerialiseAsCBOR) + deriving anyclass (EncCBOR, SerialiseAsCBOR) -- This loses the mlock safety of the seed, since it starts from a normal in-memory seed. deterministicSigningKey :: AsType UnsoundPureKesKey -> Crypto.Seed -> SigningKey UnsoundPureKesKey @@ -77,6 +78,9 @@ instance Key UnsoundPureKesKey where verificationKeyHash (KesVerificationKey vkey) = UnsoundPureKesKeyHash (Crypto.hashVerKeyKES vkey) +instance DecCBOR (SigningKey UnsoundPureKesKey) where + decCBOR = fromPlainDecoder fromCBOR + instance SerialiseAsRawBytes (VerificationKey UnsoundPureKesKey) where serialiseToRawBytes (KesVerificationKey vk) = Crypto.rawSerialiseVerKeyKES vk diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Protocol/Types.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Protocol/Types.hs index da084cc8da..6d3c693c1c 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Protocol/Types.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/Protocol/Types.hs @@ -10,7 +10,6 @@ module Cardano.Api.Protocol.Types import Cardano.Chain.Slotting (EpochSlots) import qualified Control.Tracer as Tracer -import Data.Bifunctor (bimap) import Ouroboros.Consensus.Block.Forging (MkBlockForging (..)) import Ouroboros.Consensus.Byron.ByronHFC (ByronBlockHFC) import Ouroboros.Consensus.Cardano @@ -35,14 +34,16 @@ import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Consensus import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import Ouroboros.Consensus.Shelley.ShelleyHFC (ShelleyBlockHFC) import Ouroboros.Consensus.Util.IOLike +import System.FS.API (SomeHasFS) class (RunNode blk, IOLike m) => Protocol m blk where data ProtocolInfoArgs m blk protocolInfo :: ProtocolInfoArgs m blk -> - ( ProtocolInfo blk - , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m blk] - ) + m + ( ProtocolInfo blk + , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m blk] + ) -- | Node client support for each consensus protocol. -- @@ -56,9 +57,10 @@ class RunNode blk => ProtocolClient blk where instance IOLike m => Protocol m ByronBlockHFC where data ProtocolInfoArgs m ByronBlockHFC = ProtocolInfoArgsByron ProtocolParamsByron protocolInfo (ProtocolInfoArgsByron params) = - ( inject $ protocolInfoByron params - , \_ -> pure . map (MkBlockForging . pure . inject) $ blockForgingByron params - ) + pure + ( inject $ protocolInfoByron params + , \_ -> pure . map (MkBlockForging . pure . inject) $ blockForgingByron params + ) instance ( CardanoHardForkConstraints StandardCrypto @@ -69,10 +71,11 @@ instance where data ProtocolInfoArgs m (CardanoBlock StandardCrypto) = ProtocolInfoArgsCardano + (SomeHasFS m) (CardanoProtocolParams StandardCrypto) - protocolInfo (ProtocolInfoArgsCardano paramsCardano) = - protocolInfoCardano paramsCardano + protocolInfo (ProtocolInfoArgsCardano fs paramsCardano) = + protocolInfoCardano fs paramsCardano instance ProtocolClient ByronBlockHFC where data ProtocolClientInfoArgs ByronBlockHFC @@ -99,13 +102,15 @@ instance where data ProtocolInfoArgs m (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) ShelleyEra) = ProtocolInfoArgsShelley + (SomeHasFS m) ShelleyGenesis (ProtocolParamsShelleyBased StandardCrypto) ProtVer - protocolInfo (ProtocolInfoArgsShelley genesis shelleyBasedProtocolParams' protVer) = - bimap inject injectBlockForging $ protocolInfoShelley genesis shelleyBasedProtocolParams' protVer + protocolInfo (ProtocolInfoArgsShelley fs genesis shelleyBasedProtocolParams' protVer) = do + (pinfo, bf) <- protocolInfoShelley fs genesis shelleyBasedProtocolParams' protVer + pure (inject pinfo, injectBlockForging bf) where - injectBlockForging bf tr = fmap (map inject) $ bf tr + injectBlockForging bf tr = fmap (map inject) (bf tr) instance Consensus.LedgerSupportsProtocol diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/SerialiseUsing.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/SerialiseUsing.hs index 7cbe767594..f2ef64f07a 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/SerialiseUsing.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Api/SerialiseUsing.hs @@ -9,6 +9,7 @@ module Cardano.Api.SerialiseUsing ) where import Cardano.Api.Any +import Cardano.Ledger.Binary (fromPlainDecoder) import Data.Aeson.Types ( FromJSON , FromJSONKey @@ -44,7 +45,8 @@ instance (SerialiseAsRawBytes a, Typeable a) => FromCBOR (UsingRawBytes a) where instance (SerialiseAsRawBytes a, Typeable a) => EncCBOR (UsingRawBytes a) -instance (SerialiseAsRawBytes a, Typeable a) => DecCBOR (UsingRawBytes a) +instance (SerialiseAsRawBytes a, Typeable a) => DecCBOR (UsingRawBytes a) where + decCBOR = fromPlainDecoder fromCBOR -- | For use with @deriving via@, to provide instances for any\/all of 'Show', -- 'IsString', 'ToJSON', 'FromJSON', 'ToJSONKey', FromJSONKey' using a hex diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs index 69a008d1f8..988ad1f5b5 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs @@ -37,7 +37,7 @@ import Cardano.Tools.DBAnalyser.Types import Control.Monad (join, unless, void, when) import Control.Monad.Except (runExcept) import Control.ResourceRegistry -import Control.Tracer (Tracer (..), nullTracer, traceWith) +import Control.Tracer (Tracer, nullTracer, traceWith) import Data.Int (Int64) import Data.List (intercalate) import qualified Data.Map.Strict as Map diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Cardano.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Cardano.hs index 7e4f57c20a..6c7f2f2e8c 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Cardano.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Cardano.hs @@ -77,6 +77,9 @@ import Ouroboros.Consensus.Shelley.Ledger.Block ) import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import System.Directory (makeAbsolute) +import System.FS.API (SomeHasFS (..)) +import System.FS.API.Types (MountPoint (MountPoint)) +import System.FS.IO (ioHasFS) import System.FilePath (takeDirectory, ()) import TextBuilder (TextBuilder) import qualified TextBuilder as Builder @@ -134,8 +137,10 @@ instance HasProtocolInfo (CardanoBlock StandardCrypto) where } mkProtocolInfo CardanoBlockArgs{configFile, threshold} = do - relativeToConfig :: (FilePath -> FilePath) <- - () . takeDirectory <$> makeAbsolute configFile + absoluteConfig <- makeAbsolute configFile + let configDir = takeDirectory absoluteConfig + relativeToConfig :: FilePath -> FilePath + relativeToConfig = (configDir ) cc :: CardanoConfig <- either (error . show) (return . adjustFilePaths relativeToConfig) @@ -171,13 +176,15 @@ instance HasProtocolInfo (CardanoBlock StandardCrypto) where CryptoClass.hashWith id $ content - return $ - mkCardanoProtocolInfo - genesisByron - threshold - transCfg - initialNonce - (cfgHardForkTriggers cc) + let fs = SomeHasFS (ioHasFS (MountPoint configDir)) + + mkCardanoProtocolInfo + fs + genesisByron + threshold + transCfg + initialNonce + (cfgHardForkTriggers cc) mkLSMConfig CardanoBlockArgs{configFile} = do -- The export path is interpreted relative to the LedgerDB filesystem root, @@ -427,15 +434,17 @@ getShelleyBasedUtxo = type CardanoBlockArgs = Args (CardanoBlock StandardCrypto) mkCardanoProtocolInfo :: + SomeHasFS IO -> Byron.Genesis.Config -> Maybe PBftSignatureThreshold -> SL.TransitionConfig L.LatestKnownEra -> Nonce -> CardanoHardForkTriggers -> - ProtocolInfo (CardanoBlock StandardCrypto) -mkCardanoProtocolInfo genesisByron signatureThreshold transitionConfig initialNonce triggers = - fst $ - protocolInfoCardano @_ @IO + IO (ProtocolInfo (CardanoBlock StandardCrypto)) +mkCardanoProtocolInfo fs genesisByron signatureThreshold transitionConfig initialNonce triggers = + fst + <$> protocolInfoCardano @_ @IO + fs ( CardanoProtocolParams ProtocolParamsByron { byronGenesis = genesisByron @@ -454,7 +463,6 @@ mkCardanoProtocolInfo genesisByron signatureThreshold transitionConfig initialNo emptyCheckpointsMap (ProtVer (L.eraProtVerHigh @L.LatestKnownEra) 0) ) - where castHeaderHash :: HeaderHash ByronBlock -> diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Shelley.hs index 281d1e7d1a..626aafc511 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Shelley.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Block/Shelley.hs @@ -51,6 +51,11 @@ import Ouroboros.Consensus.Shelley.Node , protocolInfoShelley ) import Ouroboros.Network.SizeInBytes (SizeInBytes (SizeInBytes)) +import System.Directory (makeAbsolute) +import System.FS.API (SomeHasFS (..)) +import System.FS.API.Types (MountPoint (MountPoint)) +import System.FS.IO (ioHasFS) +import System.FilePath (takeDirectory) import TextBuilder (decimal) -- | Usable for each Shelley-based era @@ -145,17 +150,21 @@ instance HasProtocolInfo (ShelleyBlock (TPraos StandardCrypto) ShelleyEra) where config <- either (error . show) return =<< Aeson.eitherDecodeFileStrict' configFileShelley - return $ mkShelleyProtocolInfo config initialNonce + configDir <- takeDirectory <$> makeAbsolute configFileShelley + let fs = SomeHasFS (ioHasFS (MountPoint configDir)) + mkShelleyProtocolInfo fs config initialNonce type ShelleyBlockArgs = Args (ShelleyBlock (TPraos StandardCrypto) ShelleyEra) mkShelleyProtocolInfo :: + SomeHasFS IO -> ShelleyGenesis -> Nonce -> - ProtocolInfo (ShelleyBlock (TPraos StandardCrypto) ShelleyEra) -mkShelleyProtocolInfo genesis initialNonce = - fst $ - protocolInfoShelley @IO + IO (ProtocolInfo (ShelleyBlock (TPraos StandardCrypto) ShelleyEra)) +mkShelleyProtocolInfo fs genesis initialNonce = + fst + <$> protocolInfoShelley @IO + fs genesis ProtocolParamsShelleyBased { shelleyBasedInitialNonce = initialNonce diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs index 24b7406cc4..b3950d758b 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs @@ -16,8 +16,7 @@ import Cardano.Tools.DBAnalyser.Types import Control.Monad (unless) import Control.Monad.Trans.Class import Control.ResourceRegistry -import Control.Tracer (Tracer (..), nullTracer) -import Data.Functor.Contravariant ((>$<)) +import Control.Tracer (mkTracer, nullTracer, (>$<)) import Data.Singletons (Sing, SingI (..)) import qualified Debug.Trace as Debug import Ouroboros.Consensus.Block @@ -159,8 +158,8 @@ analyse :: analyse dbaConfig args = withRegistry $ \registry -> do lock <- newMVar () - chainDBTracer <- mkTracer lock verbose - analysisTracer <- mkTracer lock True + chainDBTracer <- mkVerboseTracer lock verbose + analysisTracer <- mkVerboseTracer lock True LSMConfig{lsmConfigExportPath} <- mkLSMConfig args lsmSalt <- fst . genWord64 <$> newStdGen ProtocolInfo{pInfoInitLedger = genesisLedger, pInfoConfig = cfg} <- @@ -270,10 +269,10 @@ analyse dbaConfig args = (ImmutableDB.openDBInternal immutableDbArgs) (ImmutableDB.closeDB . fst) - mkTracer _ False = return nullTracer - mkTracer lock True = do + mkVerboseTracer _ False = return nullTracer + mkVerboseTracer lock True = do startTime <- getMonotonicTime - return $ Tracer $ \ev -> withLock $ do + return $ mkTracer $ \ev -> withLock $ do traceTime <- getMonotonicTime let diff = diffTime traceTime startTime hPutStrLn stderr $ printf "[%.6fs] %s" (realToFrac diff :: Double) (show ev) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBImmutaliser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBImmutaliser/Run.hs index 1739fe7ad0..cd5c12b386 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBImmutaliser/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBImmutaliser/Run.hs @@ -24,9 +24,8 @@ import qualified Cardano.Tools.DBAnalyser.Block.Cardano as Cardano import Cardano.Tools.DBAnalyser.HasAnalysis (mkProtocolInfo) import Control.Monad (unless) import Control.ResourceRegistry -import Control.Tracer (Tracer (..), stdoutTracer, traceWith) +import Control.Tracer (Tracer, mkTracer, stdoutTracer, traceWith, (>$<)) import Data.Foldable (for_) -import Data.Functor.Contravariant ((>$<)) import Data.List (intercalate, sortOn) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE @@ -84,7 +83,7 @@ run Opts{dbDirs, configFile, verbose, dotOut, dryRun} = do immutalise (configBlock cfg) (tracer <> dotTracer) dryRun where tracer = prettyTrace verbose >$< stdoutTracer - dotTracer = Tracer $ \case + dotTracer = mkTracer $ \case TraceAllCandidates candidates -> do let dot = dotCandidates $ fst <$> candidates whenJust dotOut $ flip Dot.encodeToFile dot diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index 29ef5554d5..d0dd4c39b9 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -58,6 +58,9 @@ import Ouroboros.Consensus.Util.IOLike (atomically) import Ouroboros.Network.Block import Ouroboros.Network.Point (WithOrigin (..)) import System.Directory +import System.FS.API (SomeHasFS (..)) +import System.FS.API.Types (MountPoint (MountPoint)) +import System.FS.IO (ioHasFS) import System.FilePath (takeDirectory, ()) import System.Random (newStdGen) @@ -67,15 +70,16 @@ initialize :: DBSynthesizerOptions -> IO (Either String (DBSynthesizerConfig, CardanoProtocolParams StandardCrypto)) initialize NodeFilePaths{nfpConfig, nfpChainDB} creds synthOptions = do - relativeToConfig :: (FilePath -> FilePath) <- - () . takeDirectory <$> makeAbsolute nfpConfig + configDir <- takeDirectory <$> makeAbsolute nfpConfig + let relativeToConfig :: FilePath -> FilePath + relativeToConfig = (configDir ) runExceptT $ do - conf <- initConf relativeToConfig + conf <- initConf configDir relativeToConfig proto <- initProtocol relativeToConfig conf pure (conf, proto) where - initConf :: (FilePath -> FilePath) -> ExceptT String IO DBSynthesizerConfig - initConf relativeToConfig = do + initConf :: FilePath -> (FilePath -> FilePath) -> ExceptT String IO DBSynthesizerConfig + initConf configDir relativeToConfig = do inp <- handleIOExceptT show (BS.readFile nfpConfig) configStub <- adjustFilePaths relativeToConfig <$> readJson inp shelleyGenesis <- readFileJson $ ncsShelleyGenesisFile configStub @@ -97,6 +101,7 @@ initialize NodeFilePaths{nfpConfig, nfpChainDB} creds synthOptions = do , confProtocolCredentials = protocolCredentials , confShelleyGenesis = shelleyGenesis , confDbDir = nfpChainDB + , confNodeConfigDir = configDir } initProtocol :: @@ -147,8 +152,16 @@ synthesize :: DBSynthesizerConfig -> (CardanoProtocolParams StandardCrypto) -> IO ForgeResult -synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir} runP = +synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir, confNodeConfigDir} runP = withRegistry $ \registry -> do + let fs = SomeHasFS (ioHasFS (MountPoint confNodeConfigDir)) + ( ProtocolInfo + { pInfoConfig + , pInfoInitLedger + } + , mkForgers + ) <- + protocolInfoCardano fs runP snapshotDelayRng <- newStdGen let epochSize = sgEpochLength confShelleyGenesis @@ -199,12 +212,6 @@ synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir { synthOpenMode , synthLimit } = confOptions - ( ProtocolInfo - { pInfoConfig - , pInfoInitLedger - } - , mkForgers - ) = protocolInfoCardano runP preOpenChainDB :: DBSynthesizerOpenMode -> FilePath -> IO () preOpenChainDB mode db = diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Types.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Types.hs index 5ab84d040a..a97b86c969 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Types.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Types.hs @@ -57,5 +57,6 @@ data DBSynthesizerConfig = DBSynthesizerConfig , confProtocolCredentials :: ProtocolFilepaths , confShelleyGenesis :: ShelleyGenesis , confDbDir :: FilePath + , confNodeConfigDir :: FilePath } deriving Show diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs index bc616275cd..6583da3db6 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs @@ -43,7 +43,7 @@ truncate :: truncate DBTruncaterConfig{dbDir, truncateAfter, verbose} args = do withRegistry $ \registry -> do lock <- mkLock - immutableDBTracer <- mkTracer lock verbose + immutableDBTracer <- mkVerboseTracer lock verbose ProtocolInfo { pInfoConfig = config } <- @@ -113,11 +113,11 @@ findLast p iter = mkLock :: MonadMVar m => m (StrictMVar m ()) mkLock = newMVar () -mkTracer :: Show a => StrictMVar IO () -> Bool -> IO (Tracer IO a) -mkTracer _ False = pure mempty -mkTracer lock True = do +mkVerboseTracer :: Show a => StrictMVar IO () -> Bool -> IO (Tracer IO a) +mkVerboseTracer _ False = pure mempty +mkVerboseTracer lock True = do startTime <- getMonotonicTime - pure $ Tracer $ \ev -> do + pure $ mkTracer $ \ev -> do bracket_ (takeMVar lock) (putMVar lock ()) $ do traceTime <- getMonotonicTime let diff = diffTime traceTime startTime diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs index 7bc4e47ad5..30331fd825 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs @@ -10,7 +10,6 @@ import Cardano.Tools.ImmDBServer.MiniProtocols (immDBServer) import Control.ResourceRegistry import Control.Tracer import qualified Data.ByteString.Lazy as BL -import Data.Functor.Contravariant ((>$<)) import Data.Void (Void) import qualified Network.Mux as Mux import Network.Socket (SockAddr (..)) @@ -67,7 +66,7 @@ serve sockAddr application = withIOManager \iocp -> { haHandshakeTracer = show >$< stdoutTracer , haBearerTracer = show >$< stdoutTracer , haHandshakeCodec = N2N.nodeToNodeHandshakeCodec - , haVersionDataCodec = Handshake.cborTermVersionDataCodec N2N.nodeToNodeCodecCBORTerm + , haVersionDataCodec = N2N.nodeToNodeVersionDataCodec , haAcceptVersion = Handshake.acceptableVersion , haQueryVersion = Handshake.queryVersion , haTimeLimits = Handshake.timeLimitsHandshake diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs index 6705b96832..6555ca47f4 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs @@ -23,19 +23,19 @@ module Test.Consensus.Shelley.Examples import qualified Cardano.Ledger.BaseTypes as SL import qualified Cardano.Ledger.Block as SL import Cardano.Ledger.Core -import qualified Cardano.Ledger.Core as LC import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Protocol.Crypto (StandardCrypto) -import qualified Cardano.Protocol.TPraos.BHeader as SL +import Cardano.Protocol.Praos.BlockHeader + ( HeaderBody (HeaderBody) + ) +import qualified Cardano.Protocol.Praos.BlockHeader as Praos +import qualified Cardano.Protocol.TPraos.BlockHeader as SL import Cardano.Slotting.EpochInfo (fixedEpochInfo) import Cardano.Slotting.Time (mkSlotLength) import Data.Coerce (coerce) -import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.Map as Map import Data.Maybe.Strict (StrictMaybe (..)) import qualified Data.Set as Set -import Lens.Micro import Ouroboros.Consensus.Block import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Extended @@ -46,10 +46,6 @@ import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Protocol.Abstract (translateChainDepState) import Ouroboros.Consensus.Protocol.Praos (Praos) import Ouroboros.Consensus.Protocol.Praos.Common -import Ouroboros.Consensus.Protocol.Praos.Header - ( HeaderBody (HeaderBody) - ) -import qualified Ouroboros.Consensus.Protocol.Praos.Header as Praos import Ouroboros.Consensus.Protocol.TPraos ( TPraos , TPraosState (TPraosState) @@ -90,34 +86,6 @@ import Test.Util.Serialisation.SomeResult (SomeResult (..)) codecConfig :: CodecConfig StandardShelleyBlock codecConfig = ShelleyCodecConfig -mkLedgerTables :: - forall proto era. - ShelleyCompatible proto era => - LC.Tx LC.TopTx era -> - LedgerTables (ShelleyBlock proto era) ValuesMK -mkLedgerTables tx = - LedgerTables $ - ValuesMK $ - Map.fromList $ - zip exampleTxIns exampleTxOuts - where - exampleTxIns :: [BigEndianTxIn] - exampleTxIns = case toList (tx ^. (LC.bodyTxL . LC.allInputsTxBodyF)) of - [] -> error "No transaction inputs were provided to construct the ledger tables" - -- We require at least one transaction input (and one - -- transaction output) in the example provided by - -- cardano-ledger to make sure that we test the serialization - -- of ledger tables with at least one non-trivial example. - -- - -- Also all transactions in Cardano have at least one input for - -- automatic replay protection. - xs -> map BigEndianTxIn xs - - exampleTxOuts :: [LC.TxOut era] - exampleTxOuts = case toList (tx ^. (LC.bodyTxL . LC.outputsTxBodyL)) of - [] -> error "No transaction outputs were provided to construct the ledger tables" - xs -> xs - fromShelleyLedgerExamples :: ShelleyCompatible (TPraos StandardCrypto) era => ProtocolLedgerExamples (SL.BHeader StandardCrypto) era -> @@ -144,13 +112,13 @@ fromShelleyLedgerExamples , exampleExtLedgerState = unlabelled extLedgerState , exampleSlotNo = unlabelled slotNo , exampleLedgerConfig = unlabelled ledgerConfig - , exampleLedgerTables = unlabelled $ mkLedgerTables leTx } where + emptyTx = mkBasicTx mkBasicTxBody blk = mkShelleyBlock pleBlock hash = ShelleyHash $ SL.unHashHeader pleHashHeader serialisedBlock = Serialised "" - tx = mkShelleyTx leTx + tx = mkShelleyTx emptyTx slotNo = SlotNo 42 serialisedHeader = SerialisedHeaderFromDepPair $ GenDepPair (NestedCtxt CtxtShelley) (Serialised "
") @@ -255,13 +223,13 @@ fromShelleyLedgerExamplesPraos , exampleResult = results , exampleAnnTip = unlabelled annTip , exampleLedgerState = unlabelled ledgerState - , exampleLedgerTables = unlabelled $ mkLedgerTables leTx , exampleChainDepState = unlabelled chainDepState , exampleExtLedgerState = unlabelled extLedgerState , exampleSlotNo = unlabelled slotNo , exampleLedgerConfig = unlabelled ledgerConfig } where + emptyTx = mkBasicTx mkBasicTxBody blk = mkShelleyBlock $ let SL.Block hdr1 bdy = pleBlock @@ -287,7 +255,7 @@ fromShelleyLedgerExamplesPraos hSig = coerce bhSig hash = ShelleyHash $ SL.unHashHeader pleHashHeader serialisedBlock = Serialised "" - tx = mkShelleyTx leTx + tx = mkShelleyTx emptyTx slotNo = SlotNo 42 serialisedHeader = SerialisedHeaderFromDepPair $ GenDepPair (NestedCtxt CtxtShelley) (Serialised "
") diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs index c5a2176a81..877c7195bf 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs @@ -13,7 +13,8 @@ import Cardano.Ledger.Core (TranslationContext) import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Ledger.State (InstantStake) import Cardano.Protocol.Crypto (Crypto) -import qualified Cardano.Protocol.TPraos.BHeader as SL +import qualified Cardano.Protocol.Praos.BlockHeader as Praos +import qualified Cardano.Protocol.TPraos.BlockHeader as SL import Cardano.Slotting.EpochInfo import Control.Monad (replicateM) import Data.Coerce (coerce) @@ -25,7 +26,6 @@ import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Protocol.Praos (Praos) import qualified Ouroboros.Consensus.Protocol.Praos as Praos -import qualified Ouroboros.Consensus.Protocol.Praos.Header as Praos import Ouroboros.Consensus.Protocol.TPraos (TPraos, TPraosState (..)) import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger @@ -33,9 +33,6 @@ import Ouroboros.Consensus.Shelley.Node.Common () import Ouroboros.Consensus.Shelley.Protocol.Praos () import Ouroboros.Consensus.Shelley.Protocol.TPraos () import Ouroboros.Network.Block (mkSerialised) -import Test.Cardano.Ledger.AllegraEraGen () -import Test.Cardano.Ledger.Alonzo.AlonzoEraGen () -import Test.Cardano.Ledger.MaryEraGen () import Test.Cardano.Ledger.Shelley.Constants ( defaultConstants , numCoreNodes @@ -46,7 +43,6 @@ import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators ( genCoherentBlock ) import Test.Cardano.Ledger.Shelley.Serialisation.Generators () -import Test.Cardano.Ledger.ShelleyMA.Serialisation.Generators () import Test.Cardano.Protocol.TPraos.Arbitrary (genBlock) import Test.Consensus.Protocol.Serialisation.Generators () import Test.Consensus.Shelley.MockCrypto (CanMock) diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs index edec78f3e5..32bf5fe343 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/MockCrypto.hs @@ -24,9 +24,10 @@ import Cardano.Ledger.BaseTypes (Seed) import qualified Cardano.Ledger.Shelley.API as SL import qualified Cardano.Ledger.Shelley.Core as Core import Cardano.Ledger.Shelley.LedgerState (StashedAVVMAddresses) +import Cardano.Ledger.Shelley.Rules (UTXOW) import Cardano.Protocol.Crypto (Crypto (..)) import qualified Cardano.Protocol.TPraos.API as SL -import qualified Cardano.Protocol.TPraos.BHeader as SL +import qualified Cardano.Protocol.TPraos.BlockHeader as SL import Control.State.Transition.Extended (PredicateFailure) import Ouroboros.Consensus.Ledger.SupportsProtocol ( LedgerSupportsProtocol @@ -81,7 +82,7 @@ type CanMock proto era = , Arbitrary (Core.Tx Core.TopTx era) , Arbitrary (Core.TxOut era) , Arbitrary (Core.Value era) - , Arbitrary (PredicateFailure (SL.ShelleyUTXOW era)) + , Arbitrary (PredicateFailure (UTXOW era)) , Arbitrary (Core.TxWits era) , Arbitrary (StashedAVVMAddresses era) , Arbitrary (Core.GovState era) diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs index e89415eda4..bd788684ba 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/Infra/Shelley.hs @@ -121,6 +121,7 @@ import Ouroboros.Consensus.Shelley.Node import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto) import Ouroboros.Consensus.Util.Assert import Quiet (Quiet (..)) +import System.FS.API (SomeHasFS) import qualified Test.Cardano.Ledger.Core.KeyPair as TL ( KeyPair (..) , mkWitnessesVKey @@ -346,8 +347,18 @@ mkGenesisConfig pVer k f d maxLovelaceSupply slotLength kesCfg coreNodes = , sgMaxLovelaceSupply = maxLovelaceSupply , sgProtocolParams = pparams , sgGenDelegs = coreNodesToGenesisMapping - , sgInitialFunds = ListMap.fromMap initialFunds - , sgStaking = initialStake + , sgInitialFunds = mempty + , sgStaking = SL.emptyGenesisStaking + , sgExtraConfig = + SL.SJust + SL.ShelleyExtraConfig + { SL.secInitialFunds = + SL.EmbeddedInjection (ListMap.fromMap initialFunds) + , SL.secStakePools = + SL.EmbeddedInjection (SL.sgsPools initialStake) + , SL.secStakeCredentials = + SL.EmbeddedInjection (SL.sgsStake initialStake) + } } where checkMaxLovelaceSupply :: Either String () @@ -463,15 +474,18 @@ mkProtocolShelley :: ( KESAgentContext c m , ShelleyCompatible (TPraos c) ShelleyEra ) => + SomeHasFS m -> ShelleyGenesis -> SL.Nonce -> ProtVer -> CoreNode c -> - ( ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra) - , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock (TPraos c) ShelleyEra)] - ) -mkProtocolShelley genesis initialNonce protVer coreNode = + m + ( ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra) + , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock (TPraos c) ShelleyEra)] + ) +mkProtocolShelley fs genesis initialNonce protVer coreNode = protocolInfoShelley + fs genesis ProtocolParamsShelleyBased { shelleyBasedInitialNonce = initialNonce diff --git a/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/Byron.hs b/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/Byron.hs index 8f8399b43a..4b1076f4f6 100644 --- a/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/Byron.hs +++ b/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/Byron.hs @@ -1118,12 +1118,13 @@ prop_simple_real_pbft_convergence testConfigB TestConfigMB { nodeInfo = \nid -> - mkProtocolByronAndHardForkTxs - params - nid - genesisConfig - genesisSecrets - theProposedProtocolVersion + pure $ + mkProtocolByronAndHardForkTxs + params + nid + genesisConfig + genesisSecrets + theProposedProtocolVersion , mkRekeyM = Just $ fromRekeyingToRekeyM diff --git a/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs b/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs index 6cb0899866..c06f454503 100644 --- a/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs +++ b/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs @@ -158,7 +158,7 @@ setupTestOutput setup@SetupDualByron{..} = setupGenesis (setupParams setup) [coreNodeId] - plainTestNodeInitialization pInfo (fmap (fmap (MkBlockForging . pure)) bfs) + pure $ plainTestNodeInitialization pInfo (fmap (fmap (MkBlockForging . pure)) bfs) , mkRekeyM = Nothing -- TODO } where diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/MiniProtocol/LocalTxSubmission/Server.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/MiniProtocol/LocalTxSubmission/Server.hs index 187058c057..ad704ae46e 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/MiniProtocol/LocalTxSubmission/Server.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/MiniProtocol/LocalTxSubmission/Server.hs @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -- | Test that we can submit transactions to the mempool using the local @@ -10,8 +11,7 @@ module Test.Consensus.Cardano.MiniProtocol.LocalTxSubmission.Server (tests) wher import Cardano.Ledger.BaseTypes (knownNonZeroBounded) import Control.Monad (void) -import Control.Tracer (Tracer, nullTracer, stdoutTracer) -import Data.Functor.Contravariant ((>$<)) +import Control.Tracer (Tracer, nullTracer, stdoutTracer, (>$<)) import Data.SOP.Strict (index_NS) import qualified Data.SOP.Telescope as Telescope import Network.TypedProtocol.Proofs (connect) @@ -66,17 +66,16 @@ tests = where localServerPassesRegressionTests era = testCase ("Passes the regression tests (" ++ show era ++ ")") $ do - let - pInfo :: ProtocolInfo (CardanoBlock StandardCrypto) - pInfo = - mkSimpleTestProtocolInfo - (Shelley.DecentralizationParam 1) - (Consensus.SecurityParam $ knownNonZeroBounded @10) - (ByronSlotLengthInSeconds 1) - (ShelleySlotLengthInSeconds 1) - protocolVersionZero - (hardForkInto era) + pInfo <- + mkSimpleTestProtocolInfo + (Shelley.DecentralizationParam 1) + (Consensus.SecurityParam $ knownNonZeroBounded @10) + (ByronSlotLengthInSeconds 1) + (ShelleySlotLengthInSeconds 1) + protocolVersionZero + (hardForkInto era) + let eraIndex = index_NS . Telescope.tip diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/SupportsSanityCheck.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/SupportsSanityCheck.hs index bfaa3f776f..15458a3995 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/SupportsSanityCheck.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/SupportsSanityCheck.hs @@ -29,15 +29,19 @@ tests = prop_cardanoBlockSanityChecks :: QC.Property prop_cardanoBlockSanityChecks = - forAllBlind genSimpleTestProtocolInfo (prop_sanityChecks . pInfoConfig) + forAllBlind arbitrary $ \setup -> + QC.ioProperty $ do + pinfo <- mkSimpleTestProtocolInfoFromSetup setup + pure $ prop_sanityChecks (pInfoConfig pinfo) prop_intentionallyBrokenConfigDoesNotSanityCheck :: QC.Property prop_intentionallyBrokenConfigDoesNotSanityCheck = - forAllBlind genSimpleTestProtocolInfo $ \pinfo -> - let saneTopLevelConfig = - pInfoConfig pinfo - brokenConfig = breakTopLevelConfig saneTopLevelConfig - in expectFailure $ prop_sanityChecks brokenConfig + forAllBlind arbitrary $ \setup -> + QC.ioProperty $ do + pinfo <- mkSimpleTestProtocolInfoFromSetup setup + let saneTopLevelConfig = pInfoConfig pinfo + brokenConfig = breakTopLevelConfig saneTopLevelConfig + pure $ expectFailure $ prop_sanityChecks brokenConfig breakTopLevelConfig :: TopLevelConfig (CardanoBlock StandardCrypto) -> TopLevelConfig (CardanoBlock StandardCrypto) @@ -55,17 +59,17 @@ breakTopLevelConfig tlc = } } -genSimpleTestProtocolInfo :: Gen (ProtocolInfo (CardanoBlock StandardCrypto)) -genSimpleTestProtocolInfo = do - setup <- arbitrary - pure $ - mkSimpleTestProtocolInfo - (decentralizationParam setup) - (securityParam setup) - (byronSlotLength setup) - (shelleySlotLength setup) - protocolVersionZero - (hardForkTriggers setup) +mkSimpleTestProtocolInfoFromSetup :: + SimpleTestProtocolInfoSetup -> + IO (ProtocolInfo (CardanoBlock StandardCrypto)) +mkSimpleTestProtocolInfoFromSetup setup = + mkSimpleTestProtocolInfo + (decentralizationParam setup) + (securityParam setup) + (byronSlotLength setup) + (shelleySlotLength setup) + protocolVersionZero + (hardForkTriggers setup) data SimpleTestProtocolInfoSetup = SimpleTestProtocolInfoSetup { decentralizationParam :: Shelley.DecentralizationParam diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/AllegraMary.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/AllegraMary.hs index 720631ff0f..e802e22851 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/AllegraMary.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/AllegraMary.hs @@ -40,6 +40,9 @@ import Ouroboros.Consensus.Shelley.Node ( ProtocolParamsShelleyBased (..) , ShelleyGenesis (..) ) +import System.FS.API (SomeHasFS (..)) +import qualified System.FS.Sim.MockFS as MockFS +import qualified System.FS.Sim.STM as Sim import Test.Consensus.Shelley.MockCrypto (MockCrypto) import Test.QuickCheck import Test.Tasty @@ -234,7 +237,8 @@ prop_simple_allegraMary_convergence setupTestConfig testConfigB TestConfigMB - { nodeInfo = \(CoreNodeId nid) -> + { nodeInfo = \(CoreNodeId nid) -> do + fs <- SomeHasFS <$> Sim.simHasFS' MockFS.empty let protocolParamsShelleyBased = ProtocolParamsShelleyBased { shelleyBasedInitialNonce = setupInitialNonce @@ -245,30 +249,32 @@ prop_simple_allegraMary_convergence } hardForkTrigger = TriggerHardForkAtVersion $ SL.getVersion majorVersion2 - (protocolInfo, blockForging) = - protocolInfoShelleyBasedHardFork - protocolParamsShelleyBased - (SL.ProtVer majorVersion1 0) - (SL.ProtVer majorVersion2 0) - ( L.mkTransitionConfig L.NoGenesis $ - L.mkTransitionConfig L.NoGenesis $ - L.mkShelleyTransitionConfig genesisShelley - ) - hardForkTrigger - in TestNodeInitialization - { tniCrucialTxs = - if not setupHardFork - then [] - else - fmap GenTxShelley1 $ - Shelley.mkMASetDecentralizationParamTxs - coreNodes - (SL.ProtVer majorVersion2 0) - (SlotNo $ unNumSlots numSlots) -- never expire - setupD -- unchanged - , tniProtocolInfo = protocolInfo - , tniBlockForging = blockForging nullTracer - } + (protocolInfo, blockForging) <- + protocolInfoShelleyBasedHardFork + fs + protocolParamsShelleyBased + (SL.ProtVer majorVersion1 0) + (SL.ProtVer majorVersion2 0) + ( L.mkTransitionConfig L.NoGenesis $ + L.mkTransitionConfig L.NoGenesis $ + L.mkShelleyTransitionConfig genesisShelley + ) + hardForkTrigger + pure $ + TestNodeInitialization + { tniCrucialTxs = + if not setupHardFork + then [] + else + fmap GenTxShelley1 $ + Shelley.mkMASetDecentralizationParamTxs + coreNodes + (SL.ProtVer majorVersion2 0) + (SlotNo $ unNumSlots numSlots) -- never expire + setupD -- unchanged + , tniProtocolInfo = protocolInfo + , tniBlockForging = blockForging nullTracer + } , mkRekeyM = Nothing } @@ -379,8 +385,8 @@ prop_simple_allegraMary_convergence -- | The major protocol version of the first era in this test majorVersion1 :: SL.Version -majorVersion1 = SL.natVersion @2 +majorVersion1 = SL.natVersion @3 -- | The major protocol version of the second era in this test majorVersion2 :: SL.Version -majorVersion2 = SL.natVersion @3 +majorVersion2 = SL.natVersion @4 diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs index f110909cb6..8c7dd8508a 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/Cardano.hs @@ -38,7 +38,6 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Word (Word64) import Lens.Micro -import Ouroboros.Consensus.Block.Forging (MkBlockForging) import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Byron.Ledger (LedgerState (..)) import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock) @@ -60,12 +59,14 @@ import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.NodeId import Ouroboros.Consensus.Protocol.PBFT import Ouroboros.Consensus.Protocol.Praos.AgentClient - ( KESAgentClientTrace - , KESAgentContext + ( KESAgentContext ) import Ouroboros.Consensus.Shelley.HFEras () import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import Ouroboros.Consensus.Shelley.Node +import System.FS.API (SomeHasFS (..)) +import qualified System.FS.Sim.MockFS as MockFS +import qualified System.FS.Sim.STM as Sim import Test.Consensus.Cardano.ProtocolInfo ( hardForkOnDefaultProtocolVersions , mkTestProtocolInfo @@ -490,7 +491,7 @@ mkProtocolCardanoAndHardForkTxs :: ShelleyGenesis -> SL.Nonce -> Shelley.CoreNode c -> - TestNodeInitialization m (CardanoBlock c) + m (TestNodeInitialization m (CardanoBlock c)) mkProtocolCardanoAndHardForkTxs pbftParams coreNodeId @@ -499,12 +500,30 @@ mkProtocolCardanoAndHardForkTxs propPV genesisShelley initialNonce - coreNodeShelley = - TestNodeInitialization - { tniCrucialTxs = crucialTxs - , tniProtocolInfo = protocolInfo - , tniBlockForging = blockForging Tracer.nullTracer - } + coreNodeShelley = do + fs <- SomeHasFS <$> Sim.simHasFS' MockFS.empty + (setByronProtVer -> protocolInfo, blockForging) <- + mkTestProtocolInfo + fs + (coreNodeId, coreNodeShelley) + genesisShelley + propPV + initialNonce + genesisByron + generatedSecretsByron + (Just $ PBftSignatureThreshold 1) -- Trivialize the PBFT signature + -- window so that the forks induced by + -- the network partition are as deep + -- as possible. + -- This test only enters the Shelley era. + (SL.ProtVer shelleyMajorVersion 0) + hardForkOnDefaultProtocolVersions + pure + TestNodeInitialization + { tniCrucialTxs = crucialTxs + , tniProtocolInfo = protocolInfo + , tniBlockForging = blockForging Tracer.nullTracer + } where crucialTxs :: [GenTx (CardanoBlock c)] crucialTxs = @@ -521,24 +540,6 @@ mkProtocolCardanoAndHardForkTxs generatedSecretsByron propPV - protocolInfo :: ProtocolInfo (CardanoBlock c) - blockForging :: Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (CardanoBlock c)] - (setByronProtVer -> protocolInfo, blockForging) = - mkTestProtocolInfo - (coreNodeId, coreNodeShelley) - genesisShelley - propPV - initialNonce - genesisByron - generatedSecretsByron - (Just $ PBftSignatureThreshold 1) -- Trivialize the PBFT signature - -- window so that the forks induced by - -- the network partition are as deep - -- as possible. - -- This test only enters the Shelley era. - (SL.ProtVer shelleyMajorVersion 0) - hardForkOnDefaultProtocolVersions - {------------------------------------------------------------------------------- Constants -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs index 41aec461cc..0a2a7577a8 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/MaryAlonzo.hs @@ -45,7 +45,11 @@ import Ouroboros.Consensus.Shelley.Node ( ProtocolParamsShelleyBased (..) , ShelleyGenesis (..) ) +import System.FS.API (SomeHasFS (..)) +import qualified System.FS.Sim.MockFS as MockFS +import qualified System.FS.Sim.STM as Sim import qualified Test.Cardano.Ledger.Alonzo.Examples as SL +import Test.Cardano.Ledger.Shelley.Examples (leTranslationContext) import Test.Consensus.Shelley.MockCrypto (MockCrypto) import Test.QuickCheck import Test.Tasty @@ -243,7 +247,8 @@ prop_simple_allegraAlonzo_convergence setupTestConfig testConfigB TestConfigMB - { nodeInfo = \(CoreNodeId nid) -> + { nodeInfo = \(CoreNodeId nid) -> do + fs <- SomeHasFS <$> Sim.simHasFS' MockFS.empty let protocolParamsShelleyBased = ProtocolParamsShelleyBased { shelleyBasedInitialNonce = setupInitialNonce @@ -254,31 +259,33 @@ prop_simple_allegraAlonzo_convergence } hardForkTrigger = TriggerHardForkAtVersion $ SL.getVersion majorVersion2 - (protocolInfo, blockForging) = - protocolInfoShelleyBasedHardFork - protocolParamsShelleyBased - (SL.ProtVer majorVersion1 0) - (SL.ProtVer majorVersion2 0) - ( L.mkTransitionConfig alonzoGenesis $ - L.mkTransitionConfig L.NoGenesis $ - L.mkTransitionConfig L.NoGenesis $ - L.mkShelleyTransitionConfig shelleyGenesis - ) - hardForkTrigger - in TestNodeInitialization - { tniCrucialTxs = - if not setupHardFork - then [] - else - fmap GenTxShelley1 $ - Shelley.mkMASetDecentralizationParamTxs - coreNodes - (SL.ProtVer majorVersion2 0) - (SlotNo $ unNumSlots numSlots) -- never expire - setupD -- unchanged - , tniProtocolInfo = protocolInfo - , tniBlockForging = blockForging nullTracer - } + (protocolInfo, blockForging) <- + protocolInfoShelleyBasedHardFork + fs + protocolParamsShelleyBased + (SL.ProtVer majorVersion1 0) + (SL.ProtVer majorVersion2 0) + ( L.mkTransitionConfig alonzoGenesis $ + L.mkTransitionConfig L.NoGenesis $ + L.mkTransitionConfig L.NoGenesis $ + L.mkShelleyTransitionConfig shelleyGenesis + ) + hardForkTrigger + pure $ + TestNodeInitialization + { tniCrucialTxs = + if not setupHardFork + then [] + else + fmap GenTxShelley1 $ + Shelley.mkMASetDecentralizationParamTxs + coreNodes + (SL.ProtVer majorVersion2 0) + (SlotNo $ unNumSlots numSlots) -- never expire + setupD -- unchanged + , tniProtocolInfo = protocolInfo + , tniBlockForging = blockForging nullTracer + } , mkRekeyM = Nothing } @@ -313,7 +320,7 @@ prop_simple_allegraAlonzo_convergence coreNodes alonzoGenesis :: AlonzoGenesis - alonzoGenesis = SL.exampleAlonzoGenesis + alonzoGenesis = leTranslationContext SL.ledgerExamples -- the Shelley ledger is designed to use a fixed epoch size, so this test -- does not randomize it @@ -392,8 +399,8 @@ prop_simple_allegraAlonzo_convergence -- | The major protocol version of the first era in this test majorVersion1 :: SL.Version -majorVersion1 = SL.natVersion @1 +majorVersion1 = SL.natVersion @4 -- | The major protocol version of the second era in this test majorVersion2 :: SL.Version -majorVersion2 = SL.natVersion @2 +majorVersion2 = SL.natVersion @5 diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/ShelleyAllegra.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/ShelleyAllegra.hs index 6335c25764..c9938b54e3 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/ShelleyAllegra.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/ThreadNet/ShelleyAllegra.hs @@ -40,6 +40,9 @@ import Ouroboros.Consensus.Shelley.Node ( ProtocolParamsShelleyBased (..) , ShelleyGenesis (..) ) +import System.FS.API (SomeHasFS (..)) +import qualified System.FS.Sim.MockFS as MockFS +import qualified System.FS.Sim.STM as Sim import Test.Consensus.Shelley.MockCrypto (MockCrypto) import Test.QuickCheck import Test.Tasty @@ -244,7 +247,8 @@ prop_simple_shelleyAllegra_convergence setupTestConfig testConfigB TestConfigMB - { nodeInfo = \(CoreNodeId nid) -> + { nodeInfo = \(CoreNodeId nid) -> do + fs <- SomeHasFS <$> Sim.simHasFS' MockFS.empty let protocolParamsShelleyBased = ProtocolParamsShelleyBased { shelleyBasedInitialNonce = setupInitialNonce @@ -255,29 +259,31 @@ prop_simple_shelleyAllegra_convergence } hardForkTrigger = TriggerHardForkAtVersion $ SL.getVersion majorVersion2 - (protocolInfo, blockForging) = - protocolInfoShelleyBasedHardFork - protocolParamsShelleyBased - (SL.ProtVer majorVersion1 0) - (SL.ProtVer majorVersion2 0) - ( L.mkTransitionConfig L.NoGenesis $ - L.mkShelleyTransitionConfig genesisShelley - ) - hardForkTrigger - in TestNodeInitialization - { tniCrucialTxs = - if not setupHardFork - then [] - else - fmap GenTxShelley1 $ - Shelley.mkSetDecentralizationParamTxs - coreNodes - (SL.ProtVer majorVersion2 0) - (SlotNo $ unNumSlots numSlots) -- never expire - setupD -- unchanged - , tniProtocolInfo = protocolInfo - , tniBlockForging = blockForging nullTracer - } + (protocolInfo, blockForging) <- + protocolInfoShelleyBasedHardFork + fs + protocolParamsShelleyBased + (SL.ProtVer majorVersion1 0) + (SL.ProtVer majorVersion2 0) + ( L.mkTransitionConfig L.NoGenesis $ + L.mkShelleyTransitionConfig genesisShelley + ) + hardForkTrigger + pure $ + TestNodeInitialization + { tniCrucialTxs = + if not setupHardFork + then [] + else + fmap GenTxShelley1 $ + Shelley.mkSetDecentralizationParamTxs + coreNodes + (SL.ProtVer majorVersion2 0) + (SlotNo $ unNumSlots numSlots) -- never expire + setupD -- unchanged + , tniProtocolInfo = protocolInfo + , tniBlockForging = blockForging nullTracer + } , mkRekeyM = Nothing } @@ -388,8 +394,8 @@ prop_simple_shelleyAllegra_convergence -- | The major protocol version of the first era in this test majorVersion1 :: SL.Version -majorVersion1 = SL.natVersion @1 +majorVersion1 = SL.natVersion @2 -- | The major protocol version of the second era in this test majorVersion2 :: SL.Version -majorVersion2 = SL.natVersion @2 +majorVersion2 = SL.natVersion @3 diff --git a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Coherence.hs b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Coherence.hs index 862a0d7c8b..ac9e4fe799 100644 --- a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Coherence.hs +++ b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Coherence.hs @@ -9,7 +9,6 @@ import Ouroboros.Consensus.Ledger.SupportsMempool ) import Ouroboros.Consensus.Shelley.Ledger.Mempool ( AlonzoMeasure (..) - , ConwayMeasure (..) , fromExUnits ) import Test.Cardano.Ledger.Alonzo.Binary.Twiddle () @@ -24,18 +23,14 @@ tests = ] -- | 'Measure.<=' and @'pointWiseExUnits' (<=)@ must agree -leqCoherence :: Word32 -> Word32 -> ExUnits -> ExUnits -> Property -leqCoherence w1 w2 eu1 eu2 = +leqCoherence :: Word32 -> ExUnits -> ExUnits -> Property +leqCoherence w1 eu1 eu2 = actual === expected where - -- ConwayMeasure is the fullest TxMeasure and mainnet's inj eu = - ConwayMeasure - ( AlonzoMeasure - (IgnoringOverflow $ ByteSize32 w1) - (fromExUnits eu) - ) - (IgnoringOverflow $ ByteSize32 w2) + AlonzoMeasure + (IgnoringOverflow $ ByteSize32 w1) + (fromExUnits eu) actual = inj eu1 Measure.<= inj eu2 expected = pointWiseExUnits (<=) eu1 eu2 diff --git a/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs b/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs index f8353e957a..a5ae09a77a 100644 --- a/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs +++ b/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs @@ -37,6 +37,9 @@ import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import Ouroboros.Consensus.Shelley.Node import Ouroboros.Consensus.Shelley.ShelleyHFC () +import System.FS.API (SomeHasFS (..)) +import qualified System.FS.Sim.MockFS as MockFS +import qualified System.FS.Sim.STM as Sim import Test.Consensus.Shelley.MockCrypto (MockCrypto) import Test.QuickCheck import Test.Tasty @@ -278,26 +281,29 @@ prop_simple_real_tpraos_convergence setupTestConfig testConfigB TestConfigMB - { nodeInfo = \(CoreNodeId nid) -> - let (protocolInfo, blockForging) = - mkProtocolShelley - genesisConfig - setupInitialNonce - nextProtVer - (coreNodes !! fromIntegral nid) - in TestNodeInitialization - { tniProtocolInfo = protocolInfo - , tniCrucialTxs = - if not includingDUpdateTx - then [] - else - mkSetDecentralizationParamTxs - coreNodes - nextProtVer - sentinel -- Does not expire during test - setupD2 - , tniBlockForging = blockForging nullTracer - } + { nodeInfo = \(CoreNodeId nid) -> do + fs <- SomeHasFS <$> Sim.simHasFS' MockFS.empty + (protocolInfo, blockForging) <- + mkProtocolShelley + fs + genesisConfig + setupInitialNonce + nextProtVer + (coreNodes !! fromIntegral nid) + pure $ + TestNodeInitialization + { tniProtocolInfo = protocolInfo + , tniCrucialTxs = + if not includingDUpdateTx + then [] + else + mkSetDecentralizationParamTxs + coreNodes + nextProtVer + sentinel -- Does not expire during test + setupD2 + , tniBlockForging = blockForging nullTracer + } , mkRekeyM = Nothing } diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs index 29d754ef69..1134ff70d7 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs @@ -376,7 +376,8 @@ nullTracers = } showTracers :: - ( Show peer + ( Monad m + , Show peer , Show (GenTx blk) , Show (GenTxId blk) , Show (ApplyTxErr blk) @@ -386,10 +387,10 @@ showTracers :: Tracer m String -> Tracers m peer blk e showTracers tr = Tracers - { tChainSyncTracer = showTracing tr - , tTxSubmissionTracer = showTracing tr - , tStateQueryTracer = showTracing tr - , tTxMonitorTracer = showTracing tr + { tChainSyncTracer = show >$< tr + , tTxSubmissionTracer = show >$< tr + , tStateQueryTracer = show >$< tr + , tTxMonitorTracer = show >$< tr } {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 53d85783fb..0f6ff48dd5 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -160,13 +160,12 @@ import Ouroboros.Network.Protocol.TxSubmission2.Client import Ouroboros.Network.Protocol.TxSubmission2.Codec import Ouroboros.Network.Protocol.TxSubmission2.Server import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.Tx (HasRawTxId) import Ouroboros.Network.TxSubmission.Inbound.V1 import Ouroboros.Network.TxSubmission.Inbound.V2 ( PeerTxAPI - , TraceTxLogic , TxDecisionPolicy (..) , TxSubmissionLogicVersion (..) - , defaultTxDecisionPolicy , txSubmissionInboundV2 , withPeer ) @@ -356,7 +355,9 @@ mkHandlers (Node.txInboundTracer tracers) ) txSubmissionInitDelay + (txDecisionPolicy miniProtocolParameters) (getMempoolWriter getMempool) + txWireSize api TxSubmissionLogicV1 -> Left $ @@ -574,7 +575,6 @@ data Tracers' peer ntnAddr blk e f = Tracers , tPerasVoteDiffusionTracer :: f (TraceLabelPeer peer (TraceSendRecv (PerasVoteDiffusion blk))) , tKeepAliveTracer :: f (TraceLabelPeer peer (TraceSendRecv KeepAlive)) , tPeerSharingTracer :: f (TraceLabelPeer peer (TraceSendRecv (PeerSharing ntnAddr))) - , tTxLogicTracer :: f (TraceLabelPeer peer (TraceTxLogic peer (GenTxId blk) (GenTx blk))) } instance (forall a. Semigroup (f a)) => Semigroup (Tracers' peer ntnAddr blk e f) where @@ -589,7 +589,6 @@ instance (forall a. Semigroup (f a)) => Semigroup (Tracers' peer ntnAddr blk e f , tPerasVoteDiffusionTracer = f tPerasVoteDiffusionTracer , tKeepAliveTracer = f tKeepAliveTracer , tPeerSharingTracer = f tPeerSharingTracer - , tTxLogicTracer = f tTxLogicTracer } where f :: @@ -612,11 +611,11 @@ nullTracers = , tPerasVoteDiffusionTracer = nullTracer , tKeepAliveTracer = nullTracer , tPeerSharingTracer = nullTracer - , tTxLogicTracer = nullTracer } showTracers :: - ( Show blk + ( Monad m + , Show blk , Show ntnAddr , Show (Header blk) , Show (GenTx blk) @@ -627,16 +626,15 @@ showTracers :: Tracer m String -> Tracers m ntnAddr blk e showTracers tr = Tracers - { tChainSyncTracer = showTracing tr - , tChainSyncSerialisedTracer = showTracing tr - , tBlockFetchTracer = showTracing tr - , tBlockFetchSerialisedTracer = showTracing tr - , tTxSubmission2Tracer = showTracing tr - , tPerasCertDiffusionTracer = showTracing tr - , tPerasVoteDiffusionTracer = showTracing tr - , tKeepAliveTracer = showTracing tr - , tPeerSharingTracer = showTracing tr - , tTxLogicTracer = showTracing tr + { tChainSyncTracer = show >$< tr + , tChainSyncSerialisedTracer = show >$< tr + , tBlockFetchTracer = show >$< tr + , tBlockFetchSerialisedTracer = show >$< tr + , tTxSubmission2Tracer = show >$< tr + , tPerasCertDiffusionTracer = show >$< tr + , tPerasVoteDiffusionTracer = show >$< tr + , tKeepAliveTracer = show >$< tr + , tPeerSharingTracer = show >$< tr } {------------------------------------------------------------------------------- @@ -781,6 +779,7 @@ mkApps :: , Show addrNTN , LedgerSupportsMempool blk , HasTxId (GenTx blk) + , HasRawTxId (GenTxId blk) ) => -- | Needed for bracketing only NodeKernel m addrNTN addrNTC blk -> @@ -983,16 +982,13 @@ mkApps kernel rng Tracers{..} mkCodecs ByteLimits{..} chainSyncTimeouts lopBucke runServer legacyTxSubmissionServer Right newTxSubmissionServer -> withPeer - (TraceLabelPeer them `contramap` tTxLogicTracer) - (getTxChannelsVar kernel) - (getTxMempoolSem kernel) - defaultTxDecisionPolicy - (getSharedTxStateVar kernel) + (getTxDecisionPolicy kernel) ( mapTxSubmissionMempoolReader txForgetValidated $ getMempoolReader (getMempool kernel) ) - (getMempoolWriter (getMempool kernel)) - txWireSize + (getSharedTxStateVar kernel) + (getPeerTxRegistry kernel) + (getTxCountersVar kernel) them $ \api -> runServer (newTxSubmissionServer api) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs index ff6f698a89..7b616ddfee 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs @@ -927,7 +927,7 @@ mkNodeKernelArgs txSubmissionInitDelay = do let (kaRng, rng') = splitGen rng - (psRng, txRng) = splitGen rng' + (psRng, _) = splitGen rng' return NodeKernelArgs { tracers @@ -955,7 +955,6 @@ mkNodeKernelArgs , getUseBootstrapPeers , keepAliveRng = kaRng , peerSharingRng = psRng - , txSubmissionRng = txRng , publicPeerSelectionStateVar , genesisArgs , getDiffusionPipeliningSupport diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs index dc48b9d317..6932cad6b5 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs @@ -18,7 +18,7 @@ module Ouroboros.Consensus.Node.Tracers ) where import Control.Exception (SomeException) -import Control.Tracer (Tracer, nullTracer, showTracing) +import Control.Tracer (Tracer, nullTracer, (>$<)) import Data.Text (Text) import Data.Time (UTCTime) import Ouroboros.Consensus.Block @@ -58,6 +58,7 @@ import Ouroboros.Network.BlockFetch.Decision.Trace ( TraceDecisionEvent ) import Ouroboros.Network.KeepAlive (TraceKeepAliveClient) +import Ouroboros.Network.Tx (HasRawTxId) import Ouroboros.Network.TxSubmission.Inbound.V2.Types import Ouroboros.Network.TxSubmission.Outbound @@ -181,7 +182,8 @@ nullTracers = } showTracers :: - ( Show blk + ( Monad m + , Show blk , Show (GenTx blk) , Show (Validated (GenTx blk)) , Show (GenTxId blk) @@ -190,40 +192,42 @@ showTracers :: , Show (ForgeStateInfo blk) , Show (ForgeStateUpdateError blk) , Show (CannotForge blk) - , Show (TxMeasure blk) + , Show (TxMeasurePhase1 blk) + , Show (TxMeasurePhase2 blk) , Show remotePeer + , HasRawTxId (GenTxId blk) , LedgerSupportsProtocol blk ) => Tracer m String -> Tracers m remotePeer localPeer blk showTracers tr = Tracers - { chainSyncClientTracer = showTracing tr - , chainSyncServerHeaderTracer = showTracing tr - , chainSyncServerBlockTracer = showTracing tr - , blockFetchDecisionTracer = showTracing tr - , blockFetchClientTracer = showTracing tr - , blockFetchServerTracer = showTracing tr - , txInboundTracer = showTracing tr - , txOutboundTracer = showTracing tr - , localTxSubmissionServerTracer = showTracing tr - , txLogicTracer = showTracing tr - , txCountersTracer = showTracing tr - , mempoolTracer = showTracing tr - , perasCertDiffusionInboundTracer = showTracing tr - , perasCertDiffusionOutboundTracer = showTracing tr - , perasVoteDiffusionInboundTracer = showTracing tr - , perasVoteDiffusionOutboundTracer = showTracing tr - , forgeTracer = showTracing tr - , blockchainTimeTracer = showTracing tr - , forgeStateInfoTracer = showTracing tr - , keepAliveClientTracer = showTracing tr - , consensusSanityCheckTracer = showTracing tr - , consensusErrorTracer = showTracing tr - , gsmTracer = showTracing tr - , gddTracer = showTracing tr - , csjTracer = showTracing tr - , dbfTracer = showTracing tr - , kesAgentTracer = showTracing tr + { chainSyncClientTracer = show >$< tr + , chainSyncServerHeaderTracer = show >$< tr + , chainSyncServerBlockTracer = show >$< tr + , blockFetchDecisionTracer = show >$< tr + , blockFetchClientTracer = show >$< tr + , blockFetchServerTracer = show >$< tr + , txInboundTracer = show >$< tr + , txOutboundTracer = show >$< tr + , localTxSubmissionServerTracer = show >$< tr + , txLogicTracer = show >$< tr + , txCountersTracer = show >$< tr + , mempoolTracer = show >$< tr + , perasCertDiffusionInboundTracer = show >$< tr + , perasCertDiffusionOutboundTracer = show >$< tr + , perasVoteDiffusionInboundTracer = show >$< tr + , perasVoteDiffusionOutboundTracer = show >$< tr + , forgeTracer = show >$< tr + , blockchainTimeTracer = show >$< tr + , forgeStateInfoTracer = show >$< tr + , keepAliveClientTracer = show >$< tr + , consensusSanityCheckTracer = show >$< tr + , consensusErrorTracer = show >$< tr + , gsmTracer = show >$< tr + , gddTracer = show >$< tr + , csjTracer = show >$< tr + , dbfTracer = show >$< tr + , kesAgentTracer = show >$< tr } {------------------------------------------------------------------------------- @@ -405,7 +409,8 @@ deriving instance , Eq (Validated (GenTx blk)) , Eq (ForgeStateUpdateError blk) , Eq (CannotForge blk) - , Eq (TxMeasure blk) + , Eq (TxMeasurePhase1 blk) + , Eq (TxMeasurePhase2 blk) ) => Eq (TraceForgeEvent blk) deriving instance @@ -414,7 +419,8 @@ deriving instance , Show (Validated (GenTx blk)) , Show (ForgeStateUpdateError blk) , Show (CannotForge blk) - , Show (TxMeasure blk) + , Show (TxMeasurePhase1 blk) + , Show (TxMeasurePhase2 blk) ) => Show (TraceForgeEvent blk) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 65ebc5ab7e..ba1609a754 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -144,14 +144,18 @@ import Ouroboros.Network.TxSubmission.Inbound.V1 , TxSubmissionMempoolWriter ) import qualified Ouroboros.Network.TxSubmission.Inbound.V1 as Inbound +import Ouroboros.Network.TxSubmission.Inbound.V2 (TxDecisionPolicy) import Ouroboros.Network.TxSubmission.Inbound.V2.Registry - ( SharedTxStateVar - , TxChannelsVar - , TxMempoolSem - , decisionLogicThreads + ( PeerTxRegistry + , SharedTxStateVar + , TxSubmissionCountersVar + , newPeerTxRegistry , newSharedTxStateVar - , newTxChannelsVar - , newTxMempoolSem + , newTxSubmissionCountersVar + , txCountersThreadV2 + ) +import Ouroboros.Network.TxSubmission.Inbound.V2.Types + ( emptySharedTxState ) import Ouroboros.Network.TxSubmission.Mempool.Reader ( TxSubmissionMempoolReader @@ -197,13 +201,14 @@ data NodeKernel m addrNTN addrNTC blk = NodeKernel , getDiffusionPipeliningSupport :: DiffusionPipeliningSupport , getBlockchainTime :: BlockchainTime m - , getTxChannelsVar :: TxChannelsVar m (ConnectionId addrNTN) (GenTxId blk) (GenTx blk) - -- ^ Communication channels between `TxSubmission` client mini-protocol and - -- decision logic. - , getSharedTxStateVar :: SharedTxStateVar m (ConnectionId addrNTN) (GenTxId blk) (GenTx blk) + , getPeerTxRegistry :: PeerTxRegistry m (ConnectionId addrNTN) + -- ^ Per-peer tx-submission state: in-flight tracking and counters. + , getSharedTxStateVar :: SharedTxStateVar m (ConnectionId addrNTN) (GenTxId blk) -- ^ Shared state of all `TxSubmission` clients. - , getTxMempoolSem :: TxMempoolSem m - -- ^ A semaphore used by tx-submission for submitting `tx`s to the mempool. + , getTxCountersVar :: TxSubmissionCountersVar m + -- ^ Accumulator for tx-submission counters of disconnected peers. + , getTxDecisionPolicy :: TxDecisionPolicy + -- ^ Tx-submission decision policy. } -- | Arguments required when initializing a node @@ -230,7 +235,6 @@ data NodeKernelArgs m addrNTN addrNTC blk = NodeKernelArgs , gsmArgs :: GsmNodeKernelArgs m blk , getUseBootstrapPeers :: STM m UseBootstrapPeers , peerSharingRng :: StdGen - , txSubmissionRng :: StdGen , txSubmissionInitDelay :: TxSubmissionInitDelay , publicPeerSelectionStateVar :: StrictSTM.StrictTVar m (PublicPeerSelectionState addrNTN) @@ -260,7 +264,6 @@ initNodeKernel , btime , gsmArgs , peerSharingRng - , txSubmissionRng , publicPeerSelectionStateVar , genesisArgs , getDiffusionPipeliningSupport @@ -348,9 +351,9 @@ initNodeKernel ps_POLICY_PEER_SHARE_STICKY_TIME ps_POLICY_PEER_SHARE_MAX_PEERS - txChannelsVar <- newTxChannelsVar - sharedTxStateVar <- newSharedTxStateVar txSubmissionRng - txMempoolSem <- newTxMempoolSem + sharedTxStateVar <- newSharedTxStateVar emptySharedTxState + peerTxRegistry <- newPeerTxRegistry + txCountersVar <- newTxSubmissionCountersVar mempty case gnkaLoEAndGDDArgs genesisArgs of LoEAndGDDDisabled -> pure () @@ -389,13 +392,14 @@ initNodeKernel blockFetchConfiguration void $ - forkLinkedThread registry "NodeKernel.decisionLogicThreads" $ - decisionLogicThreads - (txLogicTracer tracers) - (txCountersTracer tracers) + forkLinkedThread registry "NodeKernel.txCountersThreadV2" $ + txCountersThreadV2 (txDecisionPolicy miniProtocolParameters) - txChannelsVar + (txCountersTracer tracers) + (txLogicTracer tracers) + txCountersVar sharedTxStateVar + peerTxRegistry return NodeKernel @@ -415,9 +419,10 @@ initNodeKernel varOutboundConnectionsState , getDiffusionPipeliningSupport , getBlockchainTime = btime - , getTxChannelsVar = txChannelsVar + , getPeerTxRegistry = peerTxRegistry , getSharedTxStateVar = sharedTxStateVar - , getTxMempoolSem = txMempoolSem + , getTxCountersVar = txCountersVar + , getTxDecisionPolicy = txDecisionPolicy miniProtocolParameters } where blockForgingController :: diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs index 5cc1b112a0..1c943ccb5f 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs @@ -202,7 +202,7 @@ deriving instance -- that 'TestConfigB' can occur in contexts (such as in 'PropGeneralArgs') for -- which the @m@ parameter is irrelevant and hence unknown. data TestConfigMB m blk = TestConfigMB - { nodeInfo :: CoreNodeId -> TestNodeInitialization m blk + { nodeInfo :: CoreNodeId -> m (TestNodeInitialization m blk) , mkRekeyM :: Maybe (m (RekeyM m blk)) -- ^ 'runTestNetwork' immediately runs this action once in order to -- initialize an 'RekeyM' value that it then reuses throughout the test diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index ee17e0a1fb..12f8ababaa 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -61,7 +61,6 @@ import qualified Control.Monad.Except as Exc import Control.ResourceRegistry import Control.Tracer import qualified Data.ByteString.Lazy as Lazy -import Data.Functor.Contravariant ((>$<)) import Data.Functor.Identity (Identity) import qualified Data.List as List import qualified Data.List.NonEmpty as NE @@ -143,6 +142,7 @@ import Ouroboros.Network.Protocol.Limits (ProtocolTimeLimitsWithRnd (..), waitFo import Ouroboros.Network.Protocol.LocalStateQuery.Type import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharing) import Ouroboros.Network.Protocol.TxSubmission2.Type +import Ouroboros.Network.Tx (HasRawTxId) import Ouroboros.Network.TxSubmission.Inbound.V2 ( TxSubmissionInitDelay (..) , TxSubmissionLogicVersion (..) @@ -244,7 +244,7 @@ data ThreadNetworkArgs m blk = ThreadNetworkArgs { tnaForgeEbbEnv :: Maybe (ForgeEbbEnv blk) , tnaFuture :: Future , tnaJoinPlan :: NodeJoinPlan - , tnaNodeInfo :: CoreNodeId -> TestNodeInitialization m blk + , tnaNodeInfo :: CoreNodeId -> m (TestNodeInitialization m blk) , tnaNumCoreNodes :: NumCoreNodes , tnaNumSlots :: NumSlots , tnaMessageDelay :: CalcMessageDelay blk @@ -378,8 +378,8 @@ runThreadNetwork forM coreNodeIds $ \nid -> do -- assume they all start with the empty chain and the same initial -- ledger - let nodeInitData = mkProtocolInfo (CoreNodeId 0) - TestNodeInitialization{tniProtocolInfo} = nodeInitData + nodeInitData <- mkProtocolInfo (CoreNodeId 0) + let TestNodeInitialization{tniProtocolInfo} = nodeInitData ProtocolInfo{pInfoInitLedger} = tniProtocolInfo ExtLedgerState{ledgerState} = pInfoInitLedger v <- @@ -392,8 +392,8 @@ runThreadNetwork let uedges = edgesNodeTopology nodeTopology edgeStatusVars <- fmap (Map.fromList . concat) $ do -- assume they all use the same CodecConfig - let nodeInitData = mkProtocolInfo (CoreNodeId 0) - TestNodeInitialization{tniProtocolInfo} = nodeInitData + nodeInitData <- mkProtocolInfo (CoreNodeId 0) + let TestNodeInitialization{tniProtocolInfo} = nodeInitData ProtocolInfo{pInfoConfig} = tniProtocolInfo codecConfig = configCodec pInfoConfig forM uedges $ \uedge -> do @@ -500,29 +500,30 @@ runThreadNetwork nodeInfo nextInstrSlotVar = void $ forkLinkedThread sharedRegistry label $ do - loop 0 tniProtocolInfo tniBlockForging NodeRestart restarts0 + TestNodeInitialization + { tniCrucialTxs + , tniProtocolInfo + , tniBlockForging + } <- + mkProtocolInfo coreNodeId + loop tniCrucialTxs 0 tniProtocolInfo tniBlockForging NodeRestart restarts0 where label = "vertex-" <> condense coreNodeId - TestNodeInitialization - { tniCrucialTxs - , tniProtocolInfo - , tniBlockForging - } = mkProtocolInfo coreNodeId - restarts0 :: Map SlotNo NodeRestart restarts0 = Map.mapMaybe (Map.lookup coreNodeId) m where NodeRestarts m = nodeRestarts loop :: + [GenTx blk] -> SlotNo -> ProtocolInfo blk -> m [MkBlockForging m blk] -> NodeRestart -> Map SlotNo NodeRestart -> m () - loop s pInfo mkBlockForging nr rs = do + loop tniCrucialTxs s pInfo mkBlockForging nr rs = do -- a registry solely for the resources of this specific node instance (again, finalChain, finalLdgr) <- withRegistry $ \nodeRegistry -> do -- change the node's key and prepare a delegation transaction if @@ -599,7 +600,7 @@ runThreadNetwork case again of Nothing -> pure () - Just (s', pInfo', blockForging', nr', rs') -> loop s' pInfo' blockForging' nr' rs' + Just (s', pInfo', blockForging', nr', rs') -> loop tniCrucialTxs s' pInfo' blockForging' nr' rs' -- \| Instrumentation: record the tip's block number at the onset of the -- slot. @@ -793,7 +794,7 @@ runThreadNetwork Origin -> error "selTracer" -- prop_general relies on this tracer - instrumentationTracer = Tracer $ \case + instrumentationTracer = mkTracer $ \case ChainDB.TraceAddBlockEvent (ChainDB.AddBlockValidation (ChainDB.InvalidBlock e p)) -> traceWith invalidTracer (p, e) @@ -854,7 +855,7 @@ runThreadNetwork -- prop_general relies on these tracers let invalidTracer = nodeEventsInvalids nodeInfoEvents updatesTracer = nodeEventsUpdates nodeInfoEvents - wrapTracer tr = Tracer $ \(p, bno) -> do + wrapTracer tr = mkTracer $ \(p, bno) -> do s <- OracularClock.getCurrentSlot clock traceWith tr (s, p, bno) addTracer = wrapTracer $ nodeEventsAdds nodeInfoEvents @@ -988,7 +989,7 @@ runThreadNetwork -- prop_general relies on these tracers instrumentationTracers = nullTracers - { chainSyncClientTracer = Tracer $ \case + { chainSyncClientTracer = mkTracer $ \case TraceLabelPeer _ (CSClient.TraceDownloadedHeader hdr) -> case blockPoint hdr of GenesisPoint -> pure () @@ -999,7 +1000,7 @@ runThreadNetwork headerAddTracer (RealPoint s h, blockNo hdr) _ -> pure () - , forgeTracer = Tracer $ \(TraceLabelCreds _ ev) -> do + , forgeTracer = mkTracer $ \(TraceLabelCreds _ ev) -> do traceWith (nodeEventsForges nodeInfoEvents) ev case ev of TraceNodeIsLeader s -> atomically $ blockOnCrucial s @@ -1050,8 +1051,7 @@ runThreadNetwork Seed s -> mkStdGen s (kaRng, rng') = splitGen rng (gsmRng, rng'') = splitGen rng' - (psRng, rng3) = splitGen rng'' - (txRng, chainSyncRng) = splitGen rng3 + (psRng, chainSyncRng) = splitGen rng'' publicPeerSelectionStateVar <- makePublicPeerSelectionStateVar let nodeKernelArgs = NodeKernelArgs @@ -1073,7 +1073,6 @@ runThreadNetwork , mempoolTimeoutConfig = Nothing , keepAliveRng = kaRng , peerSharingRng = psRng - , txSubmissionRng = txRng , miniProtocolParameters = defaultMiniProtocolParameters , blockFetchConfiguration = BlockFetchConfiguration @@ -1739,8 +1738,8 @@ mkTestOutput vertexInfos = do -------------------------------------------------------------------------------} -- | Occurs throughout in positions that might be useful for debugging. -nullDebugTracer :: (Applicative m, Show a) => Tracer m a -nullDebugTracer = nullTracer `asTypeOf` showTracing debugTracer +nullDebugTracer :: (Monad m, Show a) => Tracer m a +nullDebugTracer = nullTracer `asTypeOf` (show >$< debugTracer) -- | Occurs throughout in positions that might be useful for debugging. nullDebugTracers :: @@ -1775,9 +1774,11 @@ type TracingConstraints blk = , Show (ForgeStateInfo blk) , Show (ForgeStateUpdateError blk) , Show (CannotForge blk) - , Show (TxMeasure blk) + , Show (TxMeasurePhase1 blk) + , Show (TxMeasurePhase2 blk) , Show (ReasonForSwitch (TiebreakerView (BlockProtocol blk))) , HasNestedContent Header blk + , HasRawTxId (GenTxId blk) ) {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs index 7ec0253a47..14d1d29fc3 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/GSM.hs @@ -41,7 +41,7 @@ import qualified Control.Monad.Class.MonadTime.SI as SI import qualified Control.Monad.Class.MonadTimer.SI as SI import qualified Control.Monad.IOSim as IOSim import Control.Monad.Reader -import Control.Tracer (Tracer (Tracer)) +import Control.Tracer (mkTracer) import Data.Functor ((<&>)) import Data.List ((\\)) import qualified Data.Map.Strict as Map @@ -132,7 +132,7 @@ setupGsm :: SystemStateVars (IOSim.IOSim s) -> GSM.GsmEntryPoints (IOSim.IOSim s) setupGsm isHaaSatisfied vars = do - let tracer = Tracer $ push varEvents . EvGsm + let tracer = mkTracer $ push varEvents . EvGsm GSM.realGsmEntryPoints (id, tracer) GSM.GsmView diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs index 2ffcd3ff8f..6558c1eb21 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs @@ -226,9 +226,10 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} = testConfigMB = TestConfigMB { nodeInfo = \a -> - plainTestNodeInitialization - (protocolInfo a) - (return blockForging) + pure $ + plainTestNodeInitialization + (protocolInfo a) + (return blockForging) , mkRekeyM = Nothing } @@ -431,7 +432,8 @@ instance HasHardForkTxOut '[BlockA, BlockB] where type TestBlock = HardForkBlock '[BlockA, BlockB] instance CanHardFork '[BlockA, BlockB] where - type HardForkTxMeasure '[BlockA, BlockB] = IgnoringOverflow ByteSize32 + type HardForkTxMeasurePhase1 '[BlockA, BlockB] = IgnoringOverflow ByteSize32 + type HardForkTxMeasurePhase2 '[BlockA, BlockB] = TrivialTxMeasurePhase2 hardForkEraTranslation = EraTranslation @@ -443,9 +445,13 @@ instance CanHardFork '[BlockA, BlockB] where hardForkChainSel = Tails.mk2 NoTiebreakerAcrossEras hardForkInjectTxs = InPairs.mk2 injectTx_AtoB - hardForkInjTxMeasure = \case - (Z (WrapTxMeasure x)) -> x - S (Z (WrapTxMeasure x)) -> x + hardForkInjTxMeasurePhase1 = \case + (Z (WrapTxMeasurePhase1 x)) -> x + S (Z (WrapTxMeasurePhase1 x)) -> x + + hardForkInjTxMeasurePhase2 = \case + (Z (WrapTxMeasurePhase2 x)) -> x + S (Z (WrapTxMeasurePhase2 x)) -> x versionN2N :: BlockNodeToNodeVersion TestBlock versionN2N = diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs index ee2e78292e..96ddc36554 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs @@ -402,10 +402,12 @@ instance LedgerSupportsMempool BlockA where mkMempoolApplyTxError = nothingMkMempoolApplyTxError instance TxLimits BlockA where - type TxMeasure BlockA = IgnoringOverflow ByteSize32 + type TxMeasurePhase1 BlockA = IgnoringOverflow ByteSize32 + type TxMeasurePhase2 BlockA = TrivialTxMeasurePhase2 txWireSize = const . fromIntegral $ (0 :: Int) - blockCapacityTxMeasure _cfg _st = IgnoringOverflow $ ByteSize32 $ 100 * 1024 -- arbitrary - txMeasure _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0 + blockCapacityTxMeasure _cfg _st = TxMeasure (IgnoringOverflow $ ByteSize32 $ 100 * 1024) TrivialTxMeasurePhase2 -- arbitrary + txMeasurePhase1 _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0 + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 newtype instance TxId (GenTx BlockA) = TxIdA Int deriving stock (Show, Eq, Ord, Generic) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs index cf1358c37b..9b9ae452e6 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs @@ -335,10 +335,12 @@ instance LedgerSupportsMempool BlockB where mkMempoolApplyTxError = nothingMkMempoolApplyTxError instance TxLimits BlockB where - type TxMeasure BlockB = IgnoringOverflow ByteSize32 + type TxMeasurePhase1 BlockB = IgnoringOverflow ByteSize32 + type TxMeasurePhase2 BlockB = TrivialTxMeasurePhase2 txWireSize = const . fromIntegral $ (0 :: Int) - blockCapacityTxMeasure _cfg _st = IgnoringOverflow $ ByteSize32 $ 100 * 1024 -- arbitrary - txMeasure _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0 + blockCapacityTxMeasure _cfg _st = TxMeasure (IgnoringOverflow $ ByteSize32 $ 100 * 1024) TrivialTxMeasurePhase2 -- arbitrary + txMeasurePhase1 _cfg _st _tx = pure $ IgnoringOverflow $ ByteSize32 0 + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 data instance TxId (GenTx BlockB) deriving stock (Show, Eq, Ord, Generic) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs index e429d0b4cd..b810444892 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs @@ -19,8 +19,7 @@ import Control.Monad (void) import Control.Monad.Class.MonadTime import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.ResourceRegistry -import Control.Tracer (Tracer, nullTracer, traceWith) -import Data.Functor.Contravariant ((>$<)) +import Control.Tracer (Tracer, nullTracer, traceWith, (>$<)) import Network.TypedProtocol.Codec ( ActiveState , AnyMessage diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs index cbceade7af..491744990b 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ChainSync.hs @@ -14,8 +14,9 @@ import Cardano.Network.NodeToNode.Version (NodeToNodeVersion) import Control.Exception (SomeException) import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.Tracer - ( Tracer (Tracer) + ( Tracer , contramap + , mkTracer , nullTracer , traceWith ) @@ -109,7 +110,7 @@ basicChainSyncClient chainSyncClient CSClient.ConfigEnv { CSClient.mkPipelineDecision0 = pipelineDecisionLowHighMark 10 20 - , CSClient.tracer = Tracer (traceWith tracer . TraceChainSyncClientEvent peerId) + , CSClient.tracer = mkTracer (traceWith tracer . TraceChainSyncClientEvent peerId) , CSClient.cfg , CSClient.chainDbView , CSClient.someHeaderInFutureCheck = dummyHeaderInFutureCheck @@ -194,7 +195,7 @@ runChainSyncClient res <- try $ runPipelinedPeerWithLimits - (Tracer $ traceWith tracer . TraceChainSyncSendRecvEvent peerId "Client") + (mkTracer $ traceWith tracer . TraceChainSyncSendRecvEvent peerId "Client") codecChainSyncId chainSyncNoSizeLimits (timeLimitsChainSync chainSyncTimeouts) @@ -270,4 +271,4 @@ runChainSyncServer tracer peerId StateViewTracers{svtPeerSimulatorResultsTracer} case fromException exn of (_ :: Maybe SomeException) -> pure () where - sendRecvTracer = Tracer $ traceWith tracer . TraceChainSyncSendRecvEvent peerId "Server" + sendRecvTracer = mkTracer $ traceWith tracer . TraceChainSyncSendRecvEvent peerId "Server" diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs index 20b4147bb7..5eed3de7f8 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs @@ -15,7 +15,7 @@ module Test.Consensus.PeerSimulator.NodeLifecycle ) where import Control.ResourceRegistry -import Control.Tracer (Tracer (..), traceWith) +import Control.Tracer (Tracer, mkTracer, traceWith) import Data.Functor (void) import Data.Set (Set) import qualified Data.Set as Set @@ -154,7 +154,7 @@ mkChainDb resources = do chainDbArgs <- do let args = updateTracer - (Tracer (traceWith lrTracer . TraceChainDBEvent)) + (mkTracer (traceWith lrTracer . TraceChainDBEvent)) ( fromMinimalChainDbArgs MinimalChainDbArgs { mcdbTopLevelConfig = lrConfig diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs index 78e43cbe4f..eef1496169 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs @@ -14,7 +14,7 @@ import Control.Monad (foldM, forM, void, when) import Control.Monad.Class.MonadTime (MonadTime) import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.ResourceRegistry -import Control.Tracer (Tracer (..), nullTracer, traceWith) +import Control.Tracer (Tracer, mkTracer, nullTracer, traceWith) import Data.Coerce (coerce) import Data.Foldable (for_) import Data.List (sort) @@ -524,7 +524,7 @@ startNode protocolInfo schedulerConfig genesisTest interval = do -- FIXME: This type of configuration should move to `Trace.mkTracer`. tracer = if scTrace schedulerConfig - then Tracer (\evt -> traceWith lrTracer evt >> traceWith svtTraceTracer evt) + then mkTracer (\evt -> traceWith lrTracer evt >> traceWith svtTraceTracer evt) else svtTraceTracer chainSyncTimeouts_ = @@ -643,7 +643,7 @@ runPointSchedule protocolInfoArgs schedulerConfig genesisTest tracer0 = lifecycle <- nodeLifecycle protocolInfoArgs schedulerConfig genesisTest tracer registry peerSim (chainDb, stateViewTracers) <- runScheduler - (Tracer $ traceWith tracer . TraceSchedulerEvent) + (mkTracer $ traceWith tracer . TraceSchedulerEvent) (cschcMap (psrHandles peerSim)) gtSchedule (psrPeers peerSim) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledBlockFetchServer.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledBlockFetchServer.hs index cb523d570f..802833d581 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledBlockFetchServer.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledBlockFetchServer.hs @@ -109,8 +109,8 @@ runScheduledBlockFetchServer ssPeerId ssTickStarted ssCurrentState tracer sbfsHa , ssTickStarted , ssCurrentState , ssCommonTracer = - Tracer (traceWith tracer . TraceScheduledBlockFetchServerEvent ssPeerId . TraceHandlerEventBF) + mkTracer (traceWith tracer . TraceScheduledBlockFetchServerEvent ssPeerId . TraceHandlerEventBF) } - , sbfsTracer = Tracer (traceWith tracer . TraceScheduledBlockFetchServerEvent ssPeerId) + , sbfsTracer = mkTracer (traceWith tracer . TraceScheduledBlockFetchServerEvent ssPeerId) , sbfsHandlers } diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledChainSyncServer.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledChainSyncServer.hs index f52aaa5ffd..bee6ea439e 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledChainSyncServer.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/ScheduledChainSyncServer.hs @@ -12,7 +12,7 @@ module Test.Consensus.PeerSimulator.ScheduledChainSyncServer , runScheduledChainSyncServer ) where -import Control.Tracer (Tracer (Tracer), traceWith) +import Control.Tracer (Tracer, mkTracer, traceWith) import Ouroboros.Consensus.Block (Header) import Ouroboros.Consensus.Block.Abstract (Point (..)) import Ouroboros.Consensus.Util.IOLike (IOLike, MonadSTM (STM)) @@ -159,8 +159,8 @@ runScheduledChainSyncServer ssPeerId ssTickStarted ssCurrentState tracer scssHan , ssTickStarted , ssCurrentState , ssCommonTracer = - Tracer (traceWith tracer . TraceScheduledChainSyncServerEvent ssPeerId . TraceHandlerEventCS) + mkTracer (traceWith tracer . TraceScheduledChainSyncServerEvent ssPeerId . TraceHandlerEventCS) } - , scssTracer = Tracer (traceWith tracer . TraceScheduledChainSyncServerEvent ssPeerId) + , scssTracer = mkTracer (traceWith tracer . TraceScheduledChainSyncServerEvent ssPeerId) , scssHandlers } diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/StateDiagram.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/StateDiagram.hs index dbe4873066..166542d606 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/StateDiagram.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/StateDiagram.hs @@ -37,7 +37,7 @@ import Control.Monad.State.Strict , runState , state ) -import Control.Tracer (Tracer (Tracer), debugTracer, traceWith) +import Control.Tracer (Tracer, debugTracer, mkTracer, traceWith) import Data.Bifunctor (first) import Data.Foldable as Foldable (foldl', foldr') import Data.List (intersperse, mapAccumL, sort, transpose) @@ -963,11 +963,11 @@ peerSimStateDiagram = -- a block tree, highlighting the candidate fragments, selection, and forks in -- different colors, omitting uninteresting segments. peerSimStateDiagramTracer :: - (AF.HasHeader blk, Eq (Header blk), GetHeader blk) => + (Monad m, AF.HasHeader blk, Eq (Header blk), GetHeader blk) => Tracer m String -> Tracer m (PeerSimState blk) peerSimStateDiagramTracer tracer = - Tracer (traceWith tracer . peerSimStateDiagram) + mkTracer (traceWith tracer . peerSimStateDiagram) -- | Construct a stateful tracer that prints the current peer simulator state in -- a block tree, highlighting the candidate fragments, selection, and forks in @@ -986,7 +986,7 @@ peerSimStateDiagramSTMTracer :: m (Tracer m ()) peerSimStateDiagramSTMTracer stringTracer pssBlockTree selectionVar candidatesVar pointsVar = do peerCache <- uncheckedNewTVarM mempty - pure $ Tracer $ const $ do + pure $ mkTracer $ const $ do (s, cachedPeers) <- atomically $ do pssSelection <- selectionVar pssCandidates <- candidatesVar diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs index 0fbb0ba758..fffc21029e 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs @@ -23,8 +23,9 @@ module Test.Consensus.PeerSimulator.Trace ) where import Control.Tracer - ( Tracer (Tracer) + ( Tracer , contramap + , mkTracer , traceWith ) import Data.Bifunctor (second) @@ -219,7 +220,7 @@ tracerTestBlock tracer0 = do -- it behaves well in IO (where it prefixes all lines by the time). tickTimeVar <- uncheckedNewTVarM $ Time (-1) let setTickTime = atomically . writeTVar tickTimeVar - tracer = Tracer $ \msg -> do + tracer = mkTracer $ \msg -> do time <- getMonotonicTime tickTime <- readTVarIO tickTimeVar let timeHeader = prettyTime time ++ " " @@ -228,9 +229,10 @@ tracerTestBlock tracer0 = do then timeHeader else replicate (length timeHeader) ' ' traceWith tracer0 $ concat $ intersperse "\n" $ map (prefix ++) $ lines msg - pure $ Tracer $ traceEventTestBlockWith setTickTime tracer0 tracer + pure $ mkTracer $ traceEventTestBlockWith setTickTime tracer0 tracer mkGDDTracerTestBlock :: + Monad m => Tracer m (TraceEvent blk) -> Tracer m (TraceGDDEvent PeerId blk) mkGDDTracerTestBlock = contramap TraceGenesisDDEvent @@ -356,7 +358,7 @@ traceSchedulerEventTestBlockWith setTickTime tracer0 tracer = \case ["(LookingForIntersection", terseJumpInfo goodJumpInfo, terseJumpInfo badJumpInfo, ")"] traceScheduledServerHandlerEventTestBlockWith :: - Condense (NodeState blk) => + (Monad m, Condense (NodeState blk)) => Tracer m String -> String -> TraceScheduledServerHandlerEvent (NodeState blk) blk -> @@ -376,7 +378,8 @@ traceScheduledServerHandlerEventTestBlockWith tracer unit = \case traceLines = traceUnitLinesWith tracer unit traceScheduledChainSyncServerEventTestBlockWith :: - ( Condense (NodeState blk) + ( Monad m + , Condense (NodeState blk) , Terse blk ) => Tracer m String -> @@ -420,7 +423,8 @@ traceScheduledChainSyncServerEventTestBlockWith tracer peerId = \case traceLines = traceUnitLinesWith tracer unit traceScheduledBlockFetchServerEventTestBlockWith :: - ( Condense (NodeState blk) + ( Monad m + , Condense (NodeState blk) , Terse blk ) => Tracer m String -> @@ -482,7 +486,8 @@ traceChainDBEventTestBlockWith tracer = \case traceChainSyncClientEventTestBlockWith :: forall blk m. - ( AF.HasHeader (Header blk) + ( Monad m + , AF.HasHeader (Header blk) , Terse blk , Typeable blk ) => @@ -545,6 +550,7 @@ terseJumpInfo :: terseJumpInfo ji = tersePoint @blk (castPoint $ headPoint $ jTheirFragment ji) traceChainSyncClientTerminationEventTestBlockWith :: + Monad m => PeerId -> Tracer m String -> TraceChainSyncClientTerminationEvent -> @@ -562,6 +568,7 @@ traceChainSyncClientTerminationEventTestBlockWith pid tracer = \case trace = traceUnitWith tracer ("ChainSyncClient " ++ condense pid) traceBlockFetchClientTerminationEventTestBlockWith :: + Monad m => PeerId -> Tracer m String -> TraceBlockFetchClientTerminationEvent -> @@ -576,7 +583,7 @@ traceBlockFetchClientTerminationEventTestBlockWith pid tracer = \case -- | Trace all the SendRecv events of the ChainSync mini-protocol. traceChainSyncSendRecvEventTestBlockWith :: - Applicative m => + Monad m => Terse blk => PeerId -> String -> @@ -605,6 +612,7 @@ traceChainSyncSendRecvEventTestBlockWith pid ptp tracer = \case MsgDone -> "MsgDone" traceDbjEventWith :: + Monad m => Tracer m String -> TraceEventDbf PeerId -> m () @@ -613,7 +621,7 @@ traceDbjEventWith tracer = RotatedDynamo old new -> "Rotated dynamo from " ++ condense old ++ " to " ++ condense new traceCsjEventWith :: - Terse blk => + (Monad m, Terse blk) => PeerId -> Tracer m String -> TraceEventCsj PeerId blk -> @@ -738,6 +746,7 @@ prettyTime (Time time) = in printf "%02d:%02d.%03d" minutes (seconds `rem` 60) (milliseconds `rem` 1_000) traceLinesWith :: + Monad m => Tracer m String -> [String] -> m () @@ -752,11 +761,11 @@ padUnit unit = unit ++ replicate (maxUnitLength - length unit) ' ' -- | Trace using the given tracer, printing the current time (typically the time -- of the simulation) and the unit name. -traceUnitLinesWith :: Tracer m String -> String -> [String] -> m () +traceUnitLinesWith :: Monad m => Tracer m String -> String -> [String] -> m () traceUnitLinesWith tracer unit msgs = traceLinesWith tracer $ map (printf "%s | %s" $ padUnit unit) msgs -- | Trace using the given tracer, printing the current time (typically the time -- of the simulation) and the unit name. -traceUnitWith :: Tracer m String -> String -> String -> m () +traceUnitWith :: Monad m => Tracer m String -> String -> String -> m () traceUnitWith tracer unit msg = traceUnitLinesWith tracer unit [msg] diff --git a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs index a455689110..80d2c4b662 100644 --- a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs +++ b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/BFT.hs @@ -109,13 +109,14 @@ prop_simple_bft_convergence testConfigB TestConfigMB { nodeInfo = \nid -> - plainTestNodeInitialization - ( protocolInfoBft - numCoreNodes - nid - k - (HardFork.defaultEraParams k slotLength) - ) - (pure $ fmap (MkBlockForging . pure) $ blockForgingBft nid) + pure $ + plainTestNodeInitialization + ( protocolInfoBft + numCoreNodes + nid + k + (HardFork.defaultEraParams k slotLength) + ) + (pure $ fmap (MkBlockForging . pure) $ blockForgingBft nid) , mkRekeyM = Nothing } diff --git a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/LeaderSchedule.hs b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/LeaderSchedule.hs index 9dd2053a66..6ad45b593b 100644 --- a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/LeaderSchedule.hs +++ b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/LeaderSchedule.hs @@ -124,20 +124,21 @@ prop_simple_leader_schedule_convergence testConfigB TestConfigMB { nodeInfo = \nid -> - plainTestNodeInitialization - ( protocolInfoPraosRule - numCoreNodes - nid - PraosParams - { praosSecurityParam = k - , praosSlotsPerEpoch = unEpochSize epochSize - , praosLeaderF = dummyF - } - (HardFork.defaultEraParams k slotLength) - schedule - emptyPraosEvolvingStake - ) - (pure $ fmap (MkBlockForging . pure) $ blockForgingPraosRule) + pure $ + plainTestNodeInitialization + ( protocolInfoPraosRule + numCoreNodes + nid + PraosParams + { praosSecurityParam = k + , praosSlotsPerEpoch = unEpochSize epochSize + , praosLeaderF = dummyF + } + (HardFork.defaultEraParams k slotLength) + schedule + emptyPraosEvolvingStake + ) + (pure $ fmap (MkBlockForging . pure) $ blockForgingPraosRule) , mkRekeyM = Nothing } diff --git a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/PBFT.hs b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/PBFT.hs index af003a923e..323b9a7b8d 100644 --- a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/PBFT.hs +++ b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/PBFT.hs @@ -123,12 +123,13 @@ prop_simple_pbft_convergence testConfigB TestConfigMB { nodeInfo = \nid -> - plainTestNodeInitialization - ( protocolInfoMockPBFT - params - (HardFork.defaultEraParams k slotLength) - ) - (pure $ fmap (MkBlockForging . pure) $ blockForgingMockPBFT nid) + pure $ + plainTestNodeInitialization + ( protocolInfoMockPBFT + params + (HardFork.defaultEraParams k slotLength) + ) + (pure $ fmap (MkBlockForging . pure) $ blockForgingMockPBFT nid) , mkRekeyM = Nothing } diff --git a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs index 4b78803da4..f3e4a00cba 100644 --- a/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs +++ b/ouroboros-consensus-diffusion/test/mock-test/Test/ThreadNet/Praos.hs @@ -159,19 +159,20 @@ prop_simple_praos_convergence testConfigB TestConfigMB { nodeInfo = \nid -> - plainTestNodeInitialization - ( protocolInfoPraos - numCoreNodes - nid - params - ( HardFork.defaultEraParams - k - slotLength - ) - setupInitialNonce - evolvingStake - ) - (fmap (fmap (MkBlockForging . pure)) $ blockForgingPraos numCoreNodes nid) + pure $ + plainTestNodeInitialization + ( protocolInfoPraos + numCoreNodes + nid + params + ( HardFork.defaultEraParams + k + slotLength + ) + setupInitialNonce + evolvingStake + ) + (fmap (fmap (MkBlockForging . pure)) $ blockForgingPraos numCoreNodes nid) , mkRekeyM = Nothing } diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs index 1089989945..5d9fcfdd61 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs @@ -39,6 +39,7 @@ import qualified Cardano.Crypto.VRF as VRF import Cardano.Ledger.BaseTypes (ActiveSlotCoeff, Nonce, (⭒)) import qualified Cardano.Ledger.BaseTypes as SL import qualified Cardano.Ledger.Chain as SL +import Cardano.Ledger.Core (fromEraCBOR, toEraCBOR) import Cardano.Ledger.Hashes (HASH) import Cardano.Ledger.Keys ( DSIGN @@ -48,11 +49,19 @@ import Cardano.Ledger.Keys , hashKey ) import qualified Cardano.Ledger.Keys as SL +import Cardano.Ledger.Shelley (ShelleyEra) import Cardano.Ledger.Slot (Duration (Duration), (+*)) import qualified Cardano.Ledger.State as SL import Cardano.Protocol.Crypto (Crypto, KES, StandardCrypto, VRF) +import Cardano.Protocol.Praos.BlockHeader (HeaderBody) +import Cardano.Protocol.Praos.VRF + ( InputVRF + , mkInputVRF + , vrfLeaderValue + , vrfNonceValue + ) import qualified Cardano.Protocol.TPraos.API as SL -import Cardano.Protocol.TPraos.BHeader +import Cardano.Protocol.TPraos.BlockHeader ( BoundedNatural (bvValue) , checkLeaderNatValue , prevHashToNonce @@ -98,13 +107,6 @@ import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey import Ouroboros.Consensus.Protocol.Ledger.Util (isNewEpoch) import Ouroboros.Consensus.Protocol.Praos.Common -import Ouroboros.Consensus.Protocol.Praos.Header (HeaderBody) -import Ouroboros.Consensus.Protocol.Praos.VRF - ( InputVRF - , mkInputVRF - , vrfLeaderValue - , vrfNonceValue - ) import qualified Ouroboros.Consensus.Protocol.Praos.Views as Views import Ouroboros.Consensus.Protocol.TPraos ( ConsensusConfig (TPraosConfig, tpraosEpochInfo, tpraosParams) @@ -310,12 +312,12 @@ instance Serialise PraosState where [ CBOR.encodeListLen 8 , toCBOR praosStateLastSlot , toCBOR praosStateOCertCounters - , toCBOR praosStateEvolvingNonce - , toCBOR praosStateCandidateNonce - , toCBOR praosStateEpochNonce - , toCBOR praosStatePreviousEpochNonce - , toCBOR praosStateLabNonce - , toCBOR praosStateLastEpochBlockNonce + , toEraCBOR @ShelleyEra praosStateEvolvingNonce + , toEraCBOR @ShelleyEra praosStateCandidateNonce + , toEraCBOR @ShelleyEra praosStateEpochNonce + , toEraCBOR @ShelleyEra praosStatePreviousEpochNonce + , toEraCBOR @ShelleyEra praosStateLabNonce + , toEraCBOR @ShelleyEra praosStateLastEpochBlockNonce ] decode = @@ -327,16 +329,16 @@ instance Serialise PraosState where PraosState <$> fromCBOR <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR - <*> fromCBOR + <*> fromEraCBOR @ShelleyEra + <*> fromEraCBOR @ShelleyEra + <*> fromEraCBOR @ShelleyEra + <*> fromEraCBOR @ShelleyEra + <*> fromEraCBOR @ShelleyEra + <*> fromEraCBOR @ShelleyEra data instance Ticked PraosState = TickedPraosState { tickedPraosStateChainDepState :: PraosState - , tickedPraosStateLedgerView :: Views.LedgerView + , tickedPraosStateLedgerView :: Views.PraosLedgerView } -- | Errors which we might encounter @@ -391,7 +393,7 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where type IsLeader (Praos c) = PraosIsLeader c type CanBeLeader (Praos c) = PraosCanBeLeader c type TiebreakerView (Praos c) = PraosTiebreakerView c - type LedgerView (Praos c) = Views.LedgerView + type LedgerView (Praos c) = Views.PraosLedgerView type ValidationErr (Praos c) = PraosValidationErr c type ValidateView (Praos c) = PraosValidateView c @@ -539,7 +541,7 @@ meetsLeaderThreshold :: Bool meetsLeaderThreshold PraosConfig{praosParams} - Views.LedgerView{Views.lvPoolDistr} + Views.PraosLedgerView{Views.plvPoolDistr} keyHash rho = checkLeaderNatValue @@ -547,7 +549,7 @@ meetsLeaderThreshold r (praosLeaderF praosParams) where - SL.PoolDistr poolDistr _totalActiveStake = lvPoolDistr + SL.PoolDistr poolDistr _totalActiveStake = plvPoolDistr r = maybe 0 SL.individualPoolStake $ Map.lookup keyHash poolDistr @@ -556,11 +558,11 @@ validateVRFSignature :: forall c. PraosCrypto c => Nonce -> - Views.LedgerView -> + Views.PraosLedgerView -> ActiveSlotCoeff -> Views.HeaderView c -> Except (PraosValidationErr c) () -validateVRFSignature eta0 (Views.lvPoolDistr -> SL.PoolDistr pd _) = +validateVRFSignature eta0 (Views.plvPoolDistr -> SL.PoolDistr pd _) = doValidateVRFSignature eta0 pd -- NOTE: this function is much easier to test than 'validateVRFSignature' because we don't need @@ -609,9 +611,9 @@ validateKESSignature PraosParams{praosMaxKESEvo, praosSlotsPerKESPeriod} _ei ) - Views.LedgerView{Views.lvPoolDistr = SL.PoolDistr lvPoolDistr _totalActiveStake} + Views.PraosLedgerView{Views.plvPoolDistr = SL.PoolDistr plvPoolDistr _totalActiveStake} ocertCounters = - doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod lvPoolDistr ocertCounters + doValidateKESSignature praosMaxKESEvo praosSlotsPerKESPeriod plvPoolDistr ocertCounters -- NOTE: This function is much easier to test than 'validateKESSignature' because we don't need to -- construct a 'PraosConfig' nor 'LedgerView' to test it. @@ -750,12 +752,12 @@ instance PraosCrypto c => PraosProtocolSupportsNode (Praos c) where -- - They share the same DSIGN verification keys -- - They share the same VRF verification keys instance TranslateProto (TPraos c) (Praos c) where - translateLedgerView _ SL.LedgerView{SL.lvPoolDistr, SL.lvChainChecks} = - Views.LedgerView - { Views.lvPoolDistr = lvPoolDistr - , Views.lvMaxHeaderSize = SL.ccMaxBHSize lvChainChecks - , Views.lvMaxBodySize = SL.ccMaxBBSize lvChainChecks - , Views.lvProtocolVersion = SL.ccProtocolVersion lvChainChecks + translateLedgerView _ SL.TPraosLedgerView{SL.tplvPoolDistr, SL.tplvChainChecks} = + Views.PraosLedgerView + { Views.plvPoolDistr = tplvPoolDistr + , Views.plvMaxHeaderSize = SL.ccMaxBHSize tplvChainChecks + , Views.plvMaxBodySize = SL.ccMaxBBSize tplvChainChecks + , Views.plvProtocolVersion = SL.ccProtocolVersion tplvChainChecks } translateChainDepState _ tpState = diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs deleted file mode 100644 index 05864f17ba..0000000000 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Header.hs +++ /dev/null @@ -1,239 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - --- | Block header associated with Praos. --- --- The choice of whether to associate the header with the ledger era or the --- protocol is a little artitrary. Functionally the header contains things which --- are associated with both ledger and protocol, and which are used by both. --- --- We choose to associate the header with the protocol, since it more strongly --- binds in that direction, and to assist with the mental picture that the --- protocol is concerned with the block header, while the ledger is concerned --- with the block body. However, in order to more cleanly illustrate which parts --- of the header are _strictly_ protocol concerns, we also provide a view of the --- header (in 'Ouroboros.Consensus.Protocol.Praos.Views') which extracts just --- the fields needed for the Praos protocol. This also allows us to hide the --- more detailed construction of the header. -module Ouroboros.Consensus.Protocol.Praos.Header - ( Header (Header, headerBody, headerSig) - , HeaderBody (..) - , headerHash - , headerSize - ) where - -import qualified Cardano.Crypto.Hash as Hash -import qualified Cardano.Crypto.KES as KES -import Cardano.Crypto.Util - ( SignableRepresentation (getSignableRepresentation) - ) -import qualified Cardano.Crypto.VRF as VRF -import Cardano.Ledger.BaseTypes (ProtVer (pvMajor)) -import Cardano.Ledger.Binary - ( Annotator (..) - , DecCBOR (decCBOR) - , EncCBOR (..) - , serialize' - , unCBORGroup - ) -import Cardano.Ledger.Binary.Coders -import Cardano.Ledger.Binary.Crypto - ( decodeSignedKES - , decodeVerKeyVRF - , encodeSignedKES - , encodeVerKeyVRF - ) -import qualified Cardano.Ledger.Binary.Plain as Plain -import Cardano.Ledger.Hashes - ( EraIndependentBlockBody - , EraIndependentBlockHeader - , HASH - , HashAnnotated (..) - , SafeToHash - , extractHash - , originalBytesSize - ) -import Cardano.Ledger.Keys (KeyRole (BlockIssuer), VKey) -import Cardano.Ledger.MemoBytes - ( Mem - , MemoBytes - , MemoHashIndex - , Memoized (..) - , getMemoRawType - , getMemoSafeHash - , mkMemoized - ) -import Cardano.Protocol.Crypto (Crypto, KES, VRF) -import Cardano.Protocol.TPraos.BHeader (PrevHash) -import Cardano.Protocol.TPraos.OCert (OCert) -import Cardano.Slotting.Block (BlockNo) -import Cardano.Slotting.Slot (SlotNo) -import Data.Word (Word32) -import GHC.Generics (Generic) -import NoThunks.Class (NoThunks (..)) -import Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF) - --- | The body of the header is the part which gets hashed to form the hash --- chain. -data HeaderBody crypto = HeaderBody - { hbBlockNo :: !BlockNo - -- ^ block number - , hbSlotNo :: !SlotNo - -- ^ block slot - , hbPrev :: !PrevHash - -- ^ Hash of the previous block header - , hbVk :: !(VKey BlockIssuer) - -- ^ verification key of block issuer - , hbVrfVk :: !(VRF.VerKeyVRF (VRF crypto)) - -- ^ VRF verification key for block issuer - , hbVrfRes :: !(VRF.CertifiedVRF (VRF crypto) InputVRF) - -- ^ Certified VRF value - , hbBodySize :: !Word32 - -- ^ Size of the block body - , hbBodyHash :: !(Hash.Hash HASH EraIndependentBlockBody) - -- ^ Hash of block body - , hbOCert :: !(OCert crypto) - -- ^ operational certificate - , hbProtVer :: !ProtVer - -- ^ protocol version - } - deriving Generic - -deriving instance Crypto crypto => Show (HeaderBody crypto) - -deriving instance Crypto crypto => Eq (HeaderBody crypto) - -instance - Crypto crypto => - SignableRepresentation (HeaderBody crypto) - where - getSignableRepresentation hb = serialize' (pvMajor (hbProtVer hb)) hb - -instance - Crypto crypto => - NoThunks (HeaderBody crypto) - -data HeaderRaw crypto = HeaderRaw - { headerRawBody :: !(HeaderBody crypto) - , headerRawSig :: !(KES.SignedKES (KES crypto) (HeaderBody crypto)) - } - deriving (Show, Generic) - -instance Crypto c => Eq (HeaderRaw c) where - h1 == h2 = - headerRawSig h1 == headerRawSig h2 - && headerRawBody h1 == headerRawBody h2 - -instance - Crypto crypto => - NoThunks (HeaderRaw crypto) - --- | Full header type, carrying its own memoised bytes. -newtype Header crypto = HeaderConstr (MemoBytes (HeaderRaw crypto)) - deriving Generic - deriving newtype (Eq, Show, NoThunks, Plain.ToCBOR, SafeToHash) - -instance Memoized (Header crypto) where - type RawType (Header crypto) = HeaderRaw crypto - -type instance MemoHashIndex (HeaderRaw crypto) = EraIndependentBlockHeader - -instance HashAnnotated (Header crypto) EraIndependentBlockHeader where - hashAnnotated = getMemoSafeHash - -pattern Header :: - Crypto crypto => - HeaderBody crypto -> - KES.SignedKES (KES crypto) (HeaderBody crypto) -> - Header crypto -pattern Header{headerBody, headerSig} <- (getMemoRawType -> HeaderRaw headerBody headerSig) - where - Header body sig = mkMemoized (pvMajor (hbProtVer body)) $ HeaderRaw body sig -{-# COMPLETE Header #-} - --- | Compute the size of the header -headerSize :: Header crypto -> Int -headerSize = originalBytesSize - --- | Hash a header -headerHash :: - Header crypto -> - Hash.Hash HASH EraIndependentBlockHeader -headerHash = extractHash . hashAnnotated - --------------------------------------------------------------------------------- --- Serialisation --------------------------------------------------------------------------------- - -instance Crypto crypto => EncCBOR (HeaderBody crypto) where - encCBOR - HeaderBody - { hbBlockNo - , hbSlotNo - , hbPrev - , hbVk - , hbVrfVk - , hbVrfRes - , hbBodySize - , hbBodyHash - , hbOCert - , hbProtVer - } = - encode $ - Rec HeaderBody - !> To hbBlockNo - !> To hbSlotNo - !> To hbPrev - !> To hbVk - !> E encodeVerKeyVRF hbVrfVk - !> To hbVrfRes - !> To hbBodySize - !> To hbBodyHash - !> To hbOCert - !> To hbProtVer - -instance Crypto crypto => DecCBOR (HeaderBody crypto) where - decCBOR = - decode $ - RecD HeaderBody - - HeaderRaw crypto -> - Encode (Closed Dense) (HeaderRaw crypto) -encodeHeaderRaw (HeaderRaw body sig) = - Rec HeaderRaw !> To body !> E encodeSignedKES sig - -instance Crypto crypto => EncCBOR (HeaderRaw crypto) where - encCBOR = encode . encodeHeaderRaw - -instance Crypto crypto => DecCBOR (HeaderRaw crypto) where - decCBOR = decode $ RecD HeaderRaw DecCBOR (Annotator (HeaderRaw crypto)) where - decCBOR = pure <$> decCBOR - -instance Crypto c => EncCBOR (Header c) - -deriving via - Mem (HeaderRaw crypto) - instance - Crypto crypto => DecCBOR (Annotator (Header crypto)) diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/VRF.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/VRF.hs deleted file mode 100644 index 4b96472124..0000000000 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/VRF.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - --- | This module implements VRF range extension as described in --- https://iohk.io/en/research/library/papers/on-uc-secure-range-extension-and-batch-verification-for-ecvrf/ -module Ouroboros.Consensus.Protocol.Praos.VRF - ( InputVRF - , VRFUsage (..) - , mkInputVRF - , vrfLeaderValue - , vrfNonceValue - ) where - -import Cardano.Binary (ToCBOR) -import Cardano.Crypto.Hash - ( Blake2b_256 - , Hash - , castHash - , hashSize - , hashToBytes - , hashWith - ) -import qualified Cardano.Crypto.Hash as Hash -import Cardano.Crypto.Util - ( SignableRepresentation (getSignableRepresentation) - , bytesToNatural - ) -import Cardano.Crypto.VRF - ( CertifiedVRF (certifiedOutput) - , getOutputVRFBytes - ) -import Cardano.Ledger.BaseTypes (Nonce (NeutralNonce, Nonce)) -import Cardano.Ledger.Binary (runByteBuilder) -import Cardano.Ledger.Hashes (HASH) -import Cardano.Ledger.Slot (SlotNo (SlotNo)) -import Cardano.Protocol.Crypto (Crypto (VRF)) -import Cardano.Protocol.TPraos.BHeader - ( BoundedNatural - , assertBoundedNatural - ) -import qualified Data.ByteString.Builder as BS -import qualified Data.ByteString.Builder.Extra as BS -import Data.Proxy (Proxy (Proxy)) -import GHC.Generics (Generic) -import NoThunks.Class (NoThunks) -import Numeric.Natural (Natural) - --- | Input to the verifiable random function. Consists of the hash of the slot --- and the epoch nonce. -newtype InputVRF = InputVRF {unInputVRF :: Hash Blake2b_256 InputVRF} - deriving (Eq, Ord, Show, Generic) - deriving newtype (NoThunks, ToCBOR) - -instance SignableRepresentation InputVRF where - getSignableRepresentation (InputVRF x) = hashToBytes x - --- | Construct a unified VRF value -mkInputVRF :: - SlotNo -> - -- | Epoch nonce - Nonce -> - InputVRF -mkInputVRF (SlotNo slot) eNonce = - InputVRF - . Hash.castHash - . Hash.hashWith id - . runByteBuilder (8 + 32) - $ BS.word64BE slot - <> ( case eNonce of - NeutralNonce -> mempty - Nonce h -> BS.byteStringCopy (Hash.hashToBytes h) - ) - --- | Indicate the usage of the VRF result. -data VRFUsage - = -- | The VRF value will be used to establish whether the issuing node is - -- indeed a leader for this slot. - VRFLeader - | -- | The VRF value will be used to contribute to the evolving nonce. - VRFNonce - --- | Singleton VRF usage -data SVRFUsage a where - SVRFLeader :: SVRFUsage VRFLeader - SVRFNonce :: SVRFUsage VRFNonce - --- | Indicate the result of the VRF evaluation. -data VRFResult (v :: VRFUsage) - --- | Compute a hash of the unified VRF output appropriate to its usage. -hashVRF :: - proxy c -> - SVRFUsage v -> - CertifiedVRF (VRF c) InputVRF -> - Hash HASH (VRFResult v) -hashVRF _ use certVRF = - let vrfOutputAsBytes = getOutputVRFBytes $ certifiedOutput certVRF - in case use of - SVRFLeader -> castHash $ hashWith id $ "L" <> vrfOutputAsBytes - SVRFNonce -> castHash $ hashWith id $ "N" <> vrfOutputAsBytes - --- | Range-extend a VRF output to be used for leader checks from the relevant --- hash. See section 4.1 of the linked paper for details. -vrfLeaderValue :: - proxy c -> - CertifiedVRF (VRF c) InputVRF -> - BoundedNatural -vrfLeaderValue p cvrf = - assertBoundedNatural - ((2 :: Natural) ^ (8 * hashSize (Proxy @HASH))) - (bytesToNatural . hashToBytes $ hashVRF p SVRFLeader cvrf) - --- | Range-extend a VRF output to be used for the evolving nonce. See section --- 4.1 of the linked paper for details. -vrfNonceValue :: - proxy c -> - CertifiedVRF (VRF c) InputVRF -> - Nonce -vrfNonceValue p = - -- The double hashing below is perhaps a little confusing. The first hash is - -- how we do range extension as per the VRF paper. The second hash is how we - -- generate a nonce value from a VRF output. However, that "VRF output" is now - -- itself a hash. - -- - -- However, while the VRF hash is crypto-dependent, for the nonce we use a - -- fixed `Blake2b_256` hashing function. So this double hashing is still - -- needed. - Nonce . castHash . hashWith id . hashToBytes . hashVRF p SVRFNonce diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs index 58fbb6dc65..590f31a1d5 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos/Views.hs @@ -1,20 +1,27 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + module Ouroboros.Consensus.Protocol.Praos.Views ( HeaderView (..) - , LedgerView (..) + , PraosLedgerView (..) + , forecastToPraosLedgerView ) where import Cardano.Crypto.KES (SignedKES) import Cardano.Crypto.VRF (CertifiedVRF, VRFAlgorithm (VerKeyVRF)) import Cardano.Ledger.BaseTypes (ProtVer) +import Cardano.Ledger.Chain (ChainChecksPParams (..)) import Cardano.Ledger.Keys (KeyRole (BlockIssuer), VKey) import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Protocol.Crypto (KES, VRF) -import Cardano.Protocol.TPraos.BHeader (PrevHash) +import Cardano.Protocol.Praos.BlockHeader (HeaderBody) +import Cardano.Protocol.Praos.VRF (InputVRF) +import Cardano.Protocol.TPraos.BlockHeader (PrevHash) import Cardano.Protocol.TPraos.OCert (OCert) import Cardano.Slotting.Slot (SlotNo) import Data.Word (Word16, Word32) -import Ouroboros.Consensus.Protocol.Praos.Header (HeaderBody) -import Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF) +import Lens.Micro ((^.)) -- | View of the block header required by the Praos protocol. data HeaderView crypto = HeaderView @@ -36,14 +43,30 @@ data HeaderView crypto = HeaderView -- ^ KES Signature of the header } -data LedgerView = LedgerView - { lvPoolDistr :: SL.PoolDistr +data PraosLedgerView = PraosLedgerView + { plvPoolDistr :: SL.PoolDistr -- ^ Stake distribution - , lvMaxHeaderSize :: !Word16 + , plvMaxHeaderSize :: !Word16 -- ^ Maximum header size - , lvMaxBodySize :: !Word32 + , plvMaxBodySize :: !Word32 -- ^ Maximum block body size - , lvProtocolVersion :: !ProtVer + , plvProtocolVersion :: !ProtVer -- ^ Current protocol version } deriving Show + +-- | Build a 'PraosLedgerView' from a ledger 'EraForecast' +forecastToPraosLedgerView :: + forall t era. + SL.EraForecast era => + SL.Forecast t era -> + PraosLedgerView +forecastToPraosLedgerView f = + PraosLedgerView + { plvPoolDistr = f ^. SL.poolDistrForecastL @era @t + , plvMaxHeaderSize = ccMaxBHSize cc + , plvMaxBodySize = ccMaxBBSize cc + , plvProtocolVersion = ccProtocolVersion cc + } + where + cc = SL.forecastChainChecks @t @era f diff --git a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs index d86ff4279c..3435eb241f 100644 --- a/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs +++ b/ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs @@ -49,7 +49,7 @@ import qualified Cardano.Ledger.Keys as SL import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Protocol.Crypto (KES, StandardCrypto, VRF) import qualified Cardano.Protocol.TPraos.API as SL -import qualified Cardano.Protocol.TPraos.BHeader as SL +import qualified Cardano.Protocol.TPraos.BlockHeader as SL import qualified Cardano.Protocol.TPraos.OCert as Absolute (KESPeriod (..)) import qualified Cardano.Protocol.TPraos.OCert as SL import qualified Cardano.Protocol.TPraos.Rules.Overlay as SL @@ -297,7 +297,7 @@ instance Serialise TPraosState where data instance Ticked TPraosState = TickedChainDepState { tickedTPraosStateChainDepState :: SL.ChainDepState - , tickedTPraosStateLedgerView :: SL.LedgerView + , tickedTPraosStateLedgerView :: SL.TPraosLedgerView } instance SL.PraosCrypto c => ConsensusProtocol (TPraos c) where @@ -305,7 +305,7 @@ instance SL.PraosCrypto c => ConsensusProtocol (TPraos c) where type IsLeader (TPraos c) = TPraosIsLeader c type CanBeLeader (TPraos c) = PraosCanBeLeader c type TiebreakerView (TPraos c) = PraosTiebreakerView c - type LedgerView (TPraos c) = SL.LedgerView + type LedgerView (TPraos c) = SL.TPraosLedgerView type ValidationErr (TPraos c) = SL.ChainTransitionError c type ValidateView (TPraos c) = TPraosValidateView c @@ -348,7 +348,7 @@ instance SL.PraosCrypto c => ConsensusProtocol (TPraos c) where where chainState = tickedTPraosStateChainDepState cs lv = tickedTPraosStateLedgerView cs - d = SL.lvD lv + d = SL.tplvD lv asc = tpraosLeaderF $ tpraosParams cfg firstSlot = firstSlotOfEpochOfSlot @@ -363,7 +363,7 @@ instance SL.PraosCrypto c => ConsensusProtocol (TPraos c) where rho = VRF.evalCertified () rho' praosCanBeLeaderSignKeyVRF y = VRF.evalCertified () y' praosCanBeLeaderSignKeyVRF - SL.GenDelegs dlgMap = SL.lvGenDelegs lv + SL.GenDelegs dlgMap = SL.tplvGenDelegs lv tickChainDepState cfg@TPraosConfig{..} @@ -435,7 +435,7 @@ meetsLeaderThreshold :: Bool meetsLeaderThreshold TPraosConfig{tpraosParams} - SL.LedgerView{lvPoolDistr} + SL.TPraosLedgerView{tplvPoolDistr} keyHash certNat = SL.checkLeaderValue @@ -443,7 +443,7 @@ meetsLeaderThreshold r (tpraosLeaderF tpraosParams) where - SL.PoolDistr poolDistr _totalActiveStake = lvPoolDistr + SL.PoolDistr poolDistr _totalActiveStake = tplvPoolDistr r = maybe 0 SL.individualPoolStake $ Map.lookup keyHash poolDistr diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs index e142f944d8..6715ca42c4 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Consensus/Protocol/Serialisation/Generators.hs @@ -6,7 +6,12 @@ module Test.Consensus.Protocol.Serialisation.Generators () where import Cardano.Crypto.KES (unsoundPureSignedKES) import Cardano.Crypto.VRF (evalCertified) -import Cardano.Protocol.TPraos.BHeader (HashHeader, PrevHash (..)) +import Cardano.Protocol.Praos.BlockHeader + ( Header (Header) + , HeaderBody (HeaderBody) + ) +import Cardano.Protocol.Praos.VRF (InputVRF, mkInputVRF) +import Cardano.Protocol.TPraos.BlockHeader (HashHeader, PrevHash (..)) import Cardano.Protocol.TPraos.OCert ( KESPeriod (KESPeriod) , OCert (OCert) @@ -18,11 +23,6 @@ import Cardano.Slotting.Slot ) import Ouroboros.Consensus.Protocol.Praos (PraosState (PraosState)) import qualified Ouroboros.Consensus.Protocol.Praos as Praos -import Ouroboros.Consensus.Protocol.Praos.Header - ( Header (Header) - , HeaderBody (HeaderBody) - ) -import Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF, mkInputVRF) import Test.Cardano.Ledger.Shelley.Serialisation.EraIndepGenerators () import Test.Crypto.KES () import Test.QuickCheck (Arbitrary (..), Gen, choose, oneof) diff --git a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs index 138990bb3e..aabd0089ec 100644 --- a/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs +++ b/ouroboros-consensus-protocol/src/unstable-protocol-testlib/Test/Ouroboros/Consensus/Protocol/Praos/Header.hs @@ -67,7 +67,17 @@ import Cardano.Ledger.Keys , hashKey , signedDSIGN ) -import Cardano.Protocol.TPraos.BHeader +import Cardano.Protocol.Praos.BlockHeader + ( Header + , HeaderBody (..) + , pattern Header + ) +import Cardano.Protocol.Praos.VRF + ( InputVRF + , mkInputVRF + , vrfLeaderValue + ) +import Cardano.Protocol.TPraos.BlockHeader ( HashHeader (..) , PrevHash (..) , checkLeaderNatValue @@ -96,16 +106,6 @@ import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Word (Word64) import GHC.Generics (Generic) import Ouroboros.Consensus.Protocol.Praos (PraosValidationErr (..)) -import Ouroboros.Consensus.Protocol.Praos.Header - ( Header - , HeaderBody (..) - , pattern Header - ) -import Ouroboros.Consensus.Protocol.Praos.VRF - ( InputVRF - , mkInputVRF - , vrfLeaderValue - ) import Ouroboros.Consensus.Protocol.TPraos (StandardCrypto) import Test.QuickCheck ( Gen diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 9429e59d6b..b1f012f9e6 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -357,16 +357,16 @@ library binary >=0.8 && <0.11, bytestring >=0.10 && <0.13, cardano-binary, - cardano-crypto-class ^>=2.3, + cardano-crypto-class ^>=2.5, cardano-diffusion:api, - cardano-ledger-binary ^>=1.8, - cardano-ledger-core ^>=1.20, + cardano-ledger-binary ^>=1.9, + cardano-ledger-core ^>=1.21, cardano-prelude, cardano-slotting, cardano-strict-containers, cborg ^>=0.2.2, containers >=0.5 && <0.9, - contra-tracer ^>=0.1, + contra-tracer ^>=0.2.1, deepseq, FailT ^>=0.1.2, filelock, @@ -946,28 +946,27 @@ library protocol Ouroboros.Consensus.Protocol.Praos Ouroboros.Consensus.Protocol.Praos.AgentClient Ouroboros.Consensus.Protocol.Praos.Common - Ouroboros.Consensus.Protocol.Praos.Header Ouroboros.Consensus.Protocol.Praos.Views - Ouroboros.Consensus.Protocol.Praos.VRF Ouroboros.Consensus.Protocol.TPraos build-depends: base, - bytestring, cardano-binary, cardano-crypto-class:cardano-crypto-class, cardano-ledger-binary, cardano-ledger-core, - cardano-ledger-shelley ^>=1.18, - cardano-protocol-tpraos ^>=1.5, + cardano-ledger-shelley ^>=1.19, + cardano-protocol ^>=0.1, + cardano-protocol-tpraos ^>=1.6, cardano-slotting, cborg, containers, contra-tracer, io-classes, io-sim, - kes-agent ^>=1.2, - kes-agent-crypto ^>=1.1, + kes-agent ^>=1.3, + kes-agent-crypto ^>=1.2, + microlens, mtl, network ^>=3.2.7, nothunks, @@ -995,7 +994,7 @@ library unstable-protocol-testlib cardano-ledger-binary, cardano-ledger-core, cardano-ledger-shelley-test, - cardano-protocol-tpraos, + cardano-protocol, cardano-slotting, containers, ouroboros-consensus:protocol, @@ -1349,6 +1348,7 @@ library cardano Ouroboros.Consensus.Shelley.Node.Serialisation Ouroboros.Consensus.Shelley.Node.TPraos Ouroboros.Consensus.Shelley.Protocol.Abstract + Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks Ouroboros.Consensus.Shelley.Protocol.Praos Ouroboros.Consensus.Shelley.Protocol.TPraos Ouroboros.Consensus.Shelley.ShelleyHFC @@ -1358,22 +1358,24 @@ library cardano base, base-deriving-via, bytestring, + cardano-base, cardano-binary, cardano-crypto, cardano-crypto-class:cardano-crypto-class, cardano-crypto-wrapper, - cardano-ledger-allegra ^>=1.9, - cardano-ledger-alonzo ^>=1.15, - cardano-ledger-api ^>=1.13, - cardano-ledger-babbage ^>=1.13, + cardano-ledger-allegra ^>=1.10, + cardano-ledger-alonzo ^>=1.16, + cardano-ledger-api ^>=1.14, + cardano-ledger-babbage ^>=1.14, cardano-ledger-binary, cardano-ledger-byron ^>=1.3, - cardano-ledger-conway ^>=1.22, + cardano-ledger-conway ^>=1.23, cardano-ledger-core, - cardano-ledger-dijkstra ^>=0.2, - cardano-ledger-mary ^>=1.10, + cardano-ledger-dijkstra ^>=0.3, + cardano-ledger-mary ^>=1.11, cardano-ledger-shelley, cardano-prelude, + cardano-protocol ^>=0.1, cardano-protocol-tpraos, cardano-slotting, cardano-strict-containers, @@ -1382,6 +1384,7 @@ library cardano contra-tracer, deepseq, formatting >=6.3 && <7.3, + fs-api, measures, mempack, microlens, @@ -1397,7 +1400,7 @@ library cardano strict-sop-core, text, these, - validation >=1.1.5, + validation >=1.2, library unstable-byronspec import: common-lib @@ -1528,20 +1531,20 @@ library unstable-shelley-testlib cardano-crypto-class, cardano-data, cardano-ledger-allegra:cardano-ledger-allegra, - cardano-ledger-alonzo-test, cardano-ledger-babbage:testlib, cardano-ledger-conway:testlib, cardano-ledger-core:{cardano-ledger-core, testlib}, cardano-ledger-dijkstra:testlib, cardano-ledger-mary:cardano-ledger-mary, - cardano-ledger-shelley-ma-test, cardano-ledger-shelley-test, cardano-ledger-shelley:{cardano-ledger-shelley, testlib}, + cardano-protocol, cardano-protocol-tpraos:{cardano-protocol-tpraos, testlib}, cardano-slotting, cardano-strict-containers, containers, contra-tracer, + fs-api, kes-agent, kes-agent-crypto, microlens, @@ -1582,6 +1585,8 @@ test-suite shelley-test containers, contra-tracer, filepath, + fs-api, + fs-sim, measures, mempack, microlens, @@ -1631,6 +1636,8 @@ library unstable-cardano-testlib cborg, containers, contra-tracer, + fs-api, + fs-sim, mempack, microlens, mtl, @@ -1690,6 +1697,8 @@ test-suite cardano-test contra-tracer, directory, filepath, + fs-api, + fs-sim, microlens, ouroboros-consensus:{cardano, ouroboros-consensus, protocol, unstable-cardano-testlib, unstable-consensus-testlib, unstable-diffusion-testlib, unstable-mempool-test-utils}, ouroboros-network:{api, protocols, protocols-tests-lib}, @@ -1959,6 +1968,19 @@ test-suite tools-test other-modules: Test.Cardano.Tools.Headers +executable check-tx-upgrade + import: common-exe + hs-source-dirs: ouroboros-consensus-cardano/app + main-is: check-tx-upgrade.hs + build-depends: + base, + cardano-ledger-core, + containers, + microlens, + mtl, + ouroboros-consensus:{cardano, ouroboros-consensus}, + sop-core, + executable gen-header import: common-exe hs-source-dirs: ouroboros-consensus-cardano/app diff --git a/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs b/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs index c447c01390..be7e58180d 100644 --- a/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs +++ b/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs @@ -241,16 +241,18 @@ instance Ledger.LedgerSupportsMempool TestBlock where mkMempoolApplyTxError = Ledger.nothingMkMempoolApplyTxError instance Ledger.TxLimits TestBlock where - type TxMeasure TestBlock = Ledger.IgnoringOverflow Ledger.ByteSize32 + type TxMeasurePhase1 TestBlock = Ledger.IgnoringOverflow Ledger.ByteSize32 + type TxMeasurePhase2 TestBlock = Ledger.TrivialTxMeasurePhase2 txWireSize = fromIntegral . Ledger.unByteSize32 . txSize -- We tweaked this in such a way that we test the case in which we exceed the -- maximum mempool capacity. The value used here depends on 'txInBlockSize'. blockCapacityTxMeasure _cfg _st = - Ledger.IgnoringOverflow $ Ledger.ByteSize32 20 + Ledger.TxMeasure (Ledger.IgnoringOverflow $ Ledger.ByteSize32 20) Ledger.TrivialTxMeasurePhase2 - txMeasure _cfg _st = pure . Ledger.IgnoringOverflow . txSize + txMeasurePhase1 _cfg _st = pure . Ledger.IgnoringOverflow . txSize + txMeasurePhase2 _cfg _st _tx = pure Ledger.TrivialTxMeasurePhase2 newtype instance Ledger.TxId (Ledger.GenTx TestBlock) = TestBlockTxId Tx deriving stock Generic diff --git a/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs b/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs index 47fbe7fd30..e0fb14f398 100644 --- a/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs +++ b/ouroboros-consensus/src/ouroboros-consensus-lsm/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs @@ -62,8 +62,6 @@ import Data.ByteString (toStrict) import qualified Data.ByteString.Builder as BS import Data.ByteString.Char8 (readInt) import qualified Data.Foldable as Foldable -import Data.Functor.Contravariant ((>$<)) -import qualified Data.List as L import qualified Data.List as List import qualified Data.Map.Strict as Map import Data.Maybe @@ -1050,7 +1048,7 @@ hACK_GET_SALT_FROM_BLOOMFILTER :: m Salt hACK_GET_SALT_FROM_BLOOMFILTER gen (SomeHasFS fs) = do files <- listDirectory fs (mkFsPath []) - case L.find ((".filter" ==) . F.takeExtension) files of + case List.find ((".filter" ==) . F.takeExtension) files of Just f -> withFile fs (mkFsPath [f]) ReadMode $ \h -> do -- We read exactly 24 bytes diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto/BLS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto/BLS.hs index 6dadea7745..17a11caded 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto/BLS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Committee/Crypto/BLS.hs @@ -48,11 +48,13 @@ module Ouroboros.Consensus.Committee.Crypto.BLS import Cardano.Binary (FromCBOR, ToCBOR) import Cardano.Crypto.DSIGN ( BLS12381MinSigDSIGN - , BLS12381SignContext (..) + , BLS12381SignContext , DSIGNAggregatable (..) , DSIGNAlgorithm (..) , SigDSIGN (..) , VerKeyDSIGN (..) + , blsSignContextAug + , minSigPoPDST ) import Cardano.Crypto.EllipticCurve.BLS12_381 (blsIsInf, blsMSM) import qualified Cardano.Crypto.Hash as Hash @@ -171,42 +173,20 @@ newtype ProofOfPossession = ProofOfPossession deriving stock (Eq, Show) deriving newtype (FromCBOR, ToCBOR) --- TODO: get these contexts directly from @cardano-base@ after --- https://github.com/IntersectMBO/cardano-base/pull/635 --- is merged. - --- Basic over G1: --- https://www.ietf.org/archive/id/draft-irtf-cfrg-bls-signature-06.html#section-4.2.1-1 -minSigSignatureDST :: BLS12381SignContext -minSigSignatureDST = - BLS12381SignContext - { blsSignContextDst = Just "BLS_SIG_BLS12381G1_XMD:SHA-256_SSWU_RO_NUL_" - , blsSignContextAug = Nothing - } - --- PoP over G1: --- https://www.ietf.org/archive/id/draft-irtf-cfrg-bls-signature-06.html#section-4.2.3-1 -minSigPoPDST :: BLS12381SignContext -minSigPoPDST = - BLS12381SignContext - { blsSignContextDst = Just "BLS_SIG_BLS12381G1_XMD:SHA-256_SSWU_RO_POP_" - , blsSignContextAug = Nothing - } - -- | Role-separated BLS contexts for signatures class HasBLSContext (r :: KeyRole) where blsCtx :: Proxy r -> KeyScope -> BLS12381SignContext instance HasBLSContext SIGN where blsCtx _ keyScope = - minSigSignatureDST + minSigPoPDST { blsSignContextAug = Just ("VOTE:" <> keyScope <> ":V0") } instance HasBLSContext VRF where blsCtx _ keyScope = - minSigSignatureDST + minSigPoPDST { blsSignContextAug = Just ("VRF:" <> keyScope <> ":V0") } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs index 592723fe8c..821dfdab3c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/CanHardFork.hs @@ -61,11 +61,17 @@ class , KnownNat (HashSizeOfHead xs) , Typeable xs , IsNonEmpty xs - , Measure (HardForkTxMeasure xs) - , HasByteSize (HardForkTxMeasure xs) - , NoThunks (HardForkTxMeasure xs) - , Show (HardForkTxMeasure xs) - , TxMeasureMetrics (HardForkTxMeasure xs) + , -- \* Phase1 + Measure (HardForkTxMeasurePhase1 xs) + , HasByteSize (HardForkTxMeasurePhase1 xs) + , NoThunks (HardForkTxMeasurePhase1 xs) + , Show (HardForkTxMeasurePhase1 xs) + , TxMeasurePhase1Metrics (HardForkTxMeasurePhase1 xs) + , -- \* Phase2 + Measure (HardForkTxMeasurePhase2 xs) + , NoThunks (HardForkTxMeasurePhase2 xs) + , Show (HardForkTxMeasurePhase2 xs) + , TxMeasurePhase2Metrics (HardForkTxMeasurePhase2 xs) ) => CanHardFork xs where @@ -74,7 +80,9 @@ class -- Usually, this can simply be the union of the sets of components of each -- individual era's 'TxMeasure'. (Which is too awkward of a type to express -- in Haskell.) - type HardForkTxMeasure xs + type HardForkTxMeasurePhase1 xs + + type HardForkTxMeasurePhase2 xs hardForkEraTranslation :: EraTranslation xs hardForkChainSel :: Tails AcrossEraTiebreaker xs @@ -91,13 +99,17 @@ class -- If that's not possible, the result must not be too small, since this is -- relied upon to determine which prefix of the mempool's txs will fit in a -- valid block. - hardForkInjTxMeasure :: SOP.NS WrapTxMeasure xs -> HardForkTxMeasure xs + hardForkInjTxMeasurePhase1 :: SOP.NS WrapTxMeasurePhase1 xs -> HardForkTxMeasurePhase1 xs + + hardForkInjTxMeasurePhase2 :: SOP.NS WrapTxMeasurePhase2 xs -> HardForkTxMeasurePhase2 xs instance SingleEraBlock blk => CanHardFork '[blk] where - type HardForkTxMeasure '[blk] = TxMeasure blk + type HardForkTxMeasurePhase1 '[blk] = TxMeasurePhase1 blk + type HardForkTxMeasurePhase2 '[blk] = TxMeasurePhase2 blk hardForkEraTranslation = trivialEraTranslation hardForkChainSel = Tails.mk1 hardForkInjectTxs = InPairs.mk1 - hardForkInjTxMeasure (SOP.Z (WrapTxMeasure x)) = x + hardForkInjTxMeasurePhase1 (SOP.Z (WrapTxMeasurePhase1 x)) = x + hardForkInjTxMeasurePhase2 (SOP.Z (WrapTxMeasurePhase2 x)) = x diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs index 95d32f9d70..febf7a3b4a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs @@ -59,6 +59,7 @@ module Ouroboros.Consensus.HardFork.Combinator.AcrossEras -- * Utility , getSameValue , oneEraBlockHeader + , oneEraGenTxIdRawHash ) where import Cardano.Binary (FromCBOR (..), ToCBOR (..)) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs index 08d35dbbd8..14946405e4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Mempool.hs @@ -26,6 +26,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Mempool import Control.Arrow ((+++)) import Control.Monad.Except +import Data.ByteString.Short (ShortByteString) import Data.Functor.Identity import Data.Functor.Product import Data.Kind (Type) @@ -55,6 +56,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util +import Ouroboros.Network.Tx (HasRawTxId (..)) data HardForkApplyTxErr xs = -- | Validation error from one of the eras @@ -320,7 +322,8 @@ instance K $ injectApplyTxErr idx <$> mkMempoolApplyTxError tlst txt instance CanHardFork xs => TxLimits (HardForkBlock xs) where - type TxMeasure (HardForkBlock xs) = HardForkTxMeasure xs + type TxMeasurePhase1 (HardForkBlock xs) = HardForkTxMeasurePhase1 xs + type TxMeasurePhase2 (HardForkBlock xs) = HardForkTxMeasurePhase2 xs txWireSize = \tx -> @@ -354,15 +357,63 @@ instance CanHardFork xs => TxLimits (HardForkBlock xs) where Index xs blk -> WrapPartialLedgerConfig blk -> FlipTickedLedgerState mk blk -> - K (HardForkTxMeasure xs) blk + K (TxMeasure (HardForkBlock xs)) blk aux idx pcfg st' = K $ - hardForkInjTxMeasure . injectNS idx . WrapTxMeasure $ - blockCapacityTxMeasure - (completeLedgerConfig' ei pcfg) - (getFlipTickedLedgerState st') + let TxMeasure p1 p2 = + blockCapacityTxMeasure + (completeLedgerConfig' ei pcfg) + (getFlipTickedLedgerState st') + in TxMeasure + (hardForkInjTxMeasurePhase1 . injectNS idx $ WrapTxMeasurePhase1 p1) + (hardForkInjTxMeasurePhase2 . injectNS idx $ WrapTxMeasurePhase2 p2) + + txMeasurePhase1 + HardForkLedgerConfig{..} + (TickedHardForkLedgerState transition hardForkState) + tx = + case matchTx injs (unwrapTx tx) hardForkState of + Left{} -> pure Measure.zero -- safe b/c the tx will be found invalid + Right pair -> hcollapse $ hcizipWith proxySingle aux cfgs pair + where + pcfgs = getPerEraLedgerConfig hardForkLedgerConfigPerEra + ei = + State.epochInfoPrecomputedTransitionInfo + hardForkLedgerConfigShape + transition + hardForkState + cfgs = hcmap proxySingle (completeLedgerConfig'' ei) pcfgs + + unwrapTx = getOneEraGenTx . getHardForkGenTx + + injs :: InPairs (InjectPolyTx GenTx) xs + injs = + InPairs.hmap (\(Pair2 injTx _injValidatedTx) -> injTx) $ + InPairs.requiringBoth cfgs hardForkInjectTxs + + aux :: + forall blk. + SingleEraBlock blk => + Index xs blk -> + WrapLedgerConfig blk -> + (Product GenTx (FlipTickedLedgerState EmptyMK)) blk -> + K (Except (HardForkApplyTxErr xs) (HardForkTxMeasurePhase1 xs)) blk + aux idx cfg (Pair tx' st') = + K + $ mapExcept + ( ( HardForkApplyTxErrFromEra + . OneEraApplyTxErr + . injectNS idx + . WrapApplyTxErr + ) + +++ (hardForkInjTxMeasurePhase1 . injectNS idx . WrapTxMeasurePhase1) + ) + $ txMeasurePhase1 + (unwrapLedgerConfig cfg) + (getFlipTickedLedgerState st') + tx' - txMeasure + txMeasurePhase2 HardForkLedgerConfig{..} (TickedHardForkLedgerState transition hardForkState) tx = @@ -391,7 +442,7 @@ instance CanHardFork xs => TxLimits (HardForkBlock xs) where Index xs blk -> WrapLedgerConfig blk -> (Product GenTx (FlipTickedLedgerState ValuesMK)) blk -> - K (Except (HardForkApplyTxErr xs) (HardForkTxMeasure xs)) blk + K (Except (HardForkApplyTxErr xs) (HardForkTxMeasurePhase2 xs)) blk aux idx cfg (Pair tx' st') = K $ mapExcept @@ -400,9 +451,9 @@ instance CanHardFork xs => TxLimits (HardForkBlock xs) where . injectNS idx . WrapApplyTxErr ) - +++ (hardForkInjTxMeasure . injectNS idx . WrapTxMeasure) + +++ (hardForkInjTxMeasurePhase2 . injectNS idx . WrapTxMeasurePhase2) ) - $ txMeasure + $ txMeasurePhase2 (unwrapLedgerConfig cfg) (getFlipTickedLedgerState st') tx' @@ -565,6 +616,10 @@ instance CanHardFork xs => HasTxId (GenTx (HardForkBlock xs)) where . getOneEraGenTx . getHardForkGenTx +instance CanHardFork xs => HasRawTxId (TxId (GenTx (HardForkBlock xs))) where + type RawTxId (TxId (GenTx (HardForkBlock xs))) = ShortByteString + getRawTxId = oneEraGenTxIdRawHash . getHardForkGenTxId + {------------------------------------------------------------------------------- HasTxs diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs index a75ab17479..ef30a6702b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs @@ -96,6 +96,7 @@ import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util (ShowProxy (..)) import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.IndexedMemPack +import Ouroboros.Network.Tx (HasRawTxId (..)) {------------------------------------------------------------------------------- Block @@ -733,18 +734,26 @@ instance Bridge m a => LedgerSupportsMempool (DualBlock m a) where Just $ DualGenTxErr x y instance Bridge m a => TxLimits (DualBlock m a) where - type TxMeasure (DualBlock m a) = TxMeasure m + type TxMeasurePhase1 (DualBlock m a) = TxMeasurePhase1 m + type TxMeasurePhase2 (DualBlock m a) = TxMeasurePhase2 m txWireSize = txWireSize . dualGenTxMain - txMeasure DualLedgerConfig{..} TickedDualLedgerState{..} DualGenTx{..} = + txMeasurePhase1 DualLedgerConfig{..} TickedDualLedgerState{..} DualGenTx{..} = do mapExcept (inj +++ id) - $ txMeasure dualLedgerConfigMain tickedDualLedgerStateMain dualGenTxMain + $ txMeasurePhase1 dualLedgerConfigMain tickedDualLedgerStateMain dualGenTxMain + where + inj m = DualGenTxErr m (error "ByronSpec has no tx-too-big error") + txMeasurePhase2 DualLedgerConfig{..} TickedDualLedgerState{..} DualGenTx{..} = + do + mapExcept (inj +++ id) + $ txMeasurePhase2 dualLedgerConfigMain tickedDualLedgerStateMain dualGenTxMain where inj m = DualGenTxErr m (error "ByronSpec has no tx-too-big error") blockCapacityTxMeasure DualLedgerConfig{..} TickedDualLedgerState{..} = - blockCapacityTxMeasure dualLedgerConfigMain tickedDualLedgerStateMain + let TxMeasure a b = blockCapacityTxMeasure dualLedgerConfigMain tickedDualLedgerStateMain + in TxMeasure a b -- We don't need a pair of IDs, as long as we can unique ID the transaction newtype instance TxId (GenTx (DualBlock m a)) = DualGenTxId @@ -759,6 +768,10 @@ instance instance Bridge m a => HasTxId (GenTx (DualBlock m a)) where txId = DualGenTxId . txId . dualGenTxMain +instance HasRawTxId (GenTxId m) => HasRawTxId (TxId (GenTx (DualBlock m a))) where + type RawTxId (TxId (GenTx (DualBlock m a))) = RawTxId (GenTxId m) + getRawTxId = getRawTxId . dualGenTxIdMain + deriving instance Bridge m a => Show (GenTx (DualBlock m a)) deriving instance Bridge m a => Show (Validated (GenTx (DualBlock m a))) deriving instance Bridge m a => Show (DualGenTxErr m a) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs index cff4102366..2061930913 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs @@ -1,13 +1,17 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeData #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Ledger.SupportsMempool ( ApplyTxErr @@ -26,7 +30,10 @@ module Ouroboros.Consensus.Ledger.SupportsMempool , ReapplyTxsResult (..) , TxId , TxLimits (..) - , TxMeasureMetrics (..) + , TxMeasure (..) + , TxMeasurePhase1Metrics (..) + , TxMeasurePhase2Metrics (..) + , TrivialTxMeasurePhase2 (..) , Validated , WhetherToIntervene (..) , nothingMkMempoolApplyTxError @@ -41,9 +48,10 @@ import Data.DerivingVia (InstantiatedAt (..)) import qualified Data.Foldable as Foldable import Data.Kind (Type) import Data.Measure (Measure) -import qualified Data.Measure +import qualified Data.Measure as M import Data.Text (Text) import Data.Word (Word32) +import GHC.Generics import GHC.Stack (HasCallStack) import NoThunks.Class import Numeric.Natural @@ -305,6 +313,48 @@ class HasTxs blk where Tx sizes -------------------------------------------------------------------------------} +data TxMeasure blk = TxMeasure + { tmPhase1 :: !(TxMeasurePhase1 blk) + , tmPhase2 :: !(TxMeasurePhase2 blk) + } + deriving Generic + +deriving instance (Eq (TxMeasurePhase1 blk), Eq (TxMeasurePhase2 blk)) => Eq (TxMeasure blk) + +deriving instance (Show (TxMeasurePhase1 blk), Show (TxMeasurePhase2 blk)) => Show (TxMeasure blk) + +deriving via + InstantiatedAt Generic (TxMeasure blk) + instance + (Measure (TxMeasurePhase1 blk), Measure (TxMeasurePhase2 blk)) => + Measure (TxMeasure blk) + +instance HasByteSize (TxMeasurePhase1 blk) => HasByteSize (TxMeasure blk) where + txMeasureByteSize = txMeasureByteSize . tmPhase1 + +instance (NoThunks (TxMeasurePhase1 blk), NoThunks (TxMeasurePhase2 blk)) => NoThunks (TxMeasure blk) + +instance TxMeasurePhase1Metrics (TxMeasurePhase1 blk) => TxMeasurePhase1Metrics (TxMeasure blk) where + txMeasureMetricTxSizeBytes (TxMeasure a _) = txMeasureMetricTxSizeBytes a + txMeasureMetricExUnitsMemory (TxMeasure a _) = txMeasureMetricExUnitsMemory a + txMeasureMetricExUnitsSteps (TxMeasure a _) = txMeasureMetricExUnitsSteps a + +instance TxMeasurePhase2Metrics (TxMeasurePhase2 blk) => TxMeasurePhase2Metrics (TxMeasure blk) where + txMeasureMetricRefScriptsSizeBytes (TxMeasure _ b) = txMeasureMetricRefScriptsSizeBytes b + +data TrivialTxMeasurePhase2 = TrivialTxMeasurePhase2 + deriving (Eq, Show, Generic) + deriving anyclass NoThunks + +instance Measure TrivialTxMeasurePhase2 where + zero = TrivialTxMeasurePhase2 + plus _ _ = TrivialTxMeasurePhase2 + max _ _ = TrivialTxMeasurePhase2 + min _ _ = TrivialTxMeasurePhase2 + +instance TxMeasurePhase2Metrics TrivialTxMeasurePhase2 where + txMeasureMetricRefScriptsSizeBytes _ = mempty + -- | Each block has its limits of how many transactions it can hold. That limit -- is compared against the sum of measurements taken of each of the -- transactions in that block. @@ -319,16 +369,24 @@ class HasTxs blk where -- execution units). For details please see the individual instances for the -- TxLimits. class - ( Measure (TxMeasure blk) - , HasByteSize (TxMeasure blk) - , NoThunks (TxMeasure blk) - , TxMeasureMetrics (TxMeasure blk) - , Show (TxMeasure blk) + ( -- \* Phase 1 + Measure (TxMeasurePhase1 blk) + , HasByteSize (TxMeasurePhase1 blk) + , NoThunks (TxMeasurePhase1 blk) + , TxMeasurePhase1Metrics (TxMeasurePhase1 blk) + , Show (TxMeasurePhase1 blk) + , -- \* Phase 2 + Measure (TxMeasurePhase2 blk) + , NoThunks (TxMeasurePhase2 blk) + , TxMeasurePhase2Metrics (TxMeasurePhase2 blk) + , Show (TxMeasurePhase2 blk) ) => TxLimits blk where -- | The (possibly multi-dimensional) size of a transaction in a block. - type TxMeasure blk + type TxMeasurePhase1 blk + + type TxMeasurePhase2 blk -- | The size of the transaction from the perspective of diffusion layer txWireSize :: GenTx blk -> Network.SizeInBytes @@ -362,14 +420,23 @@ class -- -- Returns an exception if and only if the transaction violates the per-tx -- limits. - txMeasure :: + txMeasurePhase1 :: + -- | used at least by HFC's composition logic + LedgerConfig blk -> + -- | This state needs values as a transaction measure might depend on + -- those. For example in Cardano they look at the reference scripts. + TickedLedgerState blk EmptyMK -> + GenTx blk -> + Except (ApplyTxErr blk) (TxMeasurePhase1 blk) + + txMeasurePhase2 :: -- | used at least by HFC's composition logic LedgerConfig blk -> -- | This state needs values as a transaction measure might depend on -- those. For example in Cardano they look at the reference scripts. TickedLedgerState blk ValuesMK -> GenTx blk -> - Except (ApplyTxErr blk) (TxMeasure blk) + Except (ApplyTxErr blk) (TxMeasurePhase2 blk) -- | What is the allowed capacity for the txs in an individual block? blockCapacityTxMeasure :: @@ -428,7 +495,7 @@ newtype IgnoringOverflow a = IgnoringOverflow {unIgnoringOverflow :: a} deriving newtype (Monoid, Semigroup) deriving newtype NoThunks deriving newtype HasByteSize - deriving newtype TxMeasureMetrics + deriving newtype TxMeasurePhase1Metrics instance Measure (IgnoringOverflow ByteSize32) where zero = coerce (0 :: Word32) @@ -443,17 +510,21 @@ class HasByteSize a where instance HasByteSize ByteSize32 where txMeasureByteSize = id -class TxMeasureMetrics msr where +class TxMeasurePhase1Metrics msr where txMeasureMetricTxSizeBytes :: msr -> ByteSize32 txMeasureMetricExUnitsMemory :: msr -> Natural txMeasureMetricExUnitsSteps :: msr -> Natural + +class TxMeasurePhase2Metrics msr where txMeasureMetricRefScriptsSizeBytes :: msr -> ByteSize32 -instance TxMeasureMetrics ByteSize32 where +instance TxMeasurePhase2Metrics () where + txMeasureMetricRefScriptsSizeBytes () = mempty + +instance TxMeasurePhase1Metrics ByteSize32 where txMeasureMetricTxSizeBytes = id txMeasureMetricExUnitsMemory _ = 0 txMeasureMetricExUnitsSteps _ = 0 - txMeasureMetricRefScriptsSizeBytes _ = mempty -- | A transaction that was previously valid. Used to clarify the types on the -- 'reapplyTxs' function. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs index f80457bdec..48f4ab477e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs @@ -4,6 +4,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} @@ -495,10 +496,12 @@ instance Measure (TxMeasure blk) => Measure (TxMeasureWithDiffTime blk) where instance HasByteSize (TxMeasure blk) => HasByteSize (TxMeasureWithDiffTime blk) where txMeasureByteSize = txMeasureByteSize . forgetTxMeasureWithDiffTime -instance TxMeasureMetrics (TxMeasure blk) => TxMeasureMetrics (TxMeasureWithDiffTime blk) where +instance TxMeasurePhase1Metrics (TxMeasure blk) => TxMeasurePhase1Metrics (TxMeasureWithDiffTime blk) where txMeasureMetricTxSizeBytes = txMeasureMetricTxSizeBytes . forgetTxMeasureWithDiffTime txMeasureMetricExUnitsMemory = txMeasureMetricExUnitsMemory . forgetTxMeasureWithDiffTime txMeasureMetricExUnitsSteps = txMeasureMetricExUnitsSteps . forgetTxMeasureWithDiffTime + +instance TxMeasurePhase2Metrics (TxMeasure blk) => TxMeasurePhase2Metrics (TxMeasureWithDiffTime blk) where txMeasureMetricRefScriptsSizeBytes = txMeasureMetricRefScriptsSizeBytes . forgetTxMeasureWithDiffTime -- | How long it took to validate a valid tx diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs index bfcec21e3f..f00da78485 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs @@ -175,7 +175,8 @@ deriving instance , NoThunks (TickedLedgerState blk DiffMK) , NoThunks (TxIn blk) , NoThunks (TxOut blk) - , NoThunks (TxMeasure blk) + , NoThunks (TxMeasurePhase1 blk) + , NoThunks (TxMeasurePhase2 blk) , StandardHash blk , Typeable blk ) => diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs index f441e1b73d..3bfff57ad3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs @@ -17,7 +17,6 @@ import Control.Monad.Class.MonadTimer.SI (MonadTimer, timeout) import Control.Monad.Except (runExcept) import Control.Tracer import qualified Data.Foldable as Foldable -import Data.Functor.Contravariant ((>$<)) import Data.Functor.Identity (Identity (Identity)) import Data.Kind (Type) import qualified Data.List.NonEmpty as NE @@ -28,7 +27,7 @@ import qualified Data.Text as T import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool -import Ouroboros.Consensus.Ledger.Tables.Utils (emptyLedgerTables) +import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Mempool.API import Ouroboros.Consensus.Mempool.Capacity import Ouroboros.Consensus.Mempool.Impl.Common @@ -204,86 +203,116 @@ doAddTx mpEnv caller wti tx = do Just prevSize -> check $ isMempoolSize is /= prevSize eRes <- withTMVarAnd istate additionalCheck $ - \is () -> do - frkr <- readMVar forker - tbs <- roforkerReadTables frkr (getTransactionKeySets tx) - before <- getMonotonicTime - mbX <- do - let f m = case mbToCfg of - Nothing -> Just <$> m - Just toCfg -> timeout (mempoolTimeoutHard toCfg) m - f $ do - x <- evaluate $ pureTryAddTx mpEnv cfg wti tx is tbs - case (caller, x) of - (TestingAddTx testDiffTime, Processed{}) -> do - after <- getMonotonicTime - let sofar = after `diffTime` before - threadDelay $ testDiffTime - min testDiffTime sofar - -- Note that @sofar == 0@ always and this 'threadDelay' would - -- be perfectly precise in the @IOSim@ monad. Unfortunately, - -- the state machines tests are still only in IO. - _ -> pure () - pure x - dur <- do - -- Note that both the hard 'timeout' and the soft duration check use - -- the actual monotonic clock measurements instead of simply - -- deferring to 'TestingAddTx'. This means the test will fail if the - -- 'timeout' and the monotonic clock measurement primitives are not - -- as precise as the test expects (recall that the test suite chooses - -- intended validation times that are not "too close" to the - -- thresholds). - after <- getMonotonicTime - pure $ after `diffTime` before - let rejectBecauseOfTimeoutSoft txerr = do - let outcome = - TransactionProcessingResult + \is () -> + case runExcept $ txMeasurePhase1 cfg (forgetLedgerTables $ isLedgerState is) tx of + Left err -> + -- The transaction does not have a valid measure (eg its ExUnits is + -- greater than what this ledger state allows for a single transaction). + pure + ( Right + ( TransactionProcessingResult Nothing - (MempoolTxRejected tx txerr) - $ TraceMempoolRejectedTx - tx - txerr - (MempoolRejectedByTimeoutSoft dur) - (isMempoolSize is) - pure (Right outcome, is) - mbTimeoutSoftTxErr = - -- This @txerr@ is not available in historical Cardano eras, but - -- it is starting from Conway. So this rejection will be disabled - -- prior to Conway. Which is irrelevant, since mainnet is already - -- in Conway. - let txt = T.pack $ "MempoolTxTooSlow (" <> show dur <> ") " <> show (txId tx) - in mkMempoolApplyTxError (isLedgerState is) txt - case mbX of - Nothing -> case (wti, mbTimeoutSoftTxErr) of - (Intervene, Just txerr) -> do - rejectBecauseOfTimeoutSoft txerr - _ -> do - -- Either they're not a local client or the era doesn't allow for - -- soft rejections. - throwIO $ MkExnMempoolTimeout dur tx - Just _ - | Just toCfg <- mbToCfg - , dur > mempoolTimeoutSoft toCfg - , Just txerr <- mbTimeoutSoftTxErr -> do - rejectBecauseOfTimeoutSoft txerr - Just NotEnoughSpaceLeft -> do - pure (Left (isMempoolSize is), is) - Just (NotProcessed outcome) -> do - let TransactionProcessingResult is' _ _ = outcome - pure (Right outcome, fromMaybe is is') - Just (Processed mkResult) -> do - let outcome = mkResult $ FiniteDiffTimeMeasure $ case caller of - ProductionAddTx -> dur - TestingAddTx testDiffTime -> - -- For the sake of an accurate cumulative measure, pretend - -- the tx took exactly as long to validate as the test - -- suite intended. - -- - -- Note that @testDiffTime == dur@ always in @IOSim@. - -- Unfortunately, the state machines tests are still only - -- in IO. - testDiffTime - TransactionProcessingResult is' _ _ = outcome - pure (Right outcome, fromMaybe is is') + (MempoolTxRejected tx err) + ( TraceMempoolRejectedTx + tx + err + MempoolRejectedByLedger + (isMempoolSize is) + ) + ) + , is + ) + Right txsz1 + | let currentSize = TxSeq.toSize (isTxs is) + , not $ + currentSize + Measure.<= currentSize + `Measure.plus` MkTxMeasureWithDiffTime (TxMeasure txsz1 Measure.zero) Measure.zero -> + pure (Left (isMempoolSize is), is) + | let currentSize = TxSeq.toSize (isTxs is) + , let MkTxMeasureWithDiffTime txssz _txsdifftime = currentSize + , not $ txssz `Measure.plus` (TxMeasure txsz1 Measure.zero) Measure.<= isCapacity is -> + pure (Left (isMempoolSize is), is) + | otherwise -> do + frkr <- readMVar forker + tbs <- roforkerReadTables frkr (getTransactionKeySets tx) + before <- getMonotonicTime + mbX <- do + let f m = case mbToCfg of + Nothing -> Just <$> m + Just toCfg -> timeout (mempoolTimeoutHard toCfg) m + f $ do + x <- evaluate $ pureTryAddTx mpEnv cfg wti tx is tbs txsz1 + case (caller, x) of + (TestingAddTx testDiffTime, Processed{}) -> do + after <- getMonotonicTime + let sofar = after `diffTime` before + threadDelay $ testDiffTime - min testDiffTime sofar + -- Note that @sofar == 0@ always and this 'threadDelay' would + -- be perfectly precise in the @IOSim@ monad. Unfortunately, + -- the state machines tests are still only in IO. + _ -> pure () + pure x + dur <- do + -- Note that both the hard 'timeout' and the soft duration check use + -- the actual monotonic clock measurements instead of simply + -- deferring to 'TestingAddTx'. This means the test will fail if the + -- 'timeout' and the monotonic clock measurement primitives are not + -- as precise as the test expects (recall that the test suite chooses + -- intended validation times that are not "too close" to the + -- thresholds). + after <- getMonotonicTime + pure $ after `diffTime` before + let rejectBecauseOfTimeoutSoft txerr = do + let outcome = + TransactionProcessingResult + Nothing + (MempoolTxRejected tx txerr) + $ TraceMempoolRejectedTx + tx + txerr + (MempoolRejectedByTimeoutSoft dur) + (isMempoolSize is) + pure (Right outcome, is) + mbTimeoutSoftTxErr = + -- This @txerr@ is not available in historical Cardano eras, but + -- it is starting from Conway. So this rejection will be disabled + -- prior to Conway. Which is irrelevant, since mainnet is already + -- in Conway. + let txt = T.pack $ "MempoolTxTooSlow (" <> show dur <> ") " <> show (txId tx) + in mkMempoolApplyTxError (isLedgerState is) txt + case mbX of + Nothing -> case (wti, mbTimeoutSoftTxErr) of + (Intervene, Just txerr) -> do + rejectBecauseOfTimeoutSoft txerr + _ -> do + -- Either they're not a local client or the era doesn't allow for + -- soft rejections. + throwIO $ MkExnMempoolTimeout dur tx + Just _ + | Just toCfg <- mbToCfg + , dur > mempoolTimeoutSoft toCfg + , Just txerr <- mbTimeoutSoftTxErr -> do + rejectBecauseOfTimeoutSoft txerr + Just NotEnoughSpaceLeft -> do + pure (Left (isMempoolSize is), is) + Just (NotProcessed outcome) -> do + let TransactionProcessingResult is' _ _ = outcome + pure (Right outcome, fromMaybe is is') + Just (Processed mkResult) -> do + let outcome = mkResult $ FiniteDiffTimeMeasure $ case caller of + ProductionAddTx -> dur + TestingAddTx testDiffTime -> + -- For the sake of an accurate cumulative measure, pretend + -- the tx took exactly as long to validate as the test + -- suite intended. + -- + -- Note that @testDiffTime == dur@ always in @IOSim@. + -- Unfortunately, the state machines tests are still only + -- in IO. + testDiffTime + TransactionProcessingResult is' _ _ = outcome + pure (Right outcome, fromMaybe is is') case (caller, eRes) of (ProductionAddTx, _) -> either (doAddTx' . Just) (pure . Identity) eRes (TestingAddTx _, Left _) -> pure Nothing @@ -302,8 +331,9 @@ pureTryAddTx :: -- | The current internal state of the mempool. InternalState blk -> LedgerTables blk ValuesMK -> + TxMeasurePhase1 blk -> TriedToAddTx blk -pureTryAddTx mpEnv cfg wti tx is values = +pureTryAddTx mpEnv cfg wti tx is values p1TxMeasure = let MempoolEnv { mpEnvTimeoutConfig = mbToCfg } = mpEnv @@ -313,7 +343,7 @@ pureTryAddTx mpEnv cfg wti tx is values = values (getTransactionKeySets tx) (isLedgerState is) - in case runExcept $ txMeasure cfg st tx of + in case runExcept $ txMeasurePhase2 cfg st tx of Left err -> -- The transaction does not have a valid measure (eg its ExUnits is -- greater than what this ledger state allows for a single transaction). @@ -348,7 +378,10 @@ pureTryAddTx mpEnv cfg wti tx is values = -- 'isCapacity' are much smaller than the modulus, and so this should -- never happen. Despite that, blocking until adding the transaction -- doesn't overflow seems like a reasonable way to handle this case. - | not $ currentSize Measure.<= currentSize `Measure.plus` MkTxMeasureWithDiffTime txsz Measure.zero -> + | not $ + currentSize + Measure.<= currentSize + `Measure.plus` MkTxMeasureWithDiffTime (TxMeasure p1TxMeasure txsz) Measure.zero -> NotEnoughSpaceLeft -- We add the transaction if and only if it wouldn't overrun any component -- of the mempool capacity. @@ -385,14 +418,14 @@ pureTryAddTx mpEnv cfg wti tx is values = -- tx that wouldn't even fit in an empty mempool would be rejected by -- 'txMeasure'. | let MkTxMeasureWithDiffTime txssz _txsdifftime = currentSize - , not $ txssz `Measure.plus` txsz Measure.<= isCapacity is -> + , not $ txssz `Measure.plus` (TxMeasure p1TxMeasure txsz) Measure.<= isCapacity is -> NotEnoughSpaceLeft | Just toCfg <- mbToCfg , let MkTxMeasureWithDiffTime _txssz txsdifftime = currentSize , not $ txsdifftime Measure.<= FiniteDiffTimeMeasure (mempoolTimeoutCapacity toCfg) -> NotEnoughSpaceLeft | otherwise -> - case validateNewTransaction cfg wti tx txsz values st is of + case validateNewTransaction cfg wti tx (TxMeasure p1TxMeasure txsz) values st is of (Left err, _) -> Processed $ \_dur -> TransactionProcessingResult diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs index 48dbbffd75..ce008f0d7d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs @@ -106,7 +106,7 @@ localTxMonitorServer mempool = tno (_a, b, _c) = b :: TicketNo mkMeasuresMap :: - TxMeasureMetrics (TxMeasure blk) => + (TxMeasurePhase1Metrics (TxMeasurePhase1 blk), TxMeasurePhase2Metrics (TxMeasurePhase2 blk)) => Proxy blk -> TxMeasure blk -> TxMeasure blk -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs index bbe02cd7ad..60879daaed 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs @@ -45,6 +45,7 @@ import Ouroboros.Consensus.Storage.LedgerDB import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util (ShowProxy) import Ouroboros.Network.Block (Serialised) +import Ouroboros.Network.Tx (HasRawTxId) {------------------------------------------------------------------------------- RunNode proper @@ -96,6 +97,7 @@ class , HasHardForkHistory blk , LedgerSupportsMempool blk , HasTxId (GenTx blk) + , HasRawTxId (TxId (GenTx blk)) , BlockSupportsLedgerQuery blk , SupportedNetworkProtocolVersion blk , ConfigSupportsNode blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs index aa23a44e10..25818538a6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Crypto/BLS.hs @@ -84,7 +84,7 @@ type instance PublicKey PerasBLSCrypto = PerasPublicKey -- | Hash the message of a Peras vote -- -- NOTE: this is inspired by the implementation used by the Praos VRF check in --- 'Ouroboros.Consensus.Protocol.Praos.VRF.mkInputVRF'. +-- 'Cardano.Protocol.Praos.VRF.mkInputVRF'. hashVoteSignature :: ElectionId PerasBLSCrypto -> VoteCandidate PerasBLSCrypto -> @@ -117,7 +117,7 @@ hashVoteSignature roundNo boostedBlock = -- | Hash the input for the VRF used in Peras elections -- -- NOTE: this is inspired by the implementation used by the Praos VRF check in --- 'Ouroboros.Consensus.Protocol.Praos.VRF.mkInputVRF'. +-- 'Cardano.Protocol.Praos.VRF.mkInputVRF'. hashVRFInput :: ElectionId PerasBLSCrypto -> Nonce -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index f7ef29105f..a78974d6a9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -48,7 +48,6 @@ import Control.ResourceRegistry ) import Control.Tracer import Data.Functor ((<&>)) -import Data.Functor.Contravariant ((>$<)) import qualified Data.Map.Strict as Map import Data.Maybe.Strict (StrictMaybe (..)) import GHC.Stack (HasCallStack) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs index 3828af1bf8..af2c216c17 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs @@ -16,9 +16,8 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Args ) where import Control.ResourceRegistry (ResourceRegistry) -import Control.Tracer (Tracer, nullTracer) +import Control.Tracer (Tracer, nullTracer, (>$<)) import Data.Function ((&)) -import Data.Functor.Contravariant ((>$<)) import Data.Kind import Data.Time.Clock (secondsToDiffTime) import Ouroboros.Consensus.Block @@ -241,6 +240,7 @@ completeChainDbArgs } updateTracer :: + Monad m => Tracer m (TraceEvent blk) -> ChainDbArgs f m blk -> ChainDbArgs f m blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs index c81520ac0e..b63f86a1a6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs @@ -621,4 +621,4 @@ addBlockRunner fuse cdb@CDB{..} = forever $ do lift $ atomically $ processedChainSelMessage cdbChainSelQueue message ) where - starvationTracer = Tracer $ traceWith cdbTracer . TraceChainSelStarvationEvent + starvationTracer = mkTracer $ traceWith cdbTracer . TraceChainSelStarvationEvent diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index e77b1d68ac..30499356d1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -35,10 +35,9 @@ import Control.Monad.Except () import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Control.Monad.Trans.State.Strict -import Control.Tracer (Tracer, nullTracer, traceWith) +import Control.Tracer (Tracer, nullTracer, traceWith, (>$<)) import Data.Bifunctor (first) import Data.Function (on) -import Data.Functor.Contravariant ((>$<)) import Data.List (sortBy) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Iterator.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Iterator.hs index 6ce87b0cb6..ebaad5463d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Iterator.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Iterator.hs @@ -225,7 +225,7 @@ data IteratorEnv m blk = IteratorEnv } -- | Obtain an 'IteratorEnv' from a 'ChainDbEnv'. -fromChainDbEnv :: ChainDbEnv m blk -> IteratorEnv m blk +fromChainDbEnv :: Monad m => ChainDbEnv m blk -> IteratorEnv m blk fromChainDbEnv CDB{..} = IteratorEnv { itImmutableDB = cdbImmutableDB diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs index c96f284bed..3d5b271e7f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs @@ -165,7 +165,7 @@ data ImmutableDbArgs f m blk = ImmutableDbArgs -- only the most recent chunk? -- | Default arguments -defaultArgs :: Applicative m => Incomplete ImmutableDbArgs m blk +defaultArgs :: Monad m => Incomplete ImmutableDbArgs m blk defaultArgs = ImmutableDbArgs { immCacheConfig = cacheConfig diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs index a43b34d77a..c88b01f9d6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs @@ -17,7 +17,7 @@ module Ouroboros.Consensus.Storage.LedgerDB import Control.Monad.Trans.Class import Control.ResourceRegistry -import Data.Functor.Contravariant ((>$<)) +import Control.Tracer ((>$<)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Abstract diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs index 89f9430636..070dc632a8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/API.hs @@ -226,7 +226,6 @@ import Codec.Serialise import Control.Monad.Except import Control.Tracer import Data.ByteString (ByteString) -import Data.Functor.Contravariant ((>$<)) import Data.Kind import Data.List.NonEmpty (NonEmpty) import Data.MemPack @@ -708,6 +707,7 @@ data TraceReplayEvent blk -- | Add the tip of the Immutable DB to the trace event decorateReplayTracerWithGoal :: + Monad m => -- | Tip of the ImmutableDB Point blk -> Tracer m (TraceReplayProgressEvent blk) -> @@ -716,6 +716,7 @@ decorateReplayTracerWithGoal immTip = (($ ReplayGoal immTip) >$<) -- | Add the block at which a replay started. decorateReplayTracerWithStart :: + Monad m => -- | Starting point of the replay Point blk -> Tracer m (ReplayGoal blk -> TraceReplayProgressEvent blk) -> diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs index 3536bc5681..2a99cea7f6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Args.hs @@ -62,7 +62,7 @@ data LedgerDbArgs f m blk = LedgerDbArgs -- | Default arguments defaultArgs :: - Applicative m => + Monad m => V2.SomeBackendArgs m blk -> Incomplete LedgerDbArgs m blk defaultArgs backendArgs = diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs index 20aca78c5c..938ccb925c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2.hs @@ -23,7 +23,6 @@ import Data.Bifunctor (first) import Data.Containers.ListUtils (nubOrd) import Data.Foldable (for_) import qualified Data.Foldable as Foldable -import Data.Functor.Contravariant ((>$<)) import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs index e21cb1e623..6ed1f8fa04 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs @@ -22,7 +22,6 @@ import Control.Exception import Control.Monad (when) import Control.RAWLock (RAWLock, withWriteAccess) import Control.Tracer -import Data.Functor.Contravariant ((>$<)) import Data.Maybe (fromMaybe) import GHC.Generics import Ouroboros.Consensus.Block diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs index cab8fc5997..aa5b2d6b6f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs @@ -38,7 +38,6 @@ import Control.Tracer import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Builder.Extra (defaultChunkSize) -import Data.Functor.Contravariant ((>$<)) import Data.Functor.Identity import qualified Data.List as List import qualified Data.Map.Strict as Map diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs index 2a859ffd57..7bf1426f66 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasCertDB/Impl.hs @@ -123,7 +123,7 @@ data PerasCertDbArgs f m blk = PerasCertDbArgs { pcdbaTracer :: Tracer m (TraceEvent blk) } -defaultArgs :: Applicative m => Incomplete PerasCertDbArgs m blk +defaultArgs :: Monad m => Incomplete PerasCertDbArgs m blk defaultArgs = PerasCertDbArgs { pcdbaTracer = nullTracer diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs index 7f5fce1611..0dec8d0703 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/PerasVoteDB/Impl.hs @@ -127,7 +127,7 @@ data PerasVoteDbArgs f m blk = PerasVoteDbArgs , pvdbaPerasCfg :: HKD f (PerasCfg blk) } -defaultArgs :: Applicative m => Incomplete PerasVoteDbArgs m blk +defaultArgs :: Monad m => Incomplete PerasVoteDbArgs m blk defaultArgs = PerasVoteDbArgs { pvdbaTracer = nullTracer diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs index 25453618e9..99838dbcbb 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs @@ -177,7 +177,7 @@ data VolatileDbArgs f m blk = VolatileDbArgs -- corrupt/invalid block? -- | Default arguments -defaultArgs :: Applicative m => Incomplete VolatileDbArgs m blk +defaultArgs :: Monad m => Incomplete VolatileDbArgs m blk defaultArgs = VolatileDbArgs { volCheckIntegrity = noDefault diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs index dc958e806c..2266b26ed8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/TypeFamilyWrappers.hs @@ -23,7 +23,8 @@ module Ouroboros.Consensus.TypeFamilyWrappers , WrapTentativeHeaderView (..) , WrapTipInfo (..) , WrapTxIn (..) - , WrapTxMeasure (..) + , WrapTxMeasurePhase1 (..) + , WrapTxMeasurePhase2 (..) , WrapTxOut (..) , WrapValidatedGenTx (..) @@ -88,7 +89,8 @@ newtype WrapTipInfo blk = WrapTipInfo {unwrapTipInfo :: TipInfo blk} -- wrappers in this module. newtype WrapValidatedGenTx blk = WrapValidatedGenTx {unwrapValidatedGenTx :: Validated (GenTx blk)} -newtype WrapTxMeasure blk = WrapTxMeasure {unwrapTxMeasure :: TxMeasure blk} +newtype WrapTxMeasurePhase1 blk = WrapTxMeasurePhase1 {unwrapTxMeasurePhase1 :: TxMeasurePhase1 blk} +newtype WrapTxMeasurePhase2 blk = WrapTxMeasurePhase2 {unwrapTxMeasurePhase2 :: TxMeasurePhase2 blk} newtype WrapTxIn blk = WrapTxIn {unwrapTxIn :: TxIn blk} newtype WrapTxOut blk = WrapTxOut {unwrapTxOut :: TxOut blk} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Enclose.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Enclose.hs index fa12f77a1d..0ef5f86522 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Enclose.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Enclose.hs @@ -85,7 +85,7 @@ pattern FallingEdge = FallingEdgeWith () -- pure (input + 5) -- :} encloseWith :: - Applicative m => + Monad m => Tracer m Enclosing -> m a -> m a diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs index 6dcef59082..8d7d0832ea 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -24,8 +24,7 @@ import qualified Data.MultiSet as MultiSet import Data.SOP.BasicFunctors import Data.Typeable (Typeable) import NoThunks.Class - ( InspectHeap (..) - , InspectHeapNamed (..) + ( InspectHeapNamed (..) , NoThunks (..) , OnlyCheckWhnf (..) , OnlyCheckWhnfNamed (..) @@ -33,7 +32,7 @@ import NoThunks.Class ) import Ouroboros.Network.Util.ShowProxy import System.FS.API (SomeHasFS) -import System.FS.API.Types (FsPath, Handle) +import System.FS.API.Types (Handle) import System.FS.CRC (CRC (CRC)) import System.Random (StdGen) import qualified System.Random.Internal as Random @@ -97,7 +96,6 @@ instance NoThunks StdGen where fs-api -------------------------------------------------------------------------------} -deriving via InspectHeap FsPath instance NoThunks FsPath deriving newtype instance NoThunks CRC deriving via InspectHeapNamed "Handle" (Handle h) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs index 88b5695a3d..895fe3072b 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs @@ -8,6 +8,7 @@ module Test.Util.Orphans.NoThunks () where +import Cardano.Ledger.Orphans () import Control.Concurrent.Class.MonadMVar import Control.Concurrent.Class.MonadMVar.Strict import Control.Concurrent.Class.MonadSTM.Strict @@ -19,7 +20,6 @@ import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Util.MonadSTM.StrictSVar import qualified Ouroboros.Consensus.Util.NormalForm.StrictMVar as NormalForm import qualified Ouroboros.Consensus.Util.NormalForm.StrictTVar as NormalForm -import System.FS.API.Types import System.FS.Sim.FsTree import System.FS.Sim.MockFS @@ -53,7 +53,6 @@ instance NoThunks a => NoThunks (NormalForm.StrictTVar (IOSim s) a) where fs-sim -------------------------------------------------------------------------------} -deriving instance NoThunks FsPath deriving instance NoThunks MockFS deriving instance NoThunks a => NoThunks (FsTree a) deriving instance NoThunks HandleMock diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Examples.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Examples.hs index 08c47cf704..362853aaa4 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Examples.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Examples.hs @@ -28,8 +28,6 @@ import Ouroboros.Consensus.Ledger.Abstract ( EmptyMK , LedgerConfig , LedgerState - , LedgerTables - , ValuesMK ) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) import Ouroboros.Consensus.Ledger.Query (BlockQuery, SomeBlockQuery) @@ -64,7 +62,6 @@ data Examples blk = Examples , exampleExtLedgerState :: Labelled (ExtLedgerState blk EmptyMK) , exampleSlotNo :: Labelled SlotNo , exampleLedgerConfig :: Labelled (LedgerConfig blk) - , exampleLedgerTables :: Labelled (LedgerTables blk ValuesMK) } emptyExamples :: Examples blk @@ -86,7 +83,6 @@ emptyExamples = , exampleExtLedgerState = mempty , exampleSlotNo = mempty , exampleLedgerConfig = mempty - , exampleLedgerTables = mempty } combineExamples :: @@ -113,7 +109,6 @@ combineExamples f e1 e2 = , exampleExtLedgerState = combine exampleExtLedgerState , exampleSlotNo = combine exampleSlotNo , exampleLedgerConfig = combine exampleLedgerConfig - , exampleLedgerTables = combine exampleLedgerTables } where combine :: (Examples blk -> Labelled a) -> Labelled a diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Golden.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Golden.hs index b68055e190..c873c409f4 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Golden.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/Golden.hs @@ -55,7 +55,6 @@ import Ouroboros.Consensus.Ledger.Query , blockQueryIsSupportedOnVersion , nodeToClientVersionToQueryVersion ) -import Ouroboros.Consensus.Ledger.Tables (valuesMKEncoder) import Ouroboros.Consensus.Node.NetworkProtocolVersion ( HasNetworkProtocolVersion (..) , SupportedNetworkProtocolVersion (..) @@ -223,34 +222,6 @@ goldenTests testName examples enc goldenFolder mCDDL labels :: [Maybe String] labels = map fst examples -goldenTests' :: - HasCallStack => - TestName -> - Labelled (a, a -> Encoding) -> - -- | Folder containing the golden files - FilePath -> - Maybe (FilePath, T.Text) -> - TestTree -goldenTests' testName examples goldenFolder mCDDL - | nub labels /= labels = - error $ "Examples with the same label for " <> testName - | [(Nothing, (example, exampleEncoder))] <- examples = - -- If there's just a single unlabelled example, no need for grouping, - -- which makes the output more verbose. - goldenTestCBOR testName example exampleEncoder (goldenFolder testName) mCDDL - | otherwise = - testGroup - testName - [ goldenTestCBOR testName' example exampleEncoder (goldenFolder testName') mCDDL - | (mbLabel, (example, exampleEncoder)) <- examples - , let testName' = case mbLabel of - Nothing -> testName - Just label -> testName <> "_" <> label - ] - where - labels :: [Maybe String] - labels = map fst examples - {------------------------------------------------------------------------------- Skeletons -------------------------------------------------------------------------------} @@ -322,7 +293,6 @@ goldenTest_SerialiseDisk codecConfig goldenDir Examples{..} = , test "AnnTip" exampleAnnTip (encodeDisk codecConfig) , test "ChainDepState" exampleChainDepState (encodeDisk codecConfig) , test "ExtLedgerState" exampleExtLedgerState encodeExt - , testLedgerTables ] where test :: TestName -> Labelled a -> (a -> Encoding) -> TestTree @@ -334,18 +304,6 @@ goldenTest_SerialiseDisk codecConfig goldenDir Examples{..} = (goldenDir "disk") Nothing - testLedgerTables :: TestTree - testLedgerTables = - goldenTests' - "LedgerTables" - ( zipWith - (\(lbl, tbs) (_, st) -> (lbl, (tbs, valuesMKEncoder st))) - exampleLedgerTables - exampleLedgerState - ) - (goldenDir "disk") - Nothing - encodeExt = encodeDiskExtLedgerState codecConfig -- TODO how can we ensure that we have a test for each constraint listed in diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/TxWireSize.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/TxWireSize.hs index 48b0cebd2c..041d54490d 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/TxWireSize.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Serialisation/TxWireSize.hs @@ -17,7 +17,7 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion ) import Ouroboros.Consensus.Node.Serialisation import Ouroboros.Network.SizeInBytes -import Ouroboros.Network.TxSubmission.Inbound.V2.State +import Ouroboros.Network.TxSubmission.Inbound.V2.Types ( const_MAX_TX_SIZE_DISCREPANCY ) import Test.Tasty.QuickCheck diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Tracer.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Tracer.hs index 3dbbf33c2d..9929522715 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Tracer.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Tracer.hs @@ -18,7 +18,7 @@ recordingTracerIORef :: IO (Tracer IO ev, IO [ev]) recordingTracerIORef = newIORef [] >>= \ref -> return - ( Tracer $ \ev -> atomicModifyIORef' ref $ \evs -> (ev : evs, ()) + ( mkTracer $ \ev -> atomicModifyIORef' ref $ \evs -> (ev : evs, ()) , reverse <$> readIORef ref ) @@ -29,7 +29,7 @@ recordingTracerTVar :: MonadSTM m => m (Tracer m ev, m [ev]) recordingTracerTVar = uncheckedNewTVarM [] >>= \ref -> return - ( Tracer $ \ev -> atomically $ modifyTVar ref (ev :) + ( mkTracer $ \ev -> atomically $ modifyTVar ref (ev :) , atomically $ reverse <$> readTVar ref ) diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs index 91c33862a2..a2b2d0cc36 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs @@ -114,6 +114,7 @@ import Ouroboros.Consensus.Storage.Common import Ouroboros.Consensus.Util (ShowProxy (..), hashFromBytesShortE) import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.IndexedMemPack +import Ouroboros.Network.Tx (HasRawTxId (..)) import Test.Util.Orphans.Serialise () {------------------------------------------------------------------------------- @@ -629,7 +630,8 @@ instance mkMempoolApplyTxError _tls txt = Just $ MockMempoolError txt instance TxLimits (SimpleBlock c ext) where - type TxMeasure (SimpleBlock c ext) = IgnoringOverflow ByteSize32 + type TxMeasurePhase1 (SimpleBlock c ext) = IgnoringOverflow ByteSize32 + type TxMeasurePhase2 (SimpleBlock c ext) = TrivialTxMeasurePhase2 txWireSize = fromIntegral . unByteSize32 . genTxSize @@ -637,13 +639,15 @@ instance TxLimits (SimpleBlock c ext) where -- don't override it. -- -- But not 'maxbound'!, since the mempool sometimes holds multiple blocks worth. - blockCapacityTxMeasure _cfg _st = IgnoringOverflow simpleBlockCapacity + blockCapacityTxMeasure _cfg _st = TxMeasure (IgnoringOverflow simpleBlockCapacity) TrivialTxMeasurePhase2 - txMeasure cfg _st = + txMeasurePhase1 cfg _st = fmap IgnoringOverflow . checkTxSize (simpleLedgerMockConfig cfg) . simpleGenTx + txMeasurePhase2 _cfg _st _tx = pure TrivialTxMeasurePhase2 + simpleBlockCapacity :: ByteSize32 simpleBlockCapacity = ByteSize32 512 @@ -660,6 +664,10 @@ instance instance HasTxId (GenTx (SimpleBlock c ext)) where txId = SimpleGenTxId . simpleGenTxId +instance HasRawTxId (TxId (GenTx (SimpleBlock c ext))) where + type RawTxId (TxId (GenTx (SimpleBlock c ext))) = Mock.TxId + getRawTxId = unSimpleGenTxId + instance (Typeable p, Typeable c) => NoThunks (GenTx (SimpleBlock p c)) where showTypeOf _ = show $ typeRep (Proxy @(GenTx (SimpleBlock p c))) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/TestCrypto.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/TestCrypto.hs index 3136c8b673..8dfb5cb3b2 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/TestCrypto.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Committee/TestCrypto.hs @@ -95,7 +95,7 @@ type instance PublicKey TestCrypto = (BLS.PublicKey SIGN, BLS.PublicKey VRF) -- | Hash the message of a Peras vote -- -- NOTE: this is inspired by the implementation used by the Praos VRF check in --- 'Ouroboros.Consensus.Protocol.Praos.VRF.mkInputVRF'. +-- 'Cardano.Protocol.Praos.VRF.mkInputVRF'. hashVoteSignature :: ElectionId TestCrypto -> VoteCandidate TestCrypto -> @@ -114,7 +114,7 @@ hashVoteSignature electionId candidate = -- | Hash the input for the VRF used in Peras elections -- -- NOTE: this is inspired by the implementation used by the Praos VRF check in --- 'Ouroboros.Consensus.Protocol.Praos.VRF.mkInputVRF'. +-- 'Cardano.Protocol.Praos.VRF.mkInputVRF'. hashVRFInput :: ElectionId TestCrypto -> Nonce -> diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs index f28edd2f18..ae651cff8a 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs @@ -35,7 +35,7 @@ import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.Monad.Except (runExcept) import Control.Monad.IOSim (runSimOrThrow) import Control.Monad.State (State, evalState, get, modify) -import Control.Tracer (Tracer (..)) +import Control.Tracer (mkTracer) import Data.Bifunctor (first, second) import Data.Either (isRight) import Data.Functor ((<&>)) @@ -234,7 +234,8 @@ prop_Mempool_semigroup_removeTxs (TestSetupWithTxsInMempoolToRemove testSetup tx prop_Mempool_getCapacity :: MempoolCapTestSetup -> Property prop_Mempool_getCapacity mcts = withTestMempool testSetup $ \TestMempool{mempool} -> do - IgnoringOverflow actualCapacity <- atomically $ getCapacity mempool + TxMeasure (IgnoringOverflow actualCapacity) TrivialTxMeasurePhase2 <- + atomically $ getCapacity mempool pure $ actualCapacity === expectedCapacity where MempoolCapacityBytesOverride testCapacity = testMempoolCapOverride testSetup @@ -544,10 +545,11 @@ instance Arbitrary TestSetupWithTxs where } let mempoolCap :: TheMeasure mempoolCap = - computeMempoolCapacity - testLedgerConfigNoSizeLimits - (TickedSimpleLedgerState ledger) - (testMempoolCapOverride testSetup') + tmPhase1 $ + computeMempoolCapacity + testLedgerConfigNoSizeLimits + (TickedSimpleLedgerState ledger) + (testMempoolCapOverride testSetup') largeInvalidTx <- genLargeInvalidTx mempoolCap let txs' = (largeInvalidTx, False) : txs @@ -754,7 +756,7 @@ withTestMempoolWithTimeoutConfig timeoutConfig setup@TestSetup{..} prop = -- Set up the Tracer varEvents <- uncheckedNewTVarM [] -- TODO use IOSim's dynamicTracer - let tracer = Tracer $ \ev -> atomically $ modifyTVar varEvents (ev :) + let tracer = mkTracer $ \ev -> atomically $ modifyTVar varEvents (ev :) -- Open the mempool and add the initial transactions mempool <- diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs index d4764439c1..442d25daf3 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/Fairness/TestBlock.hs @@ -120,15 +120,17 @@ instance Ledger.LedgerSupportsMempool TestBlock where mkMempoolApplyTxError = Ledger.nothingMkMempoolApplyTxError instance Ledger.TxLimits TestBlock where - type TxMeasure TestBlock = Ledger.IgnoringOverflow Ledger.ByteSize32 + type TxMeasurePhase1 TestBlock = Ledger.IgnoringOverflow Ledger.ByteSize32 + type TxMeasurePhase2 TestBlock = Ledger.TrivialTxMeasurePhase2 txWireSize = fromIntegral . Ledger.unByteSize32 . txSize . unGenTx blockCapacityTxMeasure _cfg _st = -- The tests will override this value. By using 1, @computeMempoolCapacity@ -- can be exactly what each test requests. - Ledger.IgnoringOverflow $ Ledger.ByteSize32 1 + Ledger.TxMeasure (Ledger.IgnoringOverflow $ Ledger.ByteSize32 1) Ledger.TrivialTxMeasurePhase2 - txMeasure _cfg _st = pure . Ledger.IgnoringOverflow . txSize . unGenTx + txMeasurePhase1 _cfg _st = pure . Ledger.IgnoringOverflow . txSize . unGenTx + txMeasurePhase2 _cfg _st _tx = pure Ledger.TrivialTxMeasurePhase2 {------------------------------------------------------------------------------- Ledger support (empty tables) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs index 42cfbd37b2..d097dc43c8 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs @@ -28,8 +28,8 @@ import Cardano.Slotting.Slot import Control.Arrow (second) import Control.Concurrent.Class.MonadSTM.Strict.TChan import Control.Monad.Class.MonadTimer.SI (MonadTimer) -import Control.Monad.Except (runExcept) -import qualified Control.Tracer as CT (Tracer (..), traceWith) +import Control.Monad.Except (Except, runExcept) +import qualified Control.Tracer as CT (Tracer, mkTracer, traceWith) import qualified Data.Foldable as Foldable import Data.Function (on) import qualified Data.Map.Strict as Map @@ -442,7 +442,7 @@ foldTxs cfg nextTk capacity initialFilled initialState = let slot = case getTipSlot st of Origin -> minimumPossibleSlotNo (Proxy @blk) At v -> v + 1 - in case runExcept $ (,) <$> txMeasure cfg st tx <*> applyTx cfg DoNotIntervene slot tx st of + in case runExcept $ (,) <$> txMeasureFull cfg st tx <*> applyTx cfg DoNotIntervene slot tx st of Left{} -> go ( acc @@ -474,6 +474,17 @@ foldTxs cfg nextTk capacity initialFilled initialState = ) next +txMeasureFull :: + LedgerSupportsMempool blk => + LedgerConfig blk -> + TickedLedgerState blk ValuesMK -> + GenTx blk -> + Except (ApplyTxErr blk) (TxMeasure blk) +txMeasureFull cfg st tx = + TxMeasure + <$> txMeasurePhase1 cfg (forgetLedgerTables st) tx + <*> txMeasurePhase2 cfg st tx + tick :: ( ValidateEnvelope blk , LedgerSupportsMempool blk @@ -570,16 +581,16 @@ mkSUT cfg initialLedger = do (lif, t) <- newLedgerInterface initialLedger trcrChan <- atomically newTChan :: m (StrictTChan m (Either String (TraceEventMempool blk))) let trcr = - CT.Tracer $ -- Dbg.traceShowM @(Either String (TraceEventMempool blk)) + CT.mkTracer $ -- Dbg.traceShowM @(Either String (TraceEventMempool blk)) atomically . writeTChan trcrChan mempool <- openMempoolWithoutSyncThread lif cfg - (MempoolCapacityBytesOverride $ unIgnoringOverflow txMaxBytes') + (MempoolCapacityBytesOverride $ unIgnoringOverflow $ tmPhase1 txMaxBytes') (Nothing :: Maybe MempoolTimeoutConfig) - (CT.Tracer $ CT.traceWith trcr . Right) - pure (SUT mempool t, CT.Tracer $ atomically . writeTChan trcrChan . Left) + (CT.mkTracer $ CT.traceWith trcr . Right) + pure (SUT mempool t, CT.mkTracer $ atomically . writeTChan trcrChan . Left) semantics :: ( LedgerSupportsMempool blk @@ -822,8 +833,8 @@ tests = -- | The 'TestBlock' txMaxBytes is fixed to a very high number. We use this -- local declaration to have a mempool that sometimes fill but still don't make -- it configurable. -txMaxBytes' :: IgnoringOverflow ByteSize32 -txMaxBytes' = IgnoringOverflow $ ByteSize32 maxBound +txMaxBytes' :: TxMeasure TestBlock +txMaxBytes' = TxMeasure (IgnoringOverflow $ ByteSize32 maxBound) TrivialTxMeasurePhase2 instance (StandardHash blk, GetTip (LedgerState blk)) => diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs index 2a84ff4ea4..0b7494efbc 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs @@ -30,7 +30,7 @@ import Control.Monad.Class.MonadTime import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.Monad.IOSim (runSimOrThrow) import Control.ResourceRegistry -import Control.Tracer (Tracer (..), nullTracer, traceWith) +import Control.Tracer (Tracer, mkTracer, nullTracer, traceWith) import Data.Bifunctor (first) import Data.Hashable (Hashable) import Data.Map.Strict (Map) @@ -197,7 +197,7 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do blockFetchTracer :: Tracer m (PeerRole, Driver.TraceSendRecv (BlockFetch TestBlock (Point TestBlock))) - blockFetchTracer = Tracer \case + blockFetchTracer = mkTracer \case (AsClient, ev) -> do atomically case ev of Driver.TraceRecvMsg (AnyMessage (MsgBlock _)) -> @@ -311,7 +311,7 @@ runBlockFetchTest BlockFetchClientTestSetup{..} = withRegistry \registry -> do getPerasWeightSnapshot = ChainDB.getPerasWeightSnapshot chainDB pure BlockFetchClientInterface.ChainDbView{..} where - cdbTracer = Tracer \case + cdbTracer = mkTracer \case ChainDBImpl.TraceAddBlockEvent ev -> traceWith tracer $ "ChainDB: " <> show ev _ -> pure () diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs index a5cbbdbffb..d00da3af23 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/FollowerPromptness.hs @@ -23,7 +23,7 @@ import Cardano.Ledger.BaseTypes (nonZero) import Control.Monad (forever) import Control.Monad.IOSim (runSimOrThrow) import Control.ResourceRegistry -import Control.Tracer (Tracer (..), contramapM, traceWith) +import Control.Tracer (Tracer, contramapM, mkTracer, traceWith) import Data.Foldable (for_) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -128,7 +128,7 @@ runFollowerPromptnessTest FollowerPromptnessTestSetup{..} = withRegistry \regist (withTime -> tracer, getTrace) <- recordingTracerTVar - let chainDBTracer = Tracer \case + let chainDBTracer = mkTracer \case ChainDBImpl.TraceAddBlockEvent ev -> do traceWith tracer $ "ChainDB: " <> show ev case ev of diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/LedgerSnapshots.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/LedgerSnapshots.hs index badc675dd7..009ce7474d 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/LedgerSnapshots.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/LedgerSnapshots.hs @@ -185,7 +185,7 @@ runAddBlocks lgrDbBackendArgs testSetup = withRegistry \registry -> do pure (chainDB, LedgerDB.lgrHasFS $ ChainDB.cdbLgrDbArgs chainDbArgs) isSnapshottingTracer :: StrictTMVar m () -> Tracer m (ChainDB.TraceEvent TestBlock) - isSnapshottingTracer tmvar = Tracer \case + isSnapshottingTracer tmvar = mkTracer \case ChainDB.TraceLedgerDBEvent (LedgerDB.LedgerDBSnapshotEvent (SnapshotRequestDelayed _ _ _)) -> atomically $ putTMVar tmvar () ChainDB.TraceLedgerDBEvent (LedgerDB.LedgerDBSnapshotEvent SnapshotRequestCompleted) -> @@ -411,7 +411,7 @@ runTest lgrDbBackendArgs testSetup = withRegistry \registry -> do withTime = contramapM \ev -> (,ev) <$> getMonotonicTime isSnapshottingTracer :: StrictTMVar m () -> Tracer m (ChainDB.TraceEvent TestBlock) - isSnapshottingTracer tmvar = Tracer \case + isSnapshottingTracer tmvar = mkTracer \case ChainDB.TraceLedgerDBEvent (LedgerDB.LedgerDBSnapshotEvent (SnapshotRequestDelayed _ _ _)) -> atomically $ putTMVar tmvar () ChainDB.TraceLedgerDBEvent (LedgerDB.LedgerDBSnapshotEvent SnapshotRequestCompleted) -> diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs index cf078ad55c..7bd923092d 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/StateMachine.hs @@ -35,8 +35,7 @@ import qualified Control.Monad as Monad import Control.Monad.Except import Control.Monad.State hiding (state) import Control.ResourceRegistry -import Control.Tracer (Tracer (..)) -import Data.Functor.Contravariant ((>$<)) +import Control.Tracer (Tracer, mkTracer, (>$<)) import qualified Data.List as L import qualified Data.List.NonEmpty as NE import Data.Map.Strict (Map) @@ -705,7 +704,7 @@ newtype NumOpenHandles = NumOpenHandles Word64 mkTrackOpenHandles :: IO (Tracer IO (TraceEvent TestBlock), IO NumOpenHandles) mkTrackOpenHandles = do varOpen <- uncheckedNewTVarM (NumOpenHandles 0) - let tracer = Tracer $ \case + let tracer = mkTracer $ \case LedgerDBFlavorImplEvent (FlavorImplSpecificTraceV2 ev) -> atomically $ modifyTVar varOpen $ case ev of V2.TraceLedgerTablesHandleCreate FallingEdgeWith{} -> succ diff --git a/tx-investigation.md b/tx-investigation.md new file mode 100644 index 0000000000..52332506a5 --- /dev/null +++ b/tx-investigation.md @@ -0,0 +1,167 @@ +# Babbage → Conway transaction investigation + +## The report + +The node's ledger is in **Conway**. A transaction submitted over **LocalTxSubmission** (node-to-client): + +- tagged as **Babbage** → **rejected** +- the *same* transaction tagged as **Conway** → **accepted** + +Goal: find where an older-era-tagged transaction could be rejected, and whether it lies in +consensus, the ledger's CBOR layer, or the client tooling. + +Repos consulted (sibling checkouts under `~/code/cardano/`): `ouroboros-consensus`, +`cardano-ledger`, `cardano-api`, `cardano-cli`. + +## The harness + +`ouroboros-consensus-cardano/app/check-tx-upgrade.hs` (+ `executable check-tx-upgrade` in +`ouroboros-consensus.cabal`; **uncommitted**). Run: + +``` +cabal run ouroboros-consensus:exe:check-tx-upgrade +``` + +It builds a transaction, runs it through a verbatim copy of the Babbage→Conway `InjectTx` +(`translateTxBabbageToConwayWrapper`, the per-boundary entry that `hardForkInjectTxs` +assembles), and compares transaction ids across paths. Latest output: + +``` +1. Babbage-tagged : eecad5822f…961823d3 +2. after Babbage→Conway : eecad5822f…961823d3 (== 1) +3. native Conway-tagged : 3e14d28887…44218875 (≠ 1) +``` + +## How the upgrade works (consensus) + +- A `GenTx (CardanoBlock)` carries an `NS GenTx xs` — the tx tagged with the era it was built in. +- When that era is older than the ledger's, the mempool walks the `InPairs InjectTx` chain from + `hardForkInjectTxs`, stepping the tx forward one era at a time via `SL.translateEra`. + - `Ouroboros/Consensus/HardFork/Combinator/InjectTxs.hs` + - `Ouroboros/Consensus/HardFork/Combinator/Mempool.hs` + - `Ouroboros/Consensus/Cardano/CanHardFork.hs` (`translateTxBabbageToConwayWrapper`) +- `HardForkApplyTxErrWrongEra` is produced **only** for a tx from an era *newer* than the ledger. + An older-era tx is upgraded, not rejected. So the mempool accepts + upgrades Babbage txs. + +## Findings by layer + +| Layer | Causes "Babbage-tag fails / Conway-tag succeeds"? | Evidence | +|---|---|---| +| Consensus upgrade (`hardForkInjectTxs`) | **No** | upgrades older→current; `WrongEra` only for newer-than-ledger | +| Conway CBOR **decode** | **No** | `allowTag`: tag 258 permitted, not enforced; no canonicity rule | +| Txid / witnesses | **No** | upgrade preserves the txid (harness 1 == 2); witnesses still match | +| cardano-api / cardano-cli | **No** | era tag ↔ encoding coupled; no mis-tag path | + +### 1. Decode — Conway accepts legacy (untagged) encoding + +- `cardano-ledger/libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/Decoder.hs` + - `decodeSet` is version-varied; at decode version **≥ 9** (Conway) its doc reads: + *"Set tag 258 is permitted, but not enforced."* It routes through + `decodeSetLikeEnforceNoDuplicates` → `allowTag setTag`. + - `allowTag` (`:1357`) consumes a tag *only if present*; absent tag is a no-op. +- `encodeSet` (`.../Encoding/Encoder.hs:462`): version ≥ 9 prefixes tag 258; versions 2–8 + (Shelley…Babbage) emit no tag. This is the byte difference the harness sees. +- No canonical / round-trip enforcement exists in the Conway rules. + +### 2. The upgrade preserves the txid (keeps Babbage bytes) + +- `cardano-ledger/eras/conway/impl/src/Cardano/Ledger/Conway/Translation.hs:89` + — `TranslateEra ConwayEra (Tx TopTx)` translates body/wits/auxData via + `translateEraThroughCBOR`; the `Annotator` recaptures the original (untagged Babbage) bytes, + so the upgraded Conway tx's txid equals the Babbage txid. +- Consequence: witnesses signed over the Babbage txid still verify after the upgrade. A native + Conway tx of identical content has a *different* txid (tag-258 encoding) — but that only matters + to the client that signed it, and each path signs the id matching its own era. + +### 3. Re-broadcast does not fail on later nodes + +- The Shelley `GenTx` wire encoder re-emits the tx's memoized bytes + (`Shelley/Ledger/Mempool.hs:259`, `toCBOR (ShelleyTx _ tx) = wrapCBORinCBOR toCBOR tx`), so a + node puts the *same* (Babbage-format) bytes back on the wire under the Conway tag. +- Every Conway node decodes them via `allowTag` (accepts untagged) and computes the same txid. + No deserialization failure, no network-wide txid split. This backward-compat is deliberate. + +### 4. Clients do not mis-tag the era + +- **cardano-api** `toConsensusGenTx` (`cardano-api/src/Cardano/Api/Consensus/Internal/InMode.hs:107`): + the GADT ties the HFC era index to the `Tx era` value — a `Tx BabbageEra` is always + Babbage-encoded and submitted at the Babbage index (5); `Tx ConwayEra` at index 6. +- **cardano-cli** submit (`cardano-cli/src/Cardano/CLI/EraBased/Transaction/Run.hs:1324-1326`): + `readFileTx → InAnyShelleyBasedEra era tx`, then `TxInMode era tx`. `readTx` + (`Cardano/CLI/Read.hs:321-329`, `fromSomeShelleyTx`) matches the TextEnvelope **type string** + (`"Tx ConwayEra"`, `"Tx BabbageEra"`, …) per era, so the era is pinned by the label the tx was + written with and drives both decode and the submit tag. No `--era` override on submit. +- So a Babbage-tagged submission always carries Babbage (untagged) bytes and a Conway-tagged one + carries Conway (tag-258) bytes; they cannot be crossed through the tooling. + +## The one structural asymmetry + +The **Babbage decoder (proto ver < 9)** has no `allowTag` — its `decodeSet` branch uses +`decodeCollection decodeListLenOrIndef`, which expects a plain list and therefore **rejects** a +tag-258 set. Conway (≥ 9) accepts both. But because the tooling couples era ↔ encoding, this can +only bite when: + +- raw bytes are submitted with a hand-chosen wrong era (bypassing cardano-cli/api), or +- a **version-skewed client** (an old cardano-api/cli that can't represent the Conway tx) handles + a Conway tx as Babbage. + +## Conclusion & leading hypothesis + +Nothing in the consensus upgrade, the ledger's CBOR encode/decode, txid/witness handling, or the +client tooling explains the report via a mis-tag or an encoding rejection. + +For a genuine "same logical transaction" report, the cause is a **Conway-specific *validation* +difference** between a tx *built* as Babbage vs Conway, which surfaces only after the Babbage-built +tx is upgraded and checked under Conway rules. This is now **confirmed** — see below. + +## CONFIRMED cause: the Conway reference-script minimum-fee surcharge + +Conway added a minimum-fee surcharge proportional to the size of the **reference scripts** a +transaction consumes; Babbage (and Alonzo) have no such term. + +- Babbage/Alonzo drop the ref-script size argument in the min-fee: + - `cardano-ledger/eras/babbage/impl/src/Cardano/Ledger/Babbage/UTxO.hs:62` + — `getMinFeeTxUtxo pp tx _ = getShelleyMinFeeTxUtxo pp tx` + - `cardano-ledger/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/UTxO.hs:128` — same. +- Conway adds it: + - `cardano-ledger/eras/conway/impl/src/Cardano/Ledger/Conway/UTxO.hs:137` — `getMinFeeTxUtxo = getConwayMinFeeTxUtxo` + - `.../Conway/UTxO.hs:163` — `getMinFeeTx pp tx (txNonDistinctRefScriptsSize utxo tx)` + - `.../Conway/Tx.hs:103` — `getConwayMinFeeTx pp tx sz = alonzoMinFeeTx pp tx <+> refScriptsFee`, + where `refScriptsFee = tierRefScriptFee … sz` using the new param `ppMinFeeRefScriptCostPerByte`. +- Enforced in the UTXO rule: `conwayUtxoTransition` (`.../Conway/Rules/Utxo.hs:234`) → + `Babbage.babbageUtxoValidation` → `feesOK` (`.../Babbage/Rules/Utxo.hs:181`), which sets + `minFee = getMinFeeTxUtxo pp tx u` and fails `FeeTooSmallUTxO` when `minFee > txfee`. + +**Mechanism:** a tx that consumes reference scripts (spending a script-locked UTxO via a reference +script — the common DApp case), built/tagged as **Babbage**, sets a fee *without* the surcharge. +Submitted tagged Babbage → upgraded to Conway → the Conway UTXO rule recomputes min-fee *with* the +surcharge → fee too small → `FeeTooSmallUTxO`. Built as **Conway**, the wallet includes the +surcharge → accepted. Same intent: Babbage-tagged fails, Conway-tagged succeeds — an exact match. + +**Scope:** `tierRefScriptFee` is 0 for zero ref-script bytes, so simple (no-reference-script) txs +are unaffected; only script-using txs fail. Consistent with "some transactions" reports. + +**Secondary Conway-only check:** `disjointRefInputs` (`.../Babbage/Rules/Utxo.hs`), active at +Conway protocol versions (pv 9–10), rejects a tx whose inputs and reference-inputs overlap +(`BabbageNonDisjointRefInputs`); Babbage allowed the overlap. + +**Weaker candidate (script-integrity hash / cost-model language views):** `getLanguageView` +(`.../Alonzo/PParams.hs:566`) encodes cost models at `pvMajor` of the *current* pparams, and the +ledger recomputes the integrity hash via the current-era instance — so it mainly bites when the +client builds with stale/wrong-era protocol params, not purely from the era tag. + +**Bottom line:** this is expected ledger behaviour, not a consensus/serialisation bug. The fix is +client-side — build the transaction in the *current* era (Conway) so the reference-script fee is +included. + +## Next step + +Obtain the **CBOR of an actual failing transaction** and run it through the harness: + +- prints `NOT UPGRADEABLE` → a `translateEra` failure (the smoking gun); or +- upgrades cleanly → build the validation differential (upgraded vs native Conway, with resolving + inputs), or trace the specific Conway rule in `../cardano-ledger`. + +## Status of the harness + +`check-tx-upgrade.hs` + its cabal stanza are **uncommitted** — keep or drop TBD.