{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
#if __GLASGOW_HASKELL__ >= 908
{-# OPTIONS_GHC -Wno-x-partial #-}
#endif

module Ouroboros.Network.PeerSelection.LedgerPeers
  ( DomainAccessPoint (..)
  , IP.IP (..)
  , LedgerPeers (..)
  , getLedgerPeers
  , RelayAccessPoint (..)
  , PoolStake (..)
  , AccPoolStake (..)
  , TraceLedgerPeers (..)
  , NumberOfPeers (..)
  , LedgerPeersKind (..)
  , StakeMapOverSource (..)
    -- * Ledger Peers specific functions
  , accPoolStake
  , accumulateBigLedgerStake
  , accBigPoolStakeMap
  , bigLedgerPeerQuota
  , stakeMapWithSlotOverSource
    -- * DNS based provider for ledger root peers
  , WithLedgerPeersArgs (..)
  , withLedgerPeers
    -- Re-exports for testing purposes
  , module Ouroboros.Network.PeerSelection.LedgerPeers.Type
  , module Ouroboros.Network.PeerSelection.LedgerPeers.Common
    -- * Internal only exported for testing purposes
  , resolveLedgerPeers
  ) where

import Control.Monad (when)
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadTime.SI
import Control.Tracer (Tracer, traceWith)
import Data.IP qualified as IP
import Data.List as List (foldl')
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (isJust)
import Data.Ratio
import System.Random

import Cardano.Slotting.Slot (SlotNo (..), WithOrigin (..))
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadThrow
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Void (Void)
import Data.Word (Word16, Word64)
import Network.DNS qualified as DNS
import Ouroboros.Network.PeerSelection.LedgerPeers.Common
import Ouroboros.Network.PeerSelection.LedgerPeers.Type
import Ouroboros.Network.PeerSelection.LedgerPeers.Utils
           (accumulateBigLedgerStake, bigLedgerPeerQuota,
           recomputeRelativeStake)
import Ouroboros.Network.PeerSelection.RelayAccessPoint
import Ouroboros.Network.PeerSelection.RootPeersDNS
import Ouroboros.Network.PeerSelection.RootPeersDNS.LedgerPeers
           (resolveLedgerPeers)

-- | Internal API to deal with 'UseLedgerAfter' configuration
-- option
--
-- Receiving the 'LedgerPeersConsensusInterface' we are able to compute a
-- function that given a 'SlotNo' will give us 'LedgerPeers' according to the
-- following invariants:
--
-- * 'BeforeSlot' is returned iff the latest slot is before the 'slotNo';
-- * 'LedgerPeers lsj peers' is returned iff the latest slot is after the
--   'slotNo'.
--
getLedgerPeers
  :: MonadSTM m
  => LedgerPeersConsensusInterface m
  -> AfterSlot
  -> STM m LedgerPeers
getLedgerPeers :: forall (m :: * -> *).
MonadSTM m =>
LedgerPeersConsensusInterface m -> AfterSlot -> STM m LedgerPeers
getLedgerPeers (LedgerPeersConsensusInterface STM m (WithOrigin SlotNo)
lpGetLatestSlot
                                              STM m LedgerStateJudgement
lpGetLedgerStateJudgement
                                              STM m [(PoolStake, NonEmpty RelayAccessPoint)]
lpGetLedgerPeers)
               AfterSlot
ulp = do
  wOrigin <- STM m (WithOrigin SlotNo)
lpGetLatestSlot
  case (wOrigin, ulp) of
    (WithOrigin SlotNo
_         , AfterSlot
Always) -> STM m LedgerPeers
ledgerPeers
    (At SlotNo
curSlot, After SlotNo
slot)
      | SlotNo
curSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
slot -> STM m LedgerPeers
ledgerPeers
    (WithOrigin SlotNo, AfterSlot)
_ -> LedgerPeers -> STM m LedgerPeers
forall a. a -> STM m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LedgerPeers
BeforeSlot
  where
    ledgerPeers :: STM m LedgerPeers
ledgerPeers = LedgerStateJudgement
-> [(PoolStake, NonEmpty RelayAccessPoint)] -> LedgerPeers
LedgerPeers
              (LedgerStateJudgement
 -> [(PoolStake, NonEmpty RelayAccessPoint)] -> LedgerPeers)
-> STM m LedgerStateJudgement
-> STM m ([(PoolStake, NonEmpty RelayAccessPoint)] -> LedgerPeers)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m LedgerStateJudgement
lpGetLedgerStateJudgement
              STM m ([(PoolStake, NonEmpty RelayAccessPoint)] -> LedgerPeers)
-> STM m [(PoolStake, NonEmpty RelayAccessPoint)]
-> STM m LedgerPeers
forall a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STM m [(PoolStake, NonEmpty RelayAccessPoint)]
lpGetLedgerPeers

-- | 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 =
      [(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))]
 -> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint))
