Reusable Diffusion - Make diffusion fully polymorphic

ouroboros-network-api/ouroboros-network-api.cabal

@@ -23,28 +23,29 @@ flag asserts
 library
   hs-source-dirs: src
   exposed-modules:
+    Cardano.Node.ConsensusMode
+    Cardano.Node.PeerSelection.Bootstrap
+    Cardano.Node.PeerSelection.LocalRootPeers
+    Cardano.Node.PeerSelection.PeerTrustable
+    Cardano.Node.Types
     Ouroboros.Network.AnchoredFragment
     Ouroboros.Network.AnchoredSeq
     Ouroboros.Network.Block
     Ouroboros.Network.BlockFetch.ConsensusInterface
     Ouroboros.Network.CodecCBORTerm
-    Ouroboros.Network.ConsensusMode
     Ouroboros.Network.ControlMessage
     Ouroboros.Network.Handshake
     Ouroboros.Network.Handshake.Acceptable
     Ouroboros.Network.Handshake.Queryable
     Ouroboros.Network.Magic
     Ouroboros.Network.NodeToClient.Version
     Ouroboros.Network.NodeToNode.Version
-    Ouroboros.Network.PeerSelection.Bootstrap
     Ouroboros.Network.PeerSelection.LedgerPeers.Type
     Ouroboros.Network.PeerSelection.LedgerPeers.Utils
-    Ouroboros.Network.PeerSelection.LocalRootPeers
     Ouroboros.Network.PeerSelection.PeerAdvertise
     Ouroboros.Network.PeerSelection.PeerMetric.Type
     Ouroboros.Network.PeerSelection.PeerSharing
     Ouroboros.Network.PeerSelection.PeerSharing.Codec
-    Ouroboros.Network.PeerSelection.PeerTrustable
     Ouroboros.Network.PeerSelection.RelayAccessPoint
     Ouroboros.Network.Point
     Ouroboros.Network.Protocol.Limits

ouroboros-network-api/src/Ouroboros/Network/ConsensusMode.hs → ouroboros-network-api/src/Cardano/Node/ConsensusMode.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric  #-}
 
-module Ouroboros.Network.ConsensusMode where
+module Cardano.Node.ConsensusMode where
 
 import Data.Aeson
 import GHC.Generics (Generic)

ouroboros-network-api/src/Ouroboros/Network/PeerSelection/Bootstrap.hs → ouroboros-network-api/src/Cardano/Node/PeerSelection/Bootstrap.hs

@@ -1,16 +1,15 @@
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Ouroboros.Network.PeerSelection.Bootstrap
+module Cardano.Node.PeerSelection.Bootstrap
   ( UseBootstrapPeers (..)
   , isBootstrapPeersEnabled
   , requiresBootstrapPeers
   , isNodeAbleToMakeProgress
   ) where
 
+import Cardano.Node.Types (LedgerStateJudgement (..))
 import GHC.Generics (Generic)
-import Ouroboros.Network.PeerSelection.LedgerPeers.Type
-           (LedgerStateJudgement (..))
 import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint)
 
 data UseBootstrapPeers = DontUseBootstrapPeers

ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LocalRootPeers.hs → ouroboros-network-api/src/Cardano/Node/PeerSelection/LocalRootPeers.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 
-module Ouroboros.Network.PeerSelection.LocalRootPeers (OutboundConnectionsState (..)) where
+module Cardano.Node.PeerSelection.LocalRootPeers (OutboundConnectionsState (..)) where
 
 import GHC.Generics
 import NoThunks.Class

ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerTrustable.hs → ouroboros-network-api/src/Cardano/Node/PeerSelection/PeerTrustable.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 
-module Ouroboros.Network.PeerSelection.PeerTrustable (PeerTrustable (..)) where
+module Cardano.Node.PeerSelection.PeerTrustable (PeerTrustable (..)) where
 
 import GHC.Generics (Generic)
 

