From e8f4195865d279b80557af69399f9e875ce3d677 Mon Sep 17 00:00:00 2001 From: Torsten Schmits Date: Tue, 23 Jan 2024 13:58:16 +0100 Subject: [PATCH] implement Alex's review suggestions --- .../Ouroboros/Consensus/Node.hs | 5 +- .../Test/Consensus/Genesis/Tests/Uniform.hs | 10 +++- .../Test/Consensus/PeerSimulator/Run.hs | 14 ++--- .../Ouroboros/Consensus/Fragment/Diff.hs | 57 ------------------- .../Ouroboros/Consensus/Genesis/Governor.hs | 37 ++++++------ .../MiniProtocol/ChainSync/Client.hs | 2 +- .../Consensus/Storage/ChainDB/API.hs | 40 +++++++++++-- .../Consensus/Storage/ChainDB/Impl.hs | 2 +- .../Consensus/Storage/ChainDB/Impl/Args.hs | 14 ++--- .../Storage/ChainDB/Impl/ChainSel.hs | 4 +- .../Consensus/Storage/ChainDB/Impl/Types.hs | 3 +- .../Consensus/Util/AnchoredFragment.hs | 57 +++++++++++++++++++ .../Test/Util/ChainDB.hs | 5 +- 13 files changed, 147 insertions(+), 103 deletions(-) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs index d390ed56e1..d948af52cb 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs @@ -73,7 +73,8 @@ import Ouroboros.Consensus.Config.SupportsNode import Ouroboros.Consensus.Fragment.InFuture (CheckInFuture, ClockSkew) import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture -import Ouroboros.Consensus.Genesis.Governor (updateLoEUnconditional) +import Ouroboros.Consensus.Genesis.Governor + (updateLoEFragUnconditional) import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..)) import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck import qualified Ouroboros.Consensus.Network.NodeToClient as NTC @@ -632,7 +633,7 @@ mkChainDbArgs , ChainDB.cdbGenesis = return initLedger , ChainDB.cdbCheckInFuture = inFuture , ChainDB.cdbLoELimit = LoEDefault - , ChainDB.cdbUpdateLoE = updateLoEUnconditional + , ChainDB.cdbUpdateLoEFrag = updateLoEFragUnconditional , ChainDB.cdbRegistry = registry } diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs index 0883bbd833..d2a830a0ff 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs @@ -279,6 +279,9 @@ prop_leashingAttackTimeLimited = headCallStack :: HasCallStack => [a] -> a headCallStack xs = if null xs then error "headCallStack: empty list" else head xs +-- | Test that enabling the LoE using the updater that sets the LoE fragment to +-- the shared prefix (as used by the GDDG) causes the selection to remain at +-- the first fork intersection (keeping the immutable tip honest). prop_loeStalling :: Property prop_loeStalling = forAllGenesisTest' @@ -299,8 +302,11 @@ prop_loeStalling = where prop GenesisTest {gtBlockTree = BlockTree {btTrunk, btBranches}} _ StateView{svSelectedChain} = classify (any (== selectionTip) allTips) "The selection is at a branch tip" $ + classify (any anchorIsImmutableTip suffixes) "The immutable tip is at a fork intersection" $ property (isHonest immutableTipHash) where + anchorIsImmutableTip branch = simpleHash (AF.anchorToHash (AF.anchor branch)) == immutableTipHash + isHonest = all (0 ==) immutableTipHash = simpleHash (AF.anchorToHash immutableTip) @@ -309,4 +315,6 @@ prop_loeStalling = selectionTip = simpleHash (AF.headHash svSelectedChain) - allTips = simpleHash . AF.headHash <$> (btTrunk : (btbSuffix <$> btBranches)) + allTips = simpleHash . AF.headHash <$> (btTrunk : suffixes) + + suffixes = btbSuffix <$> btBranches diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs index cf9d71b1a4..d84847cf49 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs @@ -21,14 +21,14 @@ import Data.Functor (void) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Ouroboros.Consensus.Config (TopLevelConfig (..)) -import Ouroboros.Consensus.Genesis.Governor (updateLoEStall, - updateLoEUnconditional) +import Ouroboros.Consensus.Genesis.Governor (updateLoEFragStall, + updateLoEFragUnconditional) import Ouroboros.Consensus.MiniProtocol.ChainSync.Client (ChainDbView, defaultChainDbView) import Ouroboros.Consensus.Storage.ChainDB.API import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Storage.ChainDB.Impl - (ChainDbArgs (cdbTracer), cdbLoELimit, cdbUpdateLoE) + (ChainDbArgs (cdbTracer), cdbLoELimit, cdbUpdateLoEFrag) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB.Impl import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.IOLike (IOLike, @@ -260,7 +260,7 @@ runPointSchedule schedulerConfig GenesisTest {gtSecurityParam = k, gtBlockTree} stateViewTracers <- defaultStateViewTracers resources <- makePeerSimulatorResources tracer gtBlockTree (pointSchedulePeers pointSchedule) let getCandidates = traverse readTVar =<< readTVar (psrCandidates resources) - updateLoE = updateLoEStall k getCandidates + updateLoE = updateLoEFragStall k getCandidates chainDb <- mkChainDb schedulerConfig tracer config registry updateLoE fetchClientRegistry <- newFetchClientRegistry let chainDbView = defaultChainDbView chainDb @@ -312,7 +312,7 @@ mkChainDb schedulerConfig tracer nodeCfg registry updateLoE = do ) { cdbTracer = mkCdbTracer tracer, cdbLoELimit, - cdbUpdateLoE + cdbUpdateLoEFrag } (_, (chainDB, ChainDB.Impl.Internal{intAddBlockRunner})) <- allocate @@ -322,6 +322,6 @@ mkChainDb schedulerConfig tracer nodeCfg registry updateLoE = do _ <- forkLinkedThread registry "AddBlockRunner" intAddBlockRunner pure chainDB where - (cdbLoELimit, cdbUpdateLoE) + (cdbLoELimit, cdbUpdateLoEFrag) | scEnableLoE schedulerConfig = (LoEDefault, updateLoE) - | otherwise = (LoEUnlimited, updateLoEUnconditional) + | otherwise = (LoEUnlimited, updateLoEFragUnconditional) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs index 768b3bec75..f857591f9c 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Fragment/Diff.hs @@ -21,15 +21,11 @@ module Ouroboros.Consensus.Fragment.Diff ( , apply -- * Manipulation , append - , cross , mapM - , stripCommonPrefix , takeWhileOldest , truncate ) where -import Data.Foldable (toList) -import qualified Data.List as L import Data.Word (Word64) import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Block @@ -182,56 +178,3 @@ mapM f (ChainDiff rollback suffix) = ChainDiff rollback . AF.fromOldestFirst (AF.castAnchor (AF.anchor suffix)) <$> Prelude.mapM f (AF.toOldestFirst suffix) - --- | If the two fragments `c1` and `c2` intersect, return the intersection --- point and join the prefix of `c1` before the intersection with the suffix --- of `c2` after the intersection. The resulting fragment has the same --- anchor as `c1` and the same head as `c2`. -cross :: - HasHeader block - => AnchoredFragment block - -> AnchoredFragment block - -> Maybe (Point block, AnchoredFragment block) -cross c1 c2 = do - (p1, _p2, _s1, s2) <- AF.intersect c1 c2 - -- Note that the head of `p1` and `_p2` is the intersection point, and - -- `_s1` and `s2` are anchored in the intersection point. - let crossed = case AF.join p1 s2 of - Just c -> c - Nothing -> error "invariant violation of AF.intersect" - pure (AF.anchorPoint s2, crossed) - --- | Strip the common prefix of multiple fragments. --- --- PRECONDITION: all fragments have the given anchor as their anchor. -stripCommonPrefix :: - forall f blk. - (Functor f, Foldable f, HasHeader blk) -- TODO: this uses the lazy 'map' for 'Map'... - => AF.Anchor blk - -> f (AnchoredFragment blk) - -> (AnchoredFragment blk, f (AnchoredFragment blk)) -stripCommonPrefix sharedAnchor frags - | all ((sharedAnchor ==) . AF.anchor) frags - = (commonPrefix, splitAfterCommonPrefix <$> frags) - | otherwise - = error "Not all fragments are anchored in the given anchor" - where - -- Return the common prefix of two fragments with the same anchor - -- 'sharedAnchor'. - computeCommonPrefix :: - AnchoredFragment blk - -> AnchoredFragment blk - -> AnchoredFragment blk - computeCommonPrefix frag1 frag2 = case AF.intersect frag1 frag2 of - Just (cp, _, _, _) -> cp - Nothing -> error "unreachable" - - commonPrefix - | null frags = AF.Empty sharedAnchor - -- TODO use Foldable1 once all our GHCs support it - | otherwise = L.foldl1' computeCommonPrefix (toList frags) - - splitAfterCommonPrefix frag = - case AF.splitAfterPoint frag (AF.headPoint commonPrefix) of - Just (_, afterCommonPrefix) -> afterCommonPrefix - Nothing -> error "unreachable" diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Genesis/Governor.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Genesis/Governor.hs index 9fba09a633..c70fd001d2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Genesis/Governor.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Genesis/Governor.hs @@ -12,8 +12,8 @@ {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Genesis.Governor ( - updateLoEStall - , updateLoEUnconditional + updateLoEFragStall + , updateLoEFragUnconditional ) where import Control.Monad.Except () @@ -22,28 +22,24 @@ import qualified Data.Map.Strict as Map import Ouroboros.Consensus.Block.Abstract (GetHeader, Header) import Ouroboros.Consensus.Config.SecurityParam (SecurityParam (SecurityParam)) -import Ouroboros.Consensus.Fragment.Diff (stripCommonPrefix) import Ouroboros.Consensus.Storage.ChainDB.API (UpdateLoE (UpdateLoE)) +import Ouroboros.Consensus.Util.AnchoredFragment (stripCommonPrefix) import Ouroboros.Consensus.Util.MonadSTM.NormalForm (MonadSTM (STM, atomically)) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF -updateLoEUnconditional :: +-- | A dummy version of the LoE that sets the LoE fragment to the current +-- selection. +updateLoEFragUnconditional :: MonadSTM m => UpdateLoE m blk -updateLoEUnconditional = +updateLoEFragUnconditional = UpdateLoE $ \ curChain _ setLoEFrag -> atomically (setLoEFrag curChain) -{- - -more TODO: - - - we don't yet check that the header fragments contain no blocks from the - future (will likely be fixed by efforts not directly related to Genesis) - --} - +-- | Compute the fragment between the immutable tip, as given by the anchor +-- of @curChain@, and the earliest intersection between @curChain@ and any +-- of the @candidates@. sharedCandidatePrefix :: GetHeader blk => SecurityParam -> @@ -74,13 +70,22 @@ sharedCandidatePrefix (SecurityParam k) curChain candidates = -- 'Map' via 'mapMaybe'. Map.mapMaybe splitAfterImmutableTip candidates -updateLoEStall :: +-- | This version of the LoE implements part of the intended Genesis approach. +-- The fragment is set to the prefix of all candidates, ranging from the +-- immutable tip to the earliest intersection of all peers. +-- +-- Using this will cause ChainSel to stall indefinitely, or until a peer +-- disconnects for unrelated reasons. +-- In the future, the Genesis Density Disconnect Governor variant will extend +-- this with an analysis that will always result in disconnections from peers +-- to ensure the selection can advance. +updateLoEFragStall :: MonadSTM m => GetHeader blk => SecurityParam -> STM m (Map peer (AnchoredFragment (Header blk))) -> UpdateLoE m blk -updateLoEStall k getCandidates = +updateLoEFragStall k getCandidates = UpdateLoE $ \ curChain _ setLoEFrag -> atomically $ do candidates <- getCandidates diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs index 2e5c3ed4b9..a1ac0ad130 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Client.hs @@ -52,7 +52,6 @@ import NoThunks.Class (unsafeNoThunks) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.Forecast -import Ouroboros.Consensus.Fragment.Diff (cross) import Ouroboros.Consensus.HardFork.History (PastHorizonException (PastHorizon)) import Ouroboros.Consensus.HeaderStateHistory @@ -69,6 +68,7 @@ import Ouroboros.Consensus.Storage.ChainDB (ChainDB, InvalidBlockReason) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import Ouroboros.Consensus.Util +import Ouroboros.Consensus.Util.AnchoredFragment (cross) import Ouroboros.Consensus.Util.Assert (assertWithMsg) import qualified Ouroboros.Consensus.Util.EarlyExit as EarlyExit import Ouroboros.Consensus.Util.IOLike diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 78a9a6d13c..6bbfae2be4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -72,7 +72,6 @@ module Ouroboros.Consensus.Storage.ChainDB.API ( import Control.Monad (void) import Data.Typeable (Typeable) import GHC.Generics (Generic) -import NoThunks.Class (AllowThunk (AllowThunk)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.HeaderStateHistory (HeaderStateHistory (..)) @@ -337,7 +336,7 @@ data ChainDB m blk = ChainDB { , getIsInvalidBlock :: STM m (WithFingerprint (HeaderHash blk -> Maybe (InvalidBlockReason blk))) , setLoEFrag :: AnchoredFragment (Header blk) -> STM m () - -- ^ Update the LoE, which is anchored in a recent immutable tip. + -- ^ Update the LoE fragment, which is anchored in a recent immutable tip. -- | Close the ChainDB -- @@ -867,12 +866,41 @@ instance (Typeable blk, StandardHash blk) => Exception (ChainDbError blk) where InvalidIteratorRange {} -> "An invalid range of blocks was requested" +-- | The Limit on Eagerness is a mechanism for keeping ChainSel from advancing +-- the current selection in the case of competing chains. +-- It requires a resolution mechanism to prevent indefinite stalling, which +-- will be implemented by the Genesis Density Disconnection principle soon, +-- a condition applied via 'UpdateLoE' that disconnects from peers with forks +-- it considers inferior. +-- +-- This type indicates whether the feature is enabled. data LoELimit = - LoEDefault | LoEUnlimited - deriving (NoThunks) via AllowThunk LoELimit + -- | The LoE is enabled, using the security parameter @k@ as the limit. + -- When the selection's tip is @k@ blocks after the earliest intersection of + -- of all candidate fragments, ChainSel will not add new blocks to the + -- selection. + LoEDefault + | + -- | The LoE is disabled, so ChainSel will not keep the selection from + -- advancing. + LoEUnlimited + deriving stock (Generic) + deriving anyclass (NoThunks) +-- | This callback is a hook into ChainSync that is called right before deciding +-- whether a block can be added to the current selection. +-- +-- Its purpose is to update the fragment whose tip provides the reference point +-- for the Limit on Eagerness, described in the docs of 'LoELimit'. +-- +-- The callback is applied to the current chain, the current ledger state and +-- an STM action that writes the new LoE fragment to the state. data UpdateLoE m blk = UpdateLoE { - updateLoE :: (AnchoredFragment (Header blk) -> ExtLedgerState blk -> (AnchoredFragment (Header blk) -> STM m ()) -> m ()) + updateLoE :: + AnchoredFragment (Header blk) + -> ExtLedgerState blk + -> (AnchoredFragment (Header blk) -> STM m ()) + -> m () } deriving stock (Generic) - deriving (NoThunks) via AllowThunk (UpdateLoE m blk) + deriving anyclass (NoThunks) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index 61e290deb3..d8f45a70b6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -202,7 +202,7 @@ openDBInternal args launchBgTasks = runWithTempRegistry $ do , cdbFutureBlocks = varFutureBlocks , cdbLoEFrag = varLoEFrag , cdbLoELimit = Args.cdbLoELimit args - , cdbUpdateLoE = Args.cdbUpdateLoE args + , cdbUpdateLoEFrag = Args.cdbUpdateLoEFrag args } h <- fmap CDBHandle $ newTVarIO $ ChainDbOpen env let chainDB = API.ChainDB 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 5c785a5b49..c526886779 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 @@ -79,9 +79,9 @@ data ChainDbArgs f m blk = ChainDbArgs { -- Limit on Eagerness , cdbLoELimit :: LoELimit - -- ^ How many blocks can be selected beyond the LoE. The non-degenerate - -- value for this is @k@, the security parameter. - , cdbUpdateLoE :: HKD f (UpdateLoE m blk) + -- ^ Whether the LoE is active. + , cdbUpdateLoEFrag :: HKD f (UpdateLoE m blk) + -- ^ The callback for advancing the LoE fragment. } -- | Arguments specific to the ChainDB, not to the ImmutableDB, VolatileDB, or @@ -102,7 +102,7 @@ data ChainDbSpecificArgs f m blk = ChainDbSpecificArgs { , cdbsRegistry :: HKD f (ResourceRegistry m) , cdbsTracer :: Tracer m (TraceEvent blk) , cdbsLoELimit :: LoELimit - , cdbsUpdateLoE :: HKD f (UpdateLoE m blk) + , cdbsUpdateLoEFrag :: HKD f (UpdateLoE m blk) } -- | Default arguments @@ -136,7 +136,7 @@ defaultSpecificArgs = ChainDbSpecificArgs { , cdbsRegistry = NoDefault , cdbsTracer = nullTracer , cdbsLoELimit = LoEUnlimited - , cdbsUpdateLoE = NoDefault + , cdbsUpdateLoEFrag = NoDefault } -- | Default arguments @@ -207,7 +207,7 @@ fromChainDbArgs ChainDbArgs{..} = ( , cdbsCheckInFuture = cdbCheckInFuture , cdbsBlocksToAddSize = cdbBlocksToAddSize , cdbsLoELimit = cdbLoELimit - , cdbsUpdateLoE = cdbUpdateLoE + , cdbsUpdateLoEFrag = cdbUpdateLoEFrag } ) @@ -249,7 +249,7 @@ toChainDbArgs ImmutableDB.ImmutableDbArgs {..} , cdbGcInterval = cdbsGcInterval , cdbBlocksToAddSize = cdbsBlocksToAddSize , cdbLoELimit = cdbsLoELimit - , cdbUpdateLoE = cdbsUpdateLoE + , cdbUpdateLoEFrag = cdbsUpdateLoEFrag } {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs index b8c7b4fe24..aae6f1ec1e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/ChainSel.hs @@ -44,7 +44,7 @@ import Data.Word (Word64) import GHC.Stack (HasCallStack) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config -import Ouroboros.Consensus.Fragment.Diff (ChainDiff (..), cross) +import Ouroboros.Consensus.Fragment.Diff (ChainDiff (..)) import qualified Ouroboros.Consensus.Fragment.Diff as Diff import Ouroboros.Consensus.Fragment.InFuture (CheckInFuture (..)) import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture @@ -502,7 +502,7 @@ chainSelectionForBlock cdb@CDB{..} blockCache hdr punish = do -- The preconditions assert (isJust $ lookupBlockInfo (headerHash hdr)) $ return () - updateLoE cdbUpdateLoE curChain (LgrDB.ledgerDbCurrent ledgerDB) (writeTVar cdbLoEFrag) + updateLoE cdbUpdateLoEFrag curChain (LgrDB.ledgerDbCurrent ledgerDB) (writeTVar cdbLoEFrag) if -- The chain might have grown since we added the block such that the diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index 757ec6b832..955de90ac9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -280,7 +280,8 @@ data ChainDbEnv m blk = CDB -- fragment anchored in the current immutable tip. , cdbLoELimit :: LoELimit -- ^ See 'Args.cdbLoELimit'. - , cdbUpdateLoE :: UpdateLoE m blk + , cdbUpdateLoEFrag :: UpdateLoE m blk + -- ^ See 'Args.cdbUpdateLoEFrag'. } deriving (Generic) -- | We include @blk@ in 'showTypeOf' because it helps resolving type families diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs index 5ceb02452c..08de13eef5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/AnchoredFragment.hs @@ -8,12 +8,16 @@ module Ouroboros.Consensus.Util.AnchoredFragment ( compareAnchoredFragments , compareHeadBlockNo + , cross , forksAtMostKBlocks , preferAnchoredCandidate + , stripCommonPrefix ) where import Control.Monad.Except (throwError) +import Data.Foldable (toList) import Data.Function (on) +import qualified Data.List as L import Data.Maybe (isJust) import Data.Word (Word64) import GHC.Stack @@ -134,3 +138,56 @@ preferAnchoredCandidate :: -> Bool preferAnchoredCandidate cfg ours cand = compareAnchoredFragments cfg ours cand == LT + +-- | If the two fragments `c1` and `c2` intersect, return the intersection +-- point and join the prefix of `c1` before the intersection with the suffix +-- of `c2` after the intersection. The resulting fragment has the same +-- anchor as `c1` and the same head as `c2`. +cross :: + HasHeader block + => AnchoredFragment block + -> AnchoredFragment block + -> Maybe (Point block, AnchoredFragment block) +cross c1 c2 = do + (p1, _p2, _s1, s2) <- AF.intersect c1 c2 + -- Note that the head of `p1` and `_p2` is the intersection point, and + -- `_s1` and `s2` are anchored in the intersection point. + let crossed = case AF.join p1 s2 of + Just c -> c + Nothing -> error "invariant violation of AF.intersect" + pure (AF.anchorPoint s2, crossed) + +-- | Strip the common prefix of multiple fragments. +-- +-- PRECONDITION: all fragments have the given anchor as their anchor. +stripCommonPrefix :: + forall f blk. + (Functor f, Foldable f, HasHeader blk) -- TODO: this uses the lazy 'map' for 'Map'... + => AF.Anchor blk + -> f (AnchoredFragment blk) + -> (AnchoredFragment blk, f (AnchoredFragment blk)) +stripCommonPrefix sharedAnchor frags + | all ((sharedAnchor ==) . AF.anchor) frags + = (commonPrefix, splitAfterCommonPrefix <$> frags) + | otherwise + = error "Not all fragments are anchored in the given anchor" + where + -- Return the common prefix of two fragments with the same anchor + -- 'sharedAnchor'. + computeCommonPrefix :: + AnchoredFragment blk + -> AnchoredFragment blk + -> AnchoredFragment blk + computeCommonPrefix frag1 frag2 = case AF.intersect frag1 frag2 of + Just (cp, _, _, _) -> cp + Nothing -> error "unreachable" + + commonPrefix + | null frags = AF.Empty sharedAnchor + -- TODO use Foldable1 once all our GHCs support it + | otherwise = L.foldl1' computeCommonPrefix (toList frags) + + splitAfterCommonPrefix frag = + case AF.splitAfterPoint frag (AF.headPoint commonPrefix) of + Just (_, afterCommonPrefix) -> afterCommonPrefix + Nothing -> error "unreachable" 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 1d37aa4ec7..bddaf2612b 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs @@ -21,7 +21,8 @@ import Ouroboros.Consensus.Config configSecurityParam) import Ouroboros.Consensus.Fragment.InFuture (CheckInFuture (..)) import qualified Ouroboros.Consensus.Fragment.Validated as VF -import Ouroboros.Consensus.Genesis.Governor (updateLoEUnconditional) +import Ouroboros.Consensus.Genesis.Governor + (updateLoEFragUnconditional) import Ouroboros.Consensus.HardFork.History.EraParams (EraParams, eraEpochSize) import Ouroboros.Consensus.Ledger.Basics (LedgerConfig) @@ -112,5 +113,5 @@ fromMinimalChainDbArgs MinimalChainDbArgs {..} = ChainDbArgs { , cdbGcInterval = 1 , cdbBlocksToAddSize = 1 , cdbLoELimit = LoEUnlimited - , cdbUpdateLoE = updateLoEUnconditional + , cdbUpdateLoEFrag = updateLoEFragUnconditional }