{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}

module Ouroboros.Network.PeerSelection.LedgerPeers
  ( DomainAccessPoint (..)
  , IP.IP (..)
  , LedgerPeersConsensusInterface (..)
  , RelayAccessPoint (..)
  , PoolStake (..)
  , AccPoolStake (..)
  , TraceLedgerPeers (..)
  , NumberOfPeers (..)
  , accPoolStake
  , withLedgerPeers
  , UseLedgerAfter (..)
  , Socket.PortNumber
  ) where


import           Control.DeepSeq (NFData (..))
import           Control.Exception (assert)
import           Control.Monad (when)
import           Control.Monad.Class.MonadAsync
import           Control.Monad.Class.MonadSTM.Strict
import           Control.Monad.Class.MonadTime
import           Control.Tracer (Tracer, traceWith)
import qualified Data.IP as IP
import           Data.List (foldl')
import           Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Ratio
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Void (Void)
import           Data.Word
import qualified Network.Socket as Socket
import           System.Random

import           Cardano.Slotting.Slot (SlotNo)
import           Ouroboros.Network.PeerSelection.RootPeersDNS
                     (DomainAccessPoint (..), RelayAccessPoint (..))

import           Text.Printf

-- | Only use the ledger after the given slot number.
data UseLedgerAfter = DontUseLedger | UseLedgerAfter SlotNo deriving (UseLedgerAfter -> UseLedgerAfter -> Bool
(UseLedgerAfter -> UseLedgerAfter -> Bool)
-> (UseLedgerAfter -> UseLedgerAfter -> Bool) -> Eq UseLedgerAfter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UseLedgerAfter -> UseLedgerAfter -> Bool
$c/= :: UseLedgerAfter -> UseLedgerAfter -> Bool
== :: UseLedgerAfter -> UseLedgerAfter -> Bool
$c== :: UseLedgerAfter -> UseLedgerAfter -> Bool
Eq, Int -> UseLedgerAfter -> ShowS
[UseLedgerAfter] -> ShowS
UseLedgerAfter -> String
(Int -> UseLedgerAfter -> ShowS)
-> (UseLedgerAfter -> String)
-> ([UseLedgerAfter] -> ShowS)
-> Show UseLedgerAfter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UseLedgerAfter] -> ShowS
$cshowList :: [UseLedgerAfter] -> ShowS
show :: UseLedgerAfter -> String
$cshow :: UseLedgerAfter -> String
showsPrec :: Int -> UseLedgerAfter -> ShowS
$cshowsPrec :: Int -> UseLedgerAfter -> ShowS
Show)

isLedgerPeersEnabled :: UseLedgerAfter -> Bool
isLedgerPeersEnabled :: UseLedgerAfter -> Bool
isLedgerPeersEnabled UseLedgerAfter
DontUseLedger = Bool
False
isLedgerPeersEnabled UseLedgerAfter
_             = Bool
True

newtype NumberOfPeers = NumberOfPeers Word16 deriving Int -> NumberOfPeers -> ShowS
[NumberOfPeers] -> ShowS
NumberOfPeers -> String
(Int -> NumberOfPeers -> ShowS)
-> (NumberOfPeers -> String)
-> ([NumberOfPeers] -> ShowS)
-> Show NumberOfPeers
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NumberOfPeers] -> ShowS
$cshowList :: [NumberOfPeers] -> ShowS
show :: NumberOfPeers -> String
$cshow :: NumberOfPeers -> String
showsPrec :: Int -> NumberOfPeers -> ShowS
$cshowsPrec :: Int -> NumberOfPeers -> ShowS
Show

newtype LedgerPeersConsensusInterface m = LedgerPeersConsensusInterface {
      LedgerPeersConsensusInterface m
-> SlotNo -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
lpGetPeers :: SlotNo -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
    }

-- | Trace LedgerPeers events.
data TraceLedgerPeers =
      PickedPeer RelayAccessPoint AccPoolStake PoolStake
      -- ^ Trace for a peer picked with accumulated and relative stake of its pool.
    | PickedPeers NumberOfPeers [RelayAccessPoint]
      -- ^ Trace for the number of peers we wanted to pick and the list of peers picked.
    | FetchingNewLedgerState Int
      -- ^ Trace for fetching a new list of peers from the ledger. Int is the number of peers
      -- returned.
    | DisabledLedgerPeers
      -- ^ Trace for when getting peers from the ledger is disabled, that is DontUseLedger.
    | TraceUseLedgerAfter UseLedgerAfter
      -- ^ Trace UseLedgerAfter value
    | WaitingOnRequest
    | RequestForPeers NumberOfPeers
    | ReusingLedgerState Int DiffTime
    | FallingBackToBootstrapPeers


instance Show TraceLedgerPeers where
    show :: TraceLedgerPeers -> String
show (PickedPeer RelayAccessPoint
addr AccPoolStake
ackStake PoolStake
stake) =
        String -> String -> String -> Double -> String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"PickedPeer %s ack stake %s ( %.04f) relative stake %s ( %.04f )"
            (RelayAccessPoint -> String
forall a. Show a => a -> String
show RelayAccessPoint
addr)
            (Rational -> String
forall a. Show a => a -> String
show (Rational -> String) -> Rational -> String
forall a b. (a -> b) -> a -> b
$ AccPoolStake -> Rational
unAccPoolStake AccPoolStake
ackStake)
            (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (AccPoolStake -> Rational
unAccPoolStake AccPoolStake
ackStake) :: Double)
            (Rational -> String
forall a. Show a => a -> String
show (Rational -> String) -> Rational -> String
forall a b. (a -> b) -> a -> b
$ PoolStake -> Rational
unPoolStake PoolStake
stake)
            (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (PoolStake -> Rational
unPoolStake PoolStake
stake) :: Double)
    show (PickedPeers (NumberOfPeers Word16
n) [RelayAccessPoint]
peers) =
        String -> Word16 -> ShowS
