{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Ouroboros.Network.PeerSelection.Governor.KnownPeers
  ( belowTarget
  , aboveTarget
  ) where

import Data.Hashable
import Data.List (sortBy)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe)
import Data.Set qualified as Set
import GHC.Stack (HasCallStack)
import System.Random (random)

import Control.Concurrent.JobPool (Job (..))
import Control.Exception (Exception (..), SomeException, assert)
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadSTM
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI

import Ouroboros.Network.Diffusion.Policies qualified as Policies
import Ouroboros.Network.PeerSelection.Governor.Types
import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..))
import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..))
import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers
import Ouroboros.Network.PeerSelection.State.EstablishedPeers qualified as EstablishedPeers
import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers
import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers
import Ouroboros.Network.PeerSelection.Types (PublicExtraPeersAPI (..))
import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount)


---------------------------
-- Known peers below target
--

-- | If we are below the target of /known peers/ we flip a coin to either get
-- new peers from:
--
-- * inbound connections; or
-- * peer share (if we are above the peer share request threshold).
--
-- It should be noted if the node is in bootstrap mode (i.e. in a sensitive
-- state) then this monitoring action will be disabled.
--
belowTarget
  :: (MonadAsync m, MonadTimer m, Ord peeraddr, Hashable peeraddr)
  => (extraState -> Bool)
  -- ^ This argument enables or disables this monitoring action based on an
  -- 'extraState' flag.
  --
  -- This might be useful if the user requires its diffusion layer to stop
  -- making progress during a sensitive/vulnerable situation and quarantine
  -- it and make sure it is only connected to trusted peers.
  -> PeerSelectionActions extraState extraFlags extraPeers extraAPI extraCounters peeraddr peerconn m
  -> Time -- ^ blocked at
  -> Map peeraddr PeerSharing
  -> MkGuardedDecision extraState extraDebugState extraFlags extraPeers peeraddr peerconn m
belowTarget :: forall (m :: * -> *) peeraddr extraState extraFlags extraPeers
       extraAPI extraCounters peerconn extraDebugState.
(MonadAsync m, MonadTimer m, Ord peeraddr, Hashable peeraddr) =>
(extraState -> Bool)
-> PeerSelectionActions
     extraState
     extraFlags
     extraPeers
     extraAPI
     extraCounters
     peeraddr
     peerconn
     m
-> Time
-> Map peeraddr PeerSharing
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
     m
belowTarget extraState -> Bool
enableAction
            actions :: PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
actions@PeerSelectionActions {
              PeerSharing
peerSharing :: PeerSharing
peerSharing :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSharing
peerSharing,
              extraPeersAPI :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PublicExtraPeersAPI extraPeers peeraddr
extraPeersAPI = PublicExtraPeersAPI {
                peeraddr -> extraPeers -> Bool
memberExtraPeers :: peeraddr -> extraPeers -> Bool
memberExtraPeers :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> peeraddr -> extraPeers -> Bool
memberExtraPeers,
                extraPeers -> Set peeraddr
extraPeersToSet :: extraPeers -> Set peeraddr
extraPeersToSet :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> extraPeers -> Set peeraddr
extraPeersToSet
              },
              PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters
            }
            Time
blockedAt
            Map peeraddr PeerSharing
inboundPeers
            policy :: PeerSelectionPolicy peeraddr m
policy@PeerSelectionPolicy {
              Int
policyMaxInProgressPeerShareReqs :: Int
policyMaxInProgressPeerShareReqs :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> Int
policyMaxInProgressPeerShareReqs,
              PickPolicy peeraddr (STM m)
policyPickKnownPeersForPeerShare :: PickPolicy peeraddr (STM m)
policyPickKnownPeersForPeerShare :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickKnownPeersForPeerShare,
              PickPolicy peeraddr (STM m)
policyPickInboundPeers :: PickPolicy peeraddr (STM m)
policyPickInboundPeers :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickInboundPeers,
              DiffTime
policyPeerShareRetryTime :: DiffTime
policyPeerShareRetryTime :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> DiffTime
policyPeerShareRetryTime
            }
            st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
              KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
knownPeers,
              EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers,
              Int
inProgressPeerShareReqs :: Int
inProgressPeerShareReqs :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Int
inProgressPeerShareReqs,
              Set peeraddr
inProgressDemoteToCold :: Set peeraddr
inProgressDemoteToCold :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressDemoteToCold,
              Time
inboundPeersRetryTime :: Time
inboundPeersRetryTime :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Time
inboundPeersRetryTime,
              targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionTargets
targets = PeerSelectionTargets {
                          Int
targetNumberOfKnownPeers :: Int
targetNumberOfKnownPeers :: PeerSelectionTargets -> Int
targetNumberOfKnownPeers
                        },
              extraState
extraState :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraState
extraState :: extraState
extraState,
              StdGen
stdGen :: StdGen
stdGen :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> StdGen
stdGen
            }
    --
    -- Light peer sharing
    --

  | PeerSharing
PeerSharingEnabled <- PeerSharing
peerSharing
    -- Are we under target for number of known peers?
  , Int
numKnownPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
targetNumberOfKnownPeers

    -- There are no peer share requests in-flight.
  , Int
inProgressPeerShareReqs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0

  , extraState -> Bool
enableAction extraState
extraState

  , Time
blockedAt Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
inboundPeersRetryTime

    -- Use inbound peers either if it won the coin flip or if there are no
    -- available peers to do peer sharing.
  , Bool
useInboundPeers Bool -> Bool -> Bool
|| Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
availableForPeerShare

  , let availablePeers :: Set peeraddr
availablePeers = Map peeraddr PeerSharing -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet Map peeraddr PeerSharing
inboundPeers
                  Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ KnownPeers peeraddr -> Set peeraddr
forall peeraddr. KnownPeers peeraddr -> Set peeraddr
KnownPeers.toSet KnownPeers peeraddr
knownPeers
  , Bool -> Bool