ouroboros-network-api/src/Cardano/Node/Types.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Cardano.Node.Types where
+
+import Data.Aeson (FromJSON)
+import GHC.Generics (Generic)
+import NoThunks.Class (NoThunks)
+
+-- | Wether the node is caught up or fell too far behind the chain
+data LedgerStateJudgement = YoungEnough | TooOld
+  deriving (Eq, Show, Generic)
+
+instance NoThunks LedgerStateJudgement
+
+-- | Minimum number of hot big ledger peers in Genesis mode
+--   for trusted state to be signalled to Consensus. This number
+--   should be smaller than the `targetNumberOfActiveBigLedgerPeers`
+--   but greater than 1. In Genesis, we may demote a big ledger peer
+--   for underperformance, but not promote a replacement immediately
+--   to guard against adversaries which may want to slow down our
+--   progress.
+--
+newtype MinBigLedgerPeersForTrustedState =
+  MinBigLedgerPeersForTrustedState { getMinBigLedgerPeersForTrustedState :: Int }
+  deriving stock (Eq, Show)
+  deriving newtype (FromJSON)
+

ouroboros-network-api/src/Ouroboros/Network/BlockFetch/ConsensusInterface.hs

@@ -25,10 +25,9 @@ import NoThunks.Class (NoThunks)
 
 import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
 import Ouroboros.Network.Block
-import Ouroboros.Network.ConsensusMode (ConsensusMode (..))
-import Ouroboros.Network.PeerSelection.LedgerPeers.Type
-           (LedgerStateJudgement (..))
 import Ouroboros.Network.SizeInBytes (SizeInBytes)
+import Cardano.Node.ConsensusMode (ConsensusMode (..))
+import Cardano.Node.Types (LedgerStateJudgement (..))
 
 data PraosFetchMode =
        -- | Use this mode when we are catching up on the chain but are stil

ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs

@@ -18,13 +18,11 @@ module Ouroboros.Network.PeerSelection.LedgerPeers.Type
   ( PoolStake (..)
   , AccPoolStake (..)
   , IsBigLedgerPeer (..)
-  , LedgerStateJudgement (..)
   , LedgerPeersConsensusInterface (..)
   , UseLedgerPeers (..)
   , AfterSlot (..)
   , LedgerPeersKind (..)
   , LedgerPeerSnapshot (.., LedgerPeerSnapshot)
-  , MinBigLedgerPeersForTrustedState (..)
   , isLedgerPeersEnabled
   , compareLedgerPeerSnapshotApproximate
   ) where
@@ -38,6 +36,7 @@ import Text.Read (readMaybe)
 
 import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 import Cardano.Binary qualified as Codec
+import Cardano.Node.Types (LedgerStateJudgement)
 import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..))
 import Control.Concurrent.Class.MonadSTM
 import Control.DeepSeq (NFData (..))
@@ -46,19 +45,6 @@ import Data.Aeson.Types
 import NoThunks.Class
 import Ouroboros.Network.PeerSelection.RelayAccessPoint
 
--- | Minimum number of hot big ledger peers in Genesis mode
---   for trusted state to be signalled to Consensus. This number
---   should be smaller than the `targetNumberOfActiveBigLedgerPeers`
---   but greater than 1. In Genesis, we may demote a big ledger peer
---   for underperformance, but not promote a replacement immediately
---   to guard against adversaries which may want to slow down our
---   progress.
---
-newtype MinBigLedgerPeersForTrustedState =
-  MinBigLedgerPeersForTrustedState { getMinBigLedgerPeersForTrustedState :: Int }
-  deriving stock (Eq, Show)
-  deriving newtype (FromJSON)
-
 -- |The type of big ledger peers that is serialised or later
 -- provided by node configuration for the networking layer
 -- to connect to when syncing.
@@ -237,10 +223,6 @@ data IsBigLedgerPeer
    | IsNotBigLedgerPeer
   deriving Eq
 
