ChurnMode refactored

ouroboros-network/ouroboros-network.cabal

@@ -127,6 +127,7 @@ library
                        nothunks,
                        psqueues          >=0.2.3 && <0.3,
                        random,
+                       quiet,
 
                        cardano-prelude,
                        cardano-slotting,

ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/Diffusion/Policies.hs

@@ -24,6 +24,7 @@ import System.Random
 import NoThunks.Class.Orphans ()
 
 import Cardano.Slotting.Slot (SlotNo (..))
+import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..))
 import Ouroboros.Network.Diffusion.Policies
 import Ouroboros.Network.ExitPolicy (RepromoteDelay (..))
 import Ouroboros.Network.PeerSelection.Governor
@@ -84,8 +85,12 @@ instance Arbitrary ArbitraryDemotion where
 newtype ArbitraryChurnMode = ArbitraryChurnMode ChurnMode deriving Show
 
 instance Arbitrary ArbitraryChurnMode where
-    arbitrary = ArbitraryChurnMode <$>
-        elements [ChurnModeNormal, ChurnModeBulkSync]
+    arbitrary = ArbitraryChurnMode . ChurnMode <$>
+      elements [FetchModeDeadline, FetchModeBulkSync]
+    shrink (ArbitraryChurnMode (ChurnMode FetchModeDeadline)) =
+      [ArbitraryChurnMode (ChurnMode FetchModeBulkSync)]
+    shrink (ArbitraryChurnMode (ChurnMode FetchModeBulkSync)) =
+      []
 
 instance Arbitrary ArbitraryPolicyArguments where
     arbitrary = do
@@ -182,11 +187,11 @@ prop_hotToWarmM ArbitraryPolicyArguments{..} seed = do
               -> m Property
     noneWorse metrics pickedSet = do
         scores <- atomically $ case apaChurnMode of
-                      ChurnModeNormal -> do
+                      ChurnMode FetchModeDeadline -> do
                           hup <- upstreamyness metrics
                           bup <- fetchynessBlocks metrics
                           return $ Map.unionWith (+) hup bup
-                      ChurnModeBulkSync ->
+                      ChurnMode FetchModeBulkSync ->
                           fetchynessBytes metrics
         let (picked, notPicked) = Map.partitionWithKey fn scores
             maxPicked = maximum $ Map.elems picked

ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs

@@ -103,9 +103,9 @@ import Ouroboros.Network.NodeToNode qualified as NodeToNode
 import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers)
 import Ouroboros.Network.PeerSelection.Churn (PeerChurnArgs (..))
 import Ouroboros.Network.PeerSelection.Governor qualified as Governor
-import Ouroboros.Network.PeerSelection.Governor.Types
-           (ChurnMode (ChurnModeNormal), ConsensusModePeerTargets (..),
-           DebugPeerSelection (..), PeerSelectionActions, PeerSelectionCounters,
+import Ouroboros.Network.PeerSelection.Governor.Types (ChurnMode (..),
+           ConsensusModePeerTargets (..), DebugPeerSelection (..),
+           PeerSelectionActions, PeerSelectionCounters,
            PeerSelectionInterfaces (..), PeerSelectionPolicy (..),
            PeerSelectionState, TracePeerSelection (..),
            emptyPeerSelectionCounters, emptyPeerSelectionState)
@@ -828,7 +828,7 @@ runM Interfaces
       -- demoting/promoting peers.
       policyRngVar <- newTVarIO policyRng
 
-      churnModeVar <- newTVarIO ChurnModeNormal
+      churnModeVar <- newTVarIO (ChurnMode FetchModeDeadline)
 
       localRootsVar <- newTVarIO mempty
 

ouroboros-network/src/Ouroboros/Network/Diffusion/Policies.hs

@@ -150,13 +150,13 @@ simplePeerSelectionPolicy rngVar getChurnMode metrics errorDelay = PeerSelection
     hotDemotionPolicy _ _ _ available pickNum = do
         mode <- getChurnMode
         scores <- case mode of
-                       ChurnModeNormal -> do
+                       ChurnMode FetchModeDeadline -> do
                            jpm <- joinedPeerMetricAt metrics
                            hup <- upstreamyness metrics
                            bup <- fetchynessBlocks metrics
                            return $ Map.unionWith (+) hup bup `optionalMerge` jpm
 
-                       ChurnModeBulkSync -> do
+                       ChurnMode FetchModeBulkSync -> do
                            jpm <- joinedPeerMetricAt metrics
                            bup <- fetchynessBytes metrics
                            return $ bup `optionalMerge` jpm

ouroboros-network/src/Ouroboros/Network/PeerSelection/Churn.hs

@@ -30,7 +30,6 @@ import System.Random
 import Control.Applicative (Alternative)
 import Data.Functor (($>))
 import Data.Monoid.Synchronisation (FirstToFinish (..))
-import Ouroboros.Network.BlockFetch (FetchMode (..))
 import Ouroboros.Network.ConsensusMode (ConsensusMode (..))
 import Ouroboros.Network.Diffusion.Policies (churnEstablishConnectionTimeout,
            closeConnectionTimeout, deactivateTimeout)
@@ -40,11 +39,13 @@ import Ouroboros.Network.PeerSelection.LedgerPeers.Type
 import Ouroboros.Network.PeerSelection.PeerMetric
 import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency (..))
 