not (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
availablePeers)

  = Maybe Time
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM
   m
   (TimedDecision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ do
      selected <- (peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) extraPeers extraState extraFlags
       peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
(peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr m
-> Set peeraddr
-> Int
-> m (Set peeraddr)
pickUnknownPeers
                  peeraddr -> extraPeers -> Bool
memberExtraPeers
                  PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st
                  PickPolicy peeraddr (STM m)
policyPickInboundPeers
                  Set peeraddr
availablePeers
                  (Int
Policies.maxInboundPeers Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` (Int
targetNumberOfKnownPeers Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numKnownPeers))
      let selectedMap = Map peeraddr PeerSharing
inboundPeers Map peeraddr PeerSharing
-> Set peeraddr -> Map peeraddr PeerSharing
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.restrictKeys` Set peeraddr
selected
      return $ \Time
now -> Decision {
          decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [Int
-> Int
-> Map peeraddr PeerSharing
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> Map peeraddr PeerSharing
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TracePickInboundPeers
                            Int
targetNumberOfKnownPeers
                            Int
numKnownPeers
                            Map peeraddr PeerSharing
selectedMap
                            Set peeraddr
availablePeers
                          ],
          -- NOTE: We set `DoAdvertisePeer` for all peers coming from the
          -- inbound side. `AdvertisePeer` is only a local configuration option.
          decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st { knownPeers = KnownPeers.setSuccessfulConnectionFlag selected
                                          $ KnownPeers.insert
                                              (Map.map (\PeerSharing
ps -> (PeerSharing -> Maybe PeerSharing
forall a. a -> Maybe a
Just PeerSharing
ps, PeerAdvertise -> Maybe PeerAdvertise
forall a. a -> Maybe a
Just PeerAdvertise
DoAdvertisePeer)) selectedMap)
                                              knownPeers,
                               inboundPeersRetryTime = Policies.inboundPeersRetryDelay `addTime` now,
                               stdGen = stdGen'

                             },
          decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs = []
        }

    --
    -- Peer sharing
    --

  | PeerSharing
PeerSharingEnabled <- PeerSharing
peerSharing
    -- Are we under target for number of known peers?
  , Int
numKnownPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
targetNumberOfKnownPeers

    -- Are we at our limit for number of peer share requests?
  , Int
numPeerShareReqsPossible Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0

    -- Are there any known peers that we can send a peer share request to?
    -- We can only ask ones where we have not asked them within a certain time.
  , Bool -> Bool
not (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
availableForPeerShare)

  , extraState -> Bool
enableAction extraState
extraState

  = Maybe Time
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM
   m
   (TimedDecision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ do
      -- Max selected should be <= numPeerShareReqsPossible
      selectedForPeerShare <- (peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) extraPeers extraState extraFlags
       peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
(peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr m
-> Set peeraddr
-> Int
-> m (Set peeraddr)
pickPeers peeraddr -> extraPeers -> Bool
memberExtraPeers PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st
                              PickPolicy peeraddr (STM m)
policyPickKnownPeersForPeerShare
                              Set peeraddr
availableForPeerShare
                              Int
numPeerShareReqsPossible

      let -- Should be <= numPeerShareReqsPossible
          numPeerShareReqs = Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
selectedForPeerShare
          objective        = Int
targetNumberOfKnownPeers Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numKnownPeers
          -- Split current peer target objective across all peer sharing
          -- candidates. If the objective is smaller than the number of
          -- peer share requests available, ask for at 1 peer to each.
          --
          -- This is to increase diversity.
          numPeersToReq :: PeerSharingAmount
          !numPeersToReq = Int -> PeerSharingAmount
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                         (Int -> PeerSharingAmount) -> Int -> PeerSharingAmount
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
255 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
8 (Int
objective Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
numPeerShareReqs))
          (salt, stdGen'') = random stdGen'

      return $ \Time
now -> Decision {
        decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [Int
-> Int
-> PeerSharingAmount
-> Set peeraddr
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> PeerSharingAmount
-> Set peeraddr
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TracePeerShareRequests
                          Int
targetNumberOfKnownPeers
                          Int
numKnownPeers
                          PeerSharingAmount
numPeersToReq
                          Set peeraddr
availableForPeerShare
                          Set peeraddr
selectedForPeerShare],
        decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                          inProgressPeerShareReqs = inProgressPeerShareReqs
                                                  + numPeerShareReqs,
                          establishedPeers = EstablishedPeers.setPeerShareTime
                                              selectedForPeerShare
                                              (addTime policyPeerShareRetryTime now)
                                              establishedPeers,
                          stdGen = stdGen''
                        },
        decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  =
          [PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionPolicy peeraddr m
-> Int
-> Int
-> PeerSharingAmount
-> [peeraddr]
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) extraState extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr peerconn.
(MonadAsync m, MonadTimer m, Ord peeraddr, Hashable peeraddr) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionPolicy peeraddr m
-> Int
-> Int
-> PeerSharingAmount
-> [peeraddr]
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobPeerShare PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
actions PeerSelectionPolicy peeraddr m
policy Int
objective Int
salt PeerSharingAmount
numPeersToReq
             (Set peeraddr -> [peeraddr]
forall a. Set a -> [a]
Set.toList Set peeraddr
selectedForPeerShare)]
      }

    -- If we could peer share except that there are none currently available
    -- then we return the next wakeup time (if any)
  | Int
numKnownPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
targetNumberOfKnownPeers
  , Int
numPeerShareReqsPossible Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  , Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
availableForPeerShare
  = Maybe Time
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip (Maybe Time
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> Maybe Time
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ EstablishedPeers peeraddr peerconn -> Maybe Time
forall peeraddr peercon.
Ord peeraddr =>
EstablishedPeers peeraddr peercon -> Maybe Time
EstablishedPeers.minPeerShareTime EstablishedPeers peeraddr peerconn
establishedPeers

  | Bool
otherwise
  = Maybe Time
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing
  where
    (Bool
useInboundPeers, StdGen
stdGen') = StdGen -> (Bool, StdGen)
forall g. RandomGen g => g -> (Bool, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random StdGen
stdGen
    PeerSelectionCounters {
        numberOfKnownPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfKnownPeers = Int
numKnownPeers
      }
      =
      (extraPeers -> Set peeraddr)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> extraCounters)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionCounters extraCounters
forall peeraddr extraPeers extraState extraFlags peerconn
       extraCounters.
Ord peeraddr =>
(extraPeers -> Set peeraddr)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> extraCounters)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionCounters extraCounters
peerSelectionStateToCounters extraPeers -> Set peeraddr
extraPeersToSet PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st
    numPeerShareReqsPossible :: Int
numPeerShareReqsPossible = Int
policyMaxInProgressPeerShareReqs
                             Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
inProgressPeerShareReqs
    -- Only peer which permit peersharing are available
    availableForPeerShare :: Set peeraddr
availableForPeerShare    = EstablishedPeers peeraddr peerconn -> Set peeraddr
forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Set peeraddr
EstablishedPeers.availableForPeerShare EstablishedPeers peeraddr peerconn
establishedPeers
                             Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressDemoteToCold

---------------------------
-- Peer sharing job
--


-- | The peer sharing job is run in two stages. The expected path is for all
-- peer sharing request to return within a short timeout. The second phase is
-- with a longer timeout for all still outstanding requests.
--
-- The result from each phase is filtered. Already known peers and big ledger
-- peers are removed before adding them to known peers. Big ledger peers are
-- popular so they don't need to be shared through peer sharing. However ledger
-- peers belonging to smaller pools shouldn't be discarded. Smaller pools could
-- use extra upstream peers and we spread out the load in the network.
--
-- If we ask for more peers than needed a random subset of the peers in the filtered result
-- is used.
jobPeerShare
  :: forall m extraState extraDebugState extraFlags extraPeers
           extraAPI extraCounters peeraddr peerconn.
    (MonadAsync m, MonadTimer m, Ord peeraddr, Hashable peeraddr)
  => PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
  -> PeerSelectionPolicy peeraddr m
  -> Int
  -> Int
  -> PeerSharingAmount
  -> [peeraddr]
  -> Job () m (Completion m extraState extraDebugState extraFlags extraPeers
                         peeraddr peerconn)
jobPeerShare :: forall (m :: * -> *) extraState extraDebugState extraFlags
       extraPeers extraAPI extraCounters peeraddr peerconn.
(MonadAsync m, MonadTimer m, Ord peeraddr, Hashable peeraddr) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionPolicy peeraddr m
-> Int
-> Int
-> PeerSharingAmount
-> [peeraddr]
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobPeerShare PeerSelectionActions{PeerSharingAmount -> peeraddr -> m (PeerSharingResult peeraddr)
requestPeerShare :: PeerSharingAmount -> peeraddr -> m (PeerSharingResult peeraddr)
requestPeerShare :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSharingAmount -> peeraddr -> m (PeerSharingResult peeraddr)
requestPeerShare}
             PeerSelectionPolicy { DiffTime
policyPeerShareBatchWaitTime :: DiffTime
policyPeerShareBatchWaitTime :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> DiffTime
policyPeerShareBatchWaitTime
                                 , DiffTime
policyPeerShareOverallTimeout :: DiffTime
policyPeerShareOverallTimeout :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> DiffTime
policyPeerShareOverallTimeout
                                 }
             Int
salt Int
maxAmount
             PeerSharingAmount
requestAmount =
    \[peeraddr]
peers -> m (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
-> (SomeException
    -> m (Completion
            m
            extraState
            extraDebugState
            extraFlags
            extraPeers
            peeraddr
            peerconn))
-> ()
-> String
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall group (m :: * -> *) a.
m a -> (SomeException -> m a) -> group -> String -> Job group m a
Job ([peeraddr]
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobPhase1 [peeraddr]
peers) ([peeraddr]
-> SomeException
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
handler [peeraddr]
peers) () String
"peerSharePhase1"
  where
    -- Return n random peers from a list of peers.
    --
    -- Every jobPeerShare will be called with a new random salt.
    -- This means that even if presented with the same list peers their ordering
    -- will be unpredictable.
    takeNPeers :: Int -> [peeraddr] -> [peeraddr]
    takeNPeers :: Int -> [peeraddr] -> [peeraddr]
takeNPeers Int
n [peeraddr]
addrs = Int -> [peeraddr] -> [peeraddr]
forall a. Int -> [a] -> [a]
take Int
n ([peeraddr] -> [peeraddr]) -> [peeraddr] -> [peeraddr]
forall a b. (a -> b) -> a -> b
$
      (peeraddr -> peeraddr -> Ordering) -> [peeraddr] -> [peeraddr]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\peeraddr
a peeraddr
b -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Int -> peeraddr -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt peeraddr
a) (Int -> peeraddr -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt peeraddr
b))
      [peeraddr]
addrs

    handler :: [peeraddr] -> SomeException -> m (Completion m extraState extraDebugState extraFlags extraPeers peeraddr peerconn)
    handler :: [peeraddr]
-> SomeException
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
handler [peeraddr]
peers SomeException
e = Completion
  m
  extraState
  extraDebugState
  extraFlags
  extraPeers
  peeraddr
  peerconn
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion
   m
   extraState
   extraDebugState
   extraFlags
   extraPeers
   peeraddr
   peerconn
 -> m (Completion
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$
      (PeerSelectionState
   extraState extraFlags extraPeers peeraddr peerconn
 -> Time
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall (m :: * -> *) extraState extraDebugState extraFlags
       extraPeers peeraddr peerconn.
(PeerSelectionState
   extraState extraFlags extraPeers peeraddr peerconn
 -> Time
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
Completion ((PeerSelectionState
    extraState extraFlags extraPeers peeraddr peerconn
  -> Time
  -> Decision
       m
       extraState
       extraDebugState
       extraFlags
       extraPeers
       peeraddr
       peerconn)
 -> Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> Time
    -> Decision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall a b. (a -> b) -> a -> b
$ \PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st Time
_ ->
      Decision { decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [[(peeraddr, Either SomeException (PeerSharingResult peeraddr))]
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
[(peeraddr, Either SomeException (PeerSharingResult peeraddr))]
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TracePeerShareResults [ (peeraddr
p, SomeException -> Either SomeException (PeerSharingResult peeraddr)
forall a b. a -> Either a b
Left SomeException
e) | peeraddr
p <- [peeraddr]
peers ]],
                 decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState =
                  PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st { inProgressPeerShareReqs = inProgressPeerShareReqs st
                                               - length peers
                     },
                 decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs = []
               }

    jobPhase1 :: [peeraddr] -> m (Completion m extraState extraDebugState extraFlags extraPeers peeraddr peerconn)
    jobPhase1 :: [peeraddr]
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobPhase1 [peeraddr]
peers = do
      -- In the typical case, where most requests return within a short
      -- timeout we want to collect all the responses into a batch and
      -- add them to the known peers set in one go.
      --
      -- So fire them all off in one go:
      peerShares <- [m (Async m (PeerSharingResult peeraddr))]
-> m [Async m (PeerSharingResult peeraddr)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [ m (PeerSharingResult peeraddr)
-> m (Async m (PeerSharingResult peeraddr))
forall a. m a -> m (Async m a)
forall (m :: * -> *) a. MonadAsync m => m a -> m (Async m a)
async (PeerSharingAmount -> peeraddr -> m (PeerSharingResult peeraddr)
requestPeerShare PeerSharingAmount
requestAmount peeraddr
peer)
                             | peeraddr
peer <- [peeraddr]
peers ]

      -- First to finish synchronisation between /all/ the peer share requests
      -- completing or the timeout (with whatever partial results we have at
      -- the time)
      results <- waitAllCatchOrTimeout peerShares policyPeerShareBatchWaitTime
      case results of
        Right [Either SomeException (PeerSharingResult peeraddr)]
totalResults ->
          Completion
  m
  extraState
  extraDebugState
  extraFlags
  extraPeers
  peeraddr
  peerconn
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion
   m
   extraState
   extraDebugState
   extraFlags
   extraPeers
   peeraddr
   peerconn
 -> m (Completion
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ (PeerSelectionState
   extraState extraFlags extraPeers peeraddr peerconn
 -> Time
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall (m :: * -> *) extraState extraDebugState extraFlags
       extraPeers peeraddr peerconn.
(PeerSelectionState
   extraState extraFlags extraPeers peeraddr peerconn
 -> Time
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
Completion ((PeerSelectionState
    extraState extraFlags extraPeers peeraddr peerconn
  -> Time
  -> Decision
       m
       extraState
       extraDebugState
       extraFlags
       extraPeers
       peeraddr
       peerconn)
 -> Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> Time
    -> Decision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall a b. (a -> b) -> a -> b
$ \PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st Time
_ ->
           let peerResults :: [(peeraddr, Either SomeException (PeerSharingResult peeraddr))]
peerResults = [peeraddr]
-> [Either SomeException (PeerSharingResult peeraddr)]
-> [(peeraddr, Either SomeException (PeerSharingResult peeraddr))]
forall a b. [a] -> [b] -> [(a, b)]
zip [peeraddr]
peers [Either SomeException (PeerSharingResult peeraddr)]
totalResults
               newPeers :: [peeraddr]
newPeers    = Int -> [peeraddr] -> [peeraddr]
takeNPeers Int
maxAmount ([peeraddr] -> [peeraddr]) -> [peeraddr] -> [peeraddr]
forall a b. (a -> b) -> a -> b
$
                                 [ peeraddr
p | Right (PeerSharingResult [peeraddr]
ps) <- [Either SomeException (PeerSharingResult peeraddr)]
totalResults
                                 , peeraddr
p <- [peeraddr]
ps
                                 , Bool -> Bool
not (peeraddr -> KnownPeers peeraddr -> Bool
forall peeraddr.
Ord peeraddr =>
peeraddr -> KnownPeers peeraddr -> Bool
KnownPeers.member peeraddr
p (PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
knownPeers PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st))
                                 , peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember peeraddr
p (PublicRootPeers extraPeers peeraddr -> Set peeraddr
forall extraPeers peeraddr.
PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers (PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st))]
            in Decision { decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [ [(peeraddr, Either SomeException (PeerSharingResult peeraddr))]
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
[(peeraddr, Either SomeException (PeerSharingResult peeraddr))]
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TracePeerShareResults [(peeraddr, Either SomeException (PeerSharingResult peeraddr))]
peerResults
                                          , [peeraddr]
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
[peeraddr]
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TracePeerShareResultsFiltered [peeraddr]
newPeers
                                          ]
                        , decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState =
                           PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st { -- TODO: also update with the failures
                                knownPeers = KnownPeers.alter
                                              (\Maybe KnownPeerInfo
x -> case Maybe KnownPeerInfo
x of
                                                Maybe KnownPeerInfo
Nothing ->
                                                  (Maybe PeerSharing, Maybe PeerAdvertise)
-> Maybe KnownPeerInfo -> Maybe KnownPeerInfo
KnownPeers.alterKnownPeerInfo
                                                    (Maybe PeerSharing
forall a. Maybe a
Nothing, PeerAdvertise -> Maybe PeerAdvertise
forall a. a -> Maybe a
Just PeerAdvertise
DoAdvertisePeer)
                                                    Maybe KnownPeerInfo
x
                                                Just KnownPeerInfo
_ ->
                                                  (Maybe PeerSharing, Maybe PeerAdvertise)
-> Maybe KnownPeerInfo -> Maybe KnownPeerInfo
KnownPeers.alterKnownPeerInfo
                                                    (Maybe PeerSharing
forall a. Maybe a
Nothing, Maybe PeerAdvertise
forall a. Maybe a
Nothing)
                                                    Maybe KnownPeerInfo
x
                                              )
                                              (Set.fromList newPeers)
                                              (knownPeers st),
                                inProgressPeerShareReqs = inProgressPeerShareReqs st
                                                        - length peers
                           }
                        , decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = []
                        }

        -- But if any don't make the first timeout then they'll be added later
        -- when they do reply or never if we hit the hard timeout.
        Left [Maybe (Either SomeException (PeerSharingResult peeraddr))]
partialResults -> do

          -- We have to keep track of the relationship between the peer
          -- addresses and the peer share requests, completed and still in progress:
          let peerResults :: [(peeraddr, Either SomeException (PeerSharingResult peeraddr))]
peerResults      = [ (peeraddr
p, Either SomeException (PeerSharingResult peeraddr)
r)
                                 | (peeraddr
p, Just Either SomeException (PeerSharingResult peeraddr)
r)  <- [peeraddr]
-> [Maybe (Either SomeException (PeerSharingResult peeraddr))]
-> [(peeraddr,
     Maybe (Either SomeException (PeerSharingResult peeraddr)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [peeraddr]
peers [Maybe (Either SomeException (PeerSharingResult peeraddr))]
partialResults ]
              peersRemaining :: [peeraddr]
peersRemaining   = [  peeraddr
p
                                 | (peeraddr
p, Maybe (Either SomeException (PeerSharingResult peeraddr))
Nothing) <- [peeraddr]
-> [Maybe (Either SomeException (PeerSharingResult peeraddr))]
-> [(peeraddr,
     Maybe (Either SomeException (PeerSharingResult peeraddr)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [peeraddr]
peers [Maybe (Either SomeException (PeerSharingResult peeraddr))]
partialResults ]
              peerSharesRemaining :: [Async m (PeerSharingResult peeraddr)]
peerSharesRemaining = [  Async m (PeerSharingResult peeraddr)
a
                                    | (Async m (PeerSharingResult peeraddr)
a, Maybe (Either SomeException (PeerSharingResult peeraddr))
Nothing) <- [Async m (PeerSharingResult peeraddr)]
-> [Maybe (Either SomeException (PeerSharingResult peeraddr))]
-> [(Async m (PeerSharingResult peeraddr),
     Maybe (Either SomeException (PeerSharingResult peeraddr)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Async m (PeerSharingResult peeraddr)]
peerShares [Maybe (Either SomeException (PeerSharingResult peeraddr))]
partialResults ]

          Completion
  m
  extraState
  extraDebugState
  extraFlags
  extraPeers
  peeraddr
  peerconn
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion
   m
   extraState
   extraDebugState
   extraFlags
   extraPeers
   peeraddr
   peerconn
 -> m (Completion
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ (PeerSelectionState
   extraState extraFlags extraPeers peeraddr peerconn
 -> Time
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall (m :: * -> *) extraState extraDebugState extraFlags
       extraPeers peeraddr peerconn.
(PeerSelectionState
   extraState extraFlags extraPeers peeraddr peerconn
 -> Time
 -> Decision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
Completion ((PeerSelectionState
    extraState extraFlags extraPeers peeraddr peerconn
  -> Time
  -> Decision
       m
       extraState
       extraDebugState
       extraFlags
       extraPeers
       peeraddr
       peerconn)
 -> Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> Time
    -> Decision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn)
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall a b. (a -> b) -> a -> b
$ \PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st Time
_ ->
            let newPeers :: [peeraddr]
newPeers = Int -> [peeraddr] -> [peeraddr]
takeNPeers Int
maxAmount ([peeraddr] -> [peeraddr]) -> [peeraddr] -> [peeraddr]
forall a b. (a -> b) -> a -> b
$
                               [ peeraddr
p | Just (Right (PeerSharingResult [peeraddr]
ps)) <- [Maybe (Either SomeException (PeerSharingResult peeraddr))]
partialResults
                               , peeraddr
p <- [peeraddr]
ps
                               , Bool -> Bool
not (peeraddr -> KnownPeers peeraddr -> Bool
forall peeraddr.
Ord peeraddr =>
peeraddr -> KnownPeers peeraddr -> Bool
KnownPeers.member peeraddr
p (PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
knownPeers PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st))
                               , peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember peeraddr
p (PublicRootPeers extraPeers peeraddr -> Set peeraddr
forall extraPeers peeraddr.
PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers (PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st))]
             in Decision { decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [ [(peeraddr, Either SomeException (PeerSharingResult peeraddr))]
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
[(peeraddr, Either SomeException (PeerSharingResult peeraddr))]
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TracePeerShareResults [(peeraddr, Either SomeException (PeerSharingResult peeraddr))]
peerResults
                                           , [peeraddr]
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
[peeraddr]
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TracePeerShareResultsFiltered [peeraddr]
newPeers
                                           ]
                         , decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState =
                            PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st { -- TODO: also update with the failures
                                 knownPeers = KnownPeers.alter
                                               (\Maybe KnownPeerInfo
x -> case Maybe KnownPeerInfo
x of
                                                 Maybe KnownPeerInfo
Nothing ->
                                                   (Maybe PeerSharing, Maybe PeerAdvertise)
-> Maybe KnownPeerInfo -> Maybe KnownPeerInfo
KnownPeers.alterKnownPeerInfo
                                                     (Maybe PeerSharing
forall a. Maybe a
Nothing, PeerAdvertise -> Maybe PeerAdvertise
forall a. a -> Maybe a
Just PeerAdvertise
DoAdvertisePeer)
                                                     Maybe KnownPeerInfo
x
                                                 Just KnownPeerInfo
_ ->
                                                   (Maybe PeerSharing, Maybe PeerAdvertise)
-> Maybe KnownPeerInfo -> Maybe KnownPeerInfo
KnownPeers.alterKnownPeerInfo
                                                     (Maybe PeerSharing
forall a. Maybe a
Nothing, Maybe PeerAdvertise
forall a. Maybe a
Nothing)
                                                     Maybe KnownPeerInfo
x
                                               )
                                               (Set.fromList newPeers)
                                               (knownPeers st),
                                 inProgressPeerShareReqs = inProgressPeerShareReqs st
                                                         - length peerResults
                               }
                         , decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = [m (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
-> (SomeException
    -> m (Completion
            m
            extraState
            extraDebugState
            extraFlags
            extraPeers
            peeraddr
            peerconn))
-> ()
-> String
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall group (m :: * -> *) a.
m a -> (SomeException -> m a) -> group -> String -> Job group m a
Job (Int
-> [peeraddr]
-> [Async m (PeerSharingResult peeraddr)]
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobPhase2 (Int
maxAmount Int -> Int -> Int
forall a. Num a => a -> a -> a
- [peeraddr] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [peeraddr]
newPeers) [peeraddr]
peersRemaining
                                                 [Async m (PeerSharingResult peeraddr)]
peerSharesRemaining)
                                                ([peeraddr]
-> SomeException
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
handler [peeraddr]
peersRemaining)
                                                ()
                                                String
"peerSharePhase2"]
                         }

    jobPhase2 :: Int -> [peeraddr] -> [Async m (PeerSharingResult peeraddr)]
              -> m (Completion m extraState extraDebugState extraFlags extraPeers peeraddr peerconn)
    jobPhase2 :: Int
-> [peeraddr]
-> [Async m (PeerSharingResult peeraddr)]
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobPhase2 Int
maxRemaining [peeraddr]
peers [Async m (PeerSharingResult peeraddr)]
peerShares = do

      -- Wait again, for all remaining to finish or a timeout.
      results <- [Async m (PeerSharingResult peeraddr)]
-> DiffTime
-> m (Either
        [Maybe (Either SomeException (PeerSharingResult peeraddr))]
        [Either SomeException (PeerSharingResult peeraddr)])
forall (m :: * -> *) a.
(MonadAsync m, MonadTimer m) =>
[Async m a]
-> DiffTime
-> m (Either
        [Maybe (Either SomeException a)] [Either SomeException a])
waitAllCatchOrTimeout
                      [Async m (PeerSharingResult peeraddr)]
peerShares
                      (DiffTime
policyPeerShareOverallTimeout
                       DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
- DiffTime
policyPeerShareBatchWaitTime)
      let peerResults =
            case Either
  [Maybe (Either SomeException (PeerSharingResult peeraddr))]
  [Either SomeException (PeerSharingResult peeraddr)]
results of
              Right [Either SomeException (PeerSharingResult peeraddr)]
totalResults  -> [peeraddr]
-> [Either SomeException (PeerSharingResult peeraddr)]
-> [(peeraddr, Either SomeException (PeerSharingResult peeraddr))]
forall a b. [a] -> [b] -> [(a, b)]
zip [peeraddr]
peers [Either SomeException (PeerSharingResult peeraddr)]
totalResults
              Left [Maybe (Either SomeException (PeerSharingResult peeraddr))]
partialResults -> [ (peeraddr
p, Either SomeException (PeerSharingResult peeraddr)
-> Maybe (Either SomeException (PeerSharingResult peeraddr))
-> Either SomeException (PeerSharingResult peeraddr)
forall a. a -> Maybe a -> a
fromMaybe Either SomeException (PeerSharingResult peeraddr)
forall {b}. Either SomeException b
err Maybe (Either SomeException (PeerSharingResult peeraddr))
r)
                                     | (peeraddr
p, Maybe (Either SomeException (PeerSharingResult peeraddr))
r) <- [peeraddr]
-> [Maybe (Either SomeException (PeerSharingResult peeraddr))]
-> [(peeraddr,
     Maybe (Either SomeException (PeerSharingResult peeraddr)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [peeraddr]
peers [Maybe (Either SomeException (PeerSharingResult peeraddr))]
partialResults ]
                where err :: Either SomeException b
err = SomeException -> Either SomeException b
forall a b. a -> Either a b
Left (AsyncCancelled -> SomeException
forall e. Exception e => e -> SomeException
toException AsyncCancelled
AsyncCancelled)

          peerSharesIncomplete =
            case Either
  [Maybe (Either SomeException (PeerSharingResult peeraddr))]
  [Either SomeException (PeerSharingResult peeraddr)]
results of
              Right [Either SomeException (PeerSharingResult peeraddr)]
_totalResults -> []
              Left [Maybe (Either SomeException (PeerSharingResult peeraddr))]
partialResults ->
                [ Async m (PeerSharingResult peeraddr)
a | (Async m (PeerSharingResult peeraddr)
a, Maybe (Either SomeException (PeerSharingResult peeraddr))
Nothing) <- [Async m (PeerSharingResult peeraddr)]
-> [Maybe (Either SomeException (PeerSharingResult peeraddr))]
-> [(Async m (PeerSharingResult peeraddr),
     Maybe (Either SomeException (PeerSharingResult peeraddr)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Async m (PeerSharingResult peeraddr)]
peerShares [Maybe (Either SomeException (PeerSharingResult peeraddr))]
partialResults ]

      mapM_ cancel peerSharesIncomplete

      return $ Completion $ \PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st Time
_ ->
        let newPeers :: [peeraddr]
newPeers = Int -> [peeraddr] -> [peeraddr]
takeNPeers Int
maxRemaining ([peeraddr] -> [peeraddr]) -> [peeraddr] -> [peeraddr]
forall a b. (a -> b) -> a -> b
$
              case Either
  [Maybe (Either SomeException (PeerSharingResult peeraddr))]
  [Either SomeException (PeerSharingResult peeraddr)]
results of
                Right [Either SomeException (PeerSharingResult peeraddr)]
totalResults  -> [ peeraddr
p | Right (PeerSharingResult [peeraddr]
ps) <- [Either SomeException (PeerSharingResult peeraddr)]
totalResults
                                           , peeraddr
p <- [peeraddr]
ps
                                           , Bool -> Bool
not (peeraddr -> KnownPeers peeraddr -> Bool
forall peeraddr.
Ord peeraddr =>
peeraddr -> KnownPeers peeraddr -> Bool
KnownPeers.member peeraddr
p (PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
knownPeers PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st))
                                           , peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember peeraddr
p (PublicRootPeers extraPeers peeraddr -> Set peeraddr
forall extraPeers peeraddr.
PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers (PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st))]
                Left [Maybe (Either SomeException (PeerSharingResult peeraddr))]
partialResults -> [ peeraddr
p | Just (Right (PeerSharingResult [peeraddr]
ps)) <- [Maybe (Either SomeException (PeerSharingResult peeraddr))]
partialResults
                                           , peeraddr
p <- [peeraddr]
ps
                                           , Bool -> Bool
not (peeraddr -> KnownPeers peeraddr -> Bool
forall peeraddr.
Ord peeraddr =>
peeraddr -> KnownPeers peeraddr -> Bool
KnownPeers.member peeraddr
p (PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
knownPeers PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st))
                                           , peeraddr -> Set peeraddr -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember peeraddr
p (PublicRootPeers extraPeers peeraddr -> Set peeraddr
forall extraPeers peeraddr.
PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers (PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st))]

         in Decision { decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [ [(peeraddr, Either SomeException (PeerSharingResult peeraddr))]
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
[(peeraddr, Either SomeException (PeerSharingResult peeraddr))]
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TracePeerShareResults [(peeraddr, Either SomeException (PeerSharingResult peeraddr))]
peerResults
                                       , [peeraddr]
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
[peeraddr]
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TracePeerShareResultsFiltered [peeraddr]
newPeers
                                       ]
                     , decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState =
                        PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st { -- TODO: also update with the failures
                             knownPeers = KnownPeers.alter
                                           (\Maybe KnownPeerInfo
x -> case Maybe KnownPeerInfo
x of
                                             Maybe KnownPeerInfo
Nothing ->
                                               (Maybe PeerSharing, Maybe PeerAdvertise)
-> Maybe KnownPeerInfo -> Maybe KnownPeerInfo
KnownPeers.alterKnownPeerInfo
                                                 (Maybe PeerSharing
forall a. Maybe a
Nothing, PeerAdvertise -> Maybe PeerAdvertise
forall a. a -> Maybe a
Just PeerAdvertise
DoAdvertisePeer)
                                                 Maybe KnownPeerInfo
x
                                             Just KnownPeerInfo
_ ->
                                               (Maybe PeerSharing, Maybe PeerAdvertise)
-> Maybe KnownPeerInfo -> Maybe KnownPeerInfo
KnownPeers.alterKnownPeerInfo
                                                 (Maybe PeerSharing
forall a. Maybe a
Nothing, Maybe PeerAdvertise
forall a. Maybe a
Nothing)
                                                 Maybe KnownPeerInfo
x
                                           )
                                           (Set.fromList newPeers)
                                           (knownPeers st),
                             inProgressPeerShareReqs = inProgressPeerShareReqs st
                                                     - length peers
                           }
                     , decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = []
                     }


---------------------------
-- Known peers above target
--


-- | If we are above the target of /known peers/ (i.e. /cold/, /warm/ and /hot/
-- combined), we drop some of the /cold peers/ but we protect the
-- 'targetNumberOfRootPeers' (from combined sets of /local/ and /public root/
-- peers). 'policyPickColdPeersToForget' policy is used to pick the peers.
--
aboveTarget
  :: ( MonadSTM m
     , Ord peeraddr
     , HasCallStack
     )
  => PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
  -> MkGuardedDecision
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn
      m
aboveTarget :: forall (m :: * -> *) peeraddr extraState extraFlags extraPeers
       extraAPI extraCounters peerconn extraDebugState.
(MonadSTM m, Ord peeraddr, HasCallStack) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> MkGuardedDecision
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
     m
aboveTarget PeerSelectionActions {
              extraPeersAPI :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PublicExtraPeersAPI extraPeers peeraddr
extraPeersAPI = PublicExtraPeersAPI {
                peeraddr -> extraPeers -> Bool
memberExtraPeers :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> peeraddr -> extraPeers -> Bool
memberExtraPeers :: peeraddr -> extraPeers -> Bool
memberExtraPeers,
                extraPeers -> Set peeraddr
extraPeersToSet :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> extraPeers -> Set peeraddr
extraPeersToSet :: extraPeers -> Set peeraddr
extraPeersToSet,
                extraPeers -> Int
sizeExtraPeers :: extraPeers -> Int
sizeExtraPeers :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr -> extraPeers -> Int
sizeExtraPeers,
                extraPeers -> Set peeraddr -> extraPeers
differenceExtraPeers :: extraPeers -> Set peeraddr -> extraPeers
differenceExtraPeers :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> extraPeers -> Set peeraddr -> extraPeers
differenceExtraPeers
              },
              PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters
            }
            PeerSelectionPolicy {
              PickPolicy peeraddr (STM m)
policyPickColdPeersToForget :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickColdPeersToForget :: PickPolicy peeraddr (STM m)
policyPickColdPeersToForget
            }
            st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
              LocalRootPeers extraFlags peeraddr
localRootPeers :: LocalRootPeers extraFlags peeraddr
localRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> LocalRootPeers extraFlags peeraddr
localRootPeers,
              PublicRootPeers extraPeers peeraddr
publicRootPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PublicRootPeers extraPeers peeraddr
publicRootPeers :: PublicRootPeers extraPeers peeraddr
publicRootPeers,
              KnownPeers peeraddr
knownPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> KnownPeers peeraddr
knownPeers :: KnownPeers peeraddr
knownPeers,
              EstablishedPeers peeraddr peerconn
establishedPeers :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> EstablishedPeers peeraddr peerconn
establishedPeers :: EstablishedPeers peeraddr peerconn
establishedPeers,
              Set peeraddr
inProgressPromoteCold :: Set peeraddr
inProgressPromoteCold :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Set peeraddr
inProgressPromoteCold,
              targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionTargets
targets = PeerSelectionTargets {
                          Int
targetNumberOfKnownPeers :: PeerSelectionTargets -> Int
targetNumberOfKnownPeers :: Int
targetNumberOfKnownPeers,
                          Int
targetNumberOfRootPeers :: PeerSelectionTargets -> Int
targetNumberOfRootPeers :: Int
targetNumberOfRootPeers
                        }
            }
    -- Are we above the target for number of known peers?
  | Int
numKnownPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
targetNumberOfKnownPeers

    -- Are there any cold peers we could pick to forget?
    -- As a first cheap approximation, check if there are any cold peers.
  , Int
numKnownPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
numEstablishedPeers

    -- Beyond this it gets more complicated, and it is not clear that there
    -- are any precise cheap checks. So we just do the full calculation.
    -- In particular there can be overlap between cold peers and root peers
    -- and we have constraints on forgetting root peers.
    --
    -- We must never pick local root peers to forget as this would violate
    -- our invariant that the localRootPeers is a subset of the knownPeers.
    --
    -- We also need to avoid picking public root peers if that would put us
    -- below the target for root peers.
    --
  , let numRootPeersCanForget :: Int
numRootPeersCanForget = LocalRootPeers extraFlags peeraddr -> Int
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Int
LocalRootPeers.size LocalRootPeers extraFlags peeraddr
localRootPeers
                              Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (extraPeers -> Int) -> PublicRootPeers extraPeers peeraddr -> Int
forall extraPeers peeraddr.
(extraPeers -> Int) -> PublicRootPeers extraPeers peeraddr -> Int
PublicRootPeers.size extraPeers -> Int
sizeExtraPeers PublicRootPeers extraPeers peeraddr
publicRootPeers
                              Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
targetNumberOfRootPeers
        availableToForget :: Set peeraddr
availableToForget     = KnownPeers peeraddr -> Set peeraddr
forall peeraddr. KnownPeers peeraddr -> Set peeraddr
KnownPeers.toSet KnownPeers peeraddr
knownPeers
                                  Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ EstablishedPeers peeraddr peerconn -> Set peeraddr
forall peeraddr peerconn.
EstablishedPeers peeraddr peerconn -> Set peeraddr
EstablishedPeers.toSet EstablishedPeers peeraddr peerconn
establishedPeers
                                  Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ LocalRootPeers extraFlags peeraddr -> Set peeraddr
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers extraFlags peeraddr
localRootPeers
                                  Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ (if Int
numRootPeersCanForget Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
                                            then (extraPeers -> Set peeraddr)
-> PublicRootPeers extraPeers peeraddr -> Set peeraddr
forall peeraddr extraPeers.
Ord peeraddr =>
(extraPeers -> Set peeraddr)
-> PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.toSet extraPeers -> Set peeraddr
extraPeersToSet PublicRootPeers extraPeers peeraddr
publicRootPeers
                                            else Set peeraddr
forall a. Set a
Set.empty)
                                  Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressPromoteCold
                                  Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
bigLedgerPeersSet

  , Bool -> Bool
not (Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set peeraddr
availableToForget)
  = Maybe Time
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM
   m
   (TimedDecision
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)
 -> Guarded
      (STM m)
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ do
      let numOtherPeersToForget :: Int
numOtherPeersToForget         = Int
numKnownPeers
                                        Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
targetNumberOfKnownPeers
          numPeersToForget :: Int
numPeersToForget
            | Int
numRootPeersCanForget Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
numRootPeersCanForget
                                              Int
numOtherPeersToForget
            | Bool
otherwise                 = Int
numOtherPeersToForget
      -- If we /might/ pick a root peer, limit the number to forget so we do
      -- not pick too many root peers. This may cause us to go round several
      -- times but that is ok.
      selectedToForget <- (peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr (STM m)
-> Set peeraddr
-> Int
-> STM m (Set peeraddr)
forall peeraddr (m :: * -> *) extraPeers extraState extraFlags
       peerconn.
(Ord peeraddr, Functor m, HasCallStack) =>
(peeraddr -> extraPeers -> Bool)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PickPolicy peeraddr m
-> Set peeraddr
-> Int
-> m (Set peeraddr)
pickPeers peeraddr -> extraPeers -> Bool
memberExtraPeers PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st
                            PickPolicy peeraddr (STM m)
policyPickColdPeersToForget
                            Set peeraddr
availableToForget
                            Int
numPeersToForget
      return $ \Time
_now ->
        let knownPeers' :: KnownPeers peeraddr
knownPeers'      = Set peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr
forall peeraddr.
Ord peeraddr =>
Set peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr
KnownPeers.delete
                                 Set peeraddr
selectedToForget
                                 KnownPeers peeraddr
knownPeers
            publicRootPeers' :: PublicRootPeers extraPeers peeraddr
publicRootPeers' =
              (extraPeers -> Set peeraddr -> extraPeers)
-> PublicRootPeers extraPeers peeraddr
-> Set peeraddr
-> PublicRootPeers extraPeers peeraddr
forall peeraddr extraPeers.
Ord peeraddr =>
(extraPeers -> Set peeraddr -> extraPeers)
-> PublicRootPeers extraPeers peeraddr
-> Set peeraddr
-> PublicRootPeers extraPeers peeraddr
PublicRootPeers.difference extraPeers -> Set peeraddr -> extraPeers
differenceExtraPeers PublicRootPeers extraPeers peeraddr
publicRootPeers Set peeraddr
selectedToForget
        in Bool
-> Decision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> Decision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
forall a. HasCallStack => Bool -> a -> a
assert (Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf
                    ((extraPeers -> Set peeraddr)
-> PublicRootPeers extraPeers peeraddr -> Set peeraddr
forall peeraddr extraPeers.
Ord peeraddr =>
(extraPeers -> Set peeraddr)
-> PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.toSet extraPeers -> Set peeraddr
extraPeersToSet PublicRootPeers extraPeers peeraddr
publicRootPeers')
                    (KnownPeers peeraddr -> Set peeraddr
forall peeraddr. KnownPeers peeraddr -> Set peeraddr
KnownPeers.toSet KnownPeers peeraddr
knownPeers'))

              Decision {
                decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [Int
-> Int
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> Set peeraddr
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TraceForgetColdPeers
                                   Int
targetNumberOfKnownPeers
                                   Int
numKnownPeers
                                   Set peeraddr
selectedToForget],
                decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st { knownPeers      = knownPeers',
                                     publicRootPeers = publicRootPeers' },
                decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = []
              }

  | Bool
otherwise
  = Maybe Time
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing
  where
    bigLedgerPeersSet :: Set peeraddr
bigLedgerPeersSet = PublicRootPeers extraPeers peeraddr -> Set peeraddr
forall extraPeers peeraddr.
PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.getBigLedgerPeers PublicRootPeers extraPeers peeraddr
publicRootPeers

    PeerSelectionCounters {
        numberOfKnownPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfKnownPeers       = Int
numKnownPeers,
        numberOfEstablishedPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfEstablishedPeers = Int
numEstablishedPeers
      }
      =
      (extraPeers -> Set peeraddr)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> extraCounters)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionCounters extraCounters
forall peeraddr extraPeers extraState extraFlags peerconn
       extraCounters.
Ord peeraddr =>
(extraPeers -> Set peeraddr)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> extraCounters)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionCounters extraCounters
peerSelectionStateToCounters extraPeers -> Set peeraddr
extraPeersToSet PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st


-------------------------------
-- Utils
--

-- | Perform a first-to-finish synchronisation between:
--
-- * /all/ the async actions completing; or
-- * the timeout with whatever partial results we have at the time
--
-- The result list is the same length and order as the asyncs, so the results
-- can be paired up.
--
waitAllCatchOrTimeout :: (MonadAsync m, MonadTimer m)
                      => [Async m a]
                      -> DiffTime
                      -> m (Either [Maybe (Either SomeException a)]
                                   [Either SomeException a])
waitAllCatchOrTimeout :: forall (m :: * -> *) a.
(MonadAsync m, MonadTimer m) =>
[Async m a]
-> DiffTime
-> m (Either
        [Maybe (Either SomeException a)] [Either SomeException a])
waitAllCatchOrTimeout [Async m a]
as DiffTime
time = do
    (readTimeout, cancelTimeout) <- DiffTime -> m (STM m TimeoutState, m ())
forall (m :: * -> *).
MonadTimer m =>
DiffTime -> m (STM m TimeoutState, m ())
registerDelayCancellable DiffTime
time
    results <- atomically $
                         (Right <$> mapM waitCatchSTM as)
                `orElse` (Left  <$> (readTimeout >>= \case TimeoutState
TimeoutPending -> STM m [Maybe (Either SomeException a)]
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
                                                           TimeoutState
_              -> (Async m a -> STM m (Maybe (Either SomeException a)))
-> [Async m a] -> STM m [Maybe (Either SomeException a)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Async m a -> STM m (Maybe (Either SomeException a))
forall a. Async m a -> STM m (Maybe (Either SomeException a))
forall (m :: * -> *) a.
MonadAsync m =>
Async m a -> STM m (Maybe (Either SomeException a))
pollSTM [Async m a]
as))
    case results of
      Right{} -> m ()
cancelTimeout
      Either [Maybe (Either SomeException a)] [Either SomeException a]
_       -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    return results