implement Alex's review suggestions

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
     }
 

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

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)

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"

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

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

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)

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

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
     }
 
 {-------------------------------------------------------------------------------

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