forall r. PrintfType r => String -> r
printf String
"PickedPeers %d %s" Word16
n ([RelayAccessPoint] -> String
forall a. Show a => a -> String
show [RelayAccessPoint]
peers)
    show (FetchingNewLedgerState Int
cnt) =
        String -> Int -> String
forall r. PrintfType r => String -> r
printf String
"Fetching new ledgerstate, %d registered pools"
            Int
cnt
    show (TraceUseLedgerAfter UseLedgerAfter
ula) =
        String -> ShowS
forall r. PrintfType r => String -> r
printf String
"UseLedgerAfter state %s"
            (UseLedgerAfter -> String
forall a. Show a => a -> String
show UseLedgerAfter
ula)
    show TraceLedgerPeers
WaitingOnRequest = String
"WaitingOnRequest"
    show (RequestForPeers (NumberOfPeers Word16
cnt)) = String -> Word16 -> String
forall r. PrintfType r => String -> r
printf String
"RequestForPeers %d" Word16
cnt
    show (ReusingLedgerState Int
cnt DiffTime
age) =
        String -> Int -> ShowS
forall r. PrintfType r => String -> r
printf String
"ReusingLedgerState %d peers age %s"
          Int
cnt
          (DiffTime -> String
forall a. Show a => a -> String
show DiffTime
age)
    show TraceLedgerPeers
FallingBackToBootstrapPeers = String
"Falling back to bootstrap peers"
    show TraceLedgerPeers
DisabledLedgerPeers = String
"LedgerPeers is disabled"

-- | The relative stake of a stakepool in relation to the total amount staked.
-- A value in the [0, 1] range.
--
newtype PoolStake = PoolStake { PoolStake -> Rational
unPoolStake :: Rational }
  deriving (PoolStake -> PoolStake -> Bool
(PoolStake -> PoolStake -> Bool)
-> (PoolStake -> PoolStake -> Bool) -> Eq PoolStake
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PoolStake -> PoolStake -> Bool
$c/= :: PoolStake -> PoolStake -> Bool
== :: PoolStake -> PoolStake -> Bool
$c== :: PoolStake -> PoolStake -> Bool
Eq, Num PoolStake
Num PoolStake
-> (PoolStake -> PoolStake -> PoolStake)
-> (PoolStake -> PoolStake)
-> (Rational -> PoolStake)
-> Fractional PoolStake
Rational -> PoolStake
PoolStake -> PoolStake
PoolStake -> PoolStake -> PoolStake
forall a.
Num a
-> (a -> a -> a) -> (a -> a) -> (Rational -> a) -> Fractional a
fromRational :: Rational -> PoolStake
$cfromRational :: Rational -> PoolStake
recip :: PoolStake -> PoolStake
$crecip :: PoolStake -> PoolStake
/ :: PoolStake -> PoolStake -> PoolStake
$c/ :: PoolStake -> PoolStake -> PoolStake
$cp1Fractional :: Num PoolStake
Fractional, Integer -> PoolStake
PoolStake -> PoolStake
PoolStake -> PoolStake -> PoolStake
(PoolStake -> PoolStake -> PoolStake)
-> (PoolStake -> PoolStake -> PoolStake)
-> (PoolStake -> PoolStake -> PoolStake)
-> (PoolStake -> PoolStake)
-> (PoolStake -> PoolStake)
-> (PoolStake -> PoolStake)
-> (Integer -> PoolStake)
-> Num PoolStake
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> PoolStake
$cfromInteger :: Integer -> PoolStake
signum :: PoolStake -> PoolStake
$csignum :: PoolStake -> PoolStake
abs :: PoolStake -> PoolStake
$cabs :: PoolStake -> PoolStake
negate :: PoolStake -> PoolStake
$cnegate :: PoolStake -> PoolStake
* :: PoolStake -> PoolStake -> PoolStake
$c* :: PoolStake -> PoolStake -> PoolStake
- :: PoolStake -> PoolStake -> PoolStake
$c- :: PoolStake -> PoolStake -> PoolStake
+ :: PoolStake -> PoolStake -> PoolStake
$c+ :: PoolStake -> PoolStake -> PoolStake
Num, Eq PoolStake
Eq PoolStake
-> (PoolStake -> PoolStake -> Ordering)
-> (PoolStake -> PoolStake -> Bool)
-> (PoolStake -> PoolStake -> Bool)
-> (PoolStake -> PoolStake -> Bool)
-> (PoolStake -> PoolStake -> Bool)
-> (PoolStake -> PoolStake -> PoolStake)
-> (PoolStake -> PoolStake -> PoolStake)
-> Ord PoolStake
PoolStake -> PoolStake -> Bool
PoolStake -> PoolStake -> Ordering
PoolStake -> PoolStake -> PoolStake
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PoolStake -> PoolStake -> PoolStake
$cmin :: PoolStake -> PoolStake -> PoolStake
max :: PoolStake -> PoolStake -> PoolStake
$cmax :: PoolStake -> PoolStake -> PoolStake
>= :: PoolStake -> PoolStake -> Bool
$c>= :: PoolStake -> PoolStake -> Bool
> :: PoolStake -> PoolStake -> Bool
$c> :: PoolStake -> PoolStake -> Bool
<= :: PoolStake -> PoolStake -> Bool
$c<= :: PoolStake -> PoolStake -> Bool
< :: PoolStake -> PoolStake -> Bool
$c< :: PoolStake -> PoolStake -> Bool
compare :: PoolStake -> PoolStake -> Ordering
$ccompare :: PoolStake -> PoolStake -> Ordering
$cp1Ord :: Eq PoolStake
Ord, Int -> PoolStake -> ShowS
[PoolStake] -> ShowS
PoolStake -> String
(Int -> PoolStake -> ShowS)
-> (PoolStake -> String)
-> ([PoolStake] -> ShowS)
-> Show PoolStake
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PoolStake] -> ShowS
$cshowList :: [PoolStake] -> ShowS
show :: PoolStake -> String
$cshow :: PoolStake -> String
showsPrec :: Int -> PoolStake -> ShowS
$cshowsPrec :: Int -> PoolStake -> ShowS
Show)
  deriving newtype PoolStake -> ()
(PoolStake -> ()) -> NFData PoolStake
forall a. (a -> ()) -> NFData a
rnf :: PoolStake -> ()
$crnf :: PoolStake -> ()
NFData


-- | The accumulated relative stake of a stake pool, like PoolStake but it also includes the
-- relative stake of all preceding pools. A value in the range [0, 1].
--
newtype AccPoolStake = AccPoolStake { AccPoolStake -> Rational
unAccPoolStake :: Rational }
    deriving (AccPoolStake -> AccPoolStake -> Bool
(AccPoolStake -> AccPoolStake -> Bool)
-> (AccPoolStake -> AccPoolStake -> Bool) -> Eq AccPoolStake
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AccPoolStake -> AccPoolStake -> Bool
$c/= :: AccPoolStake -> AccPoolStake -> Bool
== :: AccPoolStake -> AccPoolStake -> Bool
$c== :: AccPoolStake -> AccPoolStake -> Bool
Eq, Integer -> AccPoolStake
AccPoolStake -> AccPoolStake
AccPoolStake -> AccPoolStake -> AccPoolStake
(AccPoolStake -> AccPoolStake -> AccPoolStake)
-> (AccPoolStake -> AccPoolStake -> AccPoolStake)
-> (AccPoolStake -> AccPoolStake -> AccPoolStake)
-> (AccPoolStake -> AccPoolStake)
-> (AccPoolStake -> AccPoolStake)
-> (AccPoolStake -> AccPoolStake)
-> (Integer -> AccPoolStake)
-> Num AccPoolStake
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> AccPoolStake
$cfromInteger :: Integer -> AccPoolStake
signum :: AccPoolStake -> AccPoolStake
$csignum :: AccPoolStake -> AccPoolStake
abs :: AccPoolStake -> AccPoolStake
$cabs :: AccPoolStake -> AccPoolStake
negate :: AccPoolStake -> AccPoolStake
$cnegate :: AccPoolStake -> AccPoolStake
* :: AccPoolStake -> AccPoolStake -> AccPoolStake
$c* :: AccPoolStake -> AccPoolStake -> AccPoolStake
- :: AccPoolStake -> AccPoolStake -> AccPoolStake
$c- :: AccPoolStake -> AccPoolStake -> AccPoolStake
+ :: AccPoolStake -> AccPoolStake -> AccPoolStake
$c+ :: AccPoolStake -> AccPoolStake -> AccPoolStake
Num, Eq AccPoolStake
Eq AccPoolStake
-> (AccPoolStake -> AccPoolStake -> Ordering)
-> (AccPoolStake -> AccPoolStake -> Bool)
-> (AccPoolStake -> AccPoolStake -> Bool)
-> (AccPoolStake -> AccPoolStake -> Bool)
-> (AccPoolStake -> AccPoolStake -> Bool)
-> (AccPoolStake -> AccPoolStake -> AccPoolStake)
-> (AccPoolStake -> AccPoolStake -> AccPoolStake)
-> Ord AccPoolStake
AccPoolStake -> AccPoolStake -> Bool
AccPoolStake -> AccPoolStake -> Ordering
AccPoolStake -> AccPoolStake -> AccPoolStake
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AccPoolStake -> AccPoolStake -> AccPoolStake
$cmin :: AccPoolStake -> AccPoolStake -> AccPoolStake
max :: AccPoolStake -> AccPoolStake -> AccPoolStake
$cmax :: AccPoolStake -> AccPoolStake -> AccPoolStake
>= :: AccPoolStake -> AccPoolStake -> Bool
$c>= :: AccPoolStake -> AccPoolStake -> Bool
> :: AccPoolStake -> AccPoolStake -> Bool
$c> :: AccPoolStake -> AccPoolStake -> Bool
<= :: AccPoolStake -> AccPoolStake -> Bool
$c<= :: AccPoolStake -> AccPoolStake -> Bool
< :: AccPoolStake -> AccPoolStake -> Bool
$c< :: AccPoolStake -> AccPoolStake -> Bool
compare :: AccPoolStake -> AccPoolStake -> Ordering
$ccompare :: AccPoolStake -> AccPoolStake -> Ordering
$cp1Ord :: Eq AccPoolStake
Ord)

-- | Convert a list of pools with stake to a Map keyed on the accumulated stake.
-- Consensus provides a list of pairs of relative stake and corresponding relays for all usable
-- registered pools.
-- By creating a Map keyed on the `AccPoolStake` that is the sum of the pool's relative stake and
-- the stake of all preceding pools we can support weighted random selection in
-- O(log n) time by taking advantage of Map.lookupGE (returns the smallest key greater or equal
-- to the provided value).
--
accPoolStake :: [(PoolStake, NonEmpty RelayAccessPoint)]
             -> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accPoolStake :: [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accPoolStake [(PoolStake, NonEmpty RelayAccessPoint)]
pl =
    let pl' :: [(PoolStake, NonEmpty RelayAccessPoint)]
pl' = [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
reRelativeStake [(PoolStake, NonEmpty RelayAccessPoint)]
pl
        ackList :: [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
ackList = ([(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
 -> (PoolStake, NonEmpty RelayAccessPoint)
 -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> (PoolStake, NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
fn [] [(PoolStake, NonEmpty RelayAccessPoint)]
pl' in
    [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
ackList
  where
    fn :: [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
       -> (PoolStake, NonEmpty RelayAccessPoint)
       -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
    fn :: [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> (PoolStake, NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
fn [] (PoolStake
s, NonEmpty RelayAccessPoint
rs) =
        [(Rational -> AccPoolStake
AccPoolStake (PoolStake -> Rational
unPoolStake PoolStake
s), (PoolStake
s, NonEmpty RelayAccessPoint
rs))]
    fn [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
ps (PoolStake
s, !NonEmpty RelayAccessPoint
rs) =
        let accst :: AccPoolStake
accst = Rational -> AccPoolStake
AccPoolStake (PoolStake -> Rational
unPoolStake PoolStake
s)
            as :: AccPoolStake
as = (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> AccPoolStake
forall a b. (a, b) -> a
fst ((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
 -> AccPoolStake)
-> (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> AccPoolStake
forall a b. (a -> b) -> a -> b
$ [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
forall a. [a] -> a
head [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
ps
            !acc :: AccPoolStake
acc = AccPoolStake
as AccPoolStake -> AccPoolStake -> AccPoolStake
forall a. Num a => a -> a -> a
+ AccPoolStake
accst in
        (AccPoolStake
acc, (PoolStake
s, NonEmpty RelayAccessPoint
rs)) (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
forall a. a -> [a] -> [a]
: [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
ps

-- | Not all stake pools have valid \/ usable relay information. This means that we need to
-- recalculate the relative stake for each pool.
--
-- The relative stake is scaled by the square root in order to increase the number
-- of down stream peers smaller pools are likely to get.
-- https://en.wikipedia.org/wiki/Penrose_method
--
reRelativeStake :: [(PoolStake, NonEmpty RelayAccessPoint)]
                -> [(PoolStake, NonEmpty RelayAccessPoint)]
reRelativeStake :: [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
reRelativeStake [(PoolStake, NonEmpty RelayAccessPoint)]
pl =
    let total :: PoolStake
total = (PoolStake -> PoolStake -> PoolStake)
-> PoolStake -> [PoolStake] -> PoolStake
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' PoolStake -> PoolStake -> PoolStake
forall a. Num a => a -> a -> a
(+) PoolStake
0 ([PoolStake] -> PoolStake) -> [PoolStake] -> PoolStake
forall a b. (a -> b) -> a -> b
$ ((PoolStake, NonEmpty RelayAccessPoint) -> PoolStake)
-> [(PoolStake, NonEmpty RelayAccessPoint)] -> [PoolStake]
forall a b. (a -> b) -> [a] -> [b]
map (PoolStake -> PoolStake
adjustment (PoolStake -> PoolStake)
-> ((PoolStake, NonEmpty RelayAccessPoint) -> PoolStake)
-> (PoolStake, NonEmpty RelayAccessPoint)
-> PoolStake
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolStake, NonEmpty RelayAccessPoint) -> PoolStake
forall a b. (a, b) -> a
fst) [(PoolStake, NonEmpty RelayAccessPoint)]
pl
        pl' :: [(PoolStake, NonEmpty RelayAccessPoint)]
pl' = ((PoolStake, NonEmpty RelayAccessPoint)
 -> (PoolStake, NonEmpty RelayAccessPoint))
-> [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall a b. (a -> b) -> [a] -> [b]
map  (\(PoolStake
s, NonEmpty RelayAccessPoint
rls) -> (PoolStake -> PoolStake
adjustment PoolStake
s PoolStake -> PoolStake -> PoolStake
forall a. Fractional a => a -> a -> a
/ PoolStake
total, NonEmpty RelayAccessPoint
rls)) [(PoolStake, NonEmpty RelayAccessPoint)]
pl
        total' :: PoolStake
total' = [PoolStake] -> PoolStake
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([PoolStake] -> PoolStake) -> [PoolStake] -> PoolStake
forall a b. (a -> b) -> a -> b
$ ((PoolStake, NonEmpty RelayAccessPoint) -> PoolStake)
-> [(PoolStake, NonEmpty RelayAccessPoint)] -> [PoolStake]
forall a b. (a -> b) -> [a] -> [b]
map (PoolStake, NonEmpty RelayAccessPoint) -> PoolStake
forall a b. (a, b) -> a
fst [(PoolStake, NonEmpty RelayAccessPoint)]
pl' in
    Bool
-> [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PoolStake
total PoolStake -> PoolStake -> Bool
forall a. Eq a => a -> a -> Bool
== PoolStake
0 Bool -> Bool -> Bool
|| (PoolStake
total' PoolStake -> PoolStake -> Bool
forall a. Ord a => a -> a -> Bool
> (Rational -> PoolStake
PoolStake (Rational -> PoolStake) -> Rational -> PoolStake
forall a b. (a -> b) -> a -> b
$ Integer
999999 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
1000000) Bool -> Bool -> Bool
&&
            PoolStake
total' PoolStake -> PoolStake -> Bool
forall a. Ord a => a -> a -> Bool
< (Rational -> PoolStake
PoolStake (Rational -> PoolStake) -> Rational -> PoolStake
forall a b. (a -> b) -> a -> b
$ Integer
1000001 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
1000000))) [(PoolStake, NonEmpty RelayAccessPoint)]
pl'

  where
    -- We do loose some precisioun in the conversion. However we care about precision
    -- in the order of 1 block per year and for that a Double is good enough.
    adjustment :: PoolStake -> PoolStake
    adjustment :: PoolStake -> PoolStake
adjustment (PoolStake Rational
s) =
      let d :: Double
d = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
s ::Double in
      Rational -> PoolStake
PoolStake (Rational -> PoolStake) -> Rational -> PoolStake
forall a b. (a -> b) -> a -> b
$ Double -> Rational
forall a. Real a => a -> Rational
toRational (Double -> Rational) -> Double -> Rational
forall a b. (a -> b) -> a -> b
$ Double -> Double
forall a. Floating a => a -> a
sqrt Double
d


-- | Try to pick n random peers.
pickPeers :: forall m. Monad m
          => StdGen
          -> Tracer m TraceLedgerPeers
          -> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
          -> NumberOfPeers
          -> m (StdGen, [RelayAccessPoint])
pickPeers :: StdGen
-> Tracer m TraceLedgerPeers
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> NumberOfPeers
-> m (StdGen, [RelayAccessPoint])
pickPeers StdGen
inRng Tracer m TraceLedgerPeers
_ Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
pools NumberOfPeers
_ | Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint) -> Bool
forall k a. Map k a -> Bool
Map.null Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
pools = (StdGen, [RelayAccessPoint]) -> m (StdGen, [RelayAccessPoint])
forall (m :: * -> *) a. Monad m => a -> m a
return (StdGen
inRng, [])
pickPeers StdGen
inRng Tracer m TraceLedgerPeers
tracer Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
pools (NumberOfPeers Word16
cnt) = StdGen
-> Word16 -> [RelayAccessPoint] -> m (StdGen, [RelayAccessPoint])
go StdGen
inRng Word16
cnt []
  where
    go :: StdGen -> Word16 -> [RelayAccessPoint] -> m (StdGen, [RelayAccessPoint])
    go :: StdGen
-> Word16 -> [RelayAccessPoint] -> m (StdGen, [RelayAccessPoint])
go StdGen
rng Word16
0 [RelayAccessPoint]
picked = (StdGen, [RelayAccessPoint]) -> m (StdGen, [RelayAccessPoint])
forall (m :: * -> *) a. Monad m => a -> m a
return (StdGen
rng, [RelayAccessPoint]
picked)
    go StdGen
rng Word16
n [RelayAccessPoint]
picked =
        let (Word64
r :: Word64, StdGen
rng') = StdGen -> (Word64, StdGen)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random StdGen
rng
            d :: Word64
d = Word64
forall a. Bounded a => a
maxBound :: Word64
            x :: Rational
x = Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
r Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
d in
        case AccPoolStake
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> Maybe (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupGE (Rational -> AccPoolStake
AccPoolStake Rational
x) Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
pools of
             -- XXX We failed pick a peer. Shouldn't this be an error?
             Maybe (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
Nothing -> StdGen
-> Word16 -> [RelayAccessPoint] -> m (StdGen, [RelayAccessPoint])
go StdGen
rng' (Word16
n Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Word16
1) [RelayAccessPoint]
picked
             Just (AccPoolStake
ackStake, (PoolStake
stake, NonEmpty RelayAccessPoint
relays)) -> do
                 let (Int
ix, StdGen
rng'') = (Int, Int) -> StdGen -> (Int, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, NonEmpty RelayAccessPoint -> Int
forall a. NonEmpty a -> Int
NonEmpty.length NonEmpty RelayAccessPoint
relays Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) StdGen
rng'
                     relay :: RelayAccessPoint
relay = NonEmpty RelayAccessPoint
relays NonEmpty RelayAccessPoint -> Int -> RelayAccessPoint
forall a. NonEmpty a -> Int -> a
NonEmpty.!! Int
ix
                 Tracer m TraceLedgerPeers -> TraceLedgerPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceLedgerPeers
tracer (TraceLedgerPeers -> m ()) -> TraceLedgerPeers -> m ()
forall a b. (a -> b) -> a -> b
$ RelayAccessPoint -> AccPoolStake -> PoolStake -> TraceLedgerPeers
PickedPeer RelayAccessPoint
relay AccPoolStake
ackStake PoolStake
stake
                 StdGen
-> Word16 -> [RelayAccessPoint] -> m (StdGen, [RelayAccessPoint])
go StdGen
rng'' (Word16
n Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
- Word16
1) (RelayAccessPoint
relay RelayAccessPoint -> [RelayAccessPoint] -> [RelayAccessPoint]
forall a. a -> [a] -> [a]
: [RelayAccessPoint]
picked)


-- | Run the LedgerPeers worker thread.
--
ledgerPeersThread :: forall m peerAddr.
                     ( MonadAsync m
                     , MonadTime m
                     , Ord peerAddr
                     )
                  => StdGen
                  -> (IP.IP -> Socket.PortNumber -> peerAddr)
                  -> Tracer m TraceLedgerPeers
                  -> STM m UseLedgerAfter
                  -> LedgerPeersConsensusInterface m
                  -> ([DomainAccessPoint] -> m (Map DomainAccessPoint (Set peerAddr)))
                  -> STM m NumberOfPeers
                  -> (Maybe (Set peerAddr, DiffTime) -> STM m ())
                  -> m Void
ledgerPeersThread :: StdGen
-> (IP -> PortNumber -> peerAddr)
-> Tracer m TraceLedgerPeers
-> STM m UseLedgerAfter
-> LedgerPeersConsensusInterface m
-> ([DomainAccessPoint]
    -> m (Map DomainAccessPoint (Set peerAddr)))
-> STM m NumberOfPeers
-> (Maybe (Set peerAddr, DiffTime) -> STM m ())
-> m Void
ledgerPeersThread StdGen
inRng IP -> PortNumber -> peerAddr
toPeerAddr Tracer m TraceLedgerPeers
tracer STM m UseLedgerAfter
readUseLedgerAfter LedgerPeersConsensusInterface{SlotNo -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
lpGetPeers :: SlotNo -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
lpGetPeers :: forall (m :: * -> *).
LedgerPeersConsensusInterface m
-> SlotNo -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
..} [DomainAccessPoint] -> m (Map DomainAccessPoint (Set peerAddr))
doResolve
                  STM m NumberOfPeers
getReq Maybe (Set peerAddr, DiffTime) -> STM m ()
putRsp =
    StdGen
-> Time
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> m Void
go StdGen
inRng (DiffTime -> Time
Time DiffTime
0) Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Map k a
Map.empty
  where
    go :: StdGen -> Time -> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
       -> m Void
    go :: StdGen
-> Time
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> m Void
go StdGen
rng Time
oldTs Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap = do
        UseLedgerAfter
useLedgerAfter <- STM m UseLedgerAfter -> m UseLedgerAfter
forall (m :: * -> *) a.
(MonadSTM m, ?callStack::CallStack) =>
STM m a -> m a
atomically STM m UseLedgerAfter
readUseLedgerAfter
        Tracer m TraceLedgerPeers -> TraceLedgerPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceLedgerPeers
tracer (UseLedgerAfter -> TraceLedgerPeers
TraceUseLedgerAfter UseLedgerAfter
useLedgerAfter)

        let peerListLifeTime :: DiffTime
peerListLifeTime = if Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint) -> Bool
forall k a. Map k a -> Bool
Map.null Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap Bool -> Bool -> Bool
&& UseLedgerAfter -> Bool
isLedgerPeersEnabled UseLedgerAfter
useLedgerAfter
                                  then DiffTime
30
                                  else DiffTime
1847 -- Close to but not exactly 30min.

        Tracer m TraceLedgerPeers -> TraceLedgerPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceLedgerPeers
tracer TraceLedgerPeers
WaitingOnRequest
        NumberOfPeers
numRequested <- STM m NumberOfPeers -> m NumberOfPeers
forall (m :: * -> *) a.
(MonadSTM m, ?callStack::CallStack) =>
STM m a -> m a
atomically STM m NumberOfPeers
getReq
        Tracer m TraceLedgerPeers -> TraceLedgerPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceLedgerPeers
tracer (TraceLedgerPeers -> m ()) -> TraceLedgerPeers -> m ()
forall a b. (a -> b) -> a -> b
$ NumberOfPeers -> TraceLedgerPeers
RequestForPeers NumberOfPeers
numRequested
        !Time
now <- m Time
forall (m :: * -> *). MonadMonotonicTime m => m Time
getMonotonicTime
        let age :: DiffTime
age = Time -> Time -> DiffTime
diffTime Time
now Time
oldTs
        (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap', Time
ts) <- if DiffTime
age DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> DiffTime
peerListLifeTime
                             then
                                 case UseLedgerAfter
useLedgerAfter of
                                   UseLedgerAfter
DontUseLedger -> do
                                     Tracer m TraceLedgerPeers -> TraceLedgerPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceLedgerPeers
tracer TraceLedgerPeers
DisabledLedgerPeers
                                     (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint), Time)
-> m (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
      Time)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Map k a
Map.empty, Time
now)
                                   UseLedgerAfter SlotNo
slot -> do
                                     Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
peers_m <- STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
-> m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
forall (m :: * -> *) a.
(MonadSTM m, ?callStack::CallStack) =>
STM m a -> m a
atomically (STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
 -> m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)]))
-> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
-> m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
forall a b. (a -> b) -> a -> b
$ SlotNo -> STM m (Maybe [(PoolStake, NonEmpty RelayAccessPoint)])
lpGetPeers SlotNo
slot
                                     let peers :: Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peers = Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> ([(PoolStake, NonEmpty RelayAccessPoint)]
    -> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint))
-> Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Map k a
Map.empty [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accPoolStake Maybe [(PoolStake, NonEmpty RelayAccessPoint)]
peers_m
                                     Tracer m TraceLedgerPeers -> TraceLedgerPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceLedgerPeers
tracer (TraceLedgerPeers -> m ()) -> TraceLedgerPeers -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> TraceLedgerPeers
FetchingNewLedgerState (Int -> TraceLedgerPeers) -> Int -> TraceLedgerPeers
forall a b. (a -> b) -> a -> b
$ Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint) -> Int
forall k a. Map k a -> Int
Map.size Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peers
                                     (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint), Time)
-> m (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
      Time)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peers, Time
now)

                             else do
                                 Tracer m TraceLedgerPeers -> TraceLedgerPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceLedgerPeers
tracer (TraceLedgerPeers -> m ()) -> TraceLedgerPeers -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> DiffTime -> TraceLedgerPeers
ReusingLedgerState (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint) -> Int
forall k a. Map k a -> Int
Map.size Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap) DiffTime
age
                                 (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint), Time)
-> m (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
      Time)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap, Time
oldTs)

        if Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint) -> Bool
forall k a. Map k a -> Bool
Map.null Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap'
           then do
               Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UseLedgerAfter -> Bool
isLedgerPeersEnabled UseLedgerAfter
useLedgerAfter) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                   Tracer m TraceLedgerPeers -> TraceLedgerPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceLedgerPeers
tracer TraceLedgerPeers
FallingBackToBootstrapPeers
               STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, ?callStack::CallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe (Set peerAddr, DiffTime) -> STM m ()
putRsp Maybe (Set peerAddr, DiffTime)
forall a. Maybe a
Nothing
               StdGen
-> Time
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> m Void
go StdGen
rng Time
ts Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap'
           else do
               let ttl :: DiffTime
ttl = DiffTime
5 -- TTL, used as re-request interval by the governor.

               (StdGen
rng', ![RelayAccessPoint]
pickedPeers) <- StdGen
-> Tracer m TraceLedgerPeers
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> NumberOfPeers
-> m (StdGen, [RelayAccessPoint])
forall (m :: * -> *).
Monad m =>
StdGen
-> Tracer m TraceLedgerPeers
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> NumberOfPeers
-> m (StdGen, [RelayAccessPoint])
pickPeers StdGen
rng Tracer m TraceLedgerPeers
tracer Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap' NumberOfPeers
numRequested
               Tracer m TraceLedgerPeers -> TraceLedgerPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceLedgerPeers
tracer (TraceLedgerPeers -> m ()) -> TraceLedgerPeers -> m ()
forall a b. (a -> b) -> a -> b
$ NumberOfPeers -> [RelayAccessPoint] -> TraceLedgerPeers
PickedPeers NumberOfPeers
numRequested [RelayAccessPoint]
pickedPeers

               let (Set peerAddr
plainAddrs, [DomainAccessPoint]
domains) = ((Set peerAddr, [DomainAccessPoint])
 -> RelayAccessPoint -> (Set peerAddr, [DomainAccessPoint]))
-> (Set peerAddr, [DomainAccessPoint])
-> [RelayAccessPoint]
-> (Set peerAddr, [DomainAccessPoint])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Set peerAddr, [DomainAccessPoint])
-> RelayAccessPoint -> (Set peerAddr, [DomainAccessPoint])
splitPeers (Set peerAddr
forall a. Set a
Set.empty, []) [RelayAccessPoint]
pickedPeers

               Map DomainAccessPoint (Set peerAddr)
domainAddrs <- [DomainAccessPoint] -> m (Map DomainAccessPoint (Set peerAddr))
doResolve [DomainAccessPoint]
domains

               let (StdGen
rng'', StdGen
rngDomain) = StdGen -> (StdGen, StdGen)
forall g. RandomGen g => g -> (g, g)
split StdGen
rng'
                   pickedAddrs :: Set peerAddr
pickedAddrs = (StdGen, Set peerAddr) -> Set peerAddr
forall a b. (a, b) -> b
snd ((StdGen, Set peerAddr) -> Set peerAddr)
-> (StdGen, Set peerAddr) -> Set peerAddr
forall a b. (a -> b) -> a -> b
$ ((StdGen, Set peerAddr) -> Set peerAddr -> (StdGen, Set peerAddr))
-> (StdGen, Set peerAddr)
-> Map DomainAccessPoint (Set peerAddr)
-> (StdGen, Set peerAddr)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (StdGen, Set peerAddr) -> Set peerAddr -> (StdGen, Set peerAddr)
pickDomainAddrs (StdGen
rngDomain, Set peerAddr
plainAddrs)
                                                       Map DomainAccessPoint (Set peerAddr)
domainAddrs

               STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, ?callStack::CallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe (Set peerAddr, DiffTime) -> STM m ()
putRsp (Maybe (Set peerAddr, DiffTime) -> STM m ())
-> Maybe (Set peerAddr, DiffTime) -> STM m ()
forall a b. (a -> b) -> a -> b
$ (Set peerAddr, DiffTime) -> Maybe (Set peerAddr, DiffTime)
forall a. a -> Maybe a
Just (Set peerAddr
pickedAddrs, DiffTime
ttl)
               StdGen
-> Time
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> m Void
go StdGen
rng'' Time
ts Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap'

    -- Randomly pick one of the addresses returned in the DNS result.
    pickDomainAddrs :: (StdGen, Set peerAddr)
                    -> Set peerAddr
                    -> (StdGen, Set peerAddr)
    pickDomainAddrs :: (StdGen, Set peerAddr) -> Set peerAddr -> (StdGen, Set peerAddr)
pickDomainAddrs (StdGen
rng, Set peerAddr
pickedAddrs) Set peerAddr
addrs | Set peerAddr -> Bool
forall a. Set a -> Bool
Set.null Set peerAddr
addrs = (StdGen
rng, Set peerAddr
pickedAddrs)
    pickDomainAddrs (StdGen
rng, Set peerAddr
pickedAddrs) Set peerAddr
addrs =
        let (Int
ix, StdGen
rng') = (Int, Int) -> StdGen -> (Int, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, Set peerAddr -> Int
forall a. Set a -> Int
Set.size Set peerAddr
addrs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) StdGen
rng
            !pickedAddr :: peerAddr
pickedAddr = Int -> Set peerAddr -> peerAddr
forall a. Int -> Set a -> a
Set.elemAt Int
ix Set peerAddr
addrs in
        (StdGen
rng', peerAddr -> Set peerAddr -> Set peerAddr
forall a. Ord a => a -> Set a -> Set a
Set.insert peerAddr
pickedAddr Set peerAddr
pickedAddrs)


    -- Divide the picked peers form the ledger into addresses we can use directly and
    -- domain names that we need to resolve.
    splitPeers :: (Set peerAddr, [DomainAccessPoint])
               -> RelayAccessPoint
               -> (Set peerAddr, [DomainAccessPoint])
    splitPeers :: (Set peerAddr, [DomainAccessPoint])
-> RelayAccessPoint -> (Set peerAddr, [DomainAccessPoint])
splitPeers (Set peerAddr
addrs, [DomainAccessPoint]
domains) (RelayDomainAccessPoint DomainAccessPoint
domain) = (Set peerAddr
addrs, DomainAccessPoint
domain DomainAccessPoint -> [DomainAccessPoint] -> [DomainAccessPoint]
forall a. a -> [a] -> [a]
: [DomainAccessPoint]
domains)
    splitPeers (Set peerAddr
addrs, [DomainAccessPoint]
domains) (RelayAccessAddress IP
ip PortNumber
port) =
        let !addr :: peerAddr
addr = IP -> PortNumber -> peerAddr
toPeerAddr IP
ip PortNumber
port in
        (peerAddr -> Set peerAddr -> Set peerAddr
forall a. Ord a => a -> Set a -> Set a
Set.insert peerAddr
addr Set peerAddr
addrs, [DomainAccessPoint]
domains)


-- | For a LederPeers worker thread and submit request and receive responses.
--
withLedgerPeers :: forall peerAddr m a.
                   ( MonadAsync m
                   , MonadTime m
                   , Ord peerAddr
                   )
                => StdGen
                -> (IP.IP -> Socket.PortNumber -> peerAddr)
                -> Tracer m TraceLedgerPeers
                -> STM m UseLedgerAfter
                -> LedgerPeersConsensusInterface m
                -> ([DomainAccessPoint] -> m (Map DomainAccessPoint (Set peerAddr)))
                -> ( (NumberOfPeers -> m (Maybe (Set peerAddr, DiffTime)))
                     -> Async m Void
                     -> m a )
                -> m a
withLedgerPeers :: StdGen
-> (IP -> PortNumber -> peerAddr)
-> Tracer m TraceLedgerPeers
-> STM m UseLedgerAfter
-> LedgerPeersConsensusInterface m
-> ([DomainAccessPoint]
    -> m (Map DomainAccessPoint (Set peerAddr)))
-> ((NumberOfPeers -> m (Maybe (Set peerAddr, DiffTime)))
    -> Async m Void -> m a)
-> m a
withLedgerPeers StdGen
inRng IP -> PortNumber -> peerAddr
toPeerAddr Tracer m TraceLedgerPeers
tracer STM m UseLedgerAfter
readUseLedgerAfter LedgerPeersConsensusInterface m
interface [DomainAccessPoint] -> m (Map DomainAccessPoint (Set peerAddr))
doResolve (NumberOfPeers -> m (Maybe (Set peerAddr, DiffTime)))
-> Async m Void -> m a
k = do
    StrictTMVar m NumberOfPeers
reqVar  <- m (StrictTMVar m NumberOfPeers)
forall (m :: * -> *) a. MonadSTM m => m (StrictTMVar m a)
newEmptyTMVarIO
    StrictTMVar m (Maybe (Set peerAddr, DiffTime))
respVar <- m (StrictTMVar m (Maybe (Set peerAddr, DiffTime)))
forall (m :: * -> *) a. MonadSTM m => m (StrictTMVar m a)
newEmptyTMVarIO
    let getRequest :: STM m NumberOfPeers
getRequest  = StrictTMVar m NumberOfPeers -> STM m NumberOfPeers
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m a
takeTMVar StrictTMVar m NumberOfPeers
reqVar
        putResponse :: Maybe (Set peerAddr, DiffTime) -> STM m ()
putResponse = StrictTMVar m (Maybe (Set peerAddr, DiffTime))
-> Maybe (Set peerAddr, DiffTime) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
putTMVar  StrictTMVar m (Maybe (Set peerAddr, DiffTime))
respVar
        request :: NumberOfPeers -> m (Maybe (Set peerAddr, DiffTime))
        request :: NumberOfPeers -> m (Maybe (Set peerAddr, DiffTime))
request = \NumberOfPeers
numberOfPeers -> do
          STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, ?callStack::CallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTMVar m NumberOfPeers -> NumberOfPeers -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
putTMVar StrictTMVar m NumberOfPeers
reqVar NumberOfPeers
numberOfPeers
          STM m (Maybe (Set peerAddr, DiffTime))
-> m (Maybe (Set peerAddr, DiffTime))
forall (m :: * -> *) a.
(MonadSTM m, ?callStack::CallStack) =>
STM m a -> m a
atomically (STM m (Maybe (Set peerAddr, DiffTime))
 -> m (Maybe (Set peerAddr, DiffTime)))
-> STM m (Maybe (Set peerAddr, DiffTime))
-> m (Maybe (Set peerAddr, DiffTime))
forall a b. (a -> b) -> a -> b
$ StrictTMVar m (Maybe (Set peerAddr, DiffTime))
-> STM m (Maybe (Set peerAddr, DiffTime))
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m a
takeTMVar StrictTMVar m (Maybe (Set peerAddr, DiffTime))
respVar
    m Void -> (Async m Void -> m a) -> m a
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync
      ( StdGen
-> (IP -> PortNumber -> peerAddr)
-> Tracer m TraceLedgerPeers
-> STM m UseLedgerAfter
-> LedgerPeersConsensusInterface m
-> ([DomainAccessPoint]
    -> m (Map DomainAccessPoint (Set peerAddr)))
-> STM m NumberOfPeers
-> (Maybe (Set peerAddr, DiffTime) -> STM m ())
-> m Void
forall (m :: * -> *) peerAddr.
(MonadAsync m, MonadTime m, Ord peerAddr) =>
StdGen
-> (IP -> PortNumber -> peerAddr)
-> Tracer m TraceLedgerPeers
-> STM m UseLedgerAfter
-> LedgerPeersConsensusInterface m
-> ([DomainAccessPoint]
    -> m (Map DomainAccessPoint (Set peerAddr)))
-> STM m NumberOfPeers
-> (Maybe (Set peerAddr, DiffTime) -> STM m ())
-> m Void
ledgerPeersThread StdGen
inRng IP -> PortNumber -> peerAddr
toPeerAddr Tracer m TraceLedgerPeers
tracer STM m UseLedgerAfter
readUseLedgerAfter
                          LedgerPeersConsensusInterface m
interface [DomainAccessPoint] -> m (Map DomainAccessPoint (Set peerAddr))
doResolve
                          STM m NumberOfPeers
getRequest Maybe (Set peerAddr, DiffTime) -> STM m ()
putResponse )
      ((Async m Void -> m a) -> m a) -> (Async m Void -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \ Async m Void
thread -> (NumberOfPeers -> m (Maybe (Set peerAddr, DiffTime)))
-> Async m Void -> m a
k NumberOfPeers -> m (Maybe (Set peerAddr, DiffTime))
request Async m Void
thread