{-# LANGUAGE DeriveFunctor             #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE NamedFieldPuns            #-}
{-# LANGUAGE PatternSynonyms           #-}
{-# LANGUAGE RecordWildCards           #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-# LANGUAGE StandaloneDeriving        #-}

module Ouroboros.Network.PeerSelection.Governor.Types
  ( -- * P2P governor policies
    PeerSelectionPolicy (..)
  , PeerSelectionTargets (..)
  , nullPeerSelectionTargets
  , sanePeerSelectionTargets
  , PickPolicy
  , pickPeers
    -- * P2P governor low level API
    -- These records are needed to run the peer selection.
  , PeerStateActions (..)
  , PeerSelectionActions (..)
  , ChurnMode (..)
    -- * P2P governor internals
  , PeerSelectionState (..)
  , emptyPeerSelectionState
  , assertPeerSelectionState
  , establishedPeersStatus
  , Guarded (GuardedSkip, Guarded)
  , Decision (..)
  , TimedDecision
  , MkGuardedDecision
  , Completion (..)
  , PeerSelectionCounters (..)
  , peerStateToCounters
    -- * Traces
  , TracePeerSelection (..)
  , DebugPeerSelection (..)
  ) where

import           Data.Cache (Cache (..))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Maybe (fromMaybe)
import           Data.Monoid.Synchronisation (FirstToFinish (..))
import           Data.Semigroup (Min (..))
import           Data.Set (Set)
import qualified Data.Set as Set

import           Control.Applicative (Alternative)
import           Control.Concurrent.JobPool (Job)
import           Control.Exception (SomeException, assert)
import           Control.Monad.Class.MonadSTM
import           Control.Monad.Class.MonadTime
import           System.Random (StdGen)

import           Ouroboros.Network.ExitPolicy
import           Ouroboros.Network.PeerSelection.EstablishedPeers
                     (EstablishedPeers)
import qualified Ouroboros.Network.PeerSelection.EstablishedPeers as EstablishedPeers
import           Ouroboros.Network.PeerSelection.KnownPeers (KnownPeers)
import qualified Ouroboros.Network.PeerSelection.KnownPeers as KnownPeers
import           Ouroboros.Network.PeerSelection.LocalRootPeers (LocalRootPeers)
import qualified Ouroboros.Network.PeerSelection.LocalRootPeers as LocalRootPeers
import           Ouroboros.Network.PeerSelection.Types


-- | A peer pick policy is an action that picks a subset of elements from a
-- map of peers.
--
-- The pre-condition is that the map of available choices will be non-empty,
-- and the requested number to pick will be strictly positive.
--
-- The post-condition is that the picked set is non-empty but must not be
-- bigger than the requested number.
--
type PickPolicy peeraddr m =
         -- Extra peer attributes available to use in the picking policy.
         -- As more attributes are needed, extend this with more such functions.
         (peeraddr -> PeerSource) -- Where the peer is known from
      -> (peeraddr -> Int)        -- Connection failure count
      -> (peeraddr -> Bool)       -- Found to be tepid flag
      -> Set peeraddr             -- The set to pick from
      -> Int                      -- Max number to choose, fewer is ok.
      -> STM m (Set peeraddr)     -- The set picked.


data PeerSelectionPolicy peeraddr m = PeerSelectionPolicy {

       PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr m
policyPickKnownPeersForGossip :: PickPolicy peeraddr m,
       PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr m
policyPickColdPeersToPromote  :: PickPolicy peeraddr m,
       PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr m
policyPickWarmPeersToPromote  :: PickPolicy peeraddr m,
       PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr m
policyPickHotPeersToDemote    :: PickPolicy peeraddr m,
       PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr m
policyPickWarmPeersToDemote   :: PickPolicy peeraddr m,
       PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr m
policyPickColdPeersToForget   :: PickPolicy peeraddr m,

       PeerSelectionPolicy peeraddr m -> DiffTime
policyFindPublicRootTimeout   :: !DiffTime,
       PeerSelectionPolicy peeraddr m -> Int
policyMaxInProgressGossipReqs :: !Int,
       PeerSelectionPolicy peeraddr m -> DiffTime
policyGossipRetryTime         :: !DiffTime,
       PeerSelectionPolicy peeraddr m -> DiffTime
policyGossipBatchWaitTime     :: !DiffTime,
       PeerSelectionPolicy peeraddr m -> DiffTime
policyGossipOverallTimeout    :: !DiffTime,

       -- | Reconnection delay, passed from `ExitPolicy`.
       --
       PeerSelectionPolicy peeraddr m -> DiffTime
policyErrorDelay              :: !DiffTime
     }


-- | Adjustable targets for the peer selection mechanism.
--
-- These are used by the peer selection governor as targets. They are used by
-- the peer churn governor loop as knobs to adjust, to influence the peer
-- selection governor.
--
-- The /known/, /established/ and /active/ peer targets are targets both from
-- below and from above: the governor will attempt to grow or shrink the sets
-- to hit these targets.
--
-- Unlike the other targets, the /root/ peer target is \"one sided\", it is
-- only a target from below. The governor does not try to shrink the root set
-- to hit it, it simply stops looking for more.
--
-- There is also an implicit target that enough local root peers are selected
-- as active. This comes from the configuration for local roots, and is not an
-- independently adjustable target.
--
data PeerSelectionTargets = PeerSelectionTargets {

       PeerSelectionTargets -> Int
targetNumberOfRootPeers        :: !Int,
       PeerSelectionTargets -> Int
targetNumberOfKnownPeers       :: !Int,
       PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers :: !Int,
       PeerSelectionTargets -> Int
targetNumberOfActivePeers      :: !Int

       -- Expressed as intervals rather than frequencies
--     targetChurnIntervalKnownPeers       :: !DiffTime,
--     targetChurnIntervalEstablishedPeers :: !DiffTime,
--     targetChurnIntervalActivePeers      :: !DiffTime
     }
  deriving (PeerSelectionTargets -> PeerSelectionTargets -> Bool
(PeerSelectionTargets -> PeerSelectionTargets -> Bool)
-> (PeerSelectionTargets -> PeerSelectionTargets -> Bool)
-> Eq PeerSelectionTargets
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PeerSelectionTargets -> PeerSelectionTargets -> Bool
$c/= :: PeerSelectionTargets -> PeerSelectionTargets -> Bool
== :: PeerSelectionTargets -> PeerSelectionTargets -> Bool
$c== :: PeerSelectionTargets -> PeerSelectionTargets -> Bool
Eq, Int -> PeerSelectionTargets -> ShowS
[PeerSelectionTargets] -> ShowS
PeerSelectionTargets -> String
(Int -> PeerSelectionTargets -> ShowS)
-> (PeerSelectionTargets -> String)
-> ([PeerSelectionTargets] -> ShowS)
-> Show PeerSelectionTargets
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PeerSelectionTargets] -> ShowS
$cshowList :: [PeerSelectionTargets] -> ShowS
show :: PeerSelectionTargets -> String
$cshow :: PeerSelectionTargets -> String
showsPrec :: Int -> PeerSelectionTargets -> ShowS
$cshowsPrec :: Int -> PeerSelectionTargets -> ShowS
Show)

nullPeerSelectionTargets :: PeerSelectionTargets
nullPeerSelectionTargets :: PeerSelectionTargets
nullPeerSelectionTargets =
    PeerSelectionTargets :: Int -> Int -> Int -> Int -> PeerSelectionTargets
PeerSelectionTargets {
       targetNumberOfRootPeers :: Int
targetNumberOfRootPeers        = Int
0,
       targetNumberOfKnownPeers :: Int
targetNumberOfKnownPeers       = Int
0,
       targetNumberOfEstablishedPeers :: Int
targetNumberOfEstablishedPeers = Int
0,
       targetNumberOfActivePeers :: Int
targetNumberOfActivePeers      = Int
0
--     targetChurnIntervalKnownPeers       = 0,
--     targetChurnIntervalEstablishedPeers = 0,
--     targetChurnIntervalActivePeers      = 0
    }

sanePeerSelectionTargets :: PeerSelectionTargets -> Bool
sanePeerSelectionTargets :: PeerSelectionTargets -> Bool
sanePeerSelectionTargets PeerSelectionTargets{Int
targetNumberOfActivePeers :: Int
targetNumberOfEstablishedPeers :: Int
targetNumberOfKnownPeers :: Int
targetNumberOfRootPeers :: Int
targetNumberOfActivePeers :: PeerSelectionTargets -> Int
targetNumberOfEstablishedPeers :: PeerSelectionTargets -> Int
targetNumberOfKnownPeers :: PeerSelectionTargets -> Int
targetNumberOfRootPeers :: PeerSelectionTargets -> Int
..} =
                                 Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
targetNumberOfActivePeers
 Bool -> Bool -> Bool
&& Int
targetNumberOfActivePeers      Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
targetNumberOfEstablishedPeers
 Bool -> Bool -> Bool
&& Int
targetNumberOfEstablishedPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
targetNumberOfKnownPeers
 Bool -> Bool -> Bool
&&      Int
targetNumberOfRootPeers   Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
targetNumberOfKnownPeers
 Bool -> Bool -> Bool
&&                              Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
targetNumberOfRootPeers

 Bool -> Bool -> Bool
&& Int
targetNumberOfActivePeers      Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
100
 Bool -> Bool -> Bool
&& Int
targetNumberOfEstablishedPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1000
 Bool -> Bool -> Bool
&& Int
targetNumberOfKnownPeers       Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
10000


-- | Actions performed by the peer selection governor.
--
-- These being pluggable allows:
--
-- * choice of known peer root sets
-- * running both in simulation and for real
--
data PeerSelectionActions peeraddr peerconn m = PeerSelectionActions {

       PeerSelectionActions peeraddr peerconn m
-> STM m PeerSelectionTargets
readPeerSelectionTargets :: STM m PeerSelectionTargets,

       -- | Read the current set of locally or privately known root peers.
       --
       -- In general this is expected to be updated asynchronously by some
       -- other thread. It is intended to cover the use case of peers from
       -- local configuration. It could be dynamic due to DNS resolution, or
       -- due to dynamic configuration updates.
       --
       -- It is structured as a collection of (non-overlapping) groups of peers
       -- where we are supposed to select n from each group.
       --
       PeerSelectionActions peeraddr peerconn m
-> STM m [(Int, Map peeraddr PeerAdvertise)]
readLocalRootPeers       :: STM m [(Int, Map peeraddr PeerAdvertise)],

       -- | Request a sample of public root peers.
       --
       -- It is intended to cover use cases including:
       --
       -- * federated relays from a DNS pool
       -- * stake pool relays published in the blockchain
       -- * a pre-distributed snapshot of stake pool relays from the blockchain
       --
       PeerSelectionActions peeraddr peerconn m
-> Int -> m (Set peeraddr, DiffTime)
requestPublicRootPeers   :: Int -> m (Set peeraddr, DiffTime),

       -- | The action to contact a known peer and request a sample of its
       -- known peers.
       --
       -- This is synchronous, but it should expect to be interrupted by a
       -- timeout asynchronous exception. Failures are throw as exceptions.
       --
       PeerSelectionActions peeraddr peerconn m
-> peeraddr -> m [peeraddr]
requestPeerGossip        :: peeraddr -> m [peeraddr],

       -- | Core actions run by the governor to change 'PeerStatus'.
       --
       PeerSelectionActions peeraddr peerconn m
-> PeerStateActions peeraddr peerconn m
peerStateActions         :: PeerStateActions peeraddr peerconn m
     }

-- | Callbacks which are performed to change peer state.
--
data PeerStateActions peeraddr peerconn m = PeerStateActions {
    -- | Monitor peer state.
    --
    PeerStateActions peeraddr peerconn m
-> peerconn -> STM m (PeerStatus, ReconnectDelay)
monitorPeerConnection    :: peerconn -> STM m (PeerStatus, ReconnectDelay),

    -- | Establish new connection: cold to warm.
    --
    PeerStateActions peeraddr peerconn m -> peeraddr -> m peerconn
establishPeerConnection  :: peeraddr -> m peerconn,

    -- | Activate a connection: warm to hot promotion.
    --
    PeerStateActions peeraddr peerconn m -> peerconn -> m ()
activatePeerConnection   :: peerconn -> m (),

    -- | Deactive a peer: hot to warm demotion.
    --
    PeerStateActions peeraddr peerconn m -> peerconn -> m ()
deactivatePeerConnection :: peerconn -> m (),

    -- | Close a connection: warm to cold transition.
    --
    PeerStateActions peeraddr peerconn m -> peerconn -> m ()
closePeerConnection      :: peerconn -> m ()
  }

-----------------------
-- Peer Selection State
--

-- | The internal state used by the 'peerSelectionGovernor'.
--
-- The local and public root sets are disjoint, and their union is the
-- overall root set.
--
data PeerSelectionState peeraddr peerconn = PeerSelectionState {

       PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets                  :: !PeerSelectionTargets,

       -- | The current set of local root peers. This is structured as a
       -- bunch of groups, with a target for each group. This gives us a set of
       -- n-of-m choices, e.g. \"pick 2 from this group and 1 from this group\".
       --
       -- The targets must of course be achievable, and to keep things simple,
       -- the groups must be disjoint.
       --
       PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers           :: !(LocalRootPeers peeraddr),

       PeerSelectionState peeraddr peerconn -> Set peeraddr
publicRootPeers          :: !(Set peeraddr),

       -- |
       --
       PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers               :: !(KnownPeers peeraddr),

       -- |
       --
       PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers         :: !(EstablishedPeers peeraddr peerconn),

       -- |
       --
       PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers              :: !(Set peeraddr),

       -- | A counter to manage the exponential backoff strategy for when to
       -- retry querying for more public root peers. It is negative for retry
       -- counts after failure, and positive for retry counts that are
       -- successful but make no progress.
       --
       PeerSelectionState peeraddr peerconn -> Int
publicRootBackoffs       :: !Int,

       -- | The earliest time we would be prepared to request more public root
       -- peers. This is used with the 'publicRootBackoffs' to manage the
       -- exponential backoff.
       --
       PeerSelectionState peeraddr peerconn -> Time
publicRootRetryTime      :: !Time,

       PeerSelectionState peeraddr peerconn -> Bool
inProgressPublicRootsReq :: !Bool,
       PeerSelectionState peeraddr peerconn -> Int
inProgressGossipReqs     :: !Int,
       PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteCold    :: !(Set peeraddr),
       PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteWarm    :: !(Set peeraddr),
       PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteWarm     :: !(Set peeraddr),
       PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteHot      :: !(Set peeraddr),

       -- | Rng for fuzzy delay
       PeerSelectionState peeraddr peerconn -> StdGen
fuzzRng                  :: !StdGen,

       -- | 'PeerSelectionCounters' counters cache. Allows to only trace
       -- values when necessary.
       --
       PeerSelectionState peeraddr peerconn -> Cache PeerSelectionCounters
countersCache            :: !(Cache PeerSelectionCounters)

--     TODO: need something like this to distinguish between lots of bad peers
--     and us getting disconnected from the network locally. We don't want a
--     network disconnect to cause us to flush our full known peer set by
--     considering them all to have bad connectivity.
--     Should also take account of DNS failures for root peer set.
--     lastSucessfulNetworkEvent :: Time
     }
  deriving (Int -> PeerSelectionState peeraddr peerconn -> ShowS
[PeerSelectionState peeraddr peerconn] -> ShowS
PeerSelectionState peeraddr peerconn -> String
(Int -> PeerSelectionState peeraddr peerconn -> ShowS)
-> (PeerSelectionState peeraddr peerconn -> String)
-> ([PeerSelectionState peeraddr peerconn] -> ShowS)
-> Show (PeerSelectionState peeraddr peerconn)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall peeraddr peerconn.
(Ord peeraddr, Show peeraddr, Show peerconn) =>
Int -> PeerSelectionState peeraddr peerconn -> ShowS
forall peeraddr peerconn.
(Ord peeraddr, Show peeraddr, Show peerconn) =>
[PeerSelectionState peeraddr peerconn] -> ShowS
forall peeraddr peerconn.
(Ord peeraddr, Show peeraddr, Show peerconn) =>
PeerSelectionState peeraddr peerconn -> String
showList :: [PeerSelectionState peeraddr peerconn] -> ShowS
$cshowList :: forall peeraddr peerconn.
(Ord peeraddr, Show peeraddr, Show peerconn) =>
[PeerSelectionState peeraddr peerconn] -> ShowS
show :: PeerSelectionState peeraddr peerconn -> String
$cshow :: forall peeraddr peerconn.
(Ord peeraddr, Show peeraddr, Show peerconn) =>
PeerSelectionState peeraddr peerconn -> String
showsPrec :: Int -> PeerSelectionState peeraddr peerconn -> ShowS
$cshowsPrec :: forall peeraddr peerconn.
(Ord peeraddr, Show peeraddr, Show peerconn) =>
Int -> PeerSelectionState peeraddr peerconn -> ShowS
Show, a -> PeerSelectionState peeraddr b -> PeerSelectionState peeraddr a
(a -> b)
-> PeerSelectionState peeraddr a -> PeerSelectionState peeraddr b
(forall a b.
 (a -> b)
 -> PeerSelectionState peeraddr a -> PeerSelectionState peeraddr b)
-> (forall a b.
    a
    -> PeerSelectionState peeraddr b -> PeerSelectionState peeraddr a)
-> Functor (PeerSelectionState peeraddr)
forall a b.
a -> PeerSelectionState peeraddr b -> PeerSelectionState peeraddr a
forall a b.
(a -> b)
-> PeerSelectionState peeraddr a -> PeerSelectionState peeraddr b
forall peeraddr a b.
a -> PeerSelectionState peeraddr b -> PeerSelectionState peeraddr a
forall peeraddr a b.
(a -> b)
-> PeerSelectionState peeraddr a -> PeerSelectionState peeraddr b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PeerSelectionState peeraddr b -> PeerSelectionState peeraddr a
$c<$ :: forall peeraddr a b.
a -> PeerSelectionState peeraddr b -> PeerSelectionState peeraddr a
fmap :: (a -> b)
-> PeerSelectionState peeraddr a -> PeerSelectionState peeraddr b
$cfmap :: forall peeraddr a b.
(a -> b)
-> PeerSelectionState peeraddr a -> PeerSelectionState peeraddr b
Functor)

data PeerSelectionCounters = PeerSelectionCounters {
      PeerSelectionCounters -> Int
coldPeers :: Int,
      PeerSelectionCounters -> Int
warmPeers :: Int,
      PeerSelectionCounters -> Int
hotPeers  :: Int
    } deriving (PeerSelectionCounters -> PeerSelectionCounters -> Bool
(PeerSelectionCounters -> PeerSelectionCounters -> Bool)
-> (PeerSelectionCounters -> PeerSelectionCounters -> Bool)
-> Eq PeerSelectionCounters
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PeerSelectionCounters -> PeerSelectionCounters -> Bool
$c/= :: PeerSelectionCounters -> PeerSelectionCounters -> Bool
== :: PeerSelectionCounters -> PeerSelectionCounters -> Bool
$c== :: PeerSelectionCounters -> PeerSelectionCounters -> Bool
Eq, Int -> PeerSelectionCounters -> ShowS
[PeerSelectionCounters] -> ShowS
PeerSelectionCounters -> String
(Int -> PeerSelectionCounters -> ShowS)
-> (PeerSelectionCounters -> String)
-> ([PeerSelectionCounters] -> ShowS)
-> Show PeerSelectionCounters
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PeerSelectionCounters] -> ShowS
$cshowList :: [PeerSelectionCounters] -> ShowS
show :: PeerSelectionCounters -> String
$cshow :: PeerSelectionCounters -> String
showsPrec :: Int -> PeerSelectionCounters -> ShowS
$cshowsPrec :: Int -> PeerSelectionCounters -> ShowS
Show)

peerStateToCounters :: Ord peeraddr => PeerSelectionState peeraddr peerconn -> PeerSelectionCounters
peerStateToCounters :: PeerSelectionState peeraddr peerconn -> PeerSelectionCounters
peerStateToCounters PeerSelectionState peeraddr peerconn
st = PeerSelectionCounters :: Int -> Int -> Int -> PeerSelectionCounters
PeerSelectionCounters { Int
coldPeers :: Int
coldPeers :: Int
coldPeers, Int
warmPeers :: Int
warmPeers :: Int
warmPeers, Int
hotPeers :: Int
hotPeers :: Int
hotPeers }
  where
    knownPeersSet :: Set peeraddr
knownPeersSet = KnownPeers peeraddr -> Set peeraddr
forall peeraddr. KnownPeers peeraddr -> Set peeraddr
KnownPeers.toSet (PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers PeerSelectionState peeraddr peerconn
st)
    establishedPeersSet :: Set peeraddr
establishedPeersSet = EstablishedPeers peeraddr peerconn -> Set peeraddr
forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Set peeraddr
EstablishedPeers.toSet (PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers PeerSelectionState peeraddr peerconn
st)
    coldPeers :: Int
coldPeers = Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ Set peeraddr
knownPeersSet Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
establishedPeersSet
    warmPeers :: Int
warmPeers = Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ Set peeraddr
establishedPeersSet Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ PeerSelectionState peeraddr peerconn -> Set peeraddr
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers PeerSelectionState peeraddr peerconn
st
    hotPeers :: Int
hotPeers  = Set peeraddr -> Int
forall a. Set a -> Int
Set.size (Set peeraddr -> Int) -> Set peeraddr -> Int
forall a b. (a -> b) -> a -> b
$ PeerSelectionState peeraddr peerconn -> Set peeraddr
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers PeerSelectionState peeraddr peerconn
st

emptyPeerSelectionState :: StdGen -> PeerSelectionState peeraddr peerconn
emptyPeerSelectionState :: StdGen -> PeerSelectionState peeraddr peerconn
emptyPeerSelectionState StdGen
rng =
    PeerSelectionState :: forall peeraddr peerconn.
PeerSelectionTargets
-> LocalRootPeers peeraddr
-> Set peeraddr
-> KnownPeers peeraddr
-> EstablishedPeers peeraddr peerconn
-> Set peeraddr
-> Int
-> Time
-> Bool
-> Int
-> Set peeraddr
-> Set peeraddr
-> Set peeraddr
-> Set peeraddr
-> StdGen
-> Cache PeerSelectionCounters
-> PeerSelectionState peeraddr peerconn
PeerSelectionState {
      targets :: PeerSelectionTargets
targets              = PeerSelectionTargets
nullPeerSelectionTargets,
      localRootPeers :: LocalRootPeers peeraddr
localRootPeers       = LocalRootPeers peeraddr
forall peeraddr. LocalRootPeers peeraddr
LocalRootPeers.empty,
      publicRootPeers :: Set peeraddr
publicRootPeers      = Set peeraddr
forall a. Set a
Set.empty,
      knownPeers :: KnownPeers peeraddr
knownPeers           = KnownPeers peeraddr
forall peeraddr. KnownPeers peeraddr
KnownPeers.empty,
      establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers     = EstablishedPeers peeraddr peerconn
forall peeraddr perconn. EstablishedPeers peeraddr perconn
EstablishedPeers.empty,
      activePeers :: Set peeraddr
activePeers          = Set peeraddr
forall a. Set a
Set.empty,
      publicRootBackoffs :: Int
publicRootBackoffs   = Int
0,
      publicRootRetryTime :: Time
publicRootRetryTime  = DiffTime -> Time
Time DiffTime
0,
      inProgressPublicRootsReq :: Bool
inProgressPublicRootsReq = Bool
False,
      inProgressGossipReqs :: Int
inProgressGossipReqs     = Int
0,
      inProgressPromoteCold :: Set peeraddr
inProgressPromoteCold    = Set peeraddr
forall a. Set a
Set.empty,
      inProgressPromoteWarm :: Set peeraddr
inProgressPromoteWarm    = Set peeraddr
forall a. Set a
Set.empty,
      inProgressDemoteWarm :: Set peeraddr
inProgressDemoteWarm     = Set peeraddr
forall a. Set a
Set.empty,
      inProgressDemoteHot :: Set peeraddr
inProgressDemoteHot      = Set peeraddr
forall a. Set a
Set.empty,
      fuzzRng :: StdGen
fuzzRng                  = StdGen
rng,
      countersCache :: Cache PeerSelectionCounters
countersCache            = PeerSelectionCounters -> Cache PeerSelectionCounters
forall a. a -> Cache a
Cache (Int -> Int -> Int -> PeerSelectionCounters
PeerSelectionCounters Int
0 Int
0 Int
0)
    }


assertPeerSelectionState :: Ord peeraddr
                         => PeerSelectionState peeraddr peerconn
                         -> a -> a
assertPeerSelectionState :: PeerSelectionState peeraddr peerconn -> a -> a
assertPeerSelectionState PeerSelectionState{Bool
Int
Set peeraddr
StdGen
Cache PeerSelectionCounters
Time
EstablishedPeers peeraddr peerconn
KnownPeers peeraddr
LocalRootPeers peeraddr
PeerSelectionTargets
countersCache :: Cache PeerSelectionCounters
fuzzRng :: StdGen
inProgressDemoteHot :: Set peeraddr
inProgressDemoteWarm :: Set peeraddr
inProgressPromoteWarm :: Set peeraddr
inProgressPromoteCold :: Set peeraddr
inProgressGossipReqs :: Int
inProgressPublicRootsReq :: Bool
publicRootRetryTime :: Time
publicRootBackoffs :: Int
activePeers :: Set peeraddr
establishedPeers :: EstablishedPeers peeraddr peerconn
knownPeers :: KnownPeers peeraddr
publicRootPeers :: Set peeraddr
localRootPeers :: LocalRootPeers peeraddr
targets :: PeerSelectionTargets
countersCache :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Cache PeerSelectionCounters
fuzzRng :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> StdGen
inProgressDemoteHot :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressDemoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteWarm :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressPromoteCold :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
inProgressGossipReqs :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Int
inProgressPublicRootsReq :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Bool
publicRootRetryTime :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Time
publicRootBackoffs :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Int
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
knownPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
..} =
    Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (KnownPeers peeraddr -> Bool
forall peeraddr. Ord peeraddr => KnownPeers peeraddr -> Bool
KnownPeers.invariant KnownPeers peeraddr
knownPeers)
  (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (EstablishedPeers peeraddr peerconn -> Bool
forall peeraddr peerconn.
Ord peeraddr =>
EstablishedPeers peeraddr peerconn -> Bool
EstablishedPeers.invariant EstablishedPeers peeraddr peerconn
establishedPeers)
  (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (LocalRootPeers peeraddr -> Bool
forall peeraddr. Ord peeraddr => LocalRootPeers peeraddr -> Bool
LocalRootPeers.invariant LocalRootPeers peeraddr
localRootPeers)

    -- The activePeers is a subset of the establishedPeers
    -- which is a subset of the known peers
  (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set peeraddr
activePeersSet Set peeraddr
establishedReadySet)
  (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set peeraddr
establishedPeersSet Set peeraddr
knownPeersSet)

   -- The localRootPeers and publicRootPeers must not overlap.
  (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null (Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set peeraddr
localRootPeersSet Set peeraddr
publicRootPeers))

    -- The localRootPeers are a subset of the knownPeers,
    -- and with correct source info in the knownPeers (either
    -- 'PeerSroucePublicRoot' or 'PeerSourceLocalRoot', as local and public
    -- root peers might overlap).
  (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set peeraddr
localRootPeersSet Set peeraddr
knownPeersSet)

    -- The publicRootPeers are a subset of the knownPeers,
    -- and with correct source info in the knownPeers.
  (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set peeraddr
publicRootPeers Set peeraddr
knownPeersSet)

    -- The targets should respect the containment relationships of the root,
    -- known, established and active peers
  (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PeerSelectionTargets -> Bool
sanePeerSelectionTargets PeerSelectionTargets
targets)

    -- All the local root peers are always a subset of the known peers. The
    -- target for known peers is a target from both below and above. Thus the
    -- number of local root peers must be less than or equal to the known peers
    -- target, otherwise we could get stuck.
  (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (LocalRootPeers peeraddr -> Int
forall peeraddr. LocalRootPeers peeraddr -> Int
LocalRootPeers.size LocalRootPeers peeraddr
localRootPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= PeerSelectionTargets -> Int
targetNumberOfKnownPeers PeerSelectionTargets
targets)

    -- Interestingly, although the local root peers are also a subset of the
    -- root peers, the equivalent constraint does not apply to the target
    -- number of root peers. The reason is that the root peers target is only
    -- a target from below, not from above. It is ok to have more than the
    -- target number of root peers.
    --
    --That is, we do /not/ need or want this invariant:
    --    LocalRootPeers.size   localRootPeers <= targetNumberOfRootPeers
    --
    -- It is also not necessary for all the targets to be achievable. It is
    -- just necessary that we do not get stuck. So although we have an implicit
    -- target that all local root peers become established, and a certain
    -- number of them become active, these targets do not need to be achievable.
    --
    --That is, we do /not/ need or want this invariant:
    --    LocalRootPeers.size   localRootPeers <= targetNumberOfEstablishedPeers
    --    LocalRootPeers.target localRootPeers <= targetNumberOfActivePeers
    --

    -- All currently established peers are in the availableToConnect set since
    -- the alternative is a record of failure, but these are not (yet) failed.
  (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set peeraddr
establishedPeersSet (KnownPeers peeraddr -> Set peeraddr
forall peeraddr. KnownPeers peeraddr -> Set peeraddr
KnownPeers.availableToConnect KnownPeers peeraddr
knownPeers))

    -- No constraint for publicRootBackoffs, publicRootRetryTime
    -- or inProgressPublicRootsReq

  (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
inProgressGossipReqs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0)
  (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set peeraddr
inProgressPromoteCold Set peeraddr
coldPeersSet)
  (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set peeraddr
inProgressPromoteWarm Set peeraddr
warmPeersSet)
  (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set peeraddr
inProgressDemoteWarm  Set peeraddr
warmPeersSet)
  (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf Set peeraddr
inProgressDemoteHot   Set peeraddr
hotPeersSet)
  (a -> a) -> (a -> a) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> a -> a
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null (Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set peeraddr
inProgressPromoteWarm Set peeraddr
inProgressDemoteWarm))
  where
    knownPeersSet :: Set peeraddr
knownPeersSet       = KnownPeers peeraddr -> Set peeraddr
forall peeraddr. KnownPeers peeraddr -> Set peeraddr
KnownPeers.toSet KnownPeers peeraddr
knownPeers
    localRootPeersSet :: Set peeraddr
localRootPeersSet   = LocalRootPeers peeraddr -> Set peeraddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers peeraddr
localRootPeers
    establishedPeersSet :: Set peeraddr
establishedPeersSet = EstablishedPeers peeraddr peerconn -> Set peeraddr
forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Set peeraddr
EstablishedPeers.toSet      EstablishedPeers peeraddr peerconn
establishedPeers
    establishedReadySet :: Set peeraddr
establishedReadySet = EstablishedPeers peeraddr peerconn -> Set peeraddr
forall peeraddr peerconn.
Ord peeraddr =>
EstablishedPeers peeraddr peerconn -> Set peeraddr
EstablishedPeers.readyPeers EstablishedPeers peeraddr peerconn
establishedPeers
    activePeersSet :: Set peeraddr
activePeersSet      = Set peeraddr
activePeers
    coldPeersSet :: Set peeraddr
coldPeersSet        = Set peeraddr
knownPeersSet Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
establishedPeersSet
    warmPeersSet :: Set peeraddr
warmPeersSet        = Set peeraddr
establishedPeersSet Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
activePeersSet
    hotPeersSet :: Set peeraddr
hotPeersSet         = Set peeraddr
activePeersSet


-- | A view of the status of each established peer, for testing and debugging.
--
establishedPeersStatus :: Ord peeraddr
                       => PeerSelectionState peeraddr peerconn
                       -> Map peeraddr PeerStatus
establishedPeersStatus :: PeerSelectionState peeraddr peerconn -> Map peeraddr PeerStatus
establishedPeersStatus PeerSelectionState{EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers, Set peeraddr
activePeers :: Set peeraddr
activePeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
activePeers} =
    -- map union-override, left to right
    (peeraddr -> PeerStatus) -> Set peeraddr -> Map peeraddr PeerStatus
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (\peeraddr
_ -> PeerStatus
PeerHot)  Set peeraddr
activePeers
 Map peeraddr PeerStatus
-> Map peeraddr PeerStatus -> Map peeraddr PeerStatus
forall a. Semigroup a => a -> a -> a
<> (peeraddr -> PeerStatus) -> Set peeraddr -> Map peeraddr PeerStatus
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (\peeraddr
_ -> PeerStatus
PeerWarm) (EstablishedPeers peeraddr peerconn -> Set peeraddr
forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Set peeraddr
EstablishedPeers.toSet EstablishedPeers peeraddr peerconn
establishedPeers)


--------------------------------
-- PickPolicy wrapper function
--

-- | Check pre-conditions and post-conditions on the pick policies,
-- and supply additional peer atributes from the current state.
--
pickPeers :: (Ord peeraddr, Functor m)
          => PeerSelectionState peeraddr peerconn
          -> (   (peeraddr -> PeerSource)
              -> (peeraddr -> Int)
              -> (peeraddr -> Bool)
              -> Set peeraddr -> Int -> m (Set peeraddr))
          -> Set peeraddr -> Int -> m (Set peeraddr)
pickPeers :: PeerSelectionState peeraddr peerconn
-> ((peeraddr -> PeerSource)
    -> (peeraddr -> Int)
    -> (peeraddr -> Bool)
    -> Set peeraddr
    -> Int
    -> m (Set peeraddr))
-> Set peeraddr
-> Int
-> m (Set peeraddr)
pickPeers PeerSelectionState{LocalRootPeers peeraddr
localRootPeers :: LocalRootPeers peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers, Set peeraddr
publicRootPeers :: Set peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
publicRootPeers, KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers}
          (peeraddr -> PeerSource)
-> (peeraddr -> Int)
-> (peeraddr -> Bool)
-> Set peeraddr
-> Int
-> m (Set peeraddr)
pick Set peeraddr
available Int
num =
    Bool -> m (Set peeraddr) -> m (Set peeraddr)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert Bool
precondition (m (Set peeraddr) -> m (Set peeraddr))
-> m (Set peeraddr) -> m (Set peeraddr)
forall a b. (a -> b) -> a -> b
$
    (Set peeraddr -> Set peeraddr)
-> m (Set peeraddr) -> m (Set peeraddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Set peeraddr
picked -> Bool -> Set peeraddr -> Set peeraddr
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr -> Bool
postcondition Set peeraddr
picked) Set peeraddr
picked)
         ((peeraddr -> PeerSource)
-> (peeraddr -> Int)
-> (peeraddr -> Bool)
-> Set peeraddr
-> Int
-> m (Set peeraddr)
pick peeraddr -> PeerSource
peerSource peeraddr -> Int
peerConnectFailCount peeraddr -> Bool
peerTepidFlag
               Set peeraddr
available Int
numClamped)
  where
    precondition :: Bool
precondition         = Bool -> Bool
not (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
available) Bool -> Bool -> Bool
&& Int
num Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
    postcondition :: Set peeraddr -> Bool
postcondition Set peeraddr
picked = Bool -> Bool
not (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
picked)
                        Bool -> Bool -> Bool
&& Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
picked Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
numClamped
                        Bool -> Bool -> Bool
&& Set peeraddr
picked Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`Set.isSubsetOf` Set peeraddr
available
    numClamped :: Int
numClamped           = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
num (Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
available)

    peerSource :: peeraddr -> PeerSource
peerSource peeraddr
p
      | peeraddr -> LocalRootPeers peeraddr -> Bool
forall peeraddr.
Ord peeraddr =>
peeraddr -> LocalRootPeers peeraddr -> Bool
LocalRootPeers.member peeraddr
p LocalRootPeers peeraddr
localRootPeers = PeerSource
PeerSourceLocalRoot
      | peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member peeraddr
p Set peeraddr
publicRootPeers           = PeerSource
PeerSourcePublicRoot
      | peeraddr -> KnownPeers peeraddr -> Bool
forall peeraddr.
Ord peeraddr =>
peeraddr -> KnownPeers peeraddr -> Bool
KnownPeers.member peeraddr
p KnownPeers peeraddr
knownPeers         = PeerSource
PeerSourceGossip
      | Bool
otherwise                              = PeerSource
forall a. a
errorUnavailable

    peerConnectFailCount :: peeraddr -> Int
peerConnectFailCount peeraddr
p =
        Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
forall a. a
errorUnavailable (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$
          peeraddr -> KnownPeers peeraddr -> Maybe Int
forall peeraddr.
Ord peeraddr =>
peeraddr -> KnownPeers peeraddr -> Maybe Int
KnownPeers.lookupFailCount peeraddr
p KnownPeers peeraddr
knownPeers

    peerTepidFlag :: peeraddr -> Bool
peerTepidFlag peeraddr
p  =
        Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
forall a. a
errorUnavailable (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$
          peeraddr -> KnownPeers peeraddr -> Maybe Bool
forall peeraddr.
Ord peeraddr =>
peeraddr -> KnownPeers peeraddr -> Maybe Bool
KnownPeers.lookupTepidFlag peeraddr
p KnownPeers peeraddr
knownPeers

    errorUnavailable :: a
errorUnavailable =
        String -> a
forall a. (?callStack::CallStack) => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"A pick policy requested an attribute for peer address "
             String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" which is outside of the set given to pick from"


---------------------------
-- Peer Selection Decisions
--


-- | The governor is using @Guarded m (Decision m peeraddr peerconn)@ where 'm'
-- is an 'STM' monad, to drive its progress.
--
data Guarded m a =
    -- | 'GuardedSkip' is used to instruct that there is no action to be made
    -- by the governor.
    --
    -- Let us note that the combined value which is computed by
    -- @guardedDecisions@ term in
    -- 'Ouroboros.Newtork.PeerSelection.Governor.peerSelectionGovernorLoop' will
    -- never return it: this is bacause there are monitoring decisions which
    -- never return this constructor, e.g.  'Monitor.targetPeers',
    -- 'Monitor.jobs', 'Monitor.connections', and thus the governor has always
    -- something to do.
    --
    GuardedSkip !(Maybe (Min Time))

    -- | 'Guarded' is used to provide an action through 'FirstToFinish'
    -- synchronisation, possibly with a timeout, to
    -- the governor main loop.
    --
  | Guarded'   !(Maybe (Min Time)) (FirstToFinish m a)


-- | 'Guarded' constructor which provides an action, possibly with a timeout,
-- to the governor main loop.  It hides the use of 'FirstToFinish'
-- synchronisation.
--
pattern Guarded :: Maybe (Min Time) -> m a -> Guarded m a
pattern $bGuarded :: Maybe (Min Time) -> m a -> Guarded m a
$mGuarded :: forall r (m :: * -> *) a.
Guarded m a -> (Maybe (Min Time) -> m a -> r) -> (Void# -> r) -> r
Guarded a b <- Guarded' a (FirstToFinish b)
  where
    Guarded Maybe (Min Time)
a m a
b = Maybe (Min Time) -> FirstToFinish m a -> Guarded m a
forall (m :: * -> *) a.
Maybe (Min Time) -> FirstToFinish m a -> Guarded m a
Guarded' Maybe (Min Time)
a (m a -> FirstToFinish m a
forall (m :: * -> *) a. m a -> FirstToFinish m a
FirstToFinish m a
b)

{-# COMPLETE GuardedSkip, Guarded #-}

-- | 'Guarded' constructor is absorbing in the sense that
--
-- > Guarded x y <> a = Guarded x' y'
-- > a <> Guarded x y = Guarded x' y'
--
-- In the algebraic sense, @'Guarded' (Just minBound) (return x)@ is a left
-- absorbing element when "m ~ STM m'@ for some monad @m'@.  There is no right
-- absorbing element since there is no right absorbing elemnt in @STM m'@.
--
-- Ref. [absorbing element](https://en.wikipedia.org/wiki/Absorbing_element)
--
instance Alternative m => Semigroup (Guarded m a) where
  Guarded'    Maybe (Min Time)
ta FirstToFinish m a
a <> :: Guarded m a -> Guarded m a -> Guarded m a
<> Guarded'    Maybe (Min Time)
tb FirstToFinish m a
b = Maybe (Min Time) -> FirstToFinish m a -> Guarded m a
forall (m :: * -> *) a.
Maybe (Min Time) -> FirstToFinish m a -> Guarded m a
Guarded'    (Maybe (Min Time)
ta Maybe (Min Time) -> Maybe (Min Time) -> Maybe (Min Time)
forall a. Semigroup a => a -> a -> a
<> Maybe (Min Time)
tb) (FirstToFinish m a
a FirstToFinish m a -> FirstToFinish m a -> FirstToFinish m a
forall a. Semigroup a => a -> a -> a
<> FirstToFinish m a
b)
  Guarded'    Maybe (Min Time)
ta FirstToFinish m a
a <> GuardedSkip Maybe (Min Time)
tb   = Maybe (Min Time) -> FirstToFinish m a -> Guarded m a
forall (m :: * -> *) a.
Maybe (Min Time) -> FirstToFinish m a -> Guarded m a
Guarded'    (Maybe (Min Time)
ta Maybe (Min Time) -> Maybe (Min Time) -> Maybe (Min Time)
forall a. Semigroup a => a -> a -> a
<> Maybe (Min Time)
tb)  FirstToFinish m a
a
  GuardedSkip Maybe (Min Time)
ta   <> Guarded'    Maybe (Min Time)
tb FirstToFinish m a
b = Maybe (Min Time) -> FirstToFinish m a -> Guarded m a
forall (m :: * -> *) a.
Maybe (Min Time) -> FirstToFinish m a -> Guarded m a
Guarded'    (Maybe (Min Time)
ta Maybe (Min Time) -> Maybe (Min Time) -> Maybe (Min Time)
forall a. Semigroup a => a -> a -> a
<> Maybe (Min Time)
tb)  FirstToFinish m a
b
  GuardedSkip Maybe (Min Time)
ta   <> GuardedSkip Maybe (Min Time)
tb   = Maybe (Min Time) -> Guarded m a
forall (m :: * -> *) a. Maybe (Min Time) -> Guarded m a
GuardedSkip (Maybe (Min Time)
ta Maybe (Min Time) -> Maybe (Min Time) -> Maybe (Min Time)
forall a. Semigroup a => a -> a -> a
<> Maybe (Min Time)
tb)


data Decision m peeraddr peerconn = Decision {
         -- | A trace event to classify the decision and action
       Decision m peeraddr peerconn -> TracePeerSelection peeraddr
decisionTrace :: TracePeerSelection peeraddr,

         -- | An updated state to use immediately
       Decision m peeraddr peerconn
-> PeerSelectionState peeraddr peerconn
decisionState :: PeerSelectionState peeraddr peerconn,

       -- | An optional 'Job' to execute asynchronously. This job leads to
       -- a further 'Decision'. This gives a state update to apply upon
       -- completion, but also allows chaining further job actions.
       --
       Decision m peeraddr peerconn
-> [Job () m (Completion m peeraddr peerconn)]
decisionJobs  :: [Job () m (Completion m peeraddr peerconn)]
     }

-- | Decision which has access to the current time, rather than the time when
-- the governor's loop blocked to make a decision.
--
type TimedDecision m peeraddr peerconn = Time -> Decision m peeraddr peerconn

-- | Type alias for function types which are used to create governor decisions.
-- Allmost all decisions are following this pattern.
--
type MkGuardedDecision peeraddr peerconn m
     = PeerSelectionPolicy peeraddr m
    -> PeerSelectionState peeraddr peerconn
    -> Guarded (STM m) (TimedDecision m peeraddr peerconn)


newtype Completion m peeraddr peerconn =
        Completion (PeerSelectionState peeraddr peerconn
                 -> Time -> Decision m peeraddr peerconn)

data TracePeerSelection peeraddr =
       TraceLocalRootPeersChanged (LocalRootPeers peeraddr)
                                  (LocalRootPeers peeraddr)
     | TraceTargetsChanged     PeerSelectionTargets PeerSelectionTargets
     | TracePublicRootsRequest Int Int
     | TracePublicRootsResults (Set peeraddr) Int DiffTime
     | TracePublicRootsFailure SomeException Int DiffTime
     -- | target known peers, actual known peers, peers available for gossip,
     -- peers selected for gossip
     | TraceGossipRequests     Int Int (Set peeraddr) (Set peeraddr)
     | TraceGossipResults      [(peeraddr, Either SomeException [peeraddr])] --TODO: classify failures
     -- | target known peers, actual known peers, selected peer
     | TraceForgetColdPeers    Int Int (Set peeraddr)
     -- | target established, actual established, selected peers
     | TracePromoteColdPeers   Int Int (Set peeraddr)
     -- | target local established, actual local established, selected peers
     | TracePromoteColdLocalPeers Int Int (Set peeraddr)
     -- | target established, actual established, peer, delay until next
     -- promotion, reason
     | TracePromoteColdFailed  Int Int peeraddr DiffTime SomeException
     -- | target established, actual established, peer
     | TracePromoteColdDone    Int Int peeraddr
     -- | target active, actual active, selected peers
     | TracePromoteWarmPeers   Int Int (Set peeraddr)
     -- | Promote local peers to warm
     | TracePromoteWarmLocalPeers
         [(Int, Int)]   -- ^ local per-group `(target active, actual active)`,
                        -- only limited to groups which are below their target.
         (Set peeraddr) -- ^ selected peers
     -- | target active, actual active, peer, reason
     | TracePromoteWarmFailed  Int Int peeraddr SomeException
     -- | target active, actual active, peer
     | TracePromoteWarmDone    Int Int peeraddr
     -- | aborted promotion of a warm peer; likely it was asynchronously
     -- demoted in the meantime.
     --
     -- target active, actual active, peer
     | TracePromoteWarmAborted Int Int peeraddr
     -- | target established, actual established, selected peers
     | TraceDemoteWarmPeers    Int Int (Set peeraddr)
     -- | target established, actual established, peer, reason
     | TraceDemoteWarmFailed   Int Int  peeraddr SomeException
     -- | target established, actual established, peer
     | TraceDemoteWarmDone     Int Int peeraddr
     -- | target active, actual active, selected peers
     | TraceDemoteHotPeers     Int Int (Set peeraddr)
     -- | local per-group (target active, actual active), selected peers
     | TraceDemoteLocalHotPeers [(Int, Int)] (Set peeraddr)
     -- | target active, actual active, peer, reason
     | TraceDemoteHotFailed    Int Int peeraddr SomeException
     -- | target active, actual active, peer
     | TraceDemoteHotDone      Int Int peeraddr
     | TraceDemoteAsynchronous (Map peeraddr PeerStatus)
     | TraceGovernorWakeup
     | TraceChurnWait          DiffTime
     | TraceChurnMode          ChurnMode
  deriving Int -> TracePeerSelection peeraddr -> ShowS
[TracePeerSelection peeraddr] -> ShowS
TracePeerSelection peeraddr -> String
(Int -> TracePeerSelection peeraddr -> ShowS)
-> (TracePeerSelection peeraddr -> String)
-> ([TracePeerSelection peeraddr] -> ShowS)
-> Show (TracePeerSelection peeraddr)
forall peeraddr.
(Show peeraddr, Ord peeraddr) =>
Int -> TracePeerSelection peeraddr -> ShowS
forall peeraddr.
(Show peeraddr, Ord peeraddr) =>
[TracePeerSelection peeraddr] -> ShowS
forall peeraddr.
(Show peeraddr, Ord peeraddr) =>
TracePeerSelection peeraddr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TracePeerSelection peeraddr] -> ShowS
$cshowList :: forall peeraddr.
(Show peeraddr, Ord peeraddr) =>
[TracePeerSelection peeraddr] -> ShowS
show :: TracePeerSelection peeraddr -> String
$cshow :: forall peeraddr.
(Show peeraddr, Ord peeraddr) =>
TracePeerSelection peeraddr -> String
showsPrec :: Int -> TracePeerSelection peeraddr -> ShowS
$cshowsPrec :: forall peeraddr.
(Show peeraddr, Ord peeraddr) =>
Int -> TracePeerSelection peeraddr -> ShowS
Show

data DebugPeerSelection peeraddr where
  TraceGovernorState :: forall peeraddr peerconn.
                        Show peerconn
                     => Time            -- blocked time
                     -> Maybe DiffTime  -- wait time
                     -> PeerSelectionState peeraddr peerconn
                     -> DebugPeerSelection peeraddr

deriving instance (Ord peeraddr, Show peeraddr)
               => Show (DebugPeerSelection peeraddr)

data ChurnMode = ChurnModeBulkSync
               | ChurnModeNormal deriving Int -> ChurnMode -> ShowS
[ChurnMode] -> ShowS
ChurnMode -> String
(Int -> ChurnMode -> ShowS)
-> (ChurnMode -> String)
-> ([ChurnMode] -> ShowS)
-> Show ChurnMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChurnMode] -> ShowS
$cshowList :: [ChurnMode] -> ShowS
show :: ChurnMode -> String
$cshow :: ChurnMode -> String
showsPrec :: Int -> ChurnMode -> ShowS
$cshowsPrec :: Int -> ChurnMode -> ShowS
Show