-> ([(PoolStake, NonEmpty RelayAccessPoint)]
    -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
-> [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
 -> (PoolStake, NonEmpty RelayAccessPoint)
 -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> (PoolStake, NonEmpty RelayAccessPoint)
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
fn []
    ([(PoolStake, NonEmpty RelayAccessPoint)]
 -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
-> ([(PoolStake, NonEmpty RelayAccessPoint)]
    -> [(PoolStake, NonEmpty RelayAccessPoint)])
-> [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerPeersKind
-> [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
recomputeRelativeStake LedgerPeersKind
AllLedgerPeers
  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. HasCallStack => [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

-- | Take the result of 'accBigPoolStake' and turn it into
--
accBigPoolStakeMap :: [(PoolStake, NonEmpty RelayAccessPoint)]
                   -> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accBigPoolStakeMap :: [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accBigPoolStakeMap = [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList      -- the input list is ordered by `AccPoolStake`, thus we
                                          -- can use `fromAscList`
                     ([(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
 -> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint))
-> ([(PoolStake, NonEmpty RelayAccessPoint)]
    -> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))])
-> [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(PoolStake, NonEmpty RelayAccessPoint)]
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
accumulateBigLedgerStake

-- | Try to pick n random peers using stake distribution.
--
pickPeers :: forall m. Monad m
          => StdGen
          -> Tracer m TraceLedgerPeers
          -> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
          -- ^ all ledger peers
          -> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
          -- ^ big ledger peers
          -> NumberOfPeers
          -> LedgerPeersKind
          -> m (StdGen, [RelayAccessPoint])

pickPeers :: forall (m :: * -> *).
Monad m =>
StdGen
-> Tracer m TraceLedgerPeers
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> NumberOfPeers
-> LedgerPeersKind
-> m (StdGen, [RelayAccessPoint])
pickPeers StdGen
inRng Tracer m TraceLedgerPeers
_ Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
pools Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
_bigPools NumberOfPeers
_ LedgerPeersKind
_ | 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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (StdGen
inRng, [])

-- pick big ledger peers using ledger stake distribution
pickPeers StdGen
inRng Tracer m TraceLedgerPeers
tracer Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
_pools Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
bigPools (NumberOfPeers Word16
cnt) LedgerPeersKind
BigLedgerPeers =
    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 a. a -> m a
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 g. RandomGen g => g -> (Word64, g)
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 is the random accumulated stake capped by `bigLedgerPeerQuota`.
            -- We use it to select random big ledger peer according to their
            -- stake distribution.
            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 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (AccPoolStake -> Rational
unAccPoolStake AccPoolStake
bigLedgerPeerQuota)
        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)
bigPools 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 g. RandomGen g => (Int, Int) -> g -> (Int, g)
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. HasCallStack => 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
PickedBigLedgerPeer 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)

-- pick ledger peers (not necessarily big ones) using square root of the stake
-- distribution
pickPeers StdGen
inRng Tracer m TraceLedgerPeers
tracer Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
pools Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
_bigPools (NumberOfPeers Word16
cnt) LedgerPeersKind
AllLedgerPeers = 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 a. a -> m a
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 g. RandomGen g => g -> (Word64, g)
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 g. RandomGen g => (Int, Int) -> g -> (Int, g)
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. HasCallStack => 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
PickedLedgerPeer 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)


-- | Peer list life time decides how often previous ledger peers should be
-- reused.  If the ledger peer map is empty we use 'short_PEER_LIST_LIFE_TIME'
-- otherwise we use 'long_PEER_LIST_LIFE_TIME'
--
short_PEER_LIST_LIFE_TIME :: DiffTime
short_PEER_LIST_LIFE_TIME :: DiffTime
short_PEER_LIST_LIFE_TIME = DiffTime
30

-- | Long peer list lift time, close to 30minutes but not exactly
--
long_PEER_LIST_LIFE_TIME :: DiffTime
long_PEER_LIST_LIFE_TIME :: DiffTime
long_PEER_LIST_LIFE_TIME = DiffTime
1847 -- a prime number!

-- | Run the LedgerPeers worker thread.
--
ledgerPeersThread :: forall m peerAddr resolver exception.
                     ( MonadAsync m
                     , MonadMonotonicTime m
                     , MonadThrow m
                     , Exception exception
                     , Ord peerAddr
                     )
                  => PeerActionsDNS peerAddr resolver exception m
                  -> WithLedgerPeersArgs m
                  -- blocking request for ledger peers
                  -> STM m (NumberOfPeers, LedgerPeersKind)
                  -- response with ledger peers
                  -> (Maybe (Set peerAddr, DiffTime) -> STM m ())
                  -> m Void
ledgerPeersThread :: forall (m :: * -> *) peerAddr resolver exception.
(MonadAsync m, MonadMonotonicTime m, MonadThrow m,
 Exception exception, Ord peerAddr) =>
PeerActionsDNS peerAddr resolver exception m
-> WithLedgerPeersArgs m
-> STM m (NumberOfPeers, LedgerPeersKind)
-> (Maybe (Set peerAddr, DiffTime) -> STM m ())
-> m Void
ledgerPeersThread PeerActionsDNS {
                    IP -> PortNumber -> peerAddr
paToPeerAddr :: IP -> PortNumber -> peerAddr
paToPeerAddr :: forall peeraddr resolver exception (m :: * -> *).
PeerActionsDNS peeraddr resolver exception m
-> IP -> PortNumber -> peeraddr
paToPeerAddr,
                    DNSActions resolver exception m
paDnsActions :: DNSActions resolver exception m
paDnsActions :: forall peeraddr resolver exception (m :: * -> *).
PeerActionsDNS peeraddr resolver exception m
-> DNSActions resolver exception m
paDnsActions,
                    DNSSemaphore m
paDnsSemaphore :: DNSSemaphore m
paDnsSemaphore :: forall peeraddr resolver exception (m :: * -> *).
PeerActionsDNS peeraddr resolver exception m -> DNSSemaphore m
paDnsSemaphore }
                  WithLedgerPeersArgs {
                    StdGen
wlpRng :: StdGen
wlpRng :: forall (m :: * -> *). WithLedgerPeersArgs m -> StdGen
wlpRng,
                    LedgerPeersConsensusInterface m
wlpConsensusInterface :: LedgerPeersConsensusInterface m
wlpConsensusInterface :: forall (m :: * -> *).
WithLedgerPeersArgs m -> LedgerPeersConsensusInterface m
wlpConsensusInterface,
                    Tracer m TraceLedgerPeers
wlpTracer :: Tracer m TraceLedgerPeers
wlpTracer :: forall (m :: * -> *).
WithLedgerPeersArgs m -> Tracer m TraceLedgerPeers
wlpTracer,
                    STM m UseLedgerPeers
wlpGetUseLedgerPeers :: STM m UseLedgerPeers
wlpGetUseLedgerPeers :: forall (m :: * -> *). WithLedgerPeersArgs m -> STM m UseLedgerPeers
wlpGetUseLedgerPeers,
                    STM m (Maybe LedgerPeerSnapshot)
wlpGetLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot)
wlpGetLedgerPeerSnapshot :: forall (m :: * -> *).
WithLedgerPeersArgs m -> STM m (Maybe LedgerPeerSnapshot)
wlpGetLedgerPeerSnapshot }
                  STM m (NumberOfPeers, LedgerPeersKind)
getReq
                  Maybe (Set peerAddr, DiffTime) -> STM m ()
putResp = do
    StdGen
-> Time
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> Maybe SlotNo
-> m Void
go StdGen
wlpRng (DiffTime -> Time
Time DiffTime
0) Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Map k a
Map.empty Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Map k a
Map.empty Maybe SlotNo
forall a. Maybe a
Nothing
  where
    go :: StdGen
       -> Time
       -> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
       -> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
       -> Maybe SlotNo
       -> m Void
    go :: StdGen
-> Time
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
-> Maybe SlotNo
-> m Void
go StdGen
rng Time
oldTs Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
bigPeerMap Maybe SlotNo
cachedSlot = do
        Tracer m TraceLedgerPeers -> TraceLedgerPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceLedgerPeers
wlpTracer TraceLedgerPeers
WaitingOnRequest
        -- wait until next request of ledger peers
        ((numRequested, ledgerPeersKind), useLedgerPeers) <- STM m ((NumberOfPeers, LedgerPeersKind), UseLedgerPeers)
-> m ((NumberOfPeers, LedgerPeersKind), UseLedgerPeers)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m ((NumberOfPeers, LedgerPeersKind), UseLedgerPeers)
 -> m ((NumberOfPeers, LedgerPeersKind), UseLedgerPeers))
-> STM m ((NumberOfPeers, LedgerPeersKind), UseLedgerPeers)
-> m ((NumberOfPeers, LedgerPeersKind), UseLedgerPeers)
forall a b. (a -> b) -> a -> b
$
          (,) ((NumberOfPeers, LedgerPeersKind)
 -> UseLedgerPeers
 -> ((NumberOfPeers, LedgerPeersKind), UseLedgerPeers))
-> STM m (NumberOfPeers, LedgerPeersKind)
-> STM
     m
     (UseLedgerPeers
      -> ((NumberOfPeers, LedgerPeersKind), UseLedgerPeers))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m (NumberOfPeers, LedgerPeersKind)
getReq STM
  m
  (UseLedgerPeers
   -> ((NumberOfPeers, LedgerPeersKind), UseLedgerPeers))
-> STM m UseLedgerPeers
-> STM m ((NumberOfPeers, LedgerPeersKind), UseLedgerPeers)
forall a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STM m UseLedgerPeers
wlpGetUseLedgerPeers
        traceWith wlpTracer (TraceUseLedgerPeers useLedgerPeers)

        let 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
&& UseLedgerPeers -> Bool
isLedgerPeersEnabled UseLedgerPeers
useLedgerPeers
                                  then DiffTime
short_PEER_LIST_LIFE_TIME
                                  else DiffTime
long_PEER_LIST_LIFE_TIME

        traceWith wlpTracer $ RequestForPeers numRequested
        !now <- getMonotonicTime
        let age = Time -> Time -> DiffTime
diffTime Time
now Time
oldTs
        (peerMap', bigPeerMap', cachedSlot', ts) <-
          if age > peerListLifeTime
             then case useLedgerPeers of
               UseLedgerPeers
DontUseLedgerPeers -> do
                 Tracer m TraceLedgerPeers -> TraceLedgerPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceLedgerPeers
wlpTracer TraceLedgerPeers
DisabledLedgerPeers
                 (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
 Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
 Maybe SlotNo, Time)
-> m (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
      Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
      Maybe SlotNo, Time)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Map k a
Map.empty, Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Map k a
Map.empty, Maybe SlotNo
forall a. Maybe a
Nothing, Time
now)
               UseLedgerPeers AfterSlot
ula -> do
                 (ledgerWithOrigin, ledgerPeers, peerSnapshot) <-
                   STM m (WithOrigin SlotNo, LedgerPeers, Maybe LedgerPeerSnapshot)
-> m (WithOrigin SlotNo, LedgerPeers, Maybe LedgerPeerSnapshot)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically ((,,) (WithOrigin SlotNo
 -> LedgerPeers
 -> Maybe LedgerPeerSnapshot
 -> (WithOrigin SlotNo, LedgerPeers, Maybe LedgerPeerSnapshot))
-> STM m (WithOrigin SlotNo)
-> STM
     m
     (LedgerPeers
      -> Maybe LedgerPeerSnapshot
      -> (WithOrigin SlotNo, LedgerPeers, Maybe LedgerPeerSnapshot))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerPeersConsensusInterface m -> STM m (WithOrigin SlotNo)
forall (m :: * -> *).
LedgerPeersConsensusInterface m -> STM m (WithOrigin SlotNo)
lpGetLatestSlot LedgerPeersConsensusInterface m
wlpConsensusInterface
                                    STM
  m
  (LedgerPeers
   -> Maybe LedgerPeerSnapshot
   -> (WithOrigin SlotNo, LedgerPeers, Maybe LedgerPeerSnapshot))
-> STM m LedgerPeers
-> STM
     m
     (Maybe LedgerPeerSnapshot
      -> (WithOrigin SlotNo, LedgerPeers, Maybe LedgerPeerSnapshot))
forall a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LedgerPeersConsensusInterface m -> AfterSlot -> STM m LedgerPeers
forall (m :: * -> *).
MonadSTM m =>
LedgerPeersConsensusInterface m -> AfterSlot -> STM m LedgerPeers
getLedgerPeers LedgerPeersConsensusInterface m
wlpConsensusInterface AfterSlot
ula
                                    STM
  m
  (Maybe LedgerPeerSnapshot
   -> (WithOrigin SlotNo, LedgerPeers, Maybe LedgerPeerSnapshot))
-> STM m (Maybe LedgerPeerSnapshot)
-> STM m (WithOrigin SlotNo, LedgerPeers, Maybe LedgerPeerSnapshot)
forall a b. STM m (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> STM m (Maybe LedgerPeerSnapshot)
wlpGetLedgerPeerSnapshot)

                 let (peersStakeMap, bigPeersStakeMap, cachedSlot'') =
                       stakeMapWithSlotOverSource StakeMapOverSource {
                                                    ledgerWithOrigin,
                                                    ledgerPeers,
                                                    peerSnapshot,
                                                    cachedSlot,
                                                    peerMap,
                                                    bigPeerMap,
                                                    ula}
                 when (isJust cachedSlot'') $ traceWith wlpTracer UsingBigLedgerPeerSnapshot

                 traceWith wlpTracer $ FetchingNewLedgerState (Map.size peersStakeMap) (Map.size bigPeersStakeMap)
                 return (peersStakeMap, bigPeersStakeMap, cachedSlot'', now)
             else do
               traceWith wlpTracer $ ReusingLedgerState (Map.size peerMap) age
               return (peerMap, bigPeerMap, cachedSlot, oldTs)

        if all Map.null [peerMap', bigPeerMap']
           then do
               when (isLedgerPeersEnabled useLedgerPeers) $
                   traceWith wlpTracer FallingBackToPublicRootPeers
               atomically $ putResp Nothing
               go rng ts peerMap' bigPeerMap' cachedSlot'
           else do
               let ttl = DiffTime
5 -- TTL, used as re-request interval by the governor.

               (rng', !pickedPeers) <- pickPeers rng wlpTracer peerMap' bigPeerMap' numRequested ledgerPeersKind
               case ledgerPeersKind of
                 LedgerPeersKind
BigLedgerPeers -> do
                   let numBigLedgerPeers :: Int
numBigLedgerPeers = Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint) -> Int
forall k a. Map k a -> Int
Map.size Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
bigPeerMap'
                   Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NumberOfPeers -> Word16
getNumberOfPeers NumberOfPeers
numRequested
                           Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numBigLedgerPeers) (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
wlpTracer (NumberOfPeers -> Int -> TraceLedgerPeers
NotEnoughBigLedgerPeers NumberOfPeers
numRequested Int
numBigLedgerPeers)
                   Tracer m TraceLedgerPeers -> TraceLedgerPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceLedgerPeers
wlpTracer (NumberOfPeers -> [RelayAccessPoint] -> TraceLedgerPeers
PickedBigLedgerPeers NumberOfPeers
numRequested [RelayAccessPoint]
pickedPeers)
                 LedgerPeersKind
AllLedgerPeers -> do
                   let numLedgerPeers :: Int
numLedgerPeers = Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint) -> Int
forall k a. Map k a -> Int
Map.size Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap'
                   Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NumberOfPeers -> Word16
getNumberOfPeers NumberOfPeers
numRequested
                           Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
> Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numLedgerPeers) (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
wlpTracer (NumberOfPeers -> Int -> TraceLedgerPeers
NotEnoughLedgerPeers NumberOfPeers
numRequested Int
numLedgerPeers)
                   Tracer m TraceLedgerPeers -> TraceLedgerPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TraceLedgerPeers
wlpTracer (NumberOfPeers -> [RelayAccessPoint] -> TraceLedgerPeers
PickedLedgerPeers NumberOfPeers
numRequested [RelayAccessPoint]
pickedPeers)


               let (plainAddrs, domains) =
                     List.foldl' partitionPeer (Set.empty, []) pickedPeers

               -- NOTE: we don't set `resolveConcurrent` because
               -- of https://github.com/kazu-yamamoto/dns/issues/174
               domainAddrs <- resolveLedgerPeers wlpTracer
                                                 paToPeerAddr
                                                 paDnsSemaphore
                                                 DNS.defaultResolvConf
                                                 paDnsActions
                                                 domains

               let (rng'', rngDomain) = split rng'
                   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 b a. (b -> a -> b) -> b -> Map DomainAccessPoint a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (StdGen, Set peerAddr) -> Set peerAddr -> (StdGen, Set peerAddr)
pickDomainAddrs
                                  (StdGen
rngDomain, Set peerAddr
plainAddrs)
                                  Map DomainAccessPoint (Set peerAddr)
domainAddrs

               atomically $ putResp $ Just (pickedAddrs, ttl)
               go rng'' ts peerMap' bigPeerMap' cachedSlot'

    -- 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 g. RandomGen g => (Int, Int) -> g -> (Int, g)
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
            pickedAddrs' :: Set peerAddr
pickedAddrs' = peerAddr -> Set peerAddr -> Set peerAddr
forall a. Ord a => a -> Set a -> Set a
Set.insert peerAddr
pickedAddr Set peerAddr
pickedAddrs
        in (StdGen
rng', Set peerAddr
pickedAddrs')


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


-- | Arguments record to stakeMapWithSlotOverSource function
--
data StakeMapOverSource = StakeMapOverSource {
  StakeMapOverSource -> WithOrigin SlotNo
ledgerWithOrigin :: WithOrigin SlotNo,
  StakeMapOverSource -> LedgerPeers
ledgerPeers      :: LedgerPeers,
  StakeMapOverSource -> Maybe LedgerPeerSnapshot
peerSnapshot     :: Maybe LedgerPeerSnapshot,
  StakeMapOverSource -> Maybe SlotNo
cachedSlot       :: Maybe SlotNo,
  StakeMapOverSource
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap          :: Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
  StakeMapOverSource
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
bigPeerMap       :: Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
  StakeMapOverSource -> AfterSlot
ula              :: AfterSlot }
  deriving Int -> StakeMapOverSource -> ShowS
[StakeMapOverSource] -> ShowS
StakeMapOverSource -> String
(Int -> StakeMapOverSource -> ShowS)
-> (StakeMapOverSource -> String)
-> ([StakeMapOverSource] -> ShowS)
-> Show StakeMapOverSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> StakeMapOverSource -> ShowS
showsPrec :: Int -> StakeMapOverSource -> ShowS
$cshow :: StakeMapOverSource -> String
show :: StakeMapOverSource -> String
$cshowList :: [StakeMapOverSource] -> ShowS
showList :: [StakeMapOverSource] -> ShowS
Show

-- | Build up a stake map to sample ledger peers from. The SlotNo, if different from 0,
-- indicates that the maps are the stake pools from the snapshot taken from the particular
-- slot number.
--
stakeMapWithSlotOverSource :: StakeMapOverSource
                           -> (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
                               Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
                               Maybe SlotNo)
stakeMapWithSlotOverSource :: StakeMapOverSource
-> (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
    Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint),
    Maybe SlotNo)
stakeMapWithSlotOverSource StakeMapOverSource {
                             WithOrigin SlotNo
ledgerWithOrigin :: StakeMapOverSource -> WithOrigin SlotNo
ledgerWithOrigin :: WithOrigin SlotNo
ledgerWithOrigin,
                             LedgerPeers
ledgerPeers :: StakeMapOverSource -> LedgerPeers
ledgerPeers :: LedgerPeers
ledgerPeers,
                             Maybe LedgerPeerSnapshot
peerSnapshot :: StakeMapOverSource -> Maybe LedgerPeerSnapshot
peerSnapshot :: Maybe LedgerPeerSnapshot
peerSnapshot,
                             Maybe SlotNo
cachedSlot :: StakeMapOverSource -> Maybe SlotNo
cachedSlot :: Maybe SlotNo
cachedSlot,
                             Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap :: StakeMapOverSource
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap :: Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap,
                             Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
bigPeerMap :: StakeMapOverSource
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
bigPeerMap :: Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
bigPeerMap,
                             AfterSlot
ula :: StakeMapOverSource -> AfterSlot
ula :: AfterSlot
ula } =
  case (WithOrigin SlotNo
ledgerWithOrigin, LedgerPeers
ledgerPeers, Maybe LedgerPeerSnapshot
peerSnapshot) of
    (At SlotNo
ledgerSlotNo, LedgerPeers LedgerStateJudgement
_ [(PoolStake, NonEmpty RelayAccessPoint)]
ledgerRelays, Just (LedgerPeerSnapshot (At SlotNo
snapshotSlotNo, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
accSnapshotRelays)))
      | SlotNo
snapshotSlotNo SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
ledgerSlotNo -> -- ^ we cache the peers from the snapshot
                                          -- to avoid unnecessary work
        case Maybe SlotNo
cachedSlot of
          Just SlotNo
thatSlot | SlotNo
thatSlot SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
snapshotSlotNo ->
                          (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap, Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
bigPeerMap, Maybe SlotNo
cachedSlot)
          Maybe SlotNo
_otherwise -> ( [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accPoolStake (((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
 -> (PoolStake, NonEmpty RelayAccessPoint))
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall a b. (a -> b) -> [a] -> [b]
map (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> (PoolStake, NonEmpty RelayAccessPoint)
forall a b. (a, b) -> b
snd [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
accSnapshotRelays)
                        , [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
accSnapshotRelays
                        , SlotNo -> Maybe SlotNo
forall a. a -> Maybe a
Just SlotNo
snapshotSlotNo)
      | Bool
otherwise -> ([(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accPoolStake [(PoolStake, NonEmpty RelayAccessPoint)]
ledgerRelays, [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accBigPoolStakeMap [(PoolStake, NonEmpty RelayAccessPoint)]
ledgerRelays, Maybe SlotNo
forall a. Maybe a
Nothing)

    (WithOrigin SlotNo
_, LedgerPeers LedgerStateJudgement
_ [(PoolStake, NonEmpty RelayAccessPoint)]
ledgerRelays, Maybe LedgerPeerSnapshot
Nothing) -> ( [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accPoolStake [(PoolStake, NonEmpty RelayAccessPoint)]
ledgerRelays
                                                , [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accBigPoolStakeMap [(PoolStake, NonEmpty RelayAccessPoint)]
ledgerRelays
                                                , Maybe SlotNo
forall a. Maybe a
Nothing)

    (WithOrigin SlotNo
_, LedgerPeers
_, Just (LedgerPeerSnapshot (At SlotNo
snapshotSlotNo, [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
accSnapshotRelays)))
      | After SlotNo
slot <- AfterSlot
ula, SlotNo
snapshotSlotNo SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
slot -> do
        case Maybe SlotNo
cachedSlot of
          Just SlotNo
thatSlot | SlotNo
thatSlot SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== SlotNo
snapshotSlotNo ->
                          (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
peerMap, Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
bigPeerMap, Maybe SlotNo
cachedSlot)
          Maybe SlotNo
_otherwise -> ( [(PoolStake, NonEmpty RelayAccessPoint)]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
accPoolStake (((AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
 -> (PoolStake, NonEmpty RelayAccessPoint))
-> [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> [(PoolStake, NonEmpty RelayAccessPoint)]
forall a b. (a -> b) -> [a] -> [b]
map (AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))
-> (PoolStake, NonEmpty RelayAccessPoint)
forall a b. (a, b) -> b
snd [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
accSnapshotRelays)
                        , [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
-> Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList [(AccPoolStake, (PoolStake, NonEmpty RelayAccessPoint))]
accSnapshotRelays
                        , SlotNo -> Maybe SlotNo
forall a. a -> Maybe a
Just SlotNo
snapshotSlotNo)

    (WithOrigin SlotNo, LedgerPeers, Maybe LedgerPeerSnapshot)
_otherwise -> (Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Map k a
Map.empty, Map AccPoolStake (PoolStake, NonEmpty RelayAccessPoint)
forall k a. Map k a
Map.empty, Maybe SlotNo
forall a. Maybe a
Nothing)

-- | Argument record for withLedgerPeers
--
data WithLedgerPeersArgs m = WithLedgerPeersArgs {
  forall (m :: * -> *). WithLedgerPeersArgs m -> StdGen
wlpRng                   :: StdGen,
  -- ^ Random generator for picking ledger peers
  forall (m :: * -> *).
WithLedgerPeersArgs m -> LedgerPeersConsensusInterface m
wlpConsensusInterface    :: LedgerPeersConsensusInterface m,
  forall (m :: * -> *).
WithLedgerPeersArgs m -> Tracer m TraceLedgerPeers
wlpTracer                :: Tracer m TraceLedgerPeers,
  -- ^ Get Ledger Peers comes from here
  forall (m :: * -> *). WithLedgerPeersArgs m -> STM m UseLedgerPeers
wlpGetUseLedgerPeers     :: STM m UseLedgerPeers,
  -- ^ Get Use Ledger After value
  forall (m :: * -> *).
WithLedgerPeersArgs m -> STM m (Maybe LedgerPeerSnapshot)
wlpGetLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot)
  -- ^ Get ledger peer snapshot from file read by node
  }

-- | For a LedgerPeers worker thread and submit request and receive responses.
--
withLedgerPeers :: forall peerAddr resolver exception m a.
                   ( MonadAsync m
                   , MonadThrow m
                   , MonadMonotonicTime m
                   , Exception exception
                   , Ord peerAddr
                   )
                => PeerActionsDNS peerAddr resolver exception m
                -> WithLedgerPeersArgs m
                -> ((NumberOfPeers -> LedgerPeersKind -> m (Maybe (Set peerAddr, DiffTime)))
                     -> Async m Void
                     -> m a )
                -> m a
withLedgerPeers :: forall peerAddr resolver exception (m :: * -> *) a.
(MonadAsync m, MonadThrow m, MonadMonotonicTime m,
 Exception exception, Ord peerAddr) =>
PeerActionsDNS peerAddr resolver exception m
-> WithLedgerPeersArgs m
-> ((NumberOfPeers
     -> LedgerPeersKind -> m (Maybe (Set peerAddr, DiffTime)))
    -> Async m Void -> m a)
-> m a
withLedgerPeers PeerActionsDNS peerAddr resolver exception m
peerActionsDNS
                WithLedgerPeersArgs m
ledgerPeerArgs
                (NumberOfPeers
 -> LedgerPeersKind -> m (Maybe (Set peerAddr, DiffTime)))
-> Async m Void -> m a
k = do
    reqVar  <- m (StrictTMVar m (NumberOfPeers, LedgerPeersKind))
forall (m :: * -> *) a. MonadSTM m => m (StrictTMVar m a)
newEmptyTMVarIO
    respVar <- newEmptyTMVarIO
    let getRequest  = StrictTMVar m (NumberOfPeers, LedgerPeersKind)
-> STM m (NumberOfPeers, LedgerPeersKind)
forall (m :: * -> *) a. MonadSTM m => StrictTMVar m a -> STM m a
takeTMVar StrictTMVar m (NumberOfPeers, LedgerPeersKind)
reqVar
        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 -> LedgerPeersKind -> m (Maybe (Set peerAddr, DiffTime))
        request = \NumberOfPeers
numberOfPeers LedgerPeersKind
ledgerPeersKind -> do
          STM m () -> m ()
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTMVar m (NumberOfPeers, LedgerPeersKind)
-> (NumberOfPeers, LedgerPeersKind) -> STM m ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTMVar m a -> a -> STM m ()
putTMVar StrictTMVar m (NumberOfPeers, LedgerPeersKind)
reqVar (NumberOfPeers
numberOfPeers, LedgerPeersKind
ledgerPeersKind)
          STM m (Maybe (Set peerAddr, DiffTime))
-> m (Maybe (Set peerAddr, DiffTime))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
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
    withAsync
      (ledgerPeersThread peerActionsDNS ledgerPeerArgs getRequest putResponse)
      $ \ Async m Void
thread -> (NumberOfPeers
 -> LedgerPeersKind -> m (Maybe (Set peerAddr, DiffTime)))
-> Async m Void -> m a
k NumberOfPeers
-> LedgerPeersKind -> m (Maybe (Set peerAddr, DiffTime))
request Async m Void
thread