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

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

import           Data.Semigroup (Min (..))
import qualified Data.Set as Set

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

import           Ouroboros.Network.PeerSelection.Governor.Types
import qualified Ouroboros.Network.PeerSelection.KnownPeers as KnownPeers
import qualified Ouroboros.Network.PeerSelection.LocalRootPeers 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 :: 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 {
              LocalRootPeers peeraddr
localRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> LocalRootPeers peeraddr
localRootPeers :: LocalRootPeers peeraddr
localRootPeers,
              Set peeraddr
publicRootPeers :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
publicRootPeers :: Set peeraddr
publicRootPeers,
              Time
publicRootRetryTime :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Time
publicRootRetryTime :: Time
publicRootRetryTime,
              Bool
inProgressPublicRootsReq :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Bool
inProgressPublicRootsReq :: Bool
inProgressPublicRootsReq,
              targets :: forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> PeerSelectionTargets
targets = PeerSelectionTargets {
                          Int
targetNumberOfRootPeers :: PeerSelectionTargets -> Int
targetNumberOfRootPeers :: 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 (Min Time)
-> STM m (TimedDecision m peeraddr peerconn)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe (Min Time) -> m a -> Guarded m a
Guarded Maybe (Min 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 (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 :: forall (m :: * -> *) peeraddr peerconn.
TracePeerSelection peeraddr
-> PeerSelectionState peeraddr peerconn
-> [Job () m (Completion m peeraddr peerconn)]
-> Decision m peeraddr peerconn
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 :: Bool
inProgressPublicRootsReq = Bool
True },
        decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = [PeerSelectionActions peeraddr peerconn m
-> Int -> Job () m (Completion m peeraddr peerconn)
forall (m :: * -> *) peeraddr peerconn.
(Monad 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 (Min Time)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe (Min Time) -> Guarded m a
GuardedSkip (Min Time -> Maybe (Min Time)
forall a. a -> Maybe a
Just (Time -> Min Time
forall a. a -> Min a
Min Time
publicRootRetryTime))

  | Bool
otherwise
  = Maybe (Min Time)
-> Guarded (STM m) (TimedDecision m peeraddr peerconn)
forall (m :: * -> *) a. Maybe (Min Time) -> Guarded m a
GuardedSkip Maybe (Min Time)
forall a. Maybe a
Nothing
  where
    numRootPeers :: Int
numRootPeers      = LocalRootPeers peeraddr -> Int
forall peeraddr. LocalRootPeers peeraddr -> Int
LocalRootPeers.size LocalRootPeers peeraddr
localRootPeers
                      Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Set peeraddr -> Int
forall a. Set a -> Int
Set.size Set peeraddr
publicRootPeers
    maxExtraRootPeers :: Int
maxExtraRootPeers = Int
targetNumberOfRootPeers Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
numRootPeers


jobReqPublicRootPeers :: forall m peeraddr peerconn.
                         (Monad m, Ord peeraddr)
                      => PeerSelectionActions peeraddr peerconn m
                      -> Int
                      -> Job () m (Completion m peeraddr peerconn)
jobReqPublicRootPeers :: PeerSelectionActions peeraddr peerconn m
-> Int -> Job () m (Completion m peeraddr peerconn)
jobReqPublicRootPeers PeerSelectionActions{Int -> m (Set peeraddr, DiffTime)
requestPublicRootPeers :: forall peeraddr peerconn (m :: * -> *).
PeerSelectionActions peeraddr peerconn m
-> Int -> m (Set peeraddr, DiffTime)
requestPublicRootPeers :: Int -> m (Set 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 (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^12
      -- seconds is just over an hour.
      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
12)

          publicRootRetryTime'     :: Time
          publicRootRetryTime' :: Time
publicRootRetryTime'     = DiffTime -> Time -> Time
addTime DiffTime
publicRootRetryDiffTime' Time
now
       in Decision :: forall (m :: * -> *) peeraddr peerconn.
TracePeerSelection peeraddr
-> PeerSelectionState peeraddr peerconn
-> [Job () m (Completion m peeraddr peerconn)]
-> Decision m peeraddr peerconn
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 :: Bool
inProgressPublicRootsReq = Bool
False,
                              publicRootBackoffs :: Int
publicRootBackoffs  = Int
publicRootBackoffs',
                              publicRootRetryTime :: Time
publicRootRetryTime = Time
publicRootRetryTime'
                            },
            decisionJobs :: [Job () m (Completion m peeraddr peerconn)]
decisionJobs  = []
          }

    job :: m (Completion m peeraddr peerconn)
    job :: m (Completion m peeraddr peerconn)
job = do
      (Set peeraddr
results, DiffTime
ttl) <- Int -> m (Set peeraddr, DiffTime)
requestPublicRootPeers Int
numExtraAllowed
      Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall (m :: * -> *) a. Monad m => a -> m a
return (Completion m peeraddr peerconn
 -> m (Completion m peeraddr peerconn))
-> Completion m peeraddr peerconn
-> m (Completion m peeraddr peerconn)
forall a b. (a -> b) -> a -> b
$ (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 ->
        let newPeers :: Set peeraddr
newPeers         = Set peeraddr
results Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ 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)
                                       Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ PeerSelectionState peeraddr peerconn -> Set peeraddr
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
publicRootPeers PeerSelectionState peeraddr peerconn
st
            publicRootPeers' :: Set peeraddr
publicRootPeers' = PeerSelectionState peeraddr peerconn -> Set peeraddr
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> Set peeraddr
publicRootPeers PeerSelectionState peeraddr peerconn
st Set peeraddr -> Set peeraddr -> Set peeraddr
forall a. Semigroup a => a -> a -> a
<> Set peeraddr
newPeers
            knownPeers' :: KnownPeers peeraddr
knownPeers'      = Set peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr
forall peeraddr.
Ord peeraddr =>
Set peeraddr -> KnownPeers peeraddr -> KnownPeers peeraddr
KnownPeers.insert
                                 Set peeraddr
newPeers
                                 (PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
forall peeraddr peerconn.
PeerSelectionState peeraddr peerconn -> KnownPeers peeraddr
knownPeers PeerSelectionState 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^12
            -- seconds is just over an hour.
            publicRootBackoffs' :: Int
            publicRootBackoffs' :: Int
publicRootBackoffs'
              | Set peeraddr -> Bool
forall a. Set a -> Bool
Set.null Set 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
ttl
              | 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
12)

            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
                      Set peeraddr
publicRootPeers'
                     (KnownPeers peeraddr -> Set peeraddr
forall peeraddr. KnownPeers peeraddr -> Set peeraddr
KnownPeers.toSet KnownPeers peeraddr
knownPeers'))

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