From d4557e7ff0359f320e5edeeb4ac114b72426724c Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 11 Feb 2025 17:22:20 +0100 Subject: [PATCH] WIP2 --- .../Consensus/Byron/Ledger/Ledger.hs | 23 ++-- .../byron/Ouroboros/Consensus/Byron/Node.hs | 8 +- .../Ouroboros/Consensus/Cardano/Node.hs | 2 +- .../Consensus/Shelley/Ledger/Ledger.hs | 123 +++++++++--------- .../Consensus/Shelley/Node/TPraos.hs | 8 +- .../Consensus/HardFork/Combinator/Ledger.hs | 49 +++---- .../Ouroboros/Consensus/HeaderStateHistory.hs | 2 +- .../Ouroboros/Consensus/Ledger/Abstract.hs | 46 ++++--- .../Ouroboros/Consensus/Ledger/Basics.hs | 8 ++ .../Ouroboros/Consensus/Ledger/Dual.hs | 19 ++- .../Ouroboros/Consensus/Ledger/Extended.hs | 10 +- .../Consensus/Storage/LedgerDB/Update.hs | 4 +- 12 files changed, 155 insertions(+), 147 deletions(-) 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 538784ce2b..df78db8dfb 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 @@ -174,7 +174,7 @@ instance IsLedger (LedgerState ByronBlock) where type AuxLedgerEvent (LedgerState ByronBlock) = VoidLedgerEvent (LedgerState ByronBlock) - type STSOptions (LedgerState ByronBlock) = () + type STSOptions (LedgerState ByronBlock) = CC.ValidationMode applyChainTickLedgerResult _ cfg slotNo ByronLedgerState{..} = pureLedgerResult $ TickedByronLedgerState { @@ -184,20 +184,25 @@ instance IsLedger (LedgerState ByronBlock) where byronLedgerTransition } + fastSTSOpts _ = CC.fromBlockValidationMode CC.NoBlockValidation + accurateSTSOpts _ = CC.fromBlockValidationMode CC.BlockValidation + enableSTSEvents _ = id + +deriving instance Generic CC.ValidationMode +instance NoThunks CC.ValidationMode +deriving instance Generic CC.BlockValidationMode +instance NoThunks CC.BlockValidationMode +deriving instance Generic CC.TxValidationMode +instance NoThunks CC.TxValidationMode + {------------------------------------------------------------------------------- Supporting the various consensus interfaces -------------------------------------------------------------------------------} instance ApplyBlock (LedgerState ByronBlock) ByronBlock where - applyBlockLedgerResult _ = fmap pureLedgerResult ..: applyByronBlock validationMode - where - validationMode = CC.fromBlockValidationMode CC.BlockValidation + applyBlockLedgerResult sts = fmap pureLedgerResult ..: applyByronBlock sts - reapplyBlockLedgerResult _ = - (pureLedgerResult . validationErrorImpossible) - ..: applyByronBlock validationMode - where - validationMode = CC.fromBlockValidationMode CC.NoBlockValidation + reapplyResult _ = validationErrorImpossible data instance BlockQuery ByronBlock :: Type -> Type where GetUpdateInterfaceState :: BlockQuery ByronBlock UPI.State diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs index cbb6eaa5ca..b3701b951d 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Node.hs @@ -25,6 +25,7 @@ module Ouroboros.Consensus.Byron.Node ( , protocolInfoByron ) where +import qualified Cardano.Chain.ValidationMode as Validation import qualified Cardano.Chain.Delegation as Delegation import qualified Cardano.Chain.Genesis as Genesis import Cardano.Chain.ProtocolConstants (kEpochSlots) @@ -178,13 +179,16 @@ data ProtocolParamsByron = ProtocolParamsByron { } protocolInfoByron :: ProtocolParamsByron + -> Validation.ValidationMode -> ProtocolInfo ByronBlock protocolInfoByron ProtocolParamsByron { byronGenesis = genesisConfig , byronPbftSignatureThreshold = mSigThresh , byronProtocolVersion = pVer , byronSoftwareVersion = sVer - } = + } + sts + = ProtocolInfo { pInfoConfig = TopLevelConfig { topLevelConfigProtocol = PBftConfig { @@ -195,7 +199,7 @@ protocolInfoByron ProtocolParamsByron { , topLevelConfigCodec = mkByronCodecConfig compactedGenesisConfig , topLevelConfigStorage = ByronStorageConfig blockConfig , topLevelConfigCheckpoints = emptyCheckpointsMap - , topLevelConfigSTS = () + , topLevelConfigSTS = sts } , pInfoInitLedger = ExtLedgerState { -- Important: don't pass the compacted genesis config to 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 ecef89ad39..83ca7d2042 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 @@ -532,7 +532,7 @@ protocolInfoCardano paramsCardano , topLevelConfigBlock = blockConfigByron } , pInfoInitLedger = initExtLedgerStateByron - } = protocolInfoByron byronProtocolParams + } = protocolInfoByron byronProtocolParams undefined partialConsensusConfigByron :: PartialConsensusConfig (BlockProtocol ByronBlock) partialConsensusConfigByron = consensusConfigByron 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 fe319f4d51..1e94eee36f 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 @@ -45,7 +45,8 @@ module Ouroboros.Consensus.Shelley.Ledger.Ledger ( , encodeShelleyAnnTip , encodeShelleyHeaderState , encodeShelleyLedgerState - , someEpSing +-- , someEpSing + , SomeSTSOpts (..) ) where import qualified Cardano.Ledger.BaseTypes as SL (epochInfoPure) @@ -275,28 +276,43 @@ untickedShelleyLedgerTipPoint :: -> Point (ShelleyBlock proto era) untickedShelleyLedgerTipPoint = shelleyTipToPoint . untickedShelleyLedgerTip -data SomeEPSing where - SomeEPSing :: STS.EventReturnTypeRep ep => STS.SingEP ep -> SomeEPSing +data SomeSTSOpts where + SomeSTSOpts :: (NoThunks (STS.SingEP ep), STS.EventReturnTypeRep ep) => STS.ApplySTSOpts ep -> SomeSTSOpts -someEpSing doEvents = if doEvents then SomeEPSing STS.EPReturn else SomeEPSing STS.EPDiscard +instance NoThunks (STS.SingEP STS.EventPolicyReturn) where + wNoThunks _ STS.EPReturn = pure Nothing + showTypeOf _ = "SingEP EventPolicyReturn" -instance NoThunks SomeEPSing where - wNoThunks = undefined - showTypeOf = undefined +instance NoThunks (STS.SingEP STS.EventPolicyDiscard) where + wNoThunks _ STS.EPDiscard = pure Nothing + showTypeOf _ = "SingEP EventPolicyDiscard" + +deriving instance Generic (STS.ApplySTSOpts ep) +deriving instance NoThunks (STS.SingEP ep) => NoThunks (STS.ApplySTSOpts ep) + +deriving instance Generic STS.AssertionPolicy +deriving instance Generic STS.ValidationPolicy + +deriving instance NoThunks STS.AssertionPolicy +deriving instance NoThunks STS.ValidationPolicy + +instance NoThunks SomeSTSOpts where + wNoThunks ctxt (SomeSTSOpts ep) = wNoThunks ctxt ep + showTypeOf _ = "SomeSTSOpts" instance ShelleyBasedEra era => IsLedger (LedgerState (ShelleyBlock proto era)) where type LedgerErr (LedgerState (ShelleyBlock proto era)) = ShelleyLedgerError era type AuxLedgerEvent (LedgerState (ShelleyBlock proto era)) = ShelleyLedgerEvent era - type STSOptions (LedgerState (ShelleyBlock proto era)) = SomeEPSing + type STSOptions (LedgerState (ShelleyBlock proto era)) = SomeSTSOpts - applyChainTickLedgerResult (SomeEPSing ep) cfg slotNo ShelleyLedgerState{ + applyChainTickLedgerResult (SomeSTSOpts opts@(STS.ApplySTSOpts _ _ ep)) cfg slotNo ShelleyLedgerState{ shelleyLedgerTip , shelleyLedgerState , shelleyLedgerTransition } = - swizzle ep (appTick ep) <&> \l' -> + swizzle ep (appTick opts) <&> \l' -> TickedShelleyLedgerState { untickedShelleyLedgerTip = shelleyLedgerTip @@ -330,19 +346,29 @@ instance ShelleyBasedEra era => IsLedger (LedgerState (ShelleyBlock proto era)) } appTick :: - STS.SingEP ep + STS.ApplySTSOpts ep -> STS.EventReturnType ep (Core.EraRule "TICK" era) (SL.NewEpochState era) appTick ep' = SL.applyTickOpts - STS.ApplySTSOpts { - asoAssertions = STS.globalAssertionPolicy - , asoValidation = STS.ValidateAll - , asoEvents = ep' - } + ep' globals shelleyLedgerState slotNo + fastSTSOpts _ = SomeSTSOpts $ STS.ApplySTSOpts { + asoAssertions = STS.AssertionsOff + , asoValidation = STS.ValidateNone + , asoEvents = STS.EPDiscard + } + + accurateSTSOpts _ = SomeSTSOpts $ STS.ApplySTSOpts { + asoAssertions = STS.globalAssertionPolicy + , asoValidation = STS.ValidateAll + , asoEvents = STS.EPDiscard + } + + enableSTSEvents _ (SomeSTSOpts opts) = SomeSTSOpts $ opts { STS.asoEvents = STS.EPReturn } + -- | All events emitted by the Shelley ledger API data ShelleyLedgerEvent era = -- | An event emitted when (re)applying a block @@ -362,13 +388,17 @@ instance ShelleyCompatible proto era -- - 'updateChainDepState': executes the @PRTCL@ transition -- + 'applyBlockLedgerResult': executes the @BBODY@ transition -- - applyBlockLedgerResult (SomeEPSing ep) cfg = - applyHelper (swizzle ep ..: (appBlk ep)) cfg + applyBlockLedgerResult (SomeSTSOpts opts@(STS.ApplySTSOpts _ _ ep)) cfg = + applyHelper (swizzle ep ..: appBlk opts) cfg where swizzle :: STS.SingEP ep - -> Except (SL.BlockTransitionError era) (STS.EventReturnType ep (Core.EraRule "BBODY" era) (SL.NewEpochState era)) - -> Except (ShelleyLedgerError era) (LedgerResult (LedgerState (ShelleyBlock proto era)) (SL.NewEpochState era)) + -> Except + (SL.BlockTransitionError era) + (STS.EventReturnType ep (Core.EraRule "BBODY" era) (SL.NewEpochState era)) + -> Except + (ShelleyLedgerError era) + (LedgerResult (LedgerState (ShelleyBlock proto era)) (SL.NewEpochState era)) swizzle STS.EPDiscard m = withExcept BBodyError m <&> \l -> LedgerResult { @@ -386,58 +416,21 @@ instance ShelleyCompatible proto era -- Apply the BBODY transition using the ticked state appBlk :: STS.EventReturnTypeRep ep - => STS.SingEP ep + => STS.ApplySTSOpts ep -> SL.Globals -> SL.NewEpochState era -> SL.Block (SL.BHeaderView (ProtoCrypto proto)) era - -> Except (SL.BlockTransitionError era) (STS.EventReturnType ep (Core.EraRule "BBODY" era) (SL.NewEpochState era)) - appBlk ep' = + -> Except + (SL.BlockTransitionError era) + (STS.EventReturnType ep (Core.EraRule "BBODY" era) (SL.NewEpochState era)) + appBlk = SL.applyBlockOpts - STS.ApplySTSOpts { - asoAssertions = STS.globalAssertionPolicy - , asoValidation = STS.ValidateAll - , asoEvents = ep' - } - reapplyBlockLedgerResult (SomeEPSing ep) cfg = - runIdentity .: applyHelper (swizzle ep ..: reappBlk ep) cfg - where - swizzle STS.EPDiscard m = case runExcept m of - Left err -> - Exception.throw $! ShelleyReapplyException @era err - Right l -> - pure LedgerResult { - lrEvents = [] - , lrResult = l - } - swizzle STS.EPReturn 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 :: - STS.EventReturnTypeRep ep - => STS.SingEP ep - -> SL.Globals - -> SL.NewEpochState era - -> SL.Block (SL.BHeaderView (ProtoCrypto proto)) era - -> Except (SL.BlockTransitionError era) (STS.EventReturnType ep (Core.EraRule "BBODY" era) (SL.NewEpochState era)) - reappBlk ep' = - SL.applyBlockOpts - STS.ApplySTSOpts { - asoAssertions = STS.AssertionsOff - , asoValidation = STS.ValidateNone - , asoEvents = ep' - } + reapplyResult _ = either (\err -> Exception.throw $! ShelleyReapplyException @era err) id . runExcept data ShelleyReapplyException = - forall era. Show (SL.BlockTransitionError era) - => ShelleyReapplyException (SL.BlockTransitionError era) + forall era. Show (ShelleyLedgerError era) + => ShelleyReapplyException (ShelleyLedgerError era) instance Show ShelleyReapplyException where show (ShelleyReapplyException err) = "(ShelleyReapplyException " <> show err <> ")" 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 4e3aea4fb0..541927c8d9 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 @@ -179,7 +179,7 @@ protocolInfoShelley :: => SL.ShelleyGenesis c -> ProtocolParamsShelleyBased c -> SL.ProtVer - -> Bool + -> SomeSTSOpts -> ( ProtocolInfo (ShelleyBlock (TPraos c) (ShelleyEra c) ) , m [BlockForging m (ShelleyBlock (TPraos c) (ShelleyEra c))] ) @@ -205,7 +205,7 @@ protocolInfoTPraosShelleyBased :: -> L.TransitionConfig era -> SL.ProtVer -- ^ see 'shelleyProtVer', mutatis mutandi - -> Bool + -> SomeSTSOpts -> ( ProtocolInfo (ShelleyBlock (TPraos c) era) , m [BlockForging m (ShelleyBlock (TPraos c) era)] ) @@ -215,7 +215,7 @@ protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased { } transitionCfg protVer - doEvents + sts = assertWithMsg (validateGenesis genesis) $ ( ProtocolInfo { @@ -241,7 +241,7 @@ protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased { , topLevelConfigCodec = ShelleyCodecConfig , topLevelConfigStorage = storageConfig , topLevelConfigCheckpoints = emptyCheckpointsMap - , topLevelConfigSTS = someEpSing doEvents + , topLevelConfigSTS = sts } consensusConfig :: ConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) era)) 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 a0b593355c..d559dc6ff4 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 @@ -158,6 +158,21 @@ instance CanHardFork xs => IsLedger (LedgerState (HardForkBlock xs)) where extended :: HardForkState LedgerState xs extended = State.extendToSlot cfg slot st + fastSTSOpts _ = PerEraSTSOptions (hcpure proxySingle f) + where + f :: forall blk. IsLedger (LedgerState blk) => WrapSTSOptions blk + f = WrapSTSOptions $ fastSTSOpts (Proxy @(LedgerState blk)) + + accurateSTSOpts _ = PerEraSTSOptions (hcpure proxySingle f) + where + f :: forall blk. IsLedger (LedgerState blk) => WrapSTSOptions blk + f = WrapSTSOptions $ accurateSTSOpts (Proxy @(LedgerState blk)) + + enableSTSEvents _ = PerEraSTSOptions . hcmap proxySingle f . getPerEraSTSOptions + where + f :: forall blk. IsLedger (LedgerState blk) => WrapSTSOptions blk -> WrapSTSOptions blk + f = WrapSTSOptions . enableSTSEvents (Proxy @(LedgerState blk)) . unwrapSTSOptions + tickOne :: SingleEraBlock blk => EpochInfo (Except PastHorizonException) -> SlotNo @@ -199,24 +214,10 @@ instance CanHardFork xs transition st - reapplyBlockLedgerResult sts 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 (hzipWith (\s c -> Pair s c) (getPerEraSTSOptions sts) cfgs) matched - where - cfgs = distribLedgerConfig ei cfg - ei = State.epochInfoPrecomputedTransitionInfo - (hardForkLedgerConfigShape cfg) - transition - st + reapplyResult _ _ = + -- 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 @@ -232,18 +233,6 @@ apply index (Pair (WrapSTSOptions sts) (WrapLedgerConfig cfg)) (Pair (I block) ( $ fmap (Comp . embedLedgerResult (injectLedgerEvent index)) $ applyBlockLedgerResult sts cfg block st -reapply :: SingleEraBlock blk - => Index xs blk - -> Product WrapSTSOptions WrapLedgerConfig blk - -> Product I (Ticked :.: LedgerState) blk - -> ( LedgerResult (LedgerState (HardForkBlock xs)) - :.: LedgerState - ) blk -reapply index (Pair (WrapSTSOptions sts) (WrapLedgerConfig cfg)) (Pair (I block) (Comp st)) = - Comp - $ embedLedgerResult (injectLedgerEvent index) - $ reapplyBlockLedgerResult sts 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 a84202cde1..6a786c77e5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HeaderStateHistory.hs @@ -255,7 +255,7 @@ fromChain cfg initState chain = anchorSnapshot NE.:| snapshots = fmap (mkHeaderStateWithTime (configLedger cfg)) . NE.scanl - (flip (tickThenReapply (topLevelConfigSTS cfg) (ExtLedgerCfg cfg))) + (flip (tickThenReapply (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 fe8068c9d3..3bf41aed74 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 TypeApplications #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -91,22 +92,16 @@ class ( IsLedger l -> Ticked l -> Except (LedgerErr l) (LedgerResult l l) - -- | Re-apply a block to the very same ledger state it was applied in before. - -- - -- Since a block can only be applied to a single, specific, ledger state, - -- if we apply a previously applied block again it will be applied in the - -- very same ledger state, and therefore can't possibly fail. - -- - -- 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. + reapplyResult :: Proxy blk -> Except (LedgerErr l) (LedgerResult l l) -> LedgerResult l l + reapplyBlockLedgerResult :: HasCallStack - => STSOptions l - -> LedgerCfg l + => LedgerCfg l -> blk -> Ticked l -> LedgerResult l l + reapplyBlockLedgerResult = + reapplyResult (Proxy @blk) ..: applyBlockLedgerResult (fastSTSOpts (Proxy @l)) -- | Interaction with the ledger layer class ApplyBlock (LedgerState blk) blk => UpdateLedger blk @@ -117,6 +112,7 @@ class ApplyBlock (LedgerState blk) blk => UpdateLedger blk -- | 'lrResult' after 'applyBlockLedgerResult' applyLedgerBlock :: + forall l blk. (ApplyBlock l blk, HasCallStack) => STSOptions l -> LedgerCfg l @@ -127,13 +123,14 @@ applyLedgerBlock = fmap lrResult ...: applyBlockLedgerResult -- | 'lrResult' after 'reapplyBlockLedgerResult' reapplyLedgerBlock :: + forall l blk. (ApplyBlock l blk, HasCallStack) - => STSOptions l - -> LedgerCfg l + => LedgerCfg l -> blk -> Ticked l -> l -reapplyLedgerBlock = lrResult ...: reapplyBlockLedgerResult +reapplyLedgerBlock = + lrResult ..: reapplyBlockLedgerResult tickThenApplyLedgerResult :: ApplyBlock l blk @@ -151,21 +148,22 @@ tickThenApplyLedgerResult stsOpts cfg blk l = do } tickThenReapplyLedgerResult :: + forall l blk. ApplyBlock l blk - => STSOptions l - -> LedgerCfg l + => LedgerCfg l -> blk -> l -> LedgerResult l l -tickThenReapplyLedgerResult stsOpts cfg blk l = - let lrTick = applyChainTickLedgerResult stsOpts cfg (blockSlot blk) l - lrBlock = reapplyBlockLedgerResult stsOpts cfg blk (lrResult lrTick) +tickThenReapplyLedgerResult cfg blk l = + let lrTick = applyChainTickLedgerResult (fastSTSOpts (Proxy @l)) cfg (blockSlot blk) l + lrBlock = reapplyBlockLedgerResult cfg blk (lrResult lrTick) in LedgerResult { lrEvents = lrEvents lrTick <> lrEvents lrBlock , lrResult = lrResult lrBlock } tickThenApply :: + forall l blk. ApplyBlock l blk => STSOptions l -> LedgerCfg l @@ -175,13 +173,13 @@ tickThenApply :: tickThenApply = fmap lrResult ...: tickThenApplyLedgerResult tickThenReapply :: + forall l blk. ApplyBlock l blk - => STSOptions l - -> LedgerCfg l + => LedgerCfg l -> blk -> l -> l -tickThenReapply = lrResult ...: tickThenReapplyLedgerResult +tickThenReapply = lrResult ..: tickThenReapplyLedgerResult foldLedger :: ApplyBlock l blk @@ -190,8 +188,8 @@ foldLedger = repeatedlyM .: tickThenApply refoldLedger :: ApplyBlock l blk - => STSOptions l -> LedgerCfg l -> [blk] -> l -> l -refoldLedger = repeatedly .: tickThenReapply + => 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 f41d7fd72e..a6a9d4b16a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Basics.hs @@ -27,6 +27,7 @@ module Ouroboros.Consensus.Ledger.Basics ( , LedgerError , LedgerState , TickedLedgerState + , Proxy (..) ) where import Data.Kind (Type) @@ -34,6 +35,7 @@ import NoThunks.Class (NoThunks) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Ticked import Ouroboros.Consensus.Util ((...:)) +import Data.Proxy (Proxy (..)) {------------------------------------------------------------------------------- Tip @@ -164,6 +166,12 @@ class ( -- Requirements on the ledger state itself -> l -> LedgerResult l (Ticked l) + fastSTSOpts :: Proxy l -> STSOptions l + + accurateSTSOpts :: Proxy l -> STSOptions l + + enableSTSEvents :: Proxy l -> STSOptions l -> STSOptions l + -- | 'lrResult' after 'applyChainTickLedgerResult' applyChainTick :: IsLedger l => STSOptions l -> LedgerCfg l -> SlotNo -> l -> Ticked l applyChainTick = lrResult ...: applyChainTickLedgerResult 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 8cf3456f15..371b005b43 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs @@ -386,6 +386,10 @@ instance Bridge m a => IsLedger (LedgerState (DualBlock m a)) where slot dualLedgerStateMain + fastSTSOpts _ = fastSTSOpts (Proxy @(LedgerState m)) + accurateSTSOpts _ = accurateSTSOpts (Proxy @(LedgerState m)) + enableSTSEvents _ = enableSTSEvents (Proxy @(LedgerState m)) + instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a) where applyBlockLedgerResult sts cfg @@ -411,12 +415,14 @@ instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a) tickedDualLedgerStateBridge } - reapplyBlockLedgerResult sts cfg + reapplyResult = undefined + + reapplyBlockLedgerResult cfg block@DualBlock{..} TickedDualLedgerState{..} = castLedgerResult ledgerResult <&> \main' -> DualLedgerState { dualLedgerStateMain = main' - , dualLedgerStateAux = reapplyMaybeBlock sts + , dualLedgerStateAux = reapplyMaybeBlock (dualLedgerConfigAux cfg) dualBlockAux tickedDualLedgerStateAux @@ -426,7 +432,7 @@ instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a) tickedDualLedgerStateBridge } where - ledgerResult = reapplyBlockLedgerResult sts + ledgerResult = reapplyBlockLedgerResult (dualLedgerConfigMain cfg) dualBlockMain tickedDualLedgerStateMain @@ -788,14 +794,13 @@ applyMaybeBlock sts cfg (Just block) tst _ = applyLedgerBlock sts cfg block tst -- -- See also 'applyMaybeBlock' reapplyMaybeBlock :: UpdateLedger blk - => STSOptions (LedgerState blk) - -> LedgerConfig blk + => LedgerConfig blk -> Maybe blk -> TickedLedgerState blk -> LedgerState blk -> LedgerState blk -reapplyMaybeBlock _ _ Nothing _ st = st -reapplyMaybeBlock sts cfg (Just block) tst _ = reapplyLedgerBlock sts cfg block tst +reapplyMaybeBlock _ Nothing _ st = st +reapplyMaybeBlock cfg (Just block) tst _ = reapplyLedgerBlock 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 90ddce07f8..af7ea1f510 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs @@ -146,6 +146,10 @@ instance ( LedgerSupportsProtocol blk ledgerResult = applyChainTickLedgerResult sts lcfg slot ledger + fastSTSOpts _ = fastSTSOpts (Proxy @(LedgerState blk)) + accurateSTSOpts _ = accurateSTSOpts (Proxy @(LedgerState blk)) + enableSTSEvents _ = enableSTSEvents (Proxy @(LedgerState blk)) + instance LedgerSupportsProtocol blk => ApplyBlock (ExtLedgerState blk) blk where applyBlockLedgerResult sts cfg blk TickedExtLedgerState{..} = do ledgerResult <- @@ -163,11 +167,13 @@ instance LedgerSupportsProtocol blk => ApplyBlock (ExtLedgerState blk) blk where tickedHeaderState pure $ (\l -> ExtLedgerState l hdr) <$> castLedgerResult ledgerResult - reapplyBlockLedgerResult sts cfg blk TickedExtLedgerState{..} = + reapplyResult = undefined + + reapplyBlockLedgerResult cfg blk TickedExtLedgerState{..} = (\l -> ExtLedgerState l hdr) <$> castLedgerResult ledgerResult where ledgerResult = - reapplyBlockLedgerResult sts + reapplyBlockLedgerResult (configLedger $ getExtLedgerCfg cfg) blk tickedLedgerState 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 c045048b20..08265d7063 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 @@ -117,14 +117,14 @@ applyBlock :: forall m c l blk. (ApplyBlock l blk, Monad m, c) applyBlock sts cfg ap db = case ap of ReapplyVal b -> return $ - tickThenReapply sts cfg b l + tickThenReapply cfg b l ApplyVal b -> either (throwLedgerError db (blockRealPoint b)) return $ runExcept $ tickThenApply sts cfg b l ReapplyRef r -> do b <- doResolveBlock r return $ - tickThenReapply sts cfg b l + tickThenReapply cfg b l ApplyRef r -> do b <- doResolveBlock r either (throwLedgerError db r) return $ runExcept $