--- | Tag indicating churning approach
--- There are three syncing methods that networking layer supports, the legacy
--- method with or without bootstrap peers, and the Genesis method that relies
--- on chain skipping optimization courtesy of consensus, which also provides
-
+-- | Tag indicating churning approach.
+--
+-- There are three syncing methods supported by ouroboros-network:
+--
+-- * the legacy method (praos mode) without bootstrap peers,
+-- * bootstrap peers, and
+-- * the Genesis method which is using it's own targets for syncing.
 --
 data ChurnRegime = ChurnDefault
                  -- ^ tag to use Praos targets when caught up, or Genesis
@@ -64,12 +65,12 @@ getPeerSelectionTargets consensus lsj ConsensusModePeerTargets {
     _otherwise            -> deadlineTargets
 
 pickChurnRegime :: ConsensusMode -> ChurnMode -> UseBootstrapPeers -> ChurnRegime
-pickChurnRegime consensus churn ubp =
-  case (churn, ubp, consensus) of
-    (ChurnModeNormal, _, _)                     -> ChurnDefault
-    (_, _, GenesisMode)                         -> ChurnDefault
-    (ChurnModeBulkSync, UseBootstrapPeers _, _) -> ChurnBootstrapPraosSync
-    (ChurnModeBulkSync, _, _)                   -> ChurnPraosSync
+pickChurnRegime consensus churn bootstrap =
+  case (consensus, churn, bootstrap) of
+    (GenesisMode, _, _)                                     -> ChurnDefault
+    (_, ChurnMode FetchModeDeadline, _)                     -> ChurnDefault
+    (_, ChurnMode FetchModeBulkSync, DontUseBootstrapPeers) -> ChurnPraosSync
+    (_, ChurnMode FetchModeBulkSync, UseBootstrapPeers{})   -> ChurnBootstrapPraosSync
 
 -- | Facilitates composing updates to various targets via back-to-back pipeline
 type ModifyPeerSelectionTargets = PeerSelectionTargets -> PeerSelectionTargets
@@ -154,10 +155,7 @@ peerChurnGovernor PeerChurnArgs {
   where
     updateChurnMode :: STM m ChurnMode
     updateChurnMode = do
-        fm <- getFetchMode
-        let mode = case fm of
-                     FetchModeDeadline -> ChurnModeNormal
-                     FetchModeBulkSync -> ChurnModeBulkSync
+        mode <- ChurnMode <$> getFetchMode
         writeTVar churnModeVar mode
         return mode
 

ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE BangPatterns              #-}
 {-# LANGUAGE CPP                       #-}
 {-# LANGUAGE DeriveFunctor             #-}
+{-# LANGUAGE DeriveGeneric             #-}
+{-# LANGUAGE DerivingStrategies        #-}
+{-# LANGUAGE DerivingVia               #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts          #-}
 {-# LANGUAGE GADTs                     #-}
@@ -33,6 +36,7 @@ module Ouroboros.Network.PeerSelection.Governor.Types
   , PeerSelectionActions (..)
   , PeerSelectionInterfaces (..)
   , ChurnMode (..)
+  , FetchMode (..)
     -- * P2P governor internals
   , PeerSelectionState (..)
   , emptyPeerSelectionState
@@ -133,15 +137,17 @@ import Data.Semigroup (Min (..))
 import Data.Set (Set)
 import Data.Set qualified as Set
 import GHC.Stack (HasCallStack)
+import GHC.Generics (Generic (..))
+import Quiet (Quiet (..))
 
 import Control.Applicative (Alternative)
+import Control.Concurrent.Class.MonadSTM.Strict
 import Control.Concurrent.JobPool (Job)
 import Control.Exception (Exception (..), SomeException, assert)
-import Control.Monad.Class.MonadSTM
 import Control.Monad.Class.MonadTime.SI
 import System.Random (StdGen)
 
-import Control.Concurrent.Class.MonadSTM.Strict
+import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode (..))
 import Ouroboros.Network.ConsensusMode
 import Ouroboros.Network.ExitPolicy
 import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..))
@@ -1768,6 +1774,13 @@ data DebugPeerSelection peeraddr where
 deriving instance (Ord peeraddr, Show peeraddr)
                => Show (DebugPeerSelection peeraddr)
 
-data ChurnMode = ChurnModeBulkSync
-               | ChurnModeNormal deriving Show
+-- | Churn mode is set by `churn` and available in peer selection policy.  It
+-- follows `FetchMode`, thus it's a newtype wrapper.
+--
+-- It is shared using its own `TVar` to make sure the value available in peer
+-- selection policy is consistent with the value available in churn actions.
+--
+newtype ChurnMode = ChurnMode { getFetchMode :: FetchMode }
+  deriving stock Generic
+  deriving Show via Quiet ChurnMode