From e8a1dd98d9f02aa8050539871767fd61a89fcd6a Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Mon, 17 Feb 2025 12:44:24 +0100 Subject: [PATCH 1/2] Expose `ValidationPolicy` and `ComputeLedgerEvents` when applying and ticking --- .../20250214_122220_jasataco_sts.md | 24 +++ .../Consensus/Byron/Ledger/Ledger.hs | 40 ++--- .../Consensus/Shelley/Ledger/Ledger.hs | 153 ++++++++++-------- .../20250214_122440_jasataco_sts.md | 22 +++ .../Ouroboros/Consensus/NodeKernel.hs | 1 + .../20250214_122203_jasataco_sts.md | 24 +++ ouroboros-consensus/ouroboros-consensus.cabal | 1 + .../Consensus/HardFork/Combinator/Ledger.hs | 63 +++----- .../Ouroboros/Consensus/HeaderStateHistory.hs | 3 +- .../Ouroboros/Consensus/Ledger/Abstract.hs | 108 ++++++++++--- .../Ouroboros/Consensus/Ledger/Basics.hs | 27 +++- .../Ouroboros/Consensus/Ledger/Dual.hs | 58 ++++--- .../Ouroboros/Consensus/Ledger/Extended.hs | 43 +++-- .../Consensus/Ledger/SupportsProtocol.hs | 2 +- .../Consensus/Mempool/Impl/Common.hs | 4 +- .../Consensus/Storage/ChainDB/Impl/Args.hs | 18 ++- .../Consensus/Storage/ChainDB/Impl/LgrDB.hs | 4 +- .../Ouroboros/Consensus/Storage/LedgerDB.hs | 6 +- .../Consensus/Storage/LedgerDB/LedgerDB.hs | 19 ++- .../Consensus/Storage/LedgerDB/Update.hs | 18 +-- 20 files changed, 428 insertions(+), 210 deletions(-) create mode 100644 ouroboros-consensus-cardano/changelog.d/20250214_122220_jasataco_sts.md create mode 100644 ouroboros-consensus-diffusion/changelog.d/20250214_122440_jasataco_sts.md create mode 100644 ouroboros-consensus/changelog.d/20250214_122203_jasataco_sts.md diff --git a/ouroboros-consensus-cardano/changelog.d/20250214_122220_jasataco_sts.md b/ouroboros-consensus-cardano/changelog.d/20250214_122220_jasataco_sts.md new file mode 100644 index 0000000000..079d5f2230 --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/20250214_122220_jasataco_sts.md @@ -0,0 +1,24 @@ + + + + + +### Breaking + +- Adapt to the change in block application and ticking interface in + Byron and Shelley. Block application and ticking now can choose + validation policy and enable or disable ledger events. diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs index f455db7d44..32ed3cdf33 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs @@ -59,6 +59,7 @@ import qualified Codec.CBOR.Encoding as CBOR import Codec.Serialise (decode, encode) import Control.Monad (replicateM) import Control.Monad.Except (Except, runExcept, throwError) +import qualified Control.State.Transition.Extended as STS import Data.ByteString (ByteString) import Data.Kind (Type) import Data.Map.Strict (Map) @@ -174,7 +175,7 @@ instance IsLedger (LedgerState ByronBlock) where type AuxLedgerEvent (LedgerState ByronBlock) = VoidLedgerEvent (LedgerState ByronBlock) - applyChainTickLedgerResult cfg slotNo ByronLedgerState{..} = pureLedgerResult $ + applyChainTickLedgerResult _ cfg slotNo ByronLedgerState{..} = pureLedgerResult $ TickedByronLedgerState { tickedByronLedgerState = CC.applyChainTick cfg (toByronSlotNo slotNo) byronLedgerState @@ -187,15 +188,10 @@ instance IsLedger (LedgerState ByronBlock) where -------------------------------------------------------------------------------} instance ApplyBlock (LedgerState ByronBlock) ByronBlock where - applyBlockLedgerResult = fmap pureLedgerResult ..: applyByronBlock validationMode - where - validationMode = CC.fromBlockValidationMode CC.BlockValidation - - reapplyBlockLedgerResult = - (pureLedgerResult . validationErrorImpossible) - ..: applyByronBlock validationMode - where - validationMode = CC.fromBlockValidationMode CC.NoBlockValidation + applyBlockLedgerResultWithValidation doValidation opts = + fmap pureLedgerResult ..: applyByronBlock doValidation opts + applyBlockLedgerResult = defaultApplyBlockLedgerResult + reapplyBlockLedgerResult = defaultReapplyBlockLedgerResult validationErrorImpossible data instance BlockQuery ByronBlock :: Type -> Type where GetUpdateInterfaceState :: BlockQuery ByronBlock UPI.State @@ -309,12 +305,8 @@ instance HasHardForkHistory ByronBlock where -- the event it is given a 'BlockValidationMode' of 'BlockValidation', it still -- /looks/ like it can fail (since its type doesn't change based on the -- 'ValidationMode') and we must still treat it as such. -validationErrorImpossible :: forall err a. Except err a -> a -validationErrorImpossible = cantBeError . runExcept - where - cantBeError :: Either err a -> a - cantBeError (Left _) = error "validationErrorImpossible: unexpected error" - cantBeError (Right a) = a +validationErrorImpossible :: forall err a. err -> a +validationErrorImpossible _ = error "validationErrorImpossible: unexpected error" {------------------------------------------------------------------------------- Applying a block @@ -323,22 +315,30 @@ validationErrorImpossible = cantBeError . runExcept the right arguments, and maintain the snapshots. -------------------------------------------------------------------------------} -applyByronBlock :: CC.ValidationMode +applyByronBlock :: STS.ValidationPolicy + -> ComputeLedgerEvents -> LedgerConfig ByronBlock -> ByronBlock -> TickedLedgerState ByronBlock -> Except (LedgerError ByronBlock) (LedgerState ByronBlock) -applyByronBlock validationMode +applyByronBlock doValidation + _doEvents cfg blk@(ByronBlock raw _ (ByronHash blkHash)) ls = case raw of - CC.ABOBBlock raw' -> applyABlock validationMode cfg raw' blkHash blkNo ls - CC.ABOBBoundary raw' -> applyABoundaryBlock cfg raw' blkNo ls + CC.ABOBBlock raw' -> applyABlock byronOpts cfg raw' blkHash blkNo ls + CC.ABOBBoundary raw' -> applyABoundaryBlock cfg raw' blkNo ls where blkNo :: BlockNo blkNo = blockNo blk + byronOpts = + CC.fromBlockValidationMode $ case doValidation of + STS.ValidateAll -> CC.BlockValidation + STS.ValidateNone -> CC.NoBlockValidation + STS.ValidateSuchThat _ -> CC.BlockValidation + applyABlock :: CC.ValidationMode -> Gen.Config -> CC.ABlock ByteString 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 380f97f562..1cecf3143d 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 @@ -10,8 +10,10 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -22,7 +24,6 @@ module Ouroboros.Consensus.Shelley.Ledger.Ledger ( LedgerState (..) , ShelleyBasedEra - , ShelleyLedgerError (..) , ShelleyTip (..) , ShelleyTransition (..) , Ticked (..) @@ -62,7 +63,7 @@ import qualified Codec.CBOR.Decoding as CBOR import Codec.CBOR.Encoding (Encoding) import qualified Codec.CBOR.Encoding as CBOR import Codec.Serialise (decode, encode) -import Control.Arrow (left) +import Control.Arrow (left, second) import qualified Control.Exception as Exception import Control.Monad.Except import qualified Control.State.Transition.Extended as STS @@ -90,24 +91,13 @@ import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Config import Ouroboros.Consensus.Shelley.Ledger.Protocol () import Ouroboros.Consensus.Shelley.Protocol.Abstract - (EnvelopeCheckError, envelopeChecks, mkHeaderView) + (EnvelopeCheckError, ProtoCrypto, envelopeChecks, + mkHeaderView) import Ouroboros.Consensus.Util ((..:)) import Ouroboros.Consensus.Util.CBOR (decodeWithOrigin, encodeWithOrigin) import Ouroboros.Consensus.Util.Versioned -{------------------------------------------------------------------------------- - Ledger errors --------------------------------------------------------------------------------} - -newtype ShelleyLedgerError era = BBodyError (SL.BlockTransitionError era) - deriving (Generic) - -deriving instance ShelleyBasedEra era => Eq (ShelleyLedgerError era) -deriving instance ShelleyBasedEra era => Show (ShelleyLedgerError era) - -instance ShelleyBasedEra era => NoThunks (ShelleyLedgerError era) - {------------------------------------------------------------------------------- Config -------------------------------------------------------------------------------} @@ -275,16 +265,16 @@ untickedShelleyLedgerTipPoint :: untickedShelleyLedgerTipPoint = shelleyTipToPoint . untickedShelleyLedgerTip instance ShelleyBasedEra era => IsLedger (LedgerState (ShelleyBlock proto era)) where - type LedgerErr (LedgerState (ShelleyBlock proto era)) = ShelleyLedgerError era + type LedgerErr (LedgerState (ShelleyBlock proto era)) = SL.BlockTransitionError era type AuxLedgerEvent (LedgerState (ShelleyBlock proto era)) = ShelleyLedgerEvent era - applyChainTickLedgerResult cfg slotNo ShelleyLedgerState{ + applyChainTickLedgerResult evs cfg slotNo ShelleyLedgerState{ shelleyLedgerTip , shelleyLedgerState , shelleyLedgerTransition } = - swizzle appTick <&> \l' -> + appTick globals shelleyLedgerState slotNo <&> \l' -> TickedShelleyLedgerState { untickedShelleyLedgerTip = shelleyLedgerTip @@ -302,22 +292,14 @@ instance ShelleyBasedEra era => IsLedger (LedgerState (ShelleyBlock proto era)) ei :: EpochInfo Identity ei = SL.epochInfoPure globals - swizzle (l, events) = - LedgerResult { - lrEvents = map ShelleyLedgerEventTICK events - , lrResult = l - } - appTick = - SL.applyTickOpts - STS.ApplySTSOpts { - asoAssertions = STS.globalAssertionPolicy - , asoValidation = STS.ValidateAll - , asoEvents = STS.EPReturn - } - globals - shelleyLedgerState - slotNo + uncurry (flip LedgerResult) ..: case evs of + ComputeLedgerEvents -> + second (map ShelleyLedgerEventTICK) ..: + applyTick STS.EPReturn + OmitLedgerEvents -> + (,[]) ..: applyTickNoEvents + -- | All events emitted by the Shelley ledger API data ShelleyLedgerEvent era = @@ -326,6 +308,54 @@ data ShelleyLedgerEvent era = -- | An event emitted during the chain tick | ShelleyLedgerEventTICK (STS.Event (Core.EraRule "TICK" era)) +-------------------------------------------------------------------------------- +-- ↓↓↓ REMOVE ↓↓↓ +-- +-- This code comes from https://github.com/IntersectMBO/cardano-ledger/pull/4889 +-- and must be removed before merging!! +-------------------------------------------------------------------------------- + +applyTickNoEvents :: + SL.Globals -> + SL.NewEpochState era -> + SlotNo -> + SL.NewEpochState era +applyTickNoEvents = undefined + +applyTick :: + STS.SingEP ep -> + SL.Globals -> + SL.NewEpochState era -> + SlotNo -> + (SL.NewEpochState era, [STS.Event (Core.EraRule "TICK" era)]) +applyTick = undefined + +applyBlockEither :: + -- IMPORTANT: I had to add this proto parameter. It won't be needed because + -- the ledger removed the argument to BHeaderView, so whoever integrates this + -- must remove the Proxy from the calls below. + Proxy proto -> + STS.SingEP ep -> + STS.ValidationPolicy -> + SL.Globals -> + SL.NewEpochState era -> + SL.Block (SL.BHeaderView (ProtoCrypto proto)) era -> + Either (SL.BlockTransitionError era) (SL.NewEpochState era, [STS.Event (Core.EraRule "BBODY" era)]) +applyBlockEither = undefined + +applyBlockEitherNoEvents :: + Proxy proto -> + STS.ValidationPolicy -> + SL.Globals -> + SL.NewEpochState era -> + SL.Block (SL.BHeaderView (ProtoCrypto proto)) era -> + Either (SL.BlockTransitionError era) (SL.NewEpochState era) +applyBlockEitherNoEvents = undefined + +-------------------------------------------------------------------------------- +-- ↑↑↑ REMOVE ↑↑↑ +-------------------------------------------------------------------------------- + instance ShelleyCompatible proto era => ApplyBlock (LedgerState (ShelleyBlock proto era)) (ShelleyBlock proto era) where -- Note: in the Shelley ledger, the @CHAIN@ rule is used to apply a whole @@ -338,45 +368,24 @@ instance ShelleyCompatible proto era -- - 'updateChainDepState': executes the @PRTCL@ transition -- + 'applyBlockLedgerResult': executes the @BBODY@ transition -- - applyBlockLedgerResult = - applyHelper (swizzle ..: appBlk) + applyBlockLedgerResultWithValidation doValidate evs = + liftEither ..: applyHelper appBlk where - swizzle m = - withExcept BBodyError m <&> \(l, events) -> - LedgerResult { - lrEvents = map ShelleyLedgerEventBBODY events - , lrResult = l - } - -- Apply the BBODY transition using the ticked state appBlk = - SL.applyBlockOpts - STS.ApplySTSOpts { - asoAssertions = STS.globalAssertionPolicy - , asoValidation = STS.ValidateAll - , asoEvents = STS.EPReturn - } + fmap (uncurry (flip LedgerResult)) ..: case evs of + ComputeLedgerEvents -> + fmap (second (map ShelleyLedgerEventBBODY)) ..: + applyBlockEither (Proxy @proto) STS.EPReturn doValidate + OmitLedgerEvents -> + fmap (,[]) ..: + applyBlockEitherNoEvents (Proxy @proto) doValidate + + + applyBlockLedgerResult = defaultApplyBlockLedgerResult reapplyBlockLedgerResult = - runIdentity ..: applyHelper (swizzle ..: reappBlk) - where - swizzle m = case runExcept m of - Left err -> - Exception.throw $! ShelleyReapplyException @era err - Right (l, events) -> - pure LedgerResult { - lrEvents = map ShelleyLedgerEventBBODY events - , lrResult = l - } - - -- Reapply the BBODY transition using the ticked state - reappBlk = - SL.applyBlockOpts - STS.ApplySTSOpts { - asoAssertions = STS.AssertionsOff - , asoValidation = STS.ValidateNone - , asoEvents = STS.EPReturn - } + defaultReapplyBlockLedgerResult (\err -> Exception.throw $! ShelleyReapplyException @era err) data ShelleyReapplyException = forall era. Show (SL.BlockTransitionError era) @@ -388,11 +397,13 @@ instance Show ShelleyReapplyException where instance Exception.Exception ShelleyReapplyException where applyHelper :: - (ShelleyCompatible proto era, Monad m) + ShelleyCompatible proto era => ( SL.Globals -> SL.NewEpochState era -> SL.Block (SL.BHeaderView (EraCrypto era)) era - -> m (LedgerResult + -> Either + (SL.BlockTransitionError era) + (LedgerResult (LedgerState (ShelleyBlock proto era)) (SL.NewEpochState era) ) @@ -400,7 +411,9 @@ applyHelper :: -> LedgerConfig (ShelleyBlock proto era) -> ShelleyBlock proto era -> Ticked (LedgerState (ShelleyBlock proto era)) - -> m (LedgerResult + -> Either + (SL.BlockTransitionError era) + (LedgerResult (LedgerState (ShelleyBlock proto era)) (LedgerState (ShelleyBlock proto era))) applyHelper f cfg blk TickedShelleyLedgerState{ diff --git a/ouroboros-consensus-diffusion/changelog.d/20250214_122440_jasataco_sts.md b/ouroboros-consensus-diffusion/changelog.d/20250214_122440_jasataco_sts.md new file mode 100644 index 0000000000..204403fd5b --- /dev/null +++ b/ouroboros-consensus-diffusion/changelog.d/20250214_122440_jasataco_sts.md @@ -0,0 +1,22 @@ + + +### Patch + +- Use `OmitLedgerEvents` when ticking blocks in the forging loop + + + diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 4d645bdd54..f8bcd93318 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -541,6 +541,7 @@ forkBlockForging IS{..} blockForging = let tickedLedgerState :: Ticked (LedgerState blk) tickedLedgerState = applyChainTick + OmitLedgerEvents (configLedger cfg) currentSlot (ledgerState unticked) diff --git a/ouroboros-consensus/changelog.d/20250214_122203_jasataco_sts.md b/ouroboros-consensus/changelog.d/20250214_122203_jasataco_sts.md new file mode 100644 index 0000000000..f4172839f7 --- /dev/null +++ b/ouroboros-consensus/changelog.d/20250214_122203_jasataco_sts.md @@ -0,0 +1,24 @@ + + + + + +### Breaking + +- Expose `ValidationPolicy` and `ComputeLedgerEvents` when calling + ledger rules for block application and ticking. This allows the user + to choose any validation policy form the `small-steps` package. diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 27552f9e20..1c9a3ee718 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -305,6 +305,7 @@ library semialign >=1.1, serialise ^>=0.2, si-timers ^>=1.5, + small-steps ^>=1.1, sop-core ^>=0.5, sop-extras ^>=0.2, streaming, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs index aaa001f0b8..9b6cbf6b78 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs @@ -30,6 +30,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Ledger ( import Control.Monad (guard) import Control.Monad.Except (throwError, withExcept) +import qualified Control.State.Transition.Extended as STS import Data.Functor ((<&>)) import Data.Functor.Product import Data.Proxy @@ -117,9 +118,13 @@ instance CanHardFork xs => IsLedger (LedgerState (HardForkBlock xs)) where type AuxLedgerEvent (LedgerState (HardForkBlock xs)) = OneEraLedgerEvent xs - applyChainTickLedgerResult cfg@HardForkLedgerConfig{..} slot (HardForkLedgerState st) = + applyChainTickLedgerResult evs cfg@HardForkLedgerConfig{..} slot (HardForkLedgerState st) = sequenceHardForkState - (hcizipWith proxySingle (tickOne ei slot) cfgs extended) <&> \l' -> + (hcizipWith + proxySingle + (tickOne ei slot evs) + cfgs + extended) <&> \l' -> TickedHardForkLedgerState { tickedHardForkLedgerStateTransition = -- We are bundling a 'TransitionInfo' with a /ticked/ ledger state, @@ -155,15 +160,16 @@ instance CanHardFork xs => IsLedger (LedgerState (HardForkBlock xs)) where tickOne :: SingleEraBlock blk => EpochInfo (Except PastHorizonException) -> SlotNo + -> ComputeLedgerEvents -> Index xs blk -> WrapPartialLedgerConfig blk -> LedgerState blk -> ( LedgerResult (LedgerState (HardForkBlock xs)) :.: (Ticked :.: LedgerState) ) blk -tickOne ei slot index pcfg st = Comp $ fmap Comp $ +tickOne ei slot evs index pcfg st = Comp $ fmap Comp $ embedLedgerResult (injectLedgerEvent index) - $ applyChainTickLedgerResult (completeLedgerConfig' ei pcfg) slot st + $ applyChainTickLedgerResult evs (completeLedgerConfig' ei pcfg) slot st {------------------------------------------------------------------------------- ApplyBlock @@ -172,7 +178,7 @@ tickOne ei slot index pcfg st = Comp $ fmap Comp $ instance CanHardFork xs => ApplyBlock (LedgerState (HardForkBlock xs)) (HardForkBlock xs) where - applyBlockLedgerResult cfg + applyBlockLedgerResultWithValidation doValidate opts cfg (HardForkBlock (OneEraBlock block)) (TickedHardForkLedgerState transition st) = case State.match block st of @@ -185,7 +191,7 @@ instance CanHardFork xs Right matched -> fmap (fmap HardForkLedgerState . sequenceHardForkState) $ hsequence' - $ hcizipWith proxySingle apply cfgs matched + $ hcizipWith proxySingle (apply doValidate opts) cfgs matched where cfgs = distribLedgerConfig ei cfg ei = State.epochInfoPrecomputedTransitionInfo @@ -193,50 +199,29 @@ instance CanHardFork xs transition st - reapplyBlockLedgerResult cfg - (HardForkBlock (OneEraBlock block)) - (TickedHardForkLedgerState transition st) = - case State.match block st of - Left _mismatch -> - -- We already applied this block to this ledger state, - -- so it can't be from the wrong era - error "reapplyBlockLedgerResult: can't be from other era" - Right matched -> - fmap HardForkLedgerState - $ sequenceHardForkState - $ hcizipWith proxySingle reapply cfgs matched - where - cfgs = distribLedgerConfig ei cfg - ei = State.epochInfoPrecomputedTransitionInfo - (hardForkLedgerConfigShape cfg) - transition - st + applyBlockLedgerResult = defaultApplyBlockLedgerResult + + reapplyBlockLedgerResult = defaultReapplyBlockLedgerResult (\_ -> + -- We already applied this block to this ledger state, + -- so it can't be from the wrong era + error "reapplyBlockLedgerResult: can't be from other era" + ) apply :: SingleEraBlock blk - => Index xs blk + => STS.ValidationPolicy + -> ComputeLedgerEvents + -> Index xs blk -> WrapLedgerConfig blk -> Product I (Ticked :.: LedgerState) blk -> ( Except (HardForkLedgerError xs) :.: LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState ) blk -apply index (WrapLedgerConfig cfg) (Pair (I block) (Comp st)) = +apply doValidate opts index (WrapLedgerConfig cfg) (Pair (I block) (Comp st)) = Comp $ withExcept (injectLedgerError index) $ fmap (Comp . embedLedgerResult (injectLedgerEvent index)) - $ applyBlockLedgerResult cfg block st - -reapply :: SingleEraBlock blk - => Index xs blk - -> WrapLedgerConfig blk - -> Product I (Ticked :.: LedgerState) blk - -> ( LedgerResult (LedgerState (HardForkBlock xs)) - :.: LedgerState - ) blk -reapply index (WrapLedgerConfig cfg) (Pair (I block) (Comp st)) = - Comp - $ embedLedgerResult (injectLedgerEvent index) - $ reapplyBlockLedgerResult cfg block st + $ applyBlockLedgerResultWithValidation doValidate opts cfg block st {------------------------------------------------------------------------------- UpdateLedger diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs index 0fc4be977d..9e56726fe6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs @@ -255,8 +255,7 @@ fromChain cfg initState chain = anchorSnapshot NE.:| snapshots = fmap (mkHeaderStateWithTime (configLedger cfg)) . NE.scanl - (flip (tickThenReapply (ExtLedgerCfg cfg))) + (flip (tickThenReapply OmitLedgerEvents (ExtLedgerCfg cfg))) initState . Chain.toOldestFirst $ chain - diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs index d78c5692d0..8a2aa6a571 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Abstract.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -17,7 +18,10 @@ module Ouroboros.Consensus.Ledger.Abstract ( Validated -- * Apply block , ApplyBlock (..) + , ComputeLedgerEvents (..) , UpdateLedger + , defaultApplyBlockLedgerResult + , defaultReapplyBlockLedgerResult -- * Derived , applyLedgerBlock , foldLedger @@ -36,12 +40,13 @@ module Ouroboros.Consensus.Ledger.Abstract ( ) where import Control.Monad.Except +import qualified Control.State.Transition.Extended as STS import Data.Kind (Type) import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Ledger.Basics import Ouroboros.Consensus.Ticked -import Ouroboros.Consensus.Util (repeatedly, repeatedlyM, (..:)) +import Ouroboros.Consensus.Util -- | " Validated " transaction or block -- @@ -83,9 +88,28 @@ class ( IsLedger l -- -- This is passed the ledger state ticked to the slot of the given block, so -- 'applyChainTickLedgerResult' has already been called. + -- + -- Users of this function can set any validation level allowed by the + -- @small-steps@ package. See "Control.State.Transition.Extended". + applyBlockLedgerResultWithValidation :: + HasCallStack + => STS.ValidationPolicy + -> ComputeLedgerEvents + -> LedgerCfg l + -> blk + -> Ticked l + -> Except (LedgerErr l) (LedgerResult l l) + + -- | Apply a block to the ledger state. + -- + -- This is passed the ledger state ticked to the slot of the given block, so + -- 'applyChainTickLedgerResult' has already been called. + -- + -- This function will use 'ValidateAll' policy for calling the ledger rules. applyBlockLedgerResult :: HasCallStack - => LedgerCfg l + => ComputeLedgerEvents + -> LedgerCfg l -> blk -> Ticked l -> Except (LedgerErr l) (LedgerResult l l) @@ -98,14 +122,38 @@ class ( IsLedger l -- -- It is worth noting that since we already know that the block is valid in -- the provided ledger state, the ledger layer should not perform /any/ - -- validation checks. + -- validation checks. Thus this function will call the ledger rules with + -- 'ValidateNone' policy. reapplyBlockLedgerResult :: HasCallStack - => LedgerCfg l + => ComputeLedgerEvents + -> LedgerCfg l -> blk -> Ticked l -> LedgerResult l l +defaultApplyBlockLedgerResult :: + (HasCallStack, ApplyBlock l blk) + => ComputeLedgerEvents + -> LedgerCfg l + -> blk + -> Ticked l + -> Except (LedgerErr l) (LedgerResult l l) +defaultApplyBlockLedgerResult = + applyBlockLedgerResultWithValidation STS.ValidateAll + +defaultReapplyBlockLedgerResult :: + (HasCallStack, ApplyBlock l blk) + => (LedgerErr l -> LedgerResult l l) + -> ComputeLedgerEvents + -> LedgerCfg l + -> blk + -> Ticked l + -> (LedgerResult l l) +defaultReapplyBlockLedgerResult throwReapplyError = + (either throwReapplyError id . runExcept) + ...: applyBlockLedgerResultWithValidation STS.ValidateNone + -- | Interaction with the ledger layer class ApplyBlock (LedgerState blk) blk => UpdateLedger blk @@ -115,75 +163,87 @@ class ApplyBlock (LedgerState blk) blk => UpdateLedger blk -- | 'lrResult' after 'applyBlockLedgerResult' applyLedgerBlock :: + forall l blk. (ApplyBlock l blk, HasCallStack) - => LedgerCfg l + => ComputeLedgerEvents + -> LedgerCfg l -> blk -> Ticked l -> Except (LedgerErr l) l -applyLedgerBlock = fmap lrResult ..: applyBlockLedgerResult +applyLedgerBlock = fmap lrResult ...: applyBlockLedgerResult -- | 'lrResult' after 'reapplyBlockLedgerResult' reapplyLedgerBlock :: + forall l blk. (ApplyBlock l blk, HasCallStack) - => LedgerCfg l + => ComputeLedgerEvents + -> LedgerCfg l -> blk -> Ticked l -> l -reapplyLedgerBlock = lrResult ..: reapplyBlockLedgerResult +reapplyLedgerBlock = + lrResult ...: reapplyBlockLedgerResult tickThenApplyLedgerResult :: ApplyBlock l blk - => LedgerCfg l + => ComputeLedgerEvents + -> LedgerCfg l -> blk -> l -> Except (LedgerErr l) (LedgerResult l l) -tickThenApplyLedgerResult cfg blk l = do - let lrTick = applyChainTickLedgerResult cfg (blockSlot blk) l - lrBlock <- applyBlockLedgerResult cfg blk (lrResult lrTick) +tickThenApplyLedgerResult opts cfg blk l = do + let lrTick = applyChainTickLedgerResult opts cfg (blockSlot blk) l + lrBlock <- applyBlockLedgerResult opts cfg blk (lrResult lrTick) pure LedgerResult { lrEvents = lrEvents lrTick <> lrEvents lrBlock , lrResult = lrResult lrBlock } tickThenReapplyLedgerResult :: + forall l blk. ApplyBlock l blk - => LedgerCfg l + => ComputeLedgerEvents + -> LedgerCfg l -> blk -> l -> LedgerResult l l -tickThenReapplyLedgerResult cfg blk l = - let lrTick = applyChainTickLedgerResult cfg (blockSlot blk) l - lrBlock = reapplyBlockLedgerResult cfg blk (lrResult lrTick) +tickThenReapplyLedgerResult evs cfg blk l = + let lrTick = applyChainTickLedgerResult evs cfg (blockSlot blk) l + lrBlock = reapplyBlockLedgerResult evs cfg blk (lrResult lrTick) in LedgerResult { lrEvents = lrEvents lrTick <> lrEvents lrBlock , lrResult = lrResult lrBlock } tickThenApply :: + forall l blk. ApplyBlock l blk - => LedgerCfg l + => ComputeLedgerEvents + -> LedgerCfg l -> blk -> l -> Except (LedgerErr l) l -tickThenApply = fmap lrResult ..: tickThenApplyLedgerResult +tickThenApply = fmap lrResult ...: tickThenApplyLedgerResult tickThenReapply :: + forall l blk. ApplyBlock l blk - => LedgerCfg l + => ComputeLedgerEvents + -> LedgerCfg l -> blk -> l -> l -tickThenReapply = lrResult ..: tickThenReapplyLedgerResult +tickThenReapply = lrResult ...: tickThenReapplyLedgerResult foldLedger :: ApplyBlock l blk - => LedgerCfg l -> [blk] -> l -> Except (LedgerErr l) l -foldLedger = repeatedlyM . tickThenApply + => ComputeLedgerEvents -> LedgerCfg l -> [blk] -> l -> Except (LedgerErr l) l +foldLedger = repeatedlyM .: tickThenApply refoldLedger :: ApplyBlock l blk - => LedgerCfg l -> [blk] -> l -> l -refoldLedger = repeatedly . tickThenReapply + => ComputeLedgerEvents -> LedgerCfg l -> [blk] -> l -> l +refoldLedger = repeatedly .: tickThenReapply {------------------------------------------------------------------------------- Short-hand diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs index b7b6eca434..8a0cb13036 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} @@ -23,17 +25,21 @@ module Ouroboros.Consensus.Ledger.Basics ( , LedgerCfg , applyChainTick -- * Link block to its ledger + , ComputeLedgerEvents (..) , LedgerConfig , LedgerError , LedgerState + , Proxy (..) , TickedLedgerState ) where import Data.Kind (Type) +import Data.Proxy (Proxy (..)) +import GHC.Generics import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Ticked -import Ouroboros.Consensus.Util ((..:)) +import Ouroboros.Consensus.Util ((...:)) {------------------------------------------------------------------------------- Tip @@ -97,6 +103,18 @@ pureLedgerResult a = LedgerResult { -- Types that inhabit this family will come from the Ledger code. type family LedgerCfg l :: Type +-- | Whether we tell the ledger layer to compute ledger events +-- +-- At the moment events are not emitted in any case in the consensus +-- layer (i.e. there is no handler for those events, nor are they +-- traced), so they are not really forced, we always discard +-- them. This behavior does not incur big costs thanks to laziness. +-- +-- By passing 'OmitLedgerEvents' we tell the Ledger layer to not even +-- allocate thunks for those events, as we explicitly don't want them. +data ComputeLedgerEvents = ComputeLedgerEvents | OmitLedgerEvents + deriving (Eq, Show, Generic, NoThunks) + class ( -- Requirements on the ledger state itself Show l , Eq l @@ -155,14 +173,15 @@ class ( -- Requirements on the ledger state itself -- > ledgerTipPoint (applyChainTick cfg slot st) -- > == ledgerTipPoint st applyChainTickLedgerResult :: - LedgerCfg l + ComputeLedgerEvents + -> LedgerCfg l -> SlotNo -> l -> LedgerResult l (Ticked l) -- | 'lrResult' after 'applyChainTickLedgerResult' -applyChainTick :: IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l -applyChainTick = lrResult ..: applyChainTickLedgerResult +applyChainTick :: IsLedger l => ComputeLedgerEvents -> LedgerCfg l -> SlotNo -> l -> Ticked l +applyChainTick = lrResult ...: applyChainTickLedgerResult {------------------------------------------------------------------------------- Link block to its ledger diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs index a5dc517634..900ec6f4d6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs @@ -359,12 +359,13 @@ instance Bridge m a => IsLedger (LedgerState (DualBlock m a)) where -- any events. So we make this easy choice for for now. type AuxLedgerEvent (LedgerState (DualBlock m a)) = AuxLedgerEvent (LedgerState m) - applyChainTickLedgerResult DualLedgerConfig{..} + applyChainTickLedgerResult evs + DualLedgerConfig{..} slot DualLedgerState{..} = castLedgerResult ledgerResult <&> \main -> TickedDualLedgerState { tickedDualLedgerStateMain = main - , tickedDualLedgerStateAux = applyChainTick + , tickedDualLedgerStateAux = applyChainTick evs dualLedgerConfigAux slot dualLedgerStateAux @@ -372,23 +373,32 @@ instance Bridge m a => IsLedger (LedgerState (DualBlock m a)) where , tickedDualLedgerStateBridge = dualLedgerStateBridge } where - ledgerResult = applyChainTickLedgerResult + ledgerResult = applyChainTickLedgerResult evs dualLedgerConfigMain slot dualLedgerStateMain -instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a) where - - applyBlockLedgerResult cfg - block@DualBlock{..} - TickedDualLedgerState{..} = do +applyHelper :: + Bridge m a + => ( ComputeLedgerEvents + -> LedgerCfg (LedgerState m) + -> m + -> Ticked (LedgerState m) + -> Except (LedgerErr (LedgerState m)) (LedgerResult (LedgerState m) (LedgerState m)) + ) + -> ComputeLedgerEvents + -> DualLedgerConfig m a + -> DualBlock m a + -> Ticked (LedgerState (DualBlock m a)) + -> Except (DualLedgerError m a) (LedgerResult (LedgerState (DualBlock m a)) (LedgerState (DualBlock m a))) +applyHelper f opts cfg block@DualBlock{..} TickedDualLedgerState{..} = do (ledgerResult, aux') <- agreeOnError DualLedgerError ( - applyBlockLedgerResult + f opts (dualLedgerConfigMain cfg) dualBlockMain tickedDualLedgerStateMain - , applyMaybeBlock + , applyMaybeBlock opts (dualLedgerConfigAux cfg) dualBlockAux tickedDualLedgerStateAux @@ -402,12 +412,20 @@ instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a) tickedDualLedgerStateBridge } - reapplyBlockLedgerResult cfg +instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a) where + + applyBlockLedgerResultWithValidation doValidate = + applyHelper (applyBlockLedgerResultWithValidation doValidate) + + applyBlockLedgerResult = + applyHelper applyBlockLedgerResult + + reapplyBlockLedgerResult evs cfg block@DualBlock{..} TickedDualLedgerState{..} = castLedgerResult ledgerResult <&> \main' -> DualLedgerState { dualLedgerStateMain = main' - , dualLedgerStateAux = reapplyMaybeBlock + , dualLedgerStateAux = reapplyMaybeBlock evs (dualLedgerConfigAux cfg) dualBlockAux tickedDualLedgerStateAux @@ -417,7 +435,7 @@ instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a) tickedDualLedgerStateBridge } where - ledgerResult = reapplyBlockLedgerResult + ledgerResult = reapplyBlockLedgerResult evs (dualLedgerConfigMain cfg) dualBlockMain tickedDualLedgerStateMain @@ -766,25 +784,27 @@ type instance ForgeStateUpdateError (DualBlock m a) = ForgeStateUpdateError m -- -- Returns state unchanged on 'Nothing' applyMaybeBlock :: UpdateLedger blk - => LedgerConfig blk + => ComputeLedgerEvents + -> LedgerConfig blk -> Maybe blk -> TickedLedgerState blk -> LedgerState blk -> Except (LedgerError blk) (LedgerState blk) -applyMaybeBlock _ Nothing _ st = return st -applyMaybeBlock cfg (Just block) tst _ = applyLedgerBlock cfg block tst +applyMaybeBlock _ _ Nothing _ st = return st +applyMaybeBlock opts cfg (Just block) tst _ = applyLedgerBlock opts cfg block tst -- | Lift 'reapplyLedgerBlock' to @Maybe blk@ -- -- See also 'applyMaybeBlock' reapplyMaybeBlock :: UpdateLedger blk - => LedgerConfig blk + => ComputeLedgerEvents + -> LedgerConfig blk -> Maybe blk -> TickedLedgerState blk -> LedgerState blk -> LedgerState blk -reapplyMaybeBlock _ Nothing _ st = st -reapplyMaybeBlock cfg (Just block) tst _ = reapplyLedgerBlock cfg block tst +reapplyMaybeBlock _ _ Nothing _ st = st +reapplyMaybeBlock evs cfg (Just block) tst _ = reapplyLedgerBlock evs cfg block tst -- | Used when the concrete and abstract implementation should agree on errors -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs index 522e2e2b51..9a1a2aaa2d 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs @@ -36,6 +36,7 @@ import Data.Functor ((<&>)) import Data.Proxy import Data.Typeable import GHC.Generics (Generic) +import GHC.Stack (HasCallStack) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config @@ -116,14 +117,13 @@ instance IsLedger (LedgerState blk) => GetTip (ExtLedgerState blk) where instance IsLedger (LedgerState blk) => GetTip (Ticked (ExtLedgerState blk)) where getTip = castPoint . getTip . tickedLedgerState -instance ( LedgerSupportsProtocol blk - ) +instance LedgerSupportsProtocol blk => IsLedger (ExtLedgerState blk) where type LedgerErr (ExtLedgerState blk) = ExtValidationError blk type AuxLedgerEvent (ExtLedgerState blk) = AuxLedgerEvent (LedgerState blk) - applyChainTickLedgerResult cfg slot (ExtLedgerState ledger header) = + applyChainTickLedgerResult evs cfg slot (ExtLedgerState ledger header) = castLedgerResult ledgerResult <&> \tickedLedgerState -> let ledgerView :: LedgerView (BlockProtocol blk) ledgerView = protocolLedgerView lcfg tickedLedgerState @@ -140,13 +140,31 @@ instance ( LedgerSupportsProtocol blk lcfg :: LedgerConfig blk lcfg = configLedger $ getExtLedgerCfg cfg - ledgerResult = applyChainTickLedgerResult lcfg slot ledger + ledgerResult = applyChainTickLedgerResult evs lcfg slot ledger -instance LedgerSupportsProtocol blk => ApplyBlock (ExtLedgerState blk) blk where - applyBlockLedgerResult cfg blk TickedExtLedgerState{..} = do +applyHelper :: + forall blk. + (HasCallStack, LedgerSupportsProtocol blk) + => ( HasCallStack + => ComputeLedgerEvents + -> LedgerCfg (LedgerState blk) + -> blk + -> Ticked (LedgerState blk) + -> Except + (LedgerErr (LedgerState blk)) + (LedgerResult (LedgerState blk) (LedgerState blk)) + ) + -> ComputeLedgerEvents + -> LedgerCfg (ExtLedgerState blk) + -> blk + -> Ticked (ExtLedgerState blk) + -> Except + (LedgerErr (ExtLedgerState blk)) + (LedgerResult (ExtLedgerState blk) (ExtLedgerState blk)) +applyHelper f opts cfg blk TickedExtLedgerState{..} = do ledgerResult <- withExcept ExtValidationErrorLedger - $ applyBlockLedgerResult + $ f opts (configLedger $ getExtLedgerCfg cfg) blk tickedLedgerState @@ -159,11 +177,18 @@ instance LedgerSupportsProtocol blk => ApplyBlock (ExtLedgerState blk) blk where tickedHeaderState pure $ (\l -> ExtLedgerState l hdr) <$> castLedgerResult ledgerResult - reapplyBlockLedgerResult cfg blk TickedExtLedgerState{..} = +instance LedgerSupportsProtocol blk => ApplyBlock (ExtLedgerState blk) blk where + applyBlockLedgerResultWithValidation doValidate = + applyHelper (applyBlockLedgerResultWithValidation doValidate) + + applyBlockLedgerResult = + applyHelper applyBlockLedgerResult + + reapplyBlockLedgerResult evs cfg blk TickedExtLedgerState{..} = (\l -> ExtLedgerState l hdr) <$> castLedgerResult ledgerResult where ledgerResult = - reapplyBlockLedgerResult + reapplyBlockLedgerResult evs (configLedger $ getExtLedgerCfg cfg) blk tickedLedgerState diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs index 90939ac31c..9077d77a19 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs @@ -83,7 +83,7 @@ _lemma_ledgerViewForecastAt_applyChainTick cfg st forecast for | NotOrigin for >= ledgerTipSlot st , let lhs = forecastFor forecast for rhs = protocolLedgerView cfg - . applyChainTick cfg for + . applyChainTick OmitLedgerEvents cfg for $ st , Right lhs' <- runExcept lhs , lhs' /= rhs diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs index 0e67f2e210..bf4e5d69e3 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs @@ -235,8 +235,8 @@ tickLedgerState :: -> ForgeLedgerState blk -> (SlotNo, TickedLedgerState blk) tickLedgerState _cfg (ForgeInKnownSlot slot st) = (slot, st) -tickLedgerState cfg (ForgeInUnknownSlot st) = - (slot, applyChainTick cfg slot st) +tickLedgerState cfg (ForgeInUnknownSlot st) = + (slot, applyChainTick OmitLedgerEvents cfg slot st) where -- Optimistically assume that the transactions will be included in a block -- in the next available slot 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 9b88506e0b..aad189ccca 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 @@ -12,6 +12,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Args ( , RelativeMountPoint (..) , completeChainDbArgs , defaultArgs + , enableLedgerEvents , ensureValidateAll , updateDiskPolicyArgs , updateTracer @@ -19,11 +20,13 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Args ( import Control.ResourceRegistry (ResourceRegistry) import Control.Tracer (Tracer, nullTracer) +import Data.Function ((&)) import Data.Functor.Contravariant ((>$<)) import Data.Kind import Data.Time.Clock (secondsToDiffTime) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config +import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB.API (GetLoEFragment, @@ -185,7 +188,10 @@ completeChainDbArgs , cdbLgrDbArgs = (cdbLgrDbArgs defArgs) { LedgerDB.lgrGenesis = pure initLedger , LedgerDB.lgrHasFS = mkVolFS $ RelativeMountPoint "ledger" - , LedgerDB.lgrConfig = LedgerDB.configLedgerDb cdbsTopLevelConfig + , LedgerDB.lgrConfig = + LedgerDB.configLedgerDb + cdbsTopLevelConfig + (LedgerDB.ledgerDbCfgComputeLedgerEvents $ LedgerDB.lgrConfig (cdbLgrDbArgs defArgs)) } , cdbsArgs = (cdbsArgs defArgs) { cdbsRegistry = registry @@ -213,6 +219,16 @@ updateDiskPolicyArgs :: updateDiskPolicyArgs spa args = args { cdbLgrDbArgs = (cdbLgrDbArgs args) { LedgerDB.lgrDiskPolicyArgs = spa } } +enableLedgerEvents :: + Complete ChainDbArgs m blk + -> Complete ChainDbArgs m blk +enableLedgerEvents args = + args { cdbLgrDbArgs = (cdbLgrDbArgs args) & \x -> + x { LedgerDB.lgrConfig = + (LedgerDB.lgrConfig x) { LedgerDB.ledgerDbCfgComputeLedgerEvents = ComputeLedgerEvents } + } + } + {------------------------------------------------------------------------------- Relative mount points -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs index c3d6ae008a..c8c5c58418 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs @@ -127,7 +127,7 @@ data LgrDbArgs f m blk = LgrDbArgs { lgrDiskPolicyArgs :: LedgerDB.DiskPolicyArgs , lgrGenesis :: HKD f (m (ExtLedgerState blk)) , lgrHasFS :: HKD f (SomeHasFS m) - , lgrConfig :: HKD f (LedgerDB.LedgerDbCfg (ExtLedgerState blk)) + , lgrConfig :: LedgerDB.LedgerDbCfgF f (ExtLedgerState blk) , lgrTracer :: Tracer m (LedgerDB.TraceSnapshotEvent blk) } @@ -137,7 +137,7 @@ defaultArgs = LgrDbArgs { lgrDiskPolicyArgs = LedgerDB.defaultDiskPolicyArgs , lgrGenesis = noDefault , lgrHasFS = noDefault - , lgrConfig = noDefault + , lgrConfig = LedgerDB.LedgerDbCfg noDefault noDefault OmitLedgerEvents , lgrTracer = nullTracer } 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 abfad3fdc6..d9377953e1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs @@ -82,7 +82,8 @@ module Ouroboros.Consensus.Storage.LedgerDB ( Checkpoint (..) , LedgerDB (..) , LedgerDB' - , LedgerDbCfg (..) + , LedgerDbCfg + , LedgerDbCfgF (..) , configLedgerDb -- * Initialization , InitLog (..) @@ -172,7 +173,8 @@ import Ouroboros.Consensus.Storage.LedgerDB.Init (InitLog (..), decorateReplayTracerWithGoal, decorateReplayTracerWithStart, initLedgerDB) import Ouroboros.Consensus.Storage.LedgerDB.LedgerDB (Checkpoint (..), - LedgerDB (..), LedgerDB', LedgerDbCfg (..), configLedgerDb) + LedgerDB (..), LedgerDB', LedgerDbCfg, LedgerDbCfgF (..), + configLedgerDb) import Ouroboros.Consensus.Storage.LedgerDB.Query (ledgerDbAnchor, ledgerDbCurrent, ledgerDbIsSaturated, ledgerDbMaxRollback, ledgerDbPast, ledgerDbSnapshots, ledgerDbTip) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/LedgerDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/LedgerDB.hs index 15e2745c26..2498353501 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/LedgerDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/LedgerDB.hs @@ -12,7 +12,8 @@ module Ouroboros.Consensus.Storage.LedgerDB.LedgerDB ( Checkpoint (..) , LedgerDB (..) , LedgerDB' - , LedgerDbCfg (..) + , LedgerDbCfg + , LedgerDbCfgF (..) , configLedgerDb ) where @@ -24,6 +25,7 @@ import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended (ExtLedgerCfg (..), ExtLedgerState) import Ouroboros.Consensus.Protocol.Abstract (ConsensusProtocol) +import Ouroboros.Consensus.Util.Args import Ouroboros.Network.AnchoredSeq (Anchorable (..), AnchoredSeq (..)) import qualified Ouroboros.Network.AnchoredSeq as AS @@ -116,19 +118,24 @@ instance GetTip l => Anchorable (WithOrigin SlotNo) (Checkpoint l) (Checkpoint l LedgerDB Config -------------------------------------------------------------------------------} -data LedgerDbCfg l = LedgerDbCfg { - ledgerDbCfgSecParam :: !SecurityParam - , ledgerDbCfg :: !(LedgerCfg l) +data LedgerDbCfgF f l = LedgerDbCfg { + ledgerDbCfgSecParam :: !(HKD f SecurityParam) + , ledgerDbCfg :: !(HKD f (LedgerCfg l)) + , ledgerDbCfgComputeLedgerEvents :: !ComputeLedgerEvents } deriving (Generic) -deriving instance NoThunks (LedgerCfg l) => NoThunks (LedgerDbCfg l) +type LedgerDbCfg l = Complete LedgerDbCfgF l + +deriving instance NoThunks (LedgerCfg l) => NoThunks (Complete LedgerDbCfgF l) configLedgerDb :: ConsensusProtocol (BlockProtocol blk) => TopLevelConfig blk + -> ComputeLedgerEvents -> LedgerDbCfg (ExtLedgerState blk) -configLedgerDb cfg = LedgerDbCfg { +configLedgerDb cfg opts = LedgerDbCfg { ledgerDbCfgSecParam = configSecurityParam cfg , ledgerDbCfg = ExtLedgerCfg cfg + , ledgerDbCfgComputeLedgerEvents = opts } diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs index d79bd72c4a..cbaaed3019 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Update.hs @@ -110,26 +110,27 @@ toRealPoint (Weaken ap) = toRealPoint ap -- -- We take in the entire 'LedgerDB' because we record that as part of errors. applyBlock :: forall m c l blk. (ApplyBlock l blk, Monad m, c) - => LedgerCfg l + => ComputeLedgerEvents + -> LedgerCfg l -> Ap m l blk c -> LedgerDB l -> m l -applyBlock cfg ap db = case ap of +applyBlock opts cfg ap db = case ap of ReapplyVal b -> return $ - tickThenReapply cfg b l + tickThenReapply opts cfg b l ApplyVal b -> either (throwLedgerError db (blockRealPoint b)) return $ runExcept $ - tickThenApply cfg b l + tickThenApply opts cfg b l ReapplyRef r -> do b <- doResolveBlock r return $ - tickThenReapply cfg b l + tickThenReapply opts cfg b l ApplyRef r -> do b <- doResolveBlock r either (throwLedgerError db r) return $ runExcept $ - tickThenApply cfg b l + tickThenApply opts cfg b l Weaken ap' -> - applyBlock cfg ap' db + applyBlock opts cfg ap' db where l :: l l = ledgerDbCurrent db @@ -293,7 +294,7 @@ ledgerDbPush :: forall m c l blk. (ApplyBlock l blk, Monad m, c) -> Ap m l blk c -> LedgerDB l -> m (LedgerDB l) ledgerDbPush cfg ap db = (\current' -> pushLedgerState (ledgerDbCfgSecParam cfg) current' db) <$> - applyBlock (ledgerDbCfg cfg) ap db + applyBlock (ledgerDbCfgComputeLedgerEvents cfg) (ledgerDbCfg cfg) ap db -- | Push a bunch of blocks (oldest first) ledgerDbPushMany :: @@ -383,4 +384,3 @@ ledgerDbSwitch' cfg n bs db = case runIdentity $ ledgerDbSwitch cfg n (const $ pure ()) (map pureBlock bs) db of Left ExceededRollback{} -> Nothing Right db' -> Just db' - From 245dce7b07b008e2c3434df417cde1d0f172c604 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Mon, 17 Feb 2025 12:51:35 +0100 Subject: [PATCH 2/2] Adapt tests to use `ValidationPolicy` and `ComputeLedgerEvents` --- .../Test/Consensus/Byron/Examples.hs | 10 +++---- .../Consensus/ByronSpec/Ledger/Ledger.hs | 14 +++------- .../Test/ThreadNet/TxGen/Cardano.hs | 6 ++--- .../Cardano/Tools/DBAnalyser/Analysis.hs | 26 +++++++++---------- .../Cardano/Tools/DBSynthesizer/Forging.hs | 1 + .../Test/ThreadNet/TxGen/Shelley.hs | 2 +- .../byron-test/Test/ThreadNet/DualByron.hs | 2 +- .../shelley-test/Test/ThreadNet/Shelley.hs | 2 +- .../Test/ThreadNet/Network.hs | 8 +++--- .../Test/Consensus/HardFork/Combinator/A.hs | 15 ++++------- .../Test/Consensus/HardFork/Combinator/B.hs | 7 ++--- .../Test/Util/ChainDB.hs | 3 ++- .../Test/Util/TestBlock.hs | 16 ++++-------- .../Ouroboros/Consensus/Mock/Ledger/Block.hs | 11 ++++---- .../Ouroboros/Consensus/Tutorial/Simple.lhs | 17 ++++++------ .../Consensus/Tutorial/WithEpoch.lhs | 19 +++++++------- .../MiniProtocol/ChainSync/Client.hs | 2 +- .../MiniProtocol/LocalStateQuery/Server.hs | 3 ++- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 7 ++--- .../Ouroboros/Storage/LedgerDB/InMemory.hs | 9 ++++--- .../Test/Ouroboros/Storage/LedgerDB/OnDisk.hs | 13 +++++++--- .../Test/Ouroboros/Storage/TestBlock.hs | 9 ++++--- 22 files changed, 99 insertions(+), 103 deletions(-) diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs index 9626d98aa9..1176d0f5b3 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs +++ b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs @@ -122,7 +122,7 @@ exampleBlock = cfg (BlockNo 1) (SlotNo 1) - (applyChainTick ledgerConfig (SlotNo 1) ledgerStateAfterEBB) + (applyChainTick OmitLedgerEvents ledgerConfig (SlotNo 1) ledgerStateAfterEBB) [ValidatedByronTx exampleGenTx] (fakeMkIsLeader leaderCredentials) where @@ -180,14 +180,14 @@ emptyLedgerState = ByronLedgerState { ledgerStateAfterEBB :: LedgerState ByronBlock ledgerStateAfterEBB = - reapplyLedgerBlock ledgerConfig exampleEBB - . applyChainTick ledgerConfig (SlotNo 0) + reapplyLedgerBlock OmitLedgerEvents ledgerConfig exampleEBB + . applyChainTick OmitLedgerEvents ledgerConfig (SlotNo 0) $ emptyLedgerState exampleLedgerState :: LedgerState ByronBlock exampleLedgerState = - reapplyLedgerBlock ledgerConfig exampleBlock - . applyChainTick ledgerConfig (SlotNo 1) + reapplyLedgerBlock OmitLedgerEvents ledgerConfig exampleBlock + . applyChainTick OmitLedgerEvents ledgerConfig (SlotNo 1) $ ledgerStateAfterEBB exampleHeaderState :: HeaderState ByronBlock diff --git a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs index 685056d3f3..379949fb89 100644 --- a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs +++ b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs @@ -33,7 +33,6 @@ import qualified Ouroboros.Consensus.ByronSpec.Ledger.Rules as Rules import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ticked -import Ouroboros.Consensus.Util ((..:)) {------------------------------------------------------------------------------- State @@ -103,7 +102,7 @@ instance IsLedger (LedgerState ByronSpecBlock) where type AuxLedgerEvent (LedgerState ByronSpecBlock) = VoidLedgerEvent (LedgerState ByronSpecBlock) - applyChainTickLedgerResult cfg slot (ByronSpecLedgerState tip state) = + applyChainTickLedgerResult _evs cfg slot (ByronSpecLedgerState tip state) = pureLedgerResult $ TickedByronSpecLedgerState { untickedByronSpecLedgerTip = tip @@ -118,7 +117,7 @@ instance IsLedger (LedgerState ByronSpecBlock) where -------------------------------------------------------------------------------} instance ApplyBlock (LedgerState ByronSpecBlock) ByronSpecBlock where - applyBlockLedgerResult cfg block (TickedByronSpecLedgerState _tip state) = + applyBlockLedgerResultWithValidation _ _ cfg block (TickedByronSpecLedgerState _tip state) = withExcept ByronSpecLedgerError $ fmap (pureLedgerResult . ByronSpecLedgerState (Just (blockSlot block))) $ -- Note that the CHAIN rule also applies the chain tick. So even @@ -131,14 +130,9 @@ instance ApplyBlock (LedgerState ByronSpecBlock) ByronSpecBlock where (byronSpecBlock block) state + applyBlockLedgerResult = defaultApplyBlockLedgerResult reapplyBlockLedgerResult = - -- The spec doesn't have a "reapply" mode - dontExpectError ..: applyBlockLedgerResult - where - dontExpectError :: Except a b -> b - dontExpectError mb = case runExcept mb of - Left _ -> error "reapplyBlockLedgerResult: unexpected error" - Right b -> b + defaultReapplyBlockLedgerResult (error . ("reapplyBlockLedgerResult: unexpected error " ++) . show) {------------------------------------------------------------------------------- CommonProtocolParams diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs index 961a7b5555..52ad5f1921 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs @@ -41,8 +41,8 @@ import Ouroboros.Consensus.HardFork.Combinator.Ledger (tickedHardForkLedgerStatePerEra) import Ouroboros.Consensus.HardFork.Combinator.State.Types (currentState, getHardForkState) -import Ouroboros.Consensus.Ledger.Basics (LedgerConfig, LedgerState, - applyChainTick) +import Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..), + LedgerConfig, LedgerState, applyChainTick) import Ouroboros.Consensus.NodeId (CoreNodeId (..)) import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock, mkShelleyTx) @@ -211,7 +211,7 @@ migrateUTxO migrationInfo curSlot lcfg lst mbUTxO = fmap getUTxOShelley $ ejectShelleyTickedLedgerState $ - applyChainTick lcfg curSlot $ + applyChainTick OmitLedgerEvents lcfg curSlot $ lst MigrationInfo 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 6dfd65d6b2..ebf78c3628 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 @@ -56,8 +56,8 @@ import Ouroboros.Consensus.Ledger.Abstract (ApplyBlock (reapplyBlockLedgerResult), LedgerCfg, LedgerConfig, applyBlockLedgerResult, applyChainTick, tickThenApply, tickThenApplyLedgerResult, tickThenReapply) -import Ouroboros.Consensus.Ledger.Basics (LedgerResult (..), - LedgerState, getTipSlot) +import Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..), + LedgerResult (..), LedgerState, getTipSlot) import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.SupportsMempool (LedgerSupportsMempool) @@ -74,7 +74,7 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.LedgerDB (DiskSnapshot (..), writeSnapshot) import Ouroboros.Consensus.Storage.Serialisation (encodeDisk) -import Ouroboros.Consensus.Util (Flag (..), (..:)) +import Ouroboros.Consensus.Util (Flag (..), (...:)) import qualified Ouroboros.Consensus.Util.IOLike as IOLike import Ouroboros.Network.SizeInBytes import System.FS.API (SomeHasFS (..)) @@ -394,7 +394,7 @@ storeLedgerStateAt slotNo ledgerAppMode doChecksum env = do process :: ExtLedgerState blk -> blk -> IO (NextStep, ExtLedgerState blk) process oldLedger blk = do let ledgerCfg = ExtLedgerCfg cfg - case runExcept $ tickThenXApply ledgerCfg blk oldLedger of + case runExcept $ tickThenXApply OmitLedgerEvents ledgerCfg blk oldLedger of Right newLedger -> do when (blockSlot blk >= slotNo) $ storeLedgerState newLedger when (blockSlot blk > slotNo) $ issueWarning blk @@ -406,7 +406,7 @@ storeLedgerStateAt slotNo ledgerAppMode doChecksum env = do pure (Stop, oldLedger) tickThenXApply = case ledgerAppMode of - LedgerReapply -> pure ..: tickThenReapply + LedgerReapply -> pure ...: tickThenReapply LedgerApply -> tickThenApply continue :: blk -> NextStep @@ -473,7 +473,7 @@ checkNoThunksEvery process :: ExtLedgerState blk -> blk -> IO (ExtLedgerState blk) process oldLedger blk = do let ledgerCfg = ExtLedgerCfg cfg - appliedResult = tickThenApplyLedgerResult ledgerCfg blk oldLedger + appliedResult = tickThenApplyLedgerResult OmitLedgerEvents ledgerCfg blk oldLedger newLedger = either (error . show) lrResult $ runExcept $ appliedResult bn = blockNo blk when (unBlockNo bn `mod` nBlocks == 0 ) $ IOLike.evaluate (ledgerState newLedger) >>= checkNoThunks bn @@ -511,7 +511,7 @@ traceLedgerProcessing -> IO (ExtLedgerState blk) process oldLedger blk = do let ledgerCfg = ExtLedgerCfg cfg - appliedResult = tickThenApplyLedgerResult ledgerCfg blk oldLedger + appliedResult = tickThenApplyLedgerResult OmitLedgerEvents ledgerCfg blk oldLedger newLedger = either (error . show) lrResult $ runExcept $ appliedResult traces = (HasAnalysis.emitTraces $ @@ -667,18 +667,18 @@ benchmarkLedgerOps mOutfile ledgerAppMode AnalysisEnv {db, registry, startFrom, -> ExtLedgerState blk -> IO (Ticked (LedgerState blk)) tickTheLedgerState slot st = - pure $ applyChainTick lcfg slot (ledgerState st) + pure $ applyChainTick OmitLedgerEvents lcfg slot (ledgerState st) applyTheBlock :: Ticked (LedgerState blk) -> IO (LedgerState blk) applyTheBlock tickedLedgerSt = case ledgerAppMode of LedgerApply -> - case runExcept (lrResult <$> applyBlockLedgerResult lcfg blk tickedLedgerSt) of + case runExcept (lrResult <$> applyBlockLedgerResult OmitLedgerEvents lcfg blk tickedLedgerSt) of Left err -> fail $ "benchmark doesn't support invalid blocks: " <> show rp <> " " <> show err Right x -> pure x LedgerReapply -> - pure $! lrResult $ reapplyBlockLedgerResult lcfg blk tickedLedgerSt + pure $! lrResult $ reapplyBlockLedgerResult OmitLedgerEvents lcfg blk tickedLedgerSt withFile :: Maybe FilePath -> (IO.Handle -> IO r) -> IO r withFile (Just outfile) = IO.withFile outfile IO.WriteMode @@ -707,7 +707,7 @@ getBlockApplicationMetrics (NumberOfBlocks nrBlocks) mOutFile env = do process :: IO.Handle -> ExtLedgerState blk -> blk -> IO (ExtLedgerState blk) process outFileHandle currLedgerSt blk = do - let nextLedgerSt = tickThenReapply (ExtLedgerCfg cfg) blk currLedgerSt + let nextLedgerSt = tickThenReapply OmitLedgerEvents (ExtLedgerCfg cfg) blk currLedgerSt when (unBlockNo (blockNo blk) `mod` nrBlocks == 0) $ do let blockApplication = HasAnalysis.WithLedgerState blk @@ -830,7 +830,7 @@ reproMempoolForge numBlks env = do do let slot = blockSlot blk (ticked, durTick, mutTick, gcTick) <- timed $ IOLike.evaluate $ - applyChainTick lCfg slot (ledgerState st) + applyChainTick OmitLedgerEvents lCfg slot (ledgerState st) ((), durSnap, mutSnap, gcSnap) <- timed $ IOLike.atomically $ do snap <- Mempool.getSnapshotFor mempool $ Mempool.ForgeInKnownSlot slot ticked @@ -858,7 +858,7 @@ reproMempoolForge numBlks env = do -- since it currently matches the call in the forging thread, which is -- the primary intention of this Analysis. Maybe GHC's CSE is already -- doing this sharing optimization? - IOLike.atomically $ IOLike.writeTVar ref $! tickThenReapply elCfg blk st + IOLike.atomically $ IOLike.writeTVar ref $! tickThenReapply OmitLedgerEvents elCfg blk st -- this flushes blk from the mempool, since every tx in it is now on the chain void $ Mempool.syncWithLedger mempool diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs index f49771ea4a..1b15158cb9 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs @@ -160,6 +160,7 @@ runForge epochSize_ nextSlot opts chainDB blockForging cfg genTxs = do let tickedLedgerState :: Ticked (LedgerState blk) tickedLedgerState = applyChainTick + OmitLedgerEvents (configLedger cfg) currentSlot (ledgerState unticked) diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/TxGen/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/TxGen/Shelley.hs index 90d8dd5dad..9e47eb74bc 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/TxGen/Shelley.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/TxGen/Shelley.hs @@ -62,7 +62,7 @@ instance HashAlgorithm h => TxGen (ShelleyBlock (TPraos (MockCrypto h)) (MockShe then pure [] else do n <- choose (0, 20) - go [] n $ applyChainTick lcfg curSlotNo lst + go [] n $ applyChainTick OmitLedgerEvents lcfg curSlotNo lst where ShelleyTxGenExtra { stgeGenEnv 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 d06d4ef4dc..f0daf083ad 100644 --- a/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs +++ b/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs @@ -257,7 +257,7 @@ byronPBftParams ByronSpecGenesis{..} = instance TxGen DualByronBlock where testGenTxs _coreNodeId _numCoreNodes curSlotNo cfg () = \st -> do n <- choose (0, 20) - go [] n $ applyChainTick (configLedger cfg) curSlotNo st + go [] n $ applyChainTick OmitLedgerEvents (configLedger cfg) curSlotNo st where -- Attempt to produce @n@ transactions -- Stops when the transaction generator cannot produce more txs 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 c75fb66f8f..fadf7e5a03 100644 --- a/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs +++ b/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs @@ -314,7 +314,7 @@ prop_simple_real_tpraos_convergence TestSetup -- slots to reach the epoch transition but the last several -- slots end up empty. Shelley.tickedShelleyLedgerState $ - applyChainTick ledgerConfig sentinel lsUnticked + applyChainTick OmitLedgerEvents ledgerConfig sentinel lsUnticked msg = "The ticked final ledger state of " <> show nid <> 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 d7dd9e75cc..727cbb7f08 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 @@ -622,11 +622,11 @@ runThreadNetwork systemTime ThreadNetworkArgs snap1 <- getSnapshotFor mempool $ -- This node would include these crucial txs if it leads in -- this slot. - ForgeInKnownSlot slot $ applyChainTick lcfg slot ledger + ForgeInKnownSlot slot $ applyChainTick OmitLedgerEvents lcfg slot ledger snap2 <- getSnapshotFor mempool $ -- Other nodes might include these crucial txs when leading -- in the next slot. - ForgeInKnownSlot (succ slot) $ applyChainTick lcfg (succ slot) ledger + ForgeInKnownSlot (succ slot) $ applyChainTick OmitLedgerEvents lcfg (succ slot) ledger -- This loop will repeat for the next slot, so we only need to -- check for this one and the next. pure (snap1, snap2) @@ -887,10 +887,10 @@ runThreadNetwork systemTime ThreadNetworkArgs -- fail if the EBB is invalid -- if it is valid, we retick to the /same/ slot - let apply = applyLedgerBlock (configLedger pInfoConfig) + let apply = applyLedgerBlock OmitLedgerEvents (configLedger pInfoConfig) tickedLdgSt' <- case Exc.runExcept $ apply ebb tickedLdgSt of Left e -> Exn.throw $ JitEbbError @blk e - Right st -> pure $ applyChainTick + Right st -> pure $ applyChainTick OmitLedgerEvents (configLedger pInfoConfig) currentSlot st diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs index 4aa3b65074..a5d83d4182 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs @@ -41,7 +41,6 @@ module Test.Consensus.HardFork.Combinator.A ( import Cardano.Slotting.EpochInfo import Codec.Serialise import Control.Monad (guard) -import Control.Monad.Except (runExcept) import qualified Data.Binary as B import Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy @@ -81,7 +80,7 @@ import Ouroboros.Consensus.Node.Serialisation import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo) import Ouroboros.Consensus.Storage.Serialisation -import Ouroboros.Consensus.Util (repeatedlyM, (..:), (.:)) +import Ouroboros.Consensus.Util (repeatedlyM, (.:)) import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Network.Block (Serialised, unwrapCBORinCBOR, @@ -213,10 +212,10 @@ instance IsLedger (LedgerState BlockA) where type AuxLedgerEvent (LedgerState BlockA) = VoidLedgerEvent (LedgerState BlockA) - applyChainTickLedgerResult _ _ = pureLedgerResult . TickedLedgerStateA + applyChainTickLedgerResult _ _ _ = pureLedgerResult . TickedLedgerStateA instance ApplyBlock (LedgerState BlockA) BlockA where - applyBlockLedgerResult cfg blk = + applyBlockLedgerResultWithValidation _ _ cfg blk = fmap (pureLedgerResult . setTip) . repeatedlyM (fmap fst .: applyTx cfg DoNotIntervene (blockSlot blk)) @@ -225,13 +224,9 @@ instance ApplyBlock (LedgerState BlockA) BlockA where setTip :: TickedLedgerState BlockA -> LedgerState BlockA setTip (TickedLedgerStateA st) = st { lgrA_tip = blockPoint blk } + applyBlockLedgerResult = defaultApplyBlockLedgerResult reapplyBlockLedgerResult = - dontExpectError ..: applyBlockLedgerResult - where - dontExpectError :: Except a b -> b - dontExpectError mb = case runExcept mb of - Left _ -> error "reapplyBlockLedgerResult: unexpected error" - Right b -> b + defaultReapplyBlockLedgerResult absurd instance UpdateLedger BlockA diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs index 7c45c64137..7d4bbbe075 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs @@ -186,11 +186,12 @@ instance IsLedger (LedgerState BlockB) where type AuxLedgerEvent (LedgerState BlockB) = VoidLedgerEvent (LedgerState BlockB) - applyChainTickLedgerResult _ _ = pureLedgerResult . TickedLedgerStateB + applyChainTickLedgerResult _ _ _ = pureLedgerResult . TickedLedgerStateB instance ApplyBlock (LedgerState BlockB) BlockB where - applyBlockLedgerResult = \_ b _ -> return $ pureLedgerResult $ LgrB (blockPoint b) - reapplyBlockLedgerResult = \_ b _ -> pureLedgerResult $ LgrB (blockPoint b) + applyBlockLedgerResultWithValidation = \_ _ _ b _ -> return $ pureLedgerResult $ LgrB (blockPoint b) + applyBlockLedgerResult = defaultApplyBlockLedgerResult + reapplyBlockLedgerResult = defaultReapplyBlockLedgerResult absurd instance UpdateLedger BlockB diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs index 493bc743c8..190c1df05d 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs @@ -19,6 +19,7 @@ import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Config (TopLevelConfig (topLevelConfigLedger), configCodec) import Ouroboros.Consensus.HardFork.History.EraParams (eraEpochSize) +import Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..)) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB hiding @@ -117,7 +118,7 @@ fromMinimalChainDbArgs MinimalChainDbArgs {..} = ChainDbArgs { , lgrGenesis = return mcdbInitLedger , lgrHasFS = SomeHasFS $ simHasFS (nodeDBsLgr mcdbNodeDBs) , lgrTracer = nullTracer - , lgrConfig = configLedgerDb mcdbTopLevelConfig + , lgrConfig = configLedgerDb mcdbTopLevelConfig OmitLedgerEvents } , cdbsArgs = ChainDbSpecificArgs { cdbsBlocksToAddSize = 1 diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index 5ed7674f03..75c68e9d54 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -490,7 +490,7 @@ instance ( Typeable ptype instance PayloadSemantics ptype => ApplyBlock (LedgerState (TestBlockWith ptype)) (TestBlockWith ptype) where - applyBlockLedgerResult _ tb@TestBlockWith{..} (TickedTestLedger TestLedger{..}) + applyBlockLedgerResultWithValidation _validation _events _ tb@TestBlockWith{..} (TickedTestLedger TestLedger{..}) | blockPrevHash tb /= pointHash lastAppliedPoint = throwError $ InvalidHash (pointHash lastAppliedPoint) (blockPrevHash tb) | tbValid == Invalid @@ -504,15 +504,9 @@ instance PayloadSemantics ptype , payloadDependentState = st' } - reapplyBlockLedgerResult _ tb@TestBlockWith{..} (TickedTestLedger TestLedger{..}) = - case applyPayload payloadDependentState tbPayload of - Left err -> error $ "Found an error when reapplying a block: " ++ show err - Right st' -> pureLedgerResult - $ TestLedger { - lastAppliedPoint = Chain.blockPoint tb - , payloadDependentState = st' - } - + applyBlockLedgerResult = defaultApplyBlockLedgerResult + reapplyBlockLedgerResult = + defaultReapplyBlockLedgerResult (error . ("Found an error when reapplying a block: " ++) . show) data instance LedgerState (TestBlockWith ptype) = TestLedger { @@ -573,7 +567,7 @@ instance PayloadSemantics ptype => IsLedger (LedgerState (TestBlockWith ptype)) type AuxLedgerEvent (LedgerState (TestBlockWith ptype)) = VoidLedgerEvent (LedgerState (TestBlockWith ptype)) - applyChainTickLedgerResult _ _ = pureLedgerResult . TickedTestLedger + applyChainTickLedgerResult _ _ _ = pureLedgerResult . TickedTestLedger instance PayloadSemantics ptype => UpdateLedger (TestBlockWith ptype) diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs index f6db8e90cf..fb7f07e4b1 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs @@ -351,17 +351,16 @@ instance MockProtocolSpecific c ext type AuxLedgerEvent (LedgerState (SimpleBlock c ext)) = VoidLedgerEvent (SimpleBlock c ext) - applyChainTickLedgerResult _ _ = pureLedgerResult . TickedSimpleLedgerState + applyChainTickLedgerResult _ _ _ = pureLedgerResult . TickedSimpleLedgerState instance MockProtocolSpecific c ext => ApplyBlock (LedgerState (SimpleBlock c ext)) (SimpleBlock c ext) where - applyBlockLedgerResult = fmap pureLedgerResult ..: updateSimpleLedgerState + applyBlockLedgerResultWithValidation _validation _events = + fmap pureLedgerResult ..: updateSimpleLedgerState + applyBlockLedgerResult = defaultApplyBlockLedgerResult reapplyBlockLedgerResult = - (mustSucceed . runExcept) ..: applyBlockLedgerResult - where - mustSucceed (Left err) = error ("reapplyBlockLedgerResult: unexpected error: " <> show err) - mustSucceed (Right st) = st + defaultReapplyBlockLedgerResult (error . ("reapplyBlockLedgerResult: unexpected error: " <>) . show) newtype instance LedgerState (SimpleBlock c ext) = SimpleLedgerState { simpleLedgerState :: MockState (SimpleBlock c ext) diff --git a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs index 69af4e6f8d..70ecf79b78 100644 --- a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs +++ b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs @@ -36,7 +36,7 @@ This example uses several extensions: First, some imports we'll need: -> import Data.Void(Void) +> import Data.Void(Void, absurd) > import Data.Set(Set) > import qualified Data.Set as Set > import Data.Word(Word64, Word8) @@ -56,7 +56,8 @@ First, some imports we'll need: > import Ouroboros.Consensus.Ledger.Abstract > (GetTip(..), IsLedger(..), LedgerCfg, > LedgerResult(LedgerResult, lrEvents, lrResult), -> LedgerState, ApplyBlock(..), UpdateLedger) +> LedgerState, ApplyBlock(..), UpdateLedger, +> defaultApplyBlockLedgerResult, defaultReapplyBlockLedgerResult) > import Ouroboros.Consensus.Ledger.SupportsProtocol > (LedgerSupportsProtocol(..)) > import Ouroboros.Consensus.Forecast (trivialForecast) @@ -559,7 +560,8 @@ types for a ledger. Though we are here using > type instance LedgerErr (LedgerState BlockC) = Void > type instance AuxLedgerEvent (LedgerState BlockC) = Void > -> applyChainTickLedgerResult _cfg _slot ldgrSt = + +> applyChainTickLedgerResult _events _cfg _slot ldgrSt = > LedgerResult { lrEvents = [] > , lrResult = TickedLedgerStateC ldgrSt > } @@ -609,17 +611,14 @@ The interface used by the rest of the ledger infrastructure to access this is the `ApplyBlock` typeclass: > instance ApplyBlock (LedgerState BlockC) BlockC where -> applyBlockLedgerResult _ldgrCfg block tickedLdgrSt = +> applyBlockLedgerResultWithValidation _validation _events _ldgrCfg block tickedLdgrSt = > pure $ LedgerResult { lrEvents = [] > , lrResult = block `applyBlockTo` tickedLdgrSt > } > -> reapplyBlockLedgerResult _ldgrCfg block tickedLdgrSt = -> LedgerResult { lrEvents = [] -> , lrResult = block `applyBlockTo` tickedLdgrSt -> } -> > +> applyBlockLedgerResult = defaultApplyBlockLedgerResult +> reapplyBlockLedgerResult = defaultReapplyBlockLedgerResult absurd `applyBlockLedgerResult` tries to apply a block to the ledger and fails with a `LedgerErr` corresponding to the particular `LedgerState blk` if for whatever diff --git a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs index bc8345b871..f3b47d17f9 100644 --- a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs +++ b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs @@ -57,6 +57,7 @@ And imports, of course: > import Control.Monad () > import Control.Monad.Except (MonadError (throwError)) > import Data.Word (Word64) +> import Data.Void (Void, absurd) > import GHC.Generics (Generic) > import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) > import Data.Hashable (Hashable (hash)) @@ -77,8 +78,9 @@ And imports, of course: > import Ouroboros.Consensus.Ticked (Ticked) > import Ouroboros.Consensus.Ledger.Abstract > (LedgerState, LedgerCfg, GetTip, LedgerResult (..), ApplyBlock (..), -> UpdateLedger, IsLedger (..)) -> +> UpdateLedger, IsLedger (..), defaultApplyBlockLedgerResult, +> defaultReapplyBlockLedgerResult) + > import Ouroboros.Consensus.Ledger.SupportsMempool () > import Ouroboros.Consensus.Ledger.SupportsProtocol > (LedgerSupportsProtocol (..)) @@ -371,10 +373,11 @@ blocks are applied during the span of time represented by the slot argument. We can now use `tickLedgerStateD` to instantiate `IsLedger`: > instance IsLedger (LedgerState BlockD) where -> type instance LedgerErr (LedgerState BlockD) = String +> type instance LedgerErr (LedgerState BlockD) = Void > type instance AuxLedgerEvent (LedgerState BlockD) = () > -> applyChainTickLedgerResult _cfg slot ldgrSt = + +> applyChainTickLedgerResult _events _cfg slot ldgrSt = > LedgerResult { lrEvents = [] > , lrResult = tickLedgerStateD slot ldgrSt > } @@ -403,15 +406,13 @@ applying each individual transaction - exactly as it was in for `BlockC`: > Dec -> i - 1 > instance ApplyBlock (LedgerState BlockD) BlockD where -> applyBlockLedgerResult _ldgrCfg b tickedLdgrSt = +> applyBlockLedgerResultWithValidation _validation _events _ldgrCfg b tickedLdgrSt = > pure LedgerResult { lrResult = b `applyBlockTo` tickedLdgrSt > , lrEvents = [] > } > -> reapplyBlockLedgerResult _ldgrCfg b tickedLdgrSt = -> LedgerResult { lrResult = b `applyBlockTo` tickedLdgrSt -> , lrEvents = [] -> } +> applyBlockLedgerResult = defaultApplyBlockLedgerResult +> reapplyBlockLedgerResult = defaultReapplyBlockLedgerResult absurd Note that prior to `applyBlockLedgerResult` being invoked, the calling code will have already established that the header is valid and that the header matches diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs index 63e810a572..b07cababbc 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs @@ -776,7 +776,7 @@ computePastLedger cfg pt chain | castPoint (getTip st) == pt = st | blk:blks' <- blks - = go (tickThenReapply (ExtLedgerCfg cfg) blk st) blks' + = go (tickThenReapply OmitLedgerEvents (ExtLedgerCfg cfg) blk st) blks' | otherwise = error "point not in the list of blocks" diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs index 5310647fd7..292867fb56 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs @@ -29,6 +29,7 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Config import qualified Ouroboros.Consensus.HardFork.History as HardFork +import Ouroboros.Consensus.Ledger.Basics import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Query (Query (..)) import Ouroboros.Consensus.MiniProtocol.LocalStateQuery.Server @@ -216,7 +217,7 @@ initLgrDB k chain = do blockMapping = Map.fromList [(blockRealPoint b, b) | b <- Chain.toOldestFirst chain] - cfg = configLedgerDb $ testCfg k + cfg = configLedgerDb (testCfg k) OmitLedgerEvents genesisLedgerDB = LgrDB.ledgerDbWithAnchor testInitExtLedger diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs index 0e277dde9d..b7e5ec6713 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -350,8 +350,9 @@ getLedgerDB cfg m@Model{..} = k = configSecurityParam cfg ledgerDbCfg = LedgerDbCfg { - ledgerDbCfgSecParam = k - , ledgerDbCfg = ExtLedgerCfg cfg + ledgerDbCfgSecParam = k + , ledgerDbCfg = ExtLedgerCfg cfg + , ledgerDbCfgComputeLedgerEvents = OmitLedgerEvents } getLoEFragment :: Model blk -> LoE (AnchoredFragment blk) @@ -741,7 +742,7 @@ validate cfg Model { initLedger, invalid } chain = go ledger validPrefix = \case -- Return 'mbFinal' if it contains an "earlier" result [] -> ValidatedChain validPrefix ledger invalid - b:bs' -> case runExcept (tickThenApply (ExtLedgerCfg cfg) b ledger) of + b:bs' -> case runExcept (tickThenApply OmitLedgerEvents (ExtLedgerCfg cfg) b ledger) of -- Invalid block according to the ledger Left e -> ValidatedChain diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/InMemory.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/InMemory.hs index 2904da9c0a..a6e606e115 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/InMemory.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/InMemory.hs @@ -140,7 +140,7 @@ prop_pushExpectedLedger :: ChainSetup -> Property prop_pushExpectedLedger setup@ChainSetup{..} = classify (chainSetupSaturated setup) "saturated" $ conjoin [ - l === refoldLedger cfg (expectedChain o) testInitLedger + l === refoldLedger OmitLedgerEvents cfg (expectedChain o) testInitLedger | (o, l) <- ledgerDbSnapshots csPushed ] where @@ -206,7 +206,7 @@ prop_switchExpectedLedger :: SwitchSetup -> Property prop_switchExpectedLedger setup@SwitchSetup{..} = classify (switchSetupSaturated setup) "saturated" $ conjoin [ - l === refoldLedger cfg (expectedChain o) testInitLedger + l === refoldLedger OmitLedgerEvents cfg (expectedChain o) testInitLedger | (o, l) <- ledgerDbSnapshots ssSwitched ] where @@ -274,10 +274,11 @@ csBlockConfig = csBlockConfig' . csSecParam csBlockConfig' :: SecurityParam -> LedgerDbCfg (LedgerState TestBlock) csBlockConfig' secParam = LedgerDbCfg { - ledgerDbCfgSecParam = secParam - , ledgerDbCfg = + ledgerDbCfgSecParam = secParam + , ledgerDbCfg = testBlockLedgerConfigFrom $ HardFork.defaultEraParams secParam slotLength + , ledgerDbCfgComputeLedgerEvents = OmitLedgerEvents } where slotLength = slotLengthFromSec 20 diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs index 37f2092dd3..eb41f63b9e 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs @@ -256,8 +256,15 @@ genBlockFromLedgerState = pure . genBlock . lastAppliedPoint . ledgerState extLedgerDbConfig :: SecurityParam -> LedgerDbCfg (ExtLedgerState TestBlock) extLedgerDbConfig secParam = LedgerDbCfg { - ledgerDbCfgSecParam = secParam - , ledgerDbCfg = ExtLedgerCfg $ singleNodeTestConfigWith TestBlockCodecConfig TestBlockStorageConfig secParam (GenesisWindow (2 * maxRollbacks secParam)) + ledgerDbCfgSecParam = secParam + , ledgerDbCfg = + ExtLedgerCfg $ + singleNodeTestConfigWith + TestBlockCodecConfig + TestBlockStorageConfig + secParam + (GenesisWindow (2 * maxRollbacks secParam)) + , ledgerDbCfgComputeLedgerEvents = OmitLedgerEvents } @@ -579,7 +586,7 @@ runMock cmd initMock = push :: TestBlock -> StateT MockLedger (Except (ExtValidationError TestBlock)) () push b = do ls <- State.get - l' <- State.lift $ tickThenApply (ledgerDbCfg cfg) b (cur ls) + l' <- State.lift $ tickThenApply (ledgerDbCfgComputeLedgerEvents cfg) (ledgerDbCfg cfg) b (cur ls) State.put ((b, l'):ls) switch :: Word64 diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs index 979dabf525..128c15098d 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs @@ -556,10 +556,10 @@ instance IsLedger (LedgerState TestBlock) where type AuxLedgerEvent (LedgerState TestBlock) = VoidLedgerEvent (LedgerState TestBlock) - applyChainTickLedgerResult _ _ = pureLedgerResult . TickedTestLedger + applyChainTickLedgerResult _ _ _ = pureLedgerResult . TickedTestLedger instance ApplyBlock (LedgerState TestBlock) TestBlock where - applyBlockLedgerResult _ tb@TestBlock{..} (TickedTestLedger TestLedger{..}) + applyBlockLedgerResultWithValidation _ _ _ tb@TestBlock{..} (TickedTestLedger TestLedger{..}) | blockPrevHash tb /= lastAppliedHash = throwError $ InvalidHash lastAppliedHash (blockPrevHash tb) | not $ tbIsValid testBody @@ -567,8 +567,9 @@ instance ApplyBlock (LedgerState TestBlock) TestBlock where | otherwise = return $ pureLedgerResult $ TestLedger (Chain.blockPoint tb) (BlockHash (blockHash tb)) - reapplyBlockLedgerResult _ tb _ = - pureLedgerResult $ TestLedger (Chain.blockPoint tb) (BlockHash (blockHash tb)) + applyBlockLedgerResult = defaultApplyBlockLedgerResult + reapplyBlockLedgerResult = + defaultReapplyBlockLedgerResult (error . ("reapplyBlockLedgerResult: impossible " <>) . show) data instance LedgerState TestBlock = TestLedger {