{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

module Ouroboros.Network.PeerSelection.Governor.RootPeers (belowTarget) where

import Data.Map.Strict qualified as Map
import Data.Set qualified as Set

import Control.Concurrent.JobPool (Job (..))
import Control.Exception (SomeException, assert)
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.PublicRootPeers qualified as PublicRootPeers
import Ouroboros.Network.PeerSelection.State.KnownPeers qualified as KnownPeers
import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers


--------------------------
-- Root peers below target
--

belowTarget :: (MonadSTM m, Ord peeraddr)
            => PeerSelectionActions peeraddr peerconn m
            -> Time
            -> PeerSelectionState peeraddr peerconn
            -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
belowTarget :: forall (m :: * -> *) peeraddr peerconn.
(MonadSTM m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> Time
-> PeerSelectionState peeraddr peerconn
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
belowTarget PeerSelectionActions peeraddr peerconn m
actions
            Time
blockedAt
            st :: PeerSelectionState peeraddr peerconn
st@PeerSelectionState {
              Time
publicRootRetryTime :: Time
publicRootRetryTime :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Time
publicRootRetryTime,
              Bool
inProgressPublicRootsReq :: Bool
inProgressPublicRootsReq :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Bool
inProgressPublicRootsReq,
              targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets = PeerSelectionTargets {
                          Int
targetNumberOfRootPeers :: Int
targetNumberOfRootPeers :: PeerSelectionTargets -> Int
targetNumberOfRootPeers
                        }
            }
    -- Are we under target for number of root peers?
  | Int
maxExtraRootPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0

    -- Are we already requesting more root peers?
  , Bool -> Bool
not Bool
inProgressPublicRootsReq

    -- We limit how frequently we make requests, are we allowed to do it yet?
  , Time
blockedAt Time -> Time -> Bool
forall a. Ord a => a -> a -> Bool
>= Time
publicRootRetryTime
  = Maybe Time
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> m a -> Guarded m a
Guarded Maybe Time
forall a. Maybe a
Nothing (STM m (TimedDecision m peeraddr peerconn)
 -> Guarded (STM m) (TimedDecision m peeraddr peerconn))
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$
      TimedDecision m peeraddr peerconn
-> STM m (TimedDecision m peeraddr peerconn)
forall a. a -> STM m a
forall (m :: * -> *) a. Monad m => a -> m a
return (TimedDecision m peeraddr peerconn
 -> STM m (TimedDecision m peeraddr peerconn))
-> TimedDecision m peeraddr peerconn
-> STM m (TimedDecision m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ \Time
_now -> Decision {
        decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [Int -> Int -> TracePeerSelection peeraddr
forall peeraddr. Int -> Int -> TracePeerSelection peeraddr
TracePublicRootsRequest
                           Int
targetNumberOfRootPeers
                           Int
numRootPeers],
        decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st { inProgressPublicRootsReq = True },
        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [PeerSelectionActions peeraddr peerconn m
-> Int -> Job () m (Completion m peeraddr peerconn)
forall (m :: * -> *) peeraddr peerconn.
(MonadSTM m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> Int -> Job () m (Completion m peeraddr peerconn)
jobReqPublicRootPeers PeerSelectionActions peeraddr peerconn m
actions Int
maxExtraRootPeers]
      }

    -- If we would be able to do the request except for the time, return the
    -- next retry time.
  | Int
maxExtraRootPeers Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  , Bool -> Bool
not Bool
inProgressPublicRootsReq
  = Maybe Time -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip (Time -> Maybe Time
forall a. a -> Maybe a
Just Time
publicRootRetryTime)

  | Bool
otherwise
  = Maybe Time -> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe Time -> Guarded m a
GuardedSkip Maybe Time
forall a. Maybe a
Nothing
  where
    PeerSelectionCounters {
        numberOfRootPeers :: PeerSelectionCounters -> Int
numberOfRootPeers = Int
numRootPeers
      }
      =
      PeerSelectionState peeraddr peerconn -> PeerSelectionCounters
forall peeraddr peerconn.
Ord peeraddr =>
PeerSelectionState peeraddr peerconn -> PeerSelectionCounters
peerSelectionStateToCounters PeerSelectionState peeraddr peerconn
st

    maxExtraRootPeers :: Int
maxExtraRootPeers = Int
targetNumberOfRootPeers Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numRootPeers


jobReqPublicRootPeers :: forall m peeraddr peerconn.
                         (MonadSTM m, Ord peeraddr)
                      => PeerSelectionActions peeraddr peerconn m
                      -> Int
                      -> Job () m (Completion m peeraddr peerconn)
jobReqPublicRootPeers :: forall (m :: * -> *) peeraddr peerconn.
(MonadSTM m, Ord peeraddr) =>
PeerSelectionActions peeraddr peerconn m
-> Int -> Job () m (Completion m peeraddr peerconn)
jobReqPublicRootPeers PeerSelectionActions{ LedgerPeersKind -> Int -> m (PublicRootPeers peeraddr, DiffTime)
requestPublicRootPeers :: LedgerPeersKind -> Int -> m (PublicRootPeers peeraddr, DiffTime)
requestPublicRootPeers :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m
-> LedgerPeersKind -> Int -> m (PublicRootPeers peeraddr, DiffTime)
requestPublicRootPeers
                                          }
                      Int
numExtraAllowed =
    m (Completion m peeraddr peerconn)
-> (SomeException -> m (Completion m peeraddr peerconn))
-> ()
-> String
-> Job () m (Completion m peeraddr peerconn)
forall group (m :: * -> *) a.
m a -> (SomeException -> m a) -> group -> String -> Job group m a
Job m (Completion m peeraddr peerconn)
job (Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion m peeraddr peerconn
 -> m (Completion m peeraddr peerconn))
-> (SomeException -> Completion m peeraddr peerconn)
-> SomeException
-> m (Completion m peeraddr peerconn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Completion m peeraddr peerconn
handler) () String
"reqPublicRootPeers"
  where
    handler :: SomeException -> Completion m peeraddr peerconn
    handler :: SomeException -> Completion m peeraddr peerconn
handler SomeException
e =
      (PeerSelectionState peeraddr peerconn
 -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
forall (m :: * -> *) peeraddr peerconn.
(PeerSelectionState peeraddr peerconn
 -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
Completion ((PeerSelectionState peeraddr peerconn
  -> Time -> Decision m peeraddr peerconn)
 -> Completion m peeraddr peerconn)
-> (PeerSelectionState peeraddr peerconn
    -> Time -> Decision m peeraddr peerconn)
-> Completion m peeraddr peerconn
forall a b. (a -> b) -> a -> b
$ \PeerSelectionState 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 about 4 minutes.
      let publicRootBackoffs'      :: Int
          publicRootBackoffs' :: Int
publicRootBackoffs'      = (PeerSelectionState peeraddr peerconn -> Int
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Int
publicRootBackoffs PeerSelectionState 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

          publicRootRetryDiffTime' :: DiffTime
          publicRootRetryDiffTime' :: DiffTime
publicRootRetryDiffTime' = 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
publicRootBackoffs' Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` Int
8)

          publicRootRetryTime'     :: Time
          publicRootRetryTime' :: Time
publicRootRetryTime'     = DiffTime -> Time -> Time
addTime DiffTime
publicRootRetryDiffTime' Time
now
       in Decision {
            decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [SomeException -> Int -> DiffTime -> TracePeerSelection peeraddr
forall peeraddr.
SomeException -> Int -> DiffTime -> TracePeerSelection peeraddr
TracePublicRootsFailure
                               SomeException
e
                               Int
publicRootBackoffs'
                               DiffTime
publicRootRetryDiffTime'],
            decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                              inProgressPublicRootsReq = False,
                              publicRootBackoffs  = publicRootBackoffs',
                              publicRootRetryTime = publicRootRetryTime'
                            },
            decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = []
          }

    job :: m (Completion m peeraddr peerconn)
    job :: m (Completion m peeraddr peerconn)
job = do
      (results, ttl) <- LedgerPeersKind -> Int -> m (PublicRootPeers peeraddr, DiffTime)
requestPublicRootPeers LedgerPeersKind
AllLedgerPeers Int
numExtraAllowed
      return $ Completion $ \PeerSelectionState peeraddr peerconn
st Time
now ->
        let newPeers :: PublicRootPeers peeraddr
newPeers = PublicRootPeers peeraddr
results PublicRootPeers peeraddr
-> Set peeraddr -> PublicRootPeers peeraddr
forall peeraddr.
Ord peeraddr =>
PublicRootPeers peeraddr
-> Set peeraddr -> PublicRootPeers peeraddr
`PublicRootPeers.difference` LocalRootPeers peeraddr -> Set peeraddr
forall peeraddr. LocalRootPeers peeraddr -> Set peeraddr
LocalRootPeers.keysSet (PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers PeerSelectionState peeraddr peerconn
st)
                               PublicRootPeers peeraddr
-> Set peeraddr -> PublicRootPeers peeraddr
forall peeraddr.
Ord peeraddr =>
PublicRootPeers peeraddr
-> Set peeraddr -> PublicRootPeers peeraddr
`PublicRootPeers.difference` PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr.
Ord peeraddr =>
PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.toSet (PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers PeerSelectionState peeraddr peerconn
st)
            publicRootPeers' :: PublicRootPeers peeraddr
publicRootPeers'  = PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PublicRootPeers peeraddr
publicRootPeers PeerSelectionState peeraddr peerconn
st PublicRootPeers peeraddr
-> PublicRootPeers peeraddr -> PublicRootPeers peeraddr
forall a. Semigroup a => a -> a -> a
<> PublicRootPeers peeraddr
newPeers
            publicConfigPeers :: Map peeraddr PeerAdvertise
publicConfigPeers = PublicRootPeers peeraddr -> Map peeraddr PeerAdvertise
forall peeraddr.
PublicRootPeers peeraddr -> Map peeraddr PeerAdvertise
PublicRootPeers.getPublicConfigPeers PublicRootPeers peeraddr
publicRootPeers'
            bootstrapPeers :: Set peeraddr
bootstrapPeers    = PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr. PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.getBootstrapPeers PublicRootPeers peeraddr
publicRootPeers'
            ledgerPeers :: Set peeraddr
ledgerPeers       = PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr.
Ord peeraddr =>
PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.toAllLedgerPeerSet PublicRootPeers peeraddr
publicRootPeers'
            -- Add bootstrapPeers peers
            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
                            -- When we don't know about the PeerSharing information
                            -- we default to PeerSharingDisabled. I.e. we only pass
                            -- a Just value if we want a different value than
                            -- the the default one.
                            ( [(peeraddr, (Maybe PeerSharing, Maybe PeerAdvertise))]
-> Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                            ([(peeraddr, (Maybe PeerSharing, Maybe PeerAdvertise))]
 -> Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise))
-> ([(peeraddr, PeerAdvertise)]
    -> [(peeraddr, (Maybe PeerSharing, Maybe PeerAdvertise))])
-> [(peeraddr, PeerAdvertise)]
-> Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((peeraddr, PeerAdvertise)
 -> (peeraddr, (Maybe PeerSharing, Maybe PeerAdvertise)))
-> [(peeraddr, PeerAdvertise)]
-> [(peeraddr, (Maybe PeerSharing, Maybe PeerAdvertise))]
forall a b. (a -> b) -> [a] -> [b]
map (\(peeraddr
p, PeerAdvertise
pa) -> (peeraddr
p, (Maybe PeerSharing
forall a. Maybe a
Nothing, PeerAdvertise -> Maybe PeerAdvertise
forall a. a -> Maybe a
Just PeerAdvertise
pa)))
                            ([(peeraddr, PeerAdvertise)]
 -> Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise))
-> [(peeraddr, PeerAdvertise)]
-> Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise)
forall a b. (a -> b) -> a -> b
$ Map peeraddr PeerAdvertise -> [(peeraddr, PeerAdvertise)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map peeraddr PeerAdvertise
publicConfigPeers
                            )
                            (PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers PeerSelectionState peeraddr peerconn
st)

            -- Add all other peers
            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
                            -- When we don't know about the PeerSharing information
                            -- we default to NoPeerSharing. I.e. we only pass
                            -- a Just value if we want a different value than
                            -- the the default one.
                            ( [(peeraddr, (Maybe PeerSharing, Maybe PeerAdvertise))]
-> Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                            ([(peeraddr, (Maybe PeerSharing, Maybe PeerAdvertise))]
 -> Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise))
-> ([peeraddr]
    -> [(peeraddr, (Maybe PeerSharing, Maybe PeerAdvertise))])
-> [peeraddr]
-> Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (peeraddr -> (peeraddr, (Maybe PeerSharing, Maybe PeerAdvertise)))
-> [peeraddr]
-> [(peeraddr, (Maybe PeerSharing, Maybe PeerAdvertise))]
forall a b. (a -> b) -> [a] -> [b]
map (,(Maybe PeerSharing
forall a. Maybe a
Nothing, Maybe PeerAdvertise
forall a. Maybe a
Nothing))
                            ([peeraddr]
 -> Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise))
-> [peeraddr]
-> Map peeraddr (Maybe PeerSharing, Maybe PeerAdvertise)
forall a b. (a -> b) -> a -> b
$ Set peeraddr -> [peeraddr]
forall a. Set a -> [a]
Set.toList (Set peeraddr
bootstrapPeers Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Semigroup a => a -> a -> a
<> Set peeraddr
ledgerPeers)
                            )
                            KnownPeers peeraddr
knownPeers'

            -- 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 about 4 minutes.
            publicRootBackoffs' :: Int
            publicRootBackoffs' :: Int
publicRootBackoffs'
              | PublicRootPeers peeraddr -> Bool
forall peeraddr. PublicRootPeers peeraddr -> Bool
PublicRootPeers.null PublicRootPeers peeraddr
newPeers = (PeerSelectionState peeraddr peerconn -> Int
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Int
publicRootBackoffs PeerSelectionState 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

            publicRootRetryDiffTime :: DiffTime
            publicRootRetryDiffTime :: DiffTime
publicRootRetryDiffTime
              | Int
publicRootBackoffs' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                          = DiffTime -> DiffTime -> DiffTime
forall a. Ord a => a -> a -> a
min DiffTime
60 DiffTime
ttl -- don't let days long dns timeout kreep in here.
              | Bool
otherwise = DiffTime
2DiffTime -> Int -> DiffTime
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
publicRootBackoffs' Int -> Int -> Int
forall a. Ord a => a -> a -> a
`min` Int
8)

            publicRootRetryTime :: Time
            publicRootRetryTime :: Time
publicRootRetryTime = DiffTime -> Time -> Time
addTime DiffTime
publicRootRetryDiffTime Time
now

         in Bool
-> Decision m peeraddr peerconn -> Decision m peeraddr peerconn
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Set peeraddr -> Set peeraddr -> Bool
forall a. Ord a => Set a -> Set a -> Bool
Set.isSubsetOf
                     (PublicRootPeers peeraddr -> Set peeraddr
forall peeraddr.
Ord peeraddr =>
PublicRootPeers peeraddr -> Set peeraddr
PublicRootPeers.toSet PublicRootPeers peeraddr
publicRootPeers')
                     (KnownPeers peeraddr -> Set peeraddr
forall peeraddr. KnownPeers peeraddr -> Set peeraddr
KnownPeers.toSet KnownPeers peeraddr
knownPeers''))

             Decision {
                decisionTrace :: [TracePeerSelection peeraddr]
decisionTrace = [PublicRootPeers peeraddr
-> Int -> DiffTime -> TracePeerSelection peeraddr
forall peeraddr.
PublicRootPeers peeraddr
-> Int -> DiffTime -> TracePeerSelection peeraddr
TracePublicRootsResults
                                  PublicRootPeers peeraddr
newPeers
                                  Int
publicRootBackoffs'
                                  DiffTime
publicRootRetryDiffTime],
                decisionState :: PeerSelectionState peeraddr peerconn
decisionState = PeerSelectionState peeraddr peerconn
st {
                                  publicRootPeers     = publicRootPeers',
                                  knownPeers          = knownPeers'',
                                  publicRootBackoffs  = publicRootBackoffs',
                                  publicRootRetryTime = publicRootRetryTime,
                                  inProgressPublicRootsReq = False
                                },
                decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = []
              }