--- | Wether the node is caught up or fell too far behind the chain
-data LedgerStateJudgement = YoungEnough | TooOld
-  deriving (Eq, Show, Generic, NoThunks)
-
 -- | Return ledger state information and ledger peers.
 --
 data LedgerPeersConsensusInterface m = LedgerPeersConsensusInterface {

ouroboros-network/ouroboros-network.cabal

@@ -54,6 +54,13 @@ library
   -- At this experiment/prototype stage everything is exposed.
   -- This has to be tidied up once the design becomes clear.
   exposed-modules:
+    Cardano.Node.ArgumentsExtra
+    Cardano.Node.LedgerPeerConsensusInterface
+    Cardano.Node.PeerSelection.Governor.PeerSelectionActions
+    Cardano.Node.PeerSelection.Governor.PeerSelectionState
+    Cardano.Node.PeerSelection.PeerChurnArgs
+    Cardano.Node.PeerSelection.Types
+    Cardano.Node.PublicRootPeers
     Control.Concurrent.Class.MonadSTM.Strict.TMergeVar
     Ouroboros.Network.BlockFetch
     Ouroboros.Network.BlockFetch.Client

ouroboros-network/src/Cardano/Node/ArgumentsExtra.hs

@@ -0,0 +1,37 @@
+module Cardano.Node.ArgumentsExtra where
+
+import Cardano.Node.ConsensusMode (ConsensusMode)
+import Cardano.Node.PeerSelection.Bootstrap (UseBootstrapPeers)
+import Cardano.Node.Types (MinBigLedgerPeersForTrustedState)
+import Control.Concurrent.Class.MonadSTM (MonadSTM (..))
+import Ouroboros.Network.PeerSelection.Governor.Types
+           (PeerSelectionTargets (..))
+
+-- | Cardano Node specific (extra) arguments to be passed to diffusion.
+--
+data CardanoArgumentsExtra m =
+  CardanoArgumentsExtra {
+    -- | selection targets for the peer governor
+    caePeerTargets                      :: ConsensusModePeerTargets
+  , caeReadUseBootstrapPeers            :: STM m UseBootstrapPeers
+
+  -- | For Genesis, this sets the floor for minimum number of
+  --   active big ledger peers we must be connected to in order
+  --   to be able to signal trusted state (OutboundConnectionsState)
+  , caeMinBigLedgerPeersForTrustedState :: MinBigLedgerPeersForTrustedState
+    -- | When syncing up, ie. ledgerStateJudgement == TooOld,
+    -- when this is True we will maintain connection with many big ledger peers
+    -- to get a strong guarantee that when syncing up we will finish with a true
+    -- ledger state. When false, we will fall back on the previous algorithms
+    -- that leverage UseBootstrapPeers flag
+  , caeConsensusMode                    :: ConsensusMode
+  }
+
+-- | Provides alternate peer selection targets
+-- for various syncing modes.
+--
+data ConsensusModePeerTargets = ConsensusModePeerTargets {
+  deadlineTargets :: !PeerSelectionTargets,
+  syncTargets     :: !PeerSelectionTargets
+  }
+  deriving (Eq, Show)

ouroboros-network/src/Cardano/Node/LedgerPeerConsensusInterface.hs

@@ -0,0 +1,21 @@
+module Cardano.Node.LedgerPeerConsensusInterface where
+
+import Cardano.Node.PeerSelection.LocalRootPeers (OutboundConnectionsState)
+import Cardano.Node.Types (LedgerStateJudgement)
+import Control.Concurrent.Class.MonadSTM (MonadSTM (..))
+
+-- | Cardano Node specific consensus interface actions.
+--
+data CardanoLedgerPeersConsensusInterface m =
+  CardanoLedgerPeersConsensusInterface {
+    clpciGetLedgerStateJudgement        :: STM m LedgerStateJudgement
+
+    -- | Callback provided by consensus to inform it if the node is
+    -- connected to only local roots or also some external peers.
+    --
+    -- This is useful in order for the Bootstrap State Machine to
+    -- simply refuse to transition from TooOld to YoungEnough while
+    -- it only has local peers.
+    --
+  , clpciUpdateOutboundConnectionsState :: OutboundConnectionsState -> STM m ()
+  }

ouroboros-network/src/Cardano/Node/PeerSelection/Governor/PeerSelectionActions.hs

@@ -0,0 +1,21 @@
+module Cardano.Node.PeerSelection.Governor.PeerSelectionActions where
+
+import Cardano.Node.ArgumentsExtra (ConsensusModePeerTargets)
+import Cardano.Node.PeerSelection.Bootstrap (UseBootstrapPeers)
+import Control.Concurrent.Class.MonadSTM
+
+-- | Cardano Node PeerSelection Actions extension data type.
+--
+-- It contain specific PeerSelection actions parameters to guide the Outbound
+-- Governor.
+--
+data CardanoPeerSelectionActions m =
+  CardanoPeerSelectionActions {
+    -- | Retrieve peer targets for Genesis & non-Genesis modes
+    -- from node's configuration for the current state
+    --
+    cpsaPeerTargets           :: ConsensusModePeerTargets
+
+    -- | Read the current bootstrap peers flag
+  , cpsaReadUseBootstrapPeers :: STM m UseBootstrapPeers
+  }

ouroboros-network/src/Cardano/Node/PeerSelection/Governor/PeerSelectionState.hs

@@ -0,0 +1,55 @@
+module Cardano.Node.PeerSelection.Governor.PeerSelectionState where
+
+import Cardano.Node.ConsensusMode (ConsensusMode)
+import Cardano.Node.PeerSelection.Bootstrap (UseBootstrapPeers (..))
+import Cardano.Node.Types (LedgerStateJudgement (..),
+           MinBigLedgerPeersForTrustedState (..))
+import Control.Monad.Class.MonadTime.SI (Time)
+
+-- | Cardano Node PeerSelection State extension data type.
+-- It contain specific PeerSelection state parameters to guide the Outbound
+-- Governor.
+--
+data CardanoPeerSelectionState =
+  CardanoPeerSelectionState {
+    -- | Current ledger state judgement
+    cpstLedgerStateJudgement             :: !LedgerStateJudgement
+    -- | Flag whether to sync in genesis mode when ledgerStateJudgement == TooOld
+    -- this comes from node configuration and should be treated as read-only
+    --
+  , cpstConsensusMode                    :: !ConsensusMode
+    -- | Current value of 'UseBootstrapPeers'.
+    --
+  , cpstBootstrapPeersFlag               :: !UseBootstrapPeers
+    -- | Has the governor fully reset its state
+    --
+  , cpstHasOnlyBootstrapPeers            :: !Bool
+    -- | Has the governor fully reset its state
+    --
+  , cpstBootstrapPeersTimeout            :: !(Maybe Time)
+    -- | Use in Genesis mode to check whether we can signal to
+    --   consensus that we met criteria of trusted state to enter
+    --   deadline mode. This parameter comes from node configuration,
+    --   with a default value in the `Configuration` module.
+    --
+  , cpstMinBigLedgerPeersForTrustedState :: MinBigLedgerPeersForTrustedState
+  }
+  deriving Show
+
+empty :: ConsensusMode -> MinBigLedgerPeersForTrustedState -> CardanoPeerSelectionState
+empty consensusMode minActiveBigLedgerPeers =
+    CardanoPeerSelectionState {
+      cpstLedgerStateJudgement             = TooOld,
+      cpstConsensusMode                    = consensusMode,
+      cpstBootstrapPeersFlag               = DontUseBootstrapPeers,
+      cpstHasOnlyBootstrapPeers            = False,
+      cpstBootstrapPeersTimeout            = Nothing,
+      cpstMinBigLedgerPeersForTrustedState = minActiveBigLedgerPeers
+    }
+
+data CardanoDebugPeerSelectionState =
+  CardanoDebugPeerSelectionState {
+    cdpssLedgerStateJudgement :: !LedgerStateJudgement
+  }
+  deriving Show
+

ouroboros-network/src/Cardano/Node/PeerSelection/PeerChurnArgs.hs

@@ -0,0 +1,18 @@
+module Cardano.Node.PeerSelection.PeerChurnArgs where
+
+import Cardano.Node.ArgumentsExtra (ConsensusModePeerTargets)
+import Cardano.Node.ConsensusMode (ConsensusMode)
+import Cardano.Node.PeerSelection.Bootstrap (UseBootstrapPeers)
+import Cardano.Node.PeerSelection.Types (ChurnMode)
+import Control.Concurrent.Class.MonadSTM.Strict
+import Ouroboros.Network.BlockFetch.ConsensusInterface (FetchMode)
+
+data CardanoPeerChurnArgs m =
+  CardanoPeerChurnArgs {
+    cpcaModeVar          :: StrictTVar m ChurnMode
+  , cpcaReadFetchMode    :: STM m FetchMode
+  , cpcaPeerTargets      :: ConsensusModePeerTargets
+  , cpcaReadUseBootstrap :: STM m UseBootstrapPeers
+  , cpcaConsensusMode    :: ConsensusMode
+  }
+

ouroboros-network/src/Cardano/Node/PeerSelection/Types.hs

@@ -0,0 +1,6 @@
+module Cardano.Node.PeerSelection.Types where
+
+data ChurnMode = ChurnModeBulkSync
+               | ChurnModeNormal
+               deriving Show
+

ouroboros-network/src/Cardano/Node/PublicRootPeers.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Cardano.Node.PublicRootPeers where
+
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+import Data.Set (Set)
+import Data.Set qualified as Set
+import Data.Typeable (Typeable)
+import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise)
+
+data CardanoPublicRootPeers peeraddr =
+  CardanoPublicRootPeers
+    { cprpGetPublicConfigPeers :: !(Map peeraddr PeerAdvertise)
+    , cprpGetBootstrapPeers    :: !(Set peeraddr)
+    }
+  deriving (Eq, Show, Typeable)
+
+instance Ord peeraddr => Semigroup (CardanoPublicRootPeers peeraddr) where
+  (CardanoPublicRootPeers a b) <> (CardanoPublicRootPeers a' b') =
+    let -- Combine the sets, prioritizing bootstrapPeers
+        combinedSet = b `Set.union` b'
+        -- Combine the maps and remove any peers that are now in the set
+        combinedMap = (a `Map.union` a') `Map.withoutKeys` combinedSet
+    in CardanoPublicRootPeers combinedMap combinedSet
+
+instance Ord peeraddr => Monoid (CardanoPublicRootPeers peeraddr) where
+  mempty = empty
+
+-- Map and Set are disjoint
+--
+invariant :: Ord peeraddr => CardanoPublicRootPeers peeraddr -> Bool
+invariant (CardanoPublicRootPeers a b) = all (`Map.notMember` a) b
+
+empty :: CardanoPublicRootPeers peeraddr
+empty = CardanoPublicRootPeers Map.empty Set.empty
+
+nullPublicConfig :: CardanoPublicRootPeers peeraddr -> Bool
+nullPublicConfig CardanoPublicRootPeers { cprpGetPublicConfigPeers } =
+  Map.null cprpGetPublicConfigPeers
+
+nullBootstrap :: CardanoPublicRootPeers peeraddr -> Bool
+nullBootstrap CardanoPublicRootPeers { cprpGetBootstrapPeers } =
+  Set.null cprpGetBootstrapPeers
+