From 1d927dd3eda4f21595e16aeebe7f3ee830222b9e Mon Sep 17 00:00:00 2001 From: Fabrizio Ferrai Date: Mon, 18 May 2026 16:44:35 +0300 Subject: [PATCH] Integration for Node release 11.1 --- cabal.project | 78 +++++++++++- .../Consensus/Cardano/CanHardFork.hs | 5 +- .../Ouroboros/Consensus/Cardano/Node.hs | 108 +++++++++-------- .../Ouroboros/Consensus/Shelley/Eras.hs | 10 +- .../Ouroboros/Consensus/Shelley/HFEras.hs | 26 +--- .../Consensus/Shelley/Ledger/Block.hs | 7 +- .../Consensus/Shelley/Ledger/Forge.hs | 10 +- .../Consensus/Shelley/Ledger/Ledger.hs | 10 +- .../Consensus/Shelley/Ledger/PeerSelection.hs | 60 ++-------- .../Consensus/Shelley/Ledger/Query.hs | 41 +------ .../Ledger/Query/LegacyShelleyGenesis.hs | 14 ++- .../Shelley/Ledger/SupportsProtocol.hs | 82 +++++++------ .../Consensus/Shelley/Node/TPraos.hs | 76 +++++++----- .../Consensus/Shelley/Protocol/Abstract.hs | 9 -- .../Shelley/Protocol/EnvelopeChecks.hs | 91 ++++++++++++++ .../Consensus/Shelley/Protocol/Praos.hs | 113 ++++-------------- .../Consensus/Shelley/Protocol/TPraos.hs | 31 ++--- .../Test/Consensus/Cardano/ProtocolInfo.hs | 23 ++-- .../ThreadNet/Infra/ShelleyBasedHardFork.hs | 77 ++++++------ .../Cardano/Api/KeysPraos.hs | 6 +- .../Cardano/Api/Protocol/Types.hs | 29 +++-- .../Cardano/Api/SerialiseUsing.hs | 4 +- .../Cardano/Tools/DBAnalyser/Analysis.hs | 2 +- .../Cardano/Tools/DBAnalyser/Block/Cardano.hs | 36 +++--- .../Cardano/Tools/DBAnalyser/Block/Shelley.hs | 19 ++- .../Cardano/Tools/DBAnalyser/Run.hs | 13 +- .../Cardano/Tools/DBImmutaliser/Run.hs | 5 +- .../Cardano/Tools/DBSynthesizer/Run.hs | 31 +++-- .../Cardano/Tools/DBSynthesizer/Types.hs | 1 + .../Cardano/Tools/DBTruncater/Run.hs | 10 +- .../Cardano/Tools/ImmDBServer/Diffusion.hs | 1 - .../Test/Consensus/Shelley/Generators.hs | 3 - .../Test/ThreadNet/Infra/Shelley.hs | 26 +++- .../test/byron-test/Test/ThreadNet/Byron.hs | 13 +- .../byron-test/Test/ThreadNet/DualByron.hs | 2 +- .../MiniProtocol/LocalTxSubmission/Server.hs | 23 ++-- .../Consensus/Cardano/SupportsSanityCheck.hs | 38 +++--- .../Test/ThreadNet/AllegraMary.hs | 56 +++++---- .../cardano-test/Test/ThreadNet/Cardano.hs | 57 ++++----- .../cardano-test/Test/ThreadNet/MaryAlonzo.hs | 61 +++++----- .../Test/ThreadNet/ShelleyAllegra.hs | 54 +++++---- .../shelley-test/Test/ThreadNet/Shelley.hs | 46 +++---- .../Consensus/Network/NodeToClient.hs | 11 +- .../Ouroboros/Consensus/Network/NodeToNode.hs | 23 ++-- .../Ouroboros/Consensus/Node/Tracers.hs | 59 ++++----- .../Test/ThreadNet/General.hs | 2 +- .../Test/ThreadNet/Network.hs | 42 +++---- .../test/consensus-test/Test/Consensus/GSM.hs | 4 +- .../Test/Consensus/HardFork/Combinator.hs | 7 +- .../Consensus/PeerSimulator/BlockFetch.hs | 3 +- .../Test/Consensus/PeerSimulator/ChainSync.hs | 9 +- .../Consensus/PeerSimulator/NodeLifecycle.hs | 4 +- .../Test/Consensus/PeerSimulator/Run.hs | 6 +- .../ScheduledBlockFetchServer.hs | 4 +- .../PeerSimulator/ScheduledChainSyncServer.hs | 6 +- .../Consensus/PeerSimulator/StateDiagram.hs | 8 +- .../Test/Consensus/PeerSimulator/Trace.hs | 31 +++-- .../test/mock-test/Test/ThreadNet/BFT.hs | 17 +-- .../Test/ThreadNet/LeaderSchedule.hs | 29 ++--- .../test/mock-test/Test/ThreadNet/PBFT.hs | 13 +- .../test/mock-test/Test/ThreadNet/Praos.hs | 27 +++-- .../Ouroboros/Consensus/Protocol/Praos.hs | 54 +++++---- .../Consensus/Protocol/Praos/Header.hs | 35 +++++- .../Consensus/Protocol/Praos/Views.hs | 35 +++++- .../Ouroboros/Consensus/Protocol/TPraos.hs | 12 +- ouroboros-consensus.cabal | 40 ++++--- .../Consensus/Storage/LedgerDB/V2/LSM.hs | 1 - .../Consensus/Committee/Crypto/BLS.hs | 30 +---- .../Ouroboros/Consensus/Mempool/Update.hs | 1 - .../Consensus/Storage/ChainDB/Impl.hs | 1 - .../Consensus/Storage/ChainDB/Impl/Args.hs | 4 +- .../Storage/ChainDB/Impl/Background.hs | 2 +- .../Storage/ChainDB/Impl/ChainSel.hs | 3 +- .../Storage/ChainDB/Impl/Iterator.hs | 2 +- .../Consensus/Storage/ImmutableDB/Impl.hs | 2 +- .../Ouroboros/Consensus/Storage/LedgerDB.hs | 2 +- .../Consensus/Storage/LedgerDB/API.hs | 3 +- .../Consensus/Storage/LedgerDB/Args.hs | 2 +- .../Consensus/Storage/LedgerDB/V2.hs | 1 - .../Consensus/Storage/LedgerDB/V2/Forker.hs | 1 - .../Consensus/Storage/LedgerDB/V2/InMemory.hs | 1 - .../Consensus/Storage/PerasCertDB/Impl.hs | 2 +- .../Consensus/Storage/PerasVoteDB/Impl.hs | 2 +- .../Consensus/Storage/VolatileDB/Impl.hs | 2 +- .../Ouroboros/Consensus/Util/Enclose.hs | 2 +- .../Ouroboros/Consensus/Util/Orphans.hs | 6 +- .../Test/Util/Tracer.hs | 4 +- .../consensus-test/Test/Consensus/Mempool.hs | 4 +- .../Test/Consensus/Mempool/StateMachine.hs | 8 +- .../MiniProtocol/BlockFetch/Client.hs | 6 +- .../Storage/ChainDB/FollowerPromptness.hs | 4 +- .../Storage/ChainDB/LedgerSnapshots.hs | 4 +- .../Storage/LedgerDB/StateMachine.hs | 5 +- 93 files changed, 1092 insertions(+), 901 deletions(-) create mode 100644 ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Protocol/EnvelopeChecks.hs diff --git a/cabal.project b/cabal.project index 2bb87ac71c..2fe9a54cb4 100644 --- a/cabal.project +++ b/cabal.project @@ -16,7 +16,7 @@ index-state: -- Bump this if you need newer packages from Hackage , hackage.haskell.org 2026-05-18T17:14:36Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2026-05-18T13:56:34Z + , cardano-haskell-packages 2026-05-20T06:15:42Z active-repositories: , :rest @@ -24,6 +24,76 @@ active-repositories: packages: . +-- cardano-base master, past the contra-tracer 0.2.1 bump (PR#659) +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-base.git + tag: d6e5c68bbb87f528fc1926a32c462c5bf06f1782 + --sha256: sha256-VPm9BCey+R8dhpaopawx0v2CVxlQ3aGdVPSwurFngpA= + subdir: + base-deriving-via + cardano-base + cardano-binary + cardano-crypto-class + cardano-crypto-praos + cardano-git-rev + cardano-slotting + cardano-strict-containers + heapwords + measures + +-- plutus master, past PR#7783 (Interval inclusiveLowerBound / inclusiveUpperBound) +source-repository-package + type: git + location: https://github.com/IntersectMBO/plutus.git + tag: 59261563fd997a64f318cfb69305617f7892a7fa + --sha256: sha256-npZIAtR5PFqUKRooLehu4zrfgahbU5RkxGtLV7HTi6w= + subdir: + plutus-core + plutus-ledger-api + plutus-metatheory + plutus-tx + plutus-tx-plugin + +-- 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: 0b362519f6915841c92869ed288ce83f89b17b73 + --sha256: sha256-8pZYF7MJZZ1tM19wIUhbLKORDL+OP2ckhueWJM4aG/c= + subdir: + kes-agent + kes-agent-crypto + +-- cardano-ledger on branch f-f/prepare-11.1-2 +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-ledger.git + tag: 6a71a6b37879c0b77abdeac30ae94102620f5a2c + --sha256: sha256-8mKgdf9b4UAy6c6OeaJh0yRPqt3NDeOUH9ko2uBSSBI= + 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-tpraos + libs/non-integral + libs/small-steps + libs/vector-map + -- We want to always build the test-suites and benchmarks tests: true benchmarks: true @@ -50,12 +120,12 @@ constraints: plutus-ledger-api ^>=1.61, plutus-tx ^>=1.61 --- ouroboros-network dependency after introducing `bracketKeepAlive` (PR#5371) +-- on coot/tracing-instances branch source-repository-package type: git location: https://github.com/IntersectMBO/ouroboros-network - tag: e8d59d8a219563760fc21ba5bc86fab77d886742 - --sha256: sha256-ElgaE5JeDTPfyDQnyZs5ZlOdzlnZYl7z1OgkzCBJjek= + tag: bd53562dff7311fc8ba09b9414b395df8f1e8158 + --sha256: sha256-c7miOTTT/g89hXd9FjR0Ch0FYzXQVFn7X9rqJgr8oR4= subdir: ouroboros-network cardano-diffusion 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 f582e21083..08bc5557d5 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 @@ -395,8 +395,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..14b3d2e8a5 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 @@ -114,6 +114,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 +581,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 +935,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 . forgetLedgerTables $ + 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..148c00057a 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Eras.hs @@ -27,7 +27,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 +57,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 +94,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 +108,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..f7c92317e4 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs +++ b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/HFEras.hs @@ -16,9 +16,11 @@ module Ouroboros.Consensus.Shelley.HFEras , StandardShelleyBlock ) where +import Cardano.Ledger.Dijkstra.Era (DijkstraEraBlockHeader (..)) import Cardano.Protocol.Crypto import Ouroboros.Consensus.Protocol.Praos (Praos) import qualified Ouroboros.Consensus.Protocol.Praos as Praos +import Ouroboros.Consensus.Protocol.Praos.Header (Header) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import qualified Ouroboros.Consensus.Protocol.TPraos as TPraos import Ouroboros.Consensus.Shelley.Eras @@ -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 def77f1549..dc2550b46e 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,13 +46,15 @@ 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) @@ -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/Forge.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Forge.hs index 6e6c81bf20..d4466dd50e 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 @@ -4,9 +4,13 @@ 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 Control.Exception import qualified Data.Sequence.Strict as Seq @@ -80,7 +84,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/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..641b3d0f42 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 -> @@ -820,30 +813,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 +1041,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 +1090,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..5e575cd49c 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 @@ -86,8 +86,18 @@ instance FromCBOR LegacyShelleyGenesis where sgMaxLovelaceSupply sgProtocolParams sgGenDelegs - sgInitialFunds - sgStaking + mempty + emptyGenesisStaking + ( SJust + ShelleyExtraConfig + { secInitialFunds = + EmbeddedInjection sgInitialFunds + , secStakePools = + EmbeddedInjection (sgsPools sgStaking) + , secStakeCredentials = + EmbeddedInjection (sgsStake sgStaking) + } + ) 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..a0073cc2d3 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 @@ -18,7 +18,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 +26,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 +38,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 +68,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 +79,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 +91,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..6e19ef646a 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 @@ -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..8de84c6498 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,27 +1,19 @@ -{-# 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.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) @@ -38,65 +30,21 @@ 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..b918153524 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,9 +7,8 @@ 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 @@ -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/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 8c50f1767a..fa9132d648 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 @@ -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 () @@ -393,34 +394,53 @@ 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 + (transCfg2 ^. L.tcPreviousEraConfigL) + protVer1 + (protocolInfo2, blockForging2) <- + protocolInfoTPraosShelleyBased + fs + ProtocolParamsShelleyBased + { shelleyBasedInitialNonce + , shelleyBasedLeaderCredentials + } + transCfg2 + protVer2 + pure $ + protocolInfoBinary + -- Era 1 + protocolInfo1 + blockForging1 + eraParams1 + tpraosParams + toPartialLedgerConfig1 + -- Era 2 + protocolInfo2 + blockForging2 + eraParams2 + tpraosParams + toPartialLedgerConfig2 where ProtocolParamsShelleyBased { shelleyBasedInitialNonce @@ -432,15 +452,6 @@ protocolInfoShelleyBasedHardFork 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 +466,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..8bf8c15fd3 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 @@ -25,6 +25,7 @@ import Cardano.Api.Any import Cardano.Api.Key import Cardano.Api.SerialiseTextEnvelope import Cardano.Api.SerialiseUsing +import Cardano.Ledger.Binary (fromPlainDecoder) import qualified Cardano.Crypto.DSIGN.Class as Crypto import qualified Cardano.Crypto.Hash.Class as Crypto import qualified Cardano.Crypto.KES.Class as Crypto @@ -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 6d0f22ce34..2cd5e0a594 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) -- | An empty Dijkstra genesis to be provided when none is specified in the config. emptyDijkstraGenesis :: SL.DijkstraGenesis @@ -404,15 +411,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 @@ -431,7 +440,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 2a238a0f8d..b14607fa57 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 @@ -15,8 +15,7 @@ import Cardano.Tools.DBAnalyser.HasAnalysis import Cardano.Tools.DBAnalyser.Types 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 @@ -116,8 +115,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 lsmSalt <- fst . genWord64 <$> newStdGen ProtocolInfo{pInfoInitLedger = genesisLedger, pInfoConfig = cfg} <- mkProtocolInfo args @@ -215,10 +214,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..1deb8244f9 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 (..)) 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..e836d4b912 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 @@ -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 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..79319020ef 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 :: ProtocolInfo (CardanoBlock StandardCrypto)) <- + 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..bab0d58584 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 } 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..69dfb3381c 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 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..91b5e759a9 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 } 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..1092ff660a 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 @@ -616,7 +616,8 @@ nullTracers = } showTracers :: - ( Show blk + ( Monad m + , Show blk , Show ntnAddr , Show (Header blk) , Show (GenTx blk) @@ -627,16 +628,16 @@ 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 + , tTxLogicTracer = show >$< tr } {------------------------------------------------------------------------------- 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..b8fbb1d058 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 @@ -181,7 +181,8 @@ nullTracers = } showTracers :: - ( Show blk + ( Monad m + , Show blk , Show (GenTx blk) , Show (Validated (GenTx blk)) , Show (GenTxId blk) @@ -197,33 +198,33 @@ showTracers :: 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 } {------------------------------------------------------------------------------- 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..d70d3d6c80 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 @@ -244,7 +243,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 +377,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 +391,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 +499,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 +599,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 +793,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 +854,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 +988,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 +999,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 @@ -1739,8 +1739,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 :: 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..78f4fe5ba0 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 } 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..dc1afd7f73 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,6 +49,7 @@ 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) @@ -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 index 8054799201..e9cd7d3705 100644 --- 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 @@ -52,6 +52,8 @@ import Cardano.Ledger.Binary.Crypto , encodeVerKeyVRF ) import qualified Cardano.Ledger.Binary.Plain as Plain +import Cardano.Ledger.Block (Block (..), EraBlockHeader (..)) +import Cardano.Ledger.Core (Era) import Cardano.Ledger.Hashes ( EraIndependentBlockBody , EraIndependentBlockHeader @@ -61,7 +63,7 @@ import Cardano.Ledger.Hashes , extractHash , originalBytesSize ) -import Cardano.Ledger.Keys (KeyRole (BlockIssuer), VKey) +import Cardano.Ledger.Keys (KeyRole (BlockIssuer), VKey, hashKey) import Cardano.Ledger.MemoBytes ( Mem , MemoBytes @@ -78,6 +80,7 @@ import Cardano.Slotting.Block (BlockNo) import Cardano.Slotting.Slot (SlotNo) import Data.Word (Word32) import GHC.Generics (Generic) +import Lens.Micro (lens, to) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF) @@ -237,3 +240,33 @@ deriving via Mem (HeaderRaw crypto) instance Crypto crypto => DecCBOR (Annotator (Header crypto)) + +instance (Crypto c, Era era) => EraBlockHeader (Header c) era where + blockIssuerBlockHeaderG = + to (\(Block (Header hb _) _) -> hashKey (hbVk hb)) + blockHeaderSizeBlockHeaderG = + to (\(Block hdr _) -> originalBytesSize hdr) + blockBodySizeBlockHeaderL = + lens + (\(Block (Header hb _) _) -> hbBodySize hb) + ( \(Block (Header hb sig) body) sz -> + Block (Header hb{hbBodySize = sz} sig) body + ) + blockBodyHashBlockHeaderL = + lens + (\(Block (Header hb _) _) -> hbBodyHash hb) + ( \(Block (Header hb sig) body) h -> + Block (Header hb{hbBodyHash = h} sig) body + ) + slotNoBlockHeaderL = + lens + (\(Block (Header hb _) _) -> hbSlotNo hb) + ( \(Block (Header hb sig) body) s -> + Block (Header hb{hbSlotNo = s} sig) body + ) + protVerBlockHeaderL = + lens + (\(Block (Header hb _) _) -> hbProtVer hb) + ( \(Block (Header hb sig) body) pv -> + Block (Header hb{hbProtVer = pv} sig) body + ) 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..fd9057d169 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,11 +1,17 @@ +{-# 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) @@ -13,6 +19,7 @@ import Cardano.Protocol.TPraos.BHeader (PrevHash) import Cardano.Protocol.TPraos.OCert (OCert) import Cardano.Slotting.Slot (SlotNo) import Data.Word (Word16, Word32) +import Lens.Micro ((^.)) import Ouroboros.Consensus.Protocol.Praos.Header (HeaderBody) import Ouroboros.Consensus.Protocol.Praos.VRF (InputVRF) @@ -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..13543738c4 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 @@ -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.cabal b/ouroboros-consensus.cabal index 594d5d22b0..0ec5eb1b96 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -354,16 +354,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, @@ -951,16 +951,17 @@ library protocol 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-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, @@ -1342,6 +1343,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 @@ -1351,20 +1353,21 @@ 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-allegra ^>=1.10, + cardano-ledger-alonzo ^>=1.16, cardano-ledger-api ^>=1.13, - cardano-ledger-babbage ^>=1.13, + 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-tpraos, @@ -1376,6 +1379,7 @@ library cardano crypton, deepseq, formatting >=6.3 && <7.3, + fs-api, measures, mempack, microlens, @@ -1522,7 +1526,6 @@ 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}, @@ -1536,6 +1539,7 @@ library unstable-shelley-testlib cardano-strict-containers, containers, contra-tracer, + fs-api, kes-agent, kes-agent-crypto, microlens, @@ -1576,6 +1580,8 @@ test-suite shelley-test containers, contra-tracer, filepath, + fs-api, + fs-sim, measures, mempack, microlens, @@ -1625,6 +1631,8 @@ library unstable-cardano-testlib cborg, containers, contra-tracer, + fs-api, + fs-sim, mempack, microlens, mtl, @@ -1684,6 +1692,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}, 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 cc3586eb84..0b3c524f08 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 @@ -56,7 +56,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 List import qualified Data.Map.Strict as Map import Data.Maybe 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/Mempool/Update.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Update.hs index f441e1b73d..67b13a7ad8 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 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 1e86e9df06..e7694964fe 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 2118a9a06d..88dcc30c18 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 @@ -620,4 +620,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 0369cd7fec..b021840a79 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 @@ -34,10 +34,9 @@ import Control.Monad (forM_, join, void, when) import Control.Monad.Except () import Control.Monad.Trans.Class (lift) 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 cf3f52bfe2..d87f904afa 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 767b7a0d45..6075a017f6 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 @@ -686,6 +685,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) -> @@ -694,6 +694,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 771a100598..b6566273ee 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 @@ -66,7 +66,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/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/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/test/consensus-test/Test/Consensus/Mempool.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs index f28edd2f18..6b6640c3d2 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 ((<&>)) @@ -754,7 +754,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/StateMachine.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs index 42cfbd37b2..97fe36b0f9 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool/StateMachine.hs @@ -29,7 +29,7 @@ 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 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 @@ -570,7 +570,7 @@ 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 @@ -578,8 +578,8 @@ mkSUT cfg initialLedger = do cfg (MempoolCapacityBytesOverride $ unIgnoringOverflow 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 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 fdb86024e3..3a90c3a113 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 26734bf04d..94bf9f6780 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