{-# LANGUAGE ScopedTypeVariables #-}

-- Constants used in 'Ouroboros.Network.Diffusion'
module Ouroboros.Network.Diffusion.Policies where

import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadTime.SI

import Data.List (sortOn, unfoldr)
import Data.Map.Merge.Strict qualified as Map
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Word (Word32)
import System.Random
import System.Random qualified as Rnd

import Ouroboros.Network.ConnectionManager.Types (ConnectionType (..),
           Provenance (..), PrunePolicy)
import Ouroboros.Network.ExitPolicy as ExitPolicy
import Ouroboros.Network.PeerSelection.Governor.Types
import Ouroboros.Network.PeerSelection.PeerMetric


-- | Timeout for 'spsDeactivateTimeout' and churn hot to warm demotions.
--
-- The maximal timeout on 'ChainSync' (in 'StMustReply' state) is @269s@,
-- see `maxChainSyncTimeout` below.
--
deactivateTimeout :: DiffTime
deactivateTimeout :: DiffTime
deactivateTimeout = DiffTime
300

-- | Timeout for 'spsCloseConnectionTimeout'.
--
-- This timeout depends on 'KeepAlive' and 'TipSample' timeouts.  'KeepAlive'
-- keeps agency most of the time, but 'TipSample' can give away its agency for
-- longer periods of time.  Here we allow it to get 6 blocks (assuming a new
-- block every @20s@).
--
closeConnectionTimeout :: DiffTime
closeConnectionTimeout :: DiffTime
closeConnectionTimeout = DiffTime
120


-- | Chain sync `mustReplayTimeout` lower bound.
--
minChainSyncTimeout :: DiffTime
minChainSyncTimeout :: DiffTime
minChainSyncTimeout = DiffTime
135


-- | Chain sync `mustReplayTimeout` upper bound.
--
maxChainSyncTimeout :: DiffTime
maxChainSyncTimeout :: DiffTime
maxChainSyncTimeout = DiffTime
269

-- | Churn timeouts after 60s trying to establish a connection.
--
-- This doesn't mean the connection is terminated after it, just churns moves
-- on.
--
churnEstablishConnectionTimeout :: DiffTime
churnEstablishConnectionTimeout :: DiffTime
churnEstablishConnectionTimeout = DiffTime
60


-- | Number of events tracked by 'PeerMetrics'.  This corresponds to one hour of
-- blocks on mainnet.
--
-- TODO: issue #3866
--
peerMetricsConfiguration :: PeerMetricsConfiguration
peerMetricsConfiguration :: PeerMetricsConfiguration
peerMetricsConfiguration = PeerMetricsConfiguration {
    maxEntriesToTrack :: Int
maxEntriesToTrack = Int
180
  }


-- | Minimal delay between adding inbound peers to known set of outbound
-- governor.
--
-- It is set to 60s, the same as the peer sharing request timeout.
--
inboundPeersRetryDelay :: DiffTime
inboundPeersRetryDelay :: DiffTime
inboundPeersRetryDelay = DiffTime
60


-- | Maximal number of light peers included at once.
--
maxInboundPeers :: Int
maxInboundPeers :: Int
maxInboundPeers = Int
10


-- | Merge two dictionaries where values of the first one are obligatory, while
-- the second one are optional.
--
optionalMerge
    :: Ord k
    => Map k a
    -> Map k b
    -> Map k (a, Maybe b)
optionalMerge :: forall k a b. Ord k => Map k a -> Map k b -> Map k (a, Maybe b)
optionalMerge = SimpleWhenMissing k a (a, Maybe b)
-> SimpleWhenMissing k b (a, Maybe b)
-> SimpleWhenMatched k a b (a, Maybe b)
-> Map k a
-> Map k b
-> Map k (a, Maybe b)
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge ((k -> a -> (a, Maybe b)) -> SimpleWhenMissing k a (a, Maybe b)
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> y) -> WhenMissing f k x y
Map.mapMissing (\k
_ a
a -> (a
a, Maybe b
forall a. Maybe a
Nothing)))
                           SimpleWhenMissing k b (a, Maybe b)
forall (f :: * -> *) k x y. Applicative f => WhenMissing f k x y
Map.dropMissing
                          ((k -> a -> b -> (a, Maybe b))
-> SimpleWhenMatched k a b (a, Maybe b)
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Map.zipWithMatched (\k
_ a
a b
b -> (a
a, b -> Maybe b
forall a. a -> Maybe a
Just b
b)))



simplePeerSelectionPolicy :: forall m peerAddr.
                             ( MonadSTM m
                             , Ord peerAddr
                             )
                          => StrictTVar m StdGen
                          -> PeerMetrics m peerAddr
                          -> RepromoteDelay
                          -- ^ delay on error
                          -> PeerSelectionPolicy peerAddr m
simplePeerSelectionPolicy :: forall (m :: * -> *) peerAddr.
(MonadSTM m, Ord peerAddr) =>
StrictTVar m StdGen
-> PeerMetrics m peerAddr
-> RepromoteDelay
-> PeerSelectionPolicy peerAddr m
simplePeerSelectionPolicy StrictTVar m StdGen
rngVar PeerMetrics m peerAddr
metrics RepromoteDelay
errorDelay = PeerSelectionPolicy {
      policyPickKnownPeersForPeerShare :: PickPolicy peerAddr (STM m)
policyPickKnownPeersForPeerShare = PickPolicy peerAddr (STM m)
simplePromotionPolicy,
      policyPickColdPeersToPromote :: PickPolicy peerAddr (STM m)
policyPickColdPeersToPromote     = PickPolicy peerAddr (STM m)
simplePromotionPolicy,
      policyPickWarmPeersToPromote :: PickPolicy peerAddr (STM m)
policyPickWarmPeersToPromote     = PickPolicy peerAddr (STM m)
simplePromotionPolicy,
      policyPickInboundPeers :: PickPolicy peerAddr (STM m)
policyPickInboundPeers           = PickPolicy peerAddr (STM m)
simplePromotionPolicy,

      policyPickHotPeersToDemote :: PickPolicy peerAddr (STM m)
policyPickHotPeersToDemote  = PickPolicy peerAddr (STM m)
hotDemotionPolicy,
      policyPickWarmPeersToDemote :: PickPolicy peerAddr (STM m)
policyPickWarmPeersToDemote = PickPolicy peerAddr (STM m)
warmDemotionPolicy,
      policyPickColdPeersToForget :: PickPolicy peerAddr (STM m)
policyPickColdPeersToForget = PickPolicy peerAddr (STM m)
coldForgetPolicy,

      policyFindPublicRootTimeout :: DiffTime
policyFindPublicRootTimeout      = DiffTime
5,    -- seconds
      policyMaxInProgressPeerShareReqs :: Int
policyMaxInProgressPeerShareReqs = Int
2,
      policyPeerShareRetryTime :: DiffTime
policyPeerShareRetryTime         = DiffTime
900,  -- seconds
      policyPeerShareBatchWaitTime :: DiffTime
policyPeerShareBatchWaitTime     = DiffTime
3,    -- seconds
      policyPeerShareOverallTimeout :: DiffTime
policyPeerShareOverallTimeout    = DiffTime
10,   -- seconds
      policyPeerShareActivationDelay :: DiffTime
policyPeerShareActivationDelay   = DiffTime
300,  -- seconds

      policyErrorDelay :: DiffTime
policyErrorDelay = RepromoteDelay -> DiffTime
ExitPolicy.repromoteDelay RepromoteDelay
errorDelay
    }
  where

    hotDemotionPolicy :: PickPolicy peerAddr (STM m)
    hotDemotionPolicy :: PickPolicy peerAddr (STM m)
hotDemotionPolicy peerAddr -> PeerSource
_ peerAddr -> Int
_ peerAddr -> Bool
_ Set peerAddr
available Int
pickNum = do
        jpm <- PeerMetrics m peerAddr -> STM m (Map peerAddr SlotNo)
forall p (m :: * -> *).
(MonadSTM m, Ord p) =>
PeerMetrics m p -> STM m (Map p SlotNo)
joinedPeerMetricAt PeerMetrics m peerAddr
metrics
        hup <- upstreamyness metrics
        bup <- fetchynessBlocks metrics

        let scores = (Int -> Int -> Int)
-> Map peerAddr Int -> Map peerAddr Int -> Map peerAddr Int
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Map peerAddr Int
hup Map peerAddr Int
bup Map peerAddr Int
-> Map peerAddr SlotNo -> Map peerAddr (Int, Maybe SlotNo)
forall k a b. Ord k => Map k a -> Map k b -> Map k (a, Maybe b)
`optionalMerge` Map peerAddr SlotNo
jpm

        available' <- addRand rngVar available (,)
        return $ Set.fromList
             . map fst
             . take pickNum
               -- order the results, resolve the ties using slot number when
               -- a peer joined the leader board.
               --
               -- note: this will prefer to preserve newer peers, whose results
               -- less certain than peers who entered leader board earlier.
             . sortOn (\(peerAddr
peer, Word32
rn) ->
                          ((Int, Maybe SlotNo)
-> peerAddr
-> Map peerAddr (Int, Maybe SlotNo)
-> (Int, Maybe SlotNo)
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (Int
0, Maybe SlotNo
forall a. Maybe a
Nothing) peerAddr
peer Map peerAddr (Int, Maybe SlotNo)
scores, Word32
rn))
             . Map.assocs
             $ available'

    -- Randomly pick peers to demote, peers with knownPeerTepid set are twice
    -- as likely to be demoted.
    warmDemotionPolicy :: PickPolicy peerAddr (STM m)
    warmDemotionPolicy :: PickPolicy peerAddr (STM m)
warmDemotionPolicy peerAddr -> PeerSource
_ peerAddr -> Int
_ peerAddr -> Bool
isTepid Set peerAddr
available Int
pickNum = do
      available' <- StrictTVar m StdGen
-> Set peerAddr
-> (peerAddr -> Word32 -> (peerAddr, Word32))
-> STM m (Map peerAddr Word32)
forall (m :: * -> *) peerAddr.
(MonadSTM m, Ord peerAddr) =>
StrictTVar m StdGen
-> Set peerAddr
-> (peerAddr -> Word32 -> (peerAddr, Word32))
-> STM m (Map peerAddr Word32)
addRand StrictTVar m StdGen
rngVar Set peerAddr
available ((peerAddr -> Bool) -> peerAddr -> Word32 -> (peerAddr, Word32)
tepidWeight peerAddr -> Bool
isTepid)
      return $ Set.fromList
             . map fst
             . take pickNum
             . sortOn snd
             . Map.assocs
             $ available'


    -- Randomly pick peers to forget, peers with failures are more likely to
    -- be forgotten.
    coldForgetPolicy :: PickPolicy peerAddr (STM m)
    coldForgetPolicy :: PickPolicy peerAddr (STM m)
coldForgetPolicy peerAddr -> PeerSource
_ peerAddr -> Int
failCnt peerAddr -> Bool
_ Set peerAddr
available Int
pickNum = do
      available' <- StrictTVar m StdGen
-> Set peerAddr
-> (peerAddr -> Word32 -> (peerAddr, Word32))
-> STM m (Map peerAddr Word32)
forall (m :: * -> *) peerAddr.
(MonadSTM m, Ord peerAddr) =>
StrictTVar m StdGen
-> Set peerAddr
-> (peerAddr -> Word32 -> (peerAddr, Word32))
-> STM m (Map peerAddr Word32)
addRand StrictTVar m StdGen
rngVar Set peerAddr
available ((peerAddr -> Int) -> peerAddr -> Word32 -> (peerAddr, Word32)
failWeight peerAddr -> Int
failCnt)
      return $ Set.fromList
             . map fst
             . take pickNum
             . sortOn snd
             . Map.assocs
             $ available'

    simplePromotionPolicy :: PickPolicy peerAddr (STM m)
    simplePromotionPolicy :: PickPolicy peerAddr (STM m)
simplePromotionPolicy peerAddr -> PeerSource
_ peerAddr -> Int
_ peerAddr -> Bool
_ Set peerAddr
available Int
pickNum = do
      available' <- StrictTVar m StdGen
-> Set peerAddr
-> (peerAddr -> Word32 -> (peerAddr, Word32))
-> STM m (Map peerAddr Word32)
forall (m :: * -> *) peerAddr.
(MonadSTM m, Ord peerAddr) =>
StrictTVar m StdGen
-> Set peerAddr
-> (peerAddr -> Word32 -> (peerAddr, Word32))
-> STM m (Map peerAddr Word32)
addRand StrictTVar m StdGen
rngVar Set peerAddr
available (,)
      return $ Set.fromList
             . map fst
             . take pickNum
             . sortOn snd
             . Map.assocs
             $ available'

    -- Failures lowers r
    failWeight :: (peerAddr -> Int)
                -> peerAddr
                -> Word32
                -> (peerAddr, Word32)
    failWeight :: (peerAddr -> Int) -> peerAddr -> Word32 -> (peerAddr, Word32)
failWeight peerAddr -> Int
failCnt peerAddr
peer Word32
r =
        (peerAddr
peer, Word32
r Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (peerAddr -> Int
failCnt peerAddr
peer Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))

    -- Tepid flag cuts r in half
    tepidWeight :: (peerAddr -> Bool)
                -> peerAddr
                -> Word32
                -> (peerAddr, Word32)
    tepidWeight :: (peerAddr -> Bool) -> peerAddr -> Word32 -> (peerAddr, Word32)
tepidWeight peerAddr -> Bool
isTepid peerAddr
peer Word32
r =
          if peerAddr -> Bool
isTepid peerAddr
peer then (peerAddr
peer, Word32
r Word32 -> Word32 -> Word32
forall a. Integral a => a -> a -> a
`div` Word32
2)
                          else (peerAddr
peer, Word32
r)


 -- Add scaled random number in order to prevent ordering based on SockAddr
addRand :: ( MonadSTM m
           , Ord peerAddr
           )
        => StrictTVar m StdGen
        -> Set.Set peerAddr
        -> (peerAddr -> Word32 -> (peerAddr, Word32))
        -> STM m (Map.Map peerAddr Word32)
addRand :: forall (m :: * -> *) peerAddr.
(MonadSTM m, Ord peerAddr) =>
StrictTVar m StdGen
-> Set peerAddr
-> (peerAddr -> Word32 -> (peerAddr, Word32))
-> STM m (Map peerAddr Word32)
addRand StrictTVar m StdGen
rngVar Set peerAddr
available peerAddr -> Word32 -> (peerAddr, Word32)
scaleFn = do
  inRng <- StrictTVar m StdGen -> STM m StdGen
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m StdGen
rngVar

  let (rng, rng') = split inRng
      rns = Int -> [Word32] -> [Word32]
forall a. Int -> [a] -> [a]
take (Set peerAddr -> Int
forall a. Set a -> Int
Set.size Set peerAddr
available) ([Word32] -> [Word32]) -> [Word32] -> [Word32]
forall a b. (a -> b) -> a -> b
$ (StdGen -> Maybe (Word32, StdGen)) -> StdGen -> [Word32]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr ((Word32, StdGen) -> Maybe (Word32, StdGen)
forall a. a -> Maybe a
Just ((Word32, StdGen) -> Maybe (Word32, StdGen))
-> (StdGen -> (Word32, StdGen)) -> StdGen -> Maybe (Word32, StdGen)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StdGen -> (Word32, StdGen)
forall g. RandomGen g => g -> (Word32, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random)  StdGen
rng :: [Word32]
      available' = [(peerAddr, Word32)] -> Map peerAddr Word32
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(peerAddr, Word32)] -> Map peerAddr Word32)
-> [(peerAddr, Word32)] -> Map peerAddr Word32
forall a b. (a -> b) -> a -> b
$ (peerAddr -> Word32 -> (peerAddr, Word32))
-> [peerAddr] -> [Word32] -> [(peerAddr, Word32)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith peerAddr -> Word32 -> (peerAddr, Word32)
scaleFn (Set peerAddr -> [peerAddr]
forall a. Set a -> [a]
Set.toList Set peerAddr
available) [Word32]
rns
  writeTVar rngVar rng'
  return available'

--
-- PrunePolicy
--

-- | Sort by upstreamness and a random score.
--
-- Note: this 'PrunePolicy' does not depend on 'igsConnections'.  We put
-- 'igsPrng' in 'InboundGovernorState' only to show that we can have
-- a 'PrunePolicy' which depends on the 'InboundGovernorState' as a more
-- refined policy would do.
--
-- /complexity:/ \(\mathcal{O}(n\log\;n)\)
--
-- TODO: complexity could be improved.
--
prunePolicy :: Ord peerAddr
            => PrunePolicy peerAddr
prunePolicy :: forall peerAddr. Ord peerAddr => PrunePolicy peerAddr
prunePolicy StdGen
prng Map (ConnectionId peerAddr) ConnectionType
mp Int
n =
        [ConnectionId peerAddr] -> Set (ConnectionId peerAddr)
forall a. Ord a => [a] -> Set a
Set.fromList
      ([ConnectionId peerAddr] -> Set (ConnectionId peerAddr))
-> ([Int] -> [ConnectionId peerAddr])
-> [Int]
-> Set (ConnectionId peerAddr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [ConnectionId peerAddr] -> [ConnectionId peerAddr]
forall a. Int -> [a] -> [a]
take Int
n
      ([ConnectionId peerAddr] -> [ConnectionId peerAddr])
-> ([Int] -> [ConnectionId peerAddr])
-> [Int]
-> [ConnectionId peerAddr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((ConnectionId peerAddr, ConnectionType), Int)
 -> ConnectionId peerAddr)
-> [((ConnectionId peerAddr, ConnectionType), Int)]
-> [ConnectionId peerAddr]
forall a b. (a -> b) -> [a] -> [b]
map ((ConnectionId peerAddr, ConnectionType) -> ConnectionId peerAddr
forall a b. (a, b) -> a
fst ((ConnectionId peerAddr, ConnectionType) -> ConnectionId peerAddr)
-> (((ConnectionId peerAddr, ConnectionType), Int)
    -> (ConnectionId peerAddr, ConnectionType))
-> ((ConnectionId peerAddr, ConnectionType), Int)
-> ConnectionId peerAddr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ConnectionId peerAddr, ConnectionType), Int)
-> (ConnectionId peerAddr, ConnectionType)
forall a b. (a, b) -> a
fst)
      -- 'True' values (upstream / outbound connections) will sort last.
      ([((ConnectionId peerAddr, ConnectionType), Int)]
 -> [ConnectionId peerAddr])
-> ([Int] -> [((ConnectionId peerAddr, ConnectionType), Int)])
-> [Int]
-> [ConnectionId peerAddr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((ConnectionId peerAddr, ConnectionType), Int)
 -> (Bool, Int, ConnectionType))
-> [((ConnectionId peerAddr, ConnectionType), Int)]
-> [((ConnectionId peerAddr, ConnectionType), Int)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\((ConnectionId peerAddr
_, ConnectionType
connType), Int
score) -> (ConnectionType -> Bool
isUpstream ConnectionType
connType, Int
score, ConnectionType
connType))
      ([((ConnectionId peerAddr, ConnectionType), Int)]
 -> [((ConnectionId peerAddr, ConnectionType), Int)])
-> ([Int] -> [((ConnectionId peerAddr, ConnectionType), Int)])
-> [Int]
-> [((ConnectionId peerAddr, ConnectionType), Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(ConnectionId peerAddr, ConnectionType)]
-> [Int] -> [((ConnectionId peerAddr, ConnectionType), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Map (ConnectionId peerAddr) ConnectionType
-> [(ConnectionId peerAddr, ConnectionType)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map (ConnectionId peerAddr) ConnectionType
mp)
      ([Int] -> Set (ConnectionId peerAddr))
-> [Int] -> Set (ConnectionId peerAddr)
forall a b. (a -> b) -> a -> b
$ (StdGen -> [Int]
forall g. RandomGen g => g -> [Int]
forall a g. (Random a, RandomGen g) => g -> [a]
Rnd.randoms StdGen
prng :: [Int])
  where
    isUpstream :: ConnectionType -> Bool
    isUpstream :: ConnectionType -> Bool
isUpstream = \ConnectionType
connType ->
      case ConnectionType
connType of
        UnnegotiatedConn Provenance
Outbound -> Bool
True
        UnnegotiatedConn Provenance
Inbound  -> Bool
False
        OutboundIdleConn DataFlow
_        -> Bool
True
        InboundIdleConn         DataFlow
_ -> Bool
False
        NegotiatedConn Provenance
Outbound DataFlow
_ -> Bool
True
        NegotiatedConn Provenance
Inbound  DataFlow
_ -> Bool
False
        ConnectionType
DuplexConn                -> Bool
True