{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}

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

import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import GHC.Stack (HasCallStack)

import Control.Applicative (Alternative)
import Control.Concurrent.JobPool (Job (..))
import Control.Exception (SomeException)
import Control.Monad.Class.MonadSTM
import Control.Monad.Class.MonadTime.SI

import Ouroboros.Network.PeerSelection.Governor.Types
import Ouroboros.Network.PeerSelection.LedgerPeers (LedgerPeersKind (..))
import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..))
import Ouroboros.Network.PeerSelection.PublicRootPeers (PublicRootPeers)
import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers
import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers
import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers
import Ouroboros.Network.PeerSelection.Types (PublicExtraPeersAPI (..))


belowTarget
  :: (MonadSTM m, Ord peeraddr, Semigroup extraPeers)
  => (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
  -> PeerSelectionState
      extraState
      extraFlags
      extraPeers
      peeraddr
      peerconn
  -> Guarded (STM m)
            (TimedDecision m extraState extraDebugState extraFlags extraPeers
                           peeraddr peerconn)
belowTarget :: forall (m :: * -> *) peeraddr extraPeers extraState extraFlags
       extraAPI extraCounters peerconn extraDebugState.
(MonadSTM m, Ord peeraddr, Semigroup extraPeers) =>
(extraState -> Bool)
-> PeerSelectionActions
     extraState
     extraFlags
     extraPeers
     extraAPI
     extraCounters
     peeraddr
     peerconn
     m
-> Time
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> Guarded
     (STM m)
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
belowTarget extraState -> Bool
enableAction
            actions :: PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
actions@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 {
                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
            st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
              Time
bigLedgerPeerRetryTime :: Time
bigLedgerPeerRetryTime :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Time
bigLedgerPeerRetryTime,
              Bool
inProgressBigLedgerPeersReq :: Bool
inProgressBigLedgerPeersReq :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Bool
inProgressBigLedgerPeersReq,
              targets :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionTargets
targets = PeerSelectionTargets {
                          Int
targetNumberOfKnownBigLedgerPeers :: Int
targetNumberOfKnownBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfKnownBigLedgerPeers
                        },
              extraState
extraState :: forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraState
extraState :: extraState
extraState
            }
    | extraState -> Bool
enableAction extraState
extraState

      -- Do we need more big ledger peers?
    , Int
maxExtraBigLedgerPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0

    , Bool -> Bool
not Bool
inProgressBigLedgerPeersReq

    , Time
blockedAt Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
bigLedgerPeerRetryTime
    = 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
$
        TimedDecision
  m
  extraState
  extraDebugState
  extraFlags
  extraPeers
  peeraddr
  peerconn
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TimedDecision
   m
   extraState
   extraDebugState
   extraFlags
   extraPeers
   peeraddr
   peerconn
 -> STM
      m
      (TimedDecision
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn))
-> TimedDecision
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
-> STM
     m
     (TimedDecision
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall a b. (a -> b) -> a -> b
$ \Time
_now -> Decision {
          decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [Int
-> Int
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Int
-> Int
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TraceBigLedgerPeersRequest
                             Int
targetNumberOfKnownBigLedgerPeers
                             Int
numBigLedgerPeers],
          decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st { inProgressBigLedgerPeersReq = True },
          decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = [PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> Int
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall (m :: * -> *) extraState extraDebugState extraFlags extraAPI
       extraPeers extraCounters peeraddr peerconn.
(MonadSTM m, Ord peeraddr, Semigroup extraPeers) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> Int
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobReqBigLedgerPeers PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
actions Int
maxExtraBigLedgerPeers]
        }

    | 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
    PeerSelectionCounters {
        numberOfKnownBigLedgerPeers :: forall extraCounters. PeerSelectionCounters extraCounters -> Int
numberOfKnownBigLedgerPeers = Int
numBigLedgerPeers
      }
      =
      (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

    maxExtraBigLedgerPeers :: Int
maxExtraBigLedgerPeers = Int
targetNumberOfKnownBigLedgerPeers
                           Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numBigLedgerPeers


jobReqBigLedgerPeers
  :: forall m extraState extraDebugState extraFlags extraAPI extraPeers
           extraCounters peeraddr peerconn.
     ( MonadSTM m
     , Ord peeraddr
     , Semigroup extraPeers
     )
  => PeerSelectionActions
      extraState
      extraFlags
      extraPeers
      extraAPI
      extraCounters
      peeraddr
      peerconn
      m
  -> Int
  -> Job () m (Completion m extraState extraDebugState extraFlags extraPeers peeraddr
                          peerconn)
jobReqBigLedgerPeers :: forall (m :: * -> *) extraState extraDebugState extraFlags extraAPI
       extraPeers extraCounters peeraddr peerconn.
(MonadSTM m, Ord peeraddr, Semigroup extraPeers) =>
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> Int
-> Job
     ()
     m
     (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
jobReqBigLedgerPeers 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 {
                         extraPeers -> Set peeraddr
extraPeersToSet :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> extraPeers -> Set peeraddr
extraPeersToSet :: extraPeers -> Set peeraddr
extraPeersToSet,
                         extraPeers -> Set peeraddr -> extraPeers
differenceExtraPeers :: extraPeers -> Set peeraddr -> extraPeers
differenceExtraPeers :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> extraPeers -> Set peeraddr -> extraPeers
differenceExtraPeers,
                         extraPeers -> Bool
nullExtraPeers :: extraPeers -> Bool
nullExtraPeers :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr -> extraPeers -> Bool
nullExtraPeers
                       },
                       LedgerPeersKind
-> Int -> m (PublicRootPeers extraPeers peeraddr, DiffTime)
requestPublicRootPeers :: LedgerPeersKind
-> Int -> m (PublicRootPeers extraPeers peeraddr, DiffTime)
requestPublicRootPeers :: forall extraState extraFlags extraPeers extraAPI extraCounters
       peeraddr peerconn (m :: * -> *).
PeerSelectionActions
  extraState
  extraFlags
  extraPeers
  extraAPI
  extraCounters
  peeraddr
  peerconn
  m
-> LedgerPeersKind
-> Int
-> m (PublicRootPeers extraPeers peeraddr, DiffTime)
requestPublicRootPeers
                     }
                     Int
numExtraAllowed =
    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 m (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
job (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))
-> (SomeException
    -> Completion
         m
         extraState
         extraDebugState
         extraFlags
         extraPeers
         peeraddr
         peerconn)
-> SomeException
-> m (Completion
        m
        extraState
        extraDebugState
        extraFlags
        extraPeers
        peeraddr
        peerconn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
handler) () String
"reqBigLedgerPeers"
  where
    handler :: SomeException -> Completion m extraState extraDebugState extraFlags extraPeers peeraddr peerconn
    handler :: SomeException
-> Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn
handler SomeException
e =
      (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
now ->
      -- This is a failure, so move the backoff counter one in the failure
      -- direction (negative) and schedule the next retry time accordingly.
      -- We use an exponential backoff strategy. The max retry time of 2^8
      -- seconds is just over 4 minutes.
      let bigLedgerPeerBackoffs'      :: Int
          bigLedgerPeerBackoffs' :: Int
bigLedgerPeerBackoffs'      = (PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Int
forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Int
bigLedgerPeerBackoffs PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` Int
0) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

          bigLedgerPeerRetryDiffTime' :: DiffTime
          bigLedgerPeerRetryDiffTime' :: DiffTime
bigLedgerPeerRetryDiffTime' = DiffTime
2 DiffTime -> Int -> DiffTime
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int -> Int
forall a. Num a => a -> a
abs Int
bigLedgerPeerBackoffs' Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` Int
8)

          bigLedgerPeerRetryTime'     :: Time
          bigLedgerPeerRetryTime' :: Time
bigLedgerPeerRetryTime'     = DiffTime -> Time -> Time
addTime DiffTime
bigLedgerPeerRetryDiffTime' Time
now
       in Decision {
            decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [SomeException
-> Int
-> DiffTime
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
SomeException
-> Int
-> DiffTime
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TraceBigLedgerPeersFailure
                               SomeException
e
                               Int
bigLedgerPeerBackoffs'
                               DiffTime
bigLedgerPeerRetryDiffTime'],
            decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                              inProgressBigLedgerPeersReq = False,
                              bigLedgerPeerBackoffs       = bigLedgerPeerBackoffs',
                              bigLedgerPeerRetryTime      = bigLedgerPeerRetryTime'
                            },
            decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = []
          }

    job :: m (Completion m extraState extraDebugState extraFlags extraPeers peeraddr peerconn)
    job :: m (Completion
     m
     extraState
     extraDebugState
     extraFlags
     extraPeers
     peeraddr
     peerconn)
job = do
      (results, ttl) <- LedgerPeersKind
-> Int -> m (PublicRootPeers extraPeers peeraddr, DiffTime)
requestPublicRootPeers LedgerPeersKind
BigLedgerPeers Int
numExtraAllowed
      return $ Completion $ \PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st Time
now ->
        let -- We make sure the set of big ledger peers disjoint from the sum
            -- of local, public and ledger peers.
            newPeers :: PublicRootPeers extraPeers peeraddr
            newPeers :: PublicRootPeers extraPeers peeraddr
newPeers =
              (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
results
                (   LocalRootPeers extraFlags peeraddr -> Set peeraddr
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Set peeraddr
LocalRootPeers.keysSet (PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> LocalRootPeers extraFlags peeraddr
forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> LocalRootPeers extraFlags peeraddr
localRootPeers PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st)
                 Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Semigroup a => a -> a -> a
<> (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 (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))

            newPeersSet :: Set peeraddr
newPeersSet      = (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
newPeers
            publicRootPeers' :: PublicRootPeers extraPeers peeraddr
publicRootPeers' =
              (extraPeers -> Set peeraddr)
-> PublicRootPeers extraPeers peeraddr
-> PublicRootPeers extraPeers peeraddr
-> PublicRootPeers extraPeers peeraddr
forall peeraddr extraPeers.
(Ord peeraddr, Semigroup extraPeers) =>
(extraPeers -> Set peeraddr)
-> PublicRootPeers extraPeers peeraddr
-> PublicRootPeers extraPeers peeraddr
-> PublicRootPeers extraPeers peeraddr
PublicRootPeers.mergeG extraPeers -> Set peeraddr
extraPeersToSet
                (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) PublicRootPeers extraPeers peeraddr
newPeers

            knownPeers' :: KnownPeers peeraddr
knownPeers'
                     = Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise)
-> KnownPeers peeraddr -> KnownPeers peeraddr
forall peeraddr.
Ord peeraddr =>
Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise)
-> KnownPeers peeraddr -> KnownPeers peeraddr
KnownPeers.insert
                         ((peeraddr -> (Maybe PeerSharing, Maybe PeerAdvertise))
-> Set peeraddr
-> Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise)
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (\peeraddr
_ -> ( Maybe PeerSharing
forall a. Maybe a
Nothing
                                               -- the peer sharing flag will be
                                               -- updated once we negotiate
                                               -- the connection
                                             , PeerAdvertise -> Maybe PeerAdvertise
forall a. a -> Maybe a
Just PeerAdvertise
DoNotAdvertisePeer
                                             ))
                                      Set peeraddr
newPeersSet)
                         (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)

            -- We got a successful response to our request, but if we're still
            -- below target we're going to want to try again at some point.
            -- If we made progress towards our target then we will retry at the
            -- suggested ttl. But if we did not make progress then we want to
            -- follow an exponential backoff strategy. The max retry time of 2^8
            -- seconds is just over four minutes.
            bigLedgerPeerBackoffs' :: Int
            bigLedgerPeerBackoffs' :: Int
bigLedgerPeerBackoffs'
              | (extraPeers -> Bool) -> PublicRootPeers extraPeers peeraddr -> Bool
forall extraPeers peeraddr.
(extraPeers -> Bool) -> PublicRootPeers extraPeers peeraddr -> Bool
PublicRootPeers.null extraPeers -> Bool
nullExtraPeers PublicRootPeers extraPeers peeraddr
newPeers = (PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Int
forall extraState extraFlags extraPeers peeraddr peerconn.
PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> Int
bigLedgerPeerBackoffs PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st Int -> Int -> Int
forall a. Ord a => a -> a -> a
`max` Int
0) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
              | Bool
otherwise = Int
0

            bigLedgerPeerRetryDiffTime :: DiffTime
            bigLedgerPeerRetryDiffTime :: DiffTime
bigLedgerPeerRetryDiffTime
              | Int
bigLedgerPeerBackoffs' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                          = DiffTime
ttl
              | Bool
otherwise = DiffTime
2DiffTime -> Int -> DiffTime
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
bigLedgerPeerBackoffs' Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` Int
8)

            bigLedgerPeerRetryTime :: Time
            bigLedgerPeerRetryTime :: Time
bigLedgerPeerRetryTime = DiffTime
bigLedgerPeerRetryDiffTime DiffTime -> Time -> Time
`addTime` Time
now

         in Decision {
               decisionTrace :: [TracePeerSelection extraDebugState extraFlags extraPeers peeraddr]
decisionTrace = [Set peeraddr
-> Int
-> DiffTime
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
forall extraDebugState extraFlags extraPeers peeraddr.
Set peeraddr
-> Int
-> DiffTime
-> TracePeerSelection
     extraDebugState extraFlags extraPeers peeraddr
TraceBigLedgerPeersResults
                                 Set peeraddr
newPeersSet
                                 Int
bigLedgerPeerBackoffs'
                                 DiffTime
bigLedgerPeerRetryDiffTime],
               decisionState :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
decisionState = PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st {
                                 publicRootPeers             = publicRootPeers',
                                 knownPeers                  = knownPeers',
                                 bigLedgerPeerBackoffs       = bigLedgerPeerBackoffs',
                                 bigLedgerPeerRetryTime      = bigLedgerPeerRetryTime,
                                 inProgressBigLedgerPeersReq = False
                               },
               decisionJobs :: [Job
   ()
   m
   (Completion
      m
      extraState
      extraDebugState
      extraFlags
      extraPeers
      peeraddr
      peerconn)]
decisionJobs  = []
             }


aboveTarget
  :: forall m extraState extraDebugState extraFlags extraAPI extraPeers
            extraCounters peeraddr peerconn.
     ( Alternative (STM m)
     , 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 :: * -> *) extraState extraDebugState extraFlags extraAPI
       extraPeers extraCounters peeraddr peerconn.
(Alternative (STM m), 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 {
                extraPeers -> Set peeraddr
extraPeersToSet :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> extraPeers -> Set peeraddr
extraPeersToSet :: extraPeers -> Set peeraddr
extraPeersToSet,
                extraPeers -> Set peeraddr -> extraPeers
differenceExtraPeers :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> extraPeers -> Set peeraddr -> extraPeers
differenceExtraPeers :: extraPeers -> Set peeraddr -> extraPeers
differenceExtraPeers,
                peeraddr -> extraPeers -> Bool
memberExtraPeers :: peeraddr -> extraPeers -> Bool
memberExtraPeers :: forall extraPeers peeraddr.
PublicExtraPeersAPI extraPeers peeraddr
-> peeraddr -> extraPeers -> Bool
memberExtraPeers
              },
                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 :: PickPolicy peeraddr (STM m)
policyPickColdPeersToForget :: forall peeraddr (m :: * -> *).
PeerSelectionPolicy peeraddr m -> PickPolicy peeraddr (STM m)
policyPickColdPeersToForget}
            st :: PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st@PeerSelectionState {
                 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,
                 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
targetNumberOfKnownBigLedgerPeers :: PeerSelectionTargets -> Int
targetNumberOfKnownBigLedgerPeers :: Int
targetNumberOfKnownBigLedgerPeers
                           }
               }
    -- Are we above the target for number of known big ledger peers
    | Int
numKnownBigLedgerPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
targetNumberOfKnownBigLedgerPeers

    -- Are there any cold big ledger peers we could pick to forget?
    , Int
numKnownBigLedgerPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
numEstablishedBigLedgerPeers

    , let availableToForget :: Set peeraddr
          availableToForget :: Set peeraddr
availableToForget = Set peeraddr
bigLedgerPeersSet
                                Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
establishedBigLedgerPeers
                                Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set peeraddr
inProgressPromoteCold

    , 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 numPeersCanForget :: Int
numPeersCanForget = Int
numKnownBigLedgerPeers
                              Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
targetNumberOfKnownBigLedgerPeers
        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
numPeersCanForget
        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 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
TraceForgetBigLedgerPeers
                                  Int
targetNumberOfKnownBigLedgerPeers
                                  Int
numKnownBigLedgerPeers
                                  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

    PeerSelectionView {
        viewKnownBigLedgerPeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewKnownBigLedgerPeers       = (Set peeraddr
_, Int
numKnownBigLedgerPeers),
        viewEstablishedBigLedgerPeers :: forall extraViews a. PeerSelectionView extraViews a -> a
viewEstablishedBigLedgerPeers = (Set peeraddr
establishedBigLedgerPeers, Int
numEstablishedBigLedgerPeers)
      } = (extraPeers -> Set peeraddr)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> extraCounters)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionView extraCounters (Set peeraddr, Int)
forall peeraddr extraPeers extraState extraFlags peerconn
       extraViews.
Ord peeraddr =>
(extraPeers -> Set peeraddr)
-> (PeerSelectionState
      extraState extraFlags extraPeers peeraddr peerconn
    -> extraViews)
-> PeerSelectionState
     extraState extraFlags extraPeers peeraddr peerconn
-> PeerSelectionSetsWithSizes extraViews peeraddr
peerSelectionStateToView extraPeers -> Set peeraddr
extraPeersToSet PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
-> extraCounters
extraStateToExtraCounters PeerSelectionState
  extraState extraFlags extraPeers peeraddr peerconn
st