{-# LANGUAGE CPP                      #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts         #-}
{-# LANGUAGE LambdaCase               #-}
{-# LANGUAGE NamedFieldPuns           #-}
{-# LANGUAGE RankNTypes               #-}
{-# LANGUAGE ScopedTypeVariables      #-}
{-# LANGUAGE TupleSections            #-}

module Ouroboros.Network.PeerSelection.PeerSelectionActions
  ( withPeerSelectionActions
    -- * Re-exports
  , PeerSelectionTargets (..)
  , PeerAdvertise (..)
  , PeerSelectionActionsArgs (..)
  , PeerSelectionActionsDiffusionMode (..)
  ) where


import Control.Applicative (Alternative)
import Control.Concurrent.Class.MonadMVar (MonadMVar (..))
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
import Control.Tracer (Tracer)

import Data.Map (Map)
import Data.Map qualified as Map
import Data.Set (Set)
import Data.Void (Void)

import Network.DNS qualified as DNS

import Data.Bifunctor (first)
import Ouroboros.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..),
           requiresBootstrapPeers)
import Ouroboros.Network.PeerSelection.Governor.Types
import Ouroboros.Network.PeerSelection.LedgerPeers hiding (getLedgerPeers)
import Ouroboros.Network.PeerSelection.LocalRootPeers (OutboundConnectionsState)
import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..))
import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing)
import Ouroboros.Network.PeerSelection.PublicRootPeers (PublicRootPeers)
import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers
import Ouroboros.Network.PeerSelection.RootPeersDNS
import Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers
import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers
import Ouroboros.Network.PeerSelection.State.LocalRootPeers
import Ouroboros.Network.PeerSharing (PeerSharingController, requestPeers)
import Ouroboros.Network.Protocol.PeerSharing.Type (PeerSharingAmount (..))

-- | Record of parameters for withPeerSelectionActions independent of diffusion mode
--
data PeerSelectionActionsArgs peeraddr peerconn exception m = PeerSelectionActionsArgs {
  forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> Tracer m (TraceLocalRootPeers peeraddr exception)
psLocalRootPeersTracer      :: Tracer m (TraceLocalRootPeers peeraddr exception),
  forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> Tracer m TracePublicRootPeers
psPublicRootPeersTracer     :: Tracer m TracePublicRootPeers,
  forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> STM m PeerSelectionTargets
psReadTargets               :: STM m PeerSelectionTargets,
  forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> ConsensusModePeerTargets
peerTargets                 :: ConsensusModePeerTargets,
  -- ^ peer selection governor know, established and active targets
  forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> LedgerPeersConsensusInterface m
getLedgerStateCtx          :: LedgerPeersConsensusInterface m,
  -- ^ Is consensus close to current slot?
  forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> STM
     m [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
psReadLocalRootPeers        :: STM m [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)],
  forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> STM m (Map RelayAccessPoint PeerAdvertise)
psReadPublicRootPeers       :: STM m (Map RelayAccessPoint PeerAdvertise),
  forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> STM m UseBootstrapPeers
psReadUseBootstrapPeers     :: STM m UseBootstrapPeers,
  forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> PeerSharing
psPeerSharing               :: PeerSharing,
  -- ^ peer sharing configured value
  forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> peerconn -> PeerSharing
psPeerConnToPeerSharing     :: peerconn -> PeerSharing,
  -- ^ Extract peer sharing information from peerconn
  forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> STM m (Map peeraddr (PeerSharingController peeraddr m))
psReadPeerSharingController :: STM m (Map peeraddr (PeerSharingController peeraddr m)),
  -- ^ peer sharing registry
  forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> OutboundConnectionsState -> STM m ()
psUpdateOutboundConnectionsState
                              :: OutboundConnectionsState -> STM m (),
  -- ^ Callback which updates information about outbound connections state.
  forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> m (Map peeraddr PeerSharing)
psReadInboundPeers          :: m (Map peeraddr PeerSharing),
  -- ^ inbound duplex peers
  forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> STM m (Maybe LedgerPeerSnapshot)
readLedgerPeerSnapshot      :: STM m (Maybe LedgerPeerSnapshot)
  }

-- | Record of remaining parameters for withPeerSelectionActions
-- that were extracted out since the following vary based on the diffusion mode
--
newtype PeerSelectionActionsDiffusionMode peeraddr peerhandle m = PeerSelectionActionsDiffusionMode {
  forall peeraddr peerhandle (m :: * -> *).
PeerSelectionActionsDiffusionMode peeraddr peerhandle m
-> PeerStateActions peeraddr peerhandle m
psPeerStateActions :: PeerStateActions peeraddr peerhandle m
  -- ^ callbacks for peer state changes
  }

withPeerSelectionActions
  :: forall peeraddr peerconn resolver exception m a.
     ( Alternative (STM m)
     , MonadAsync m
     , MonadDelay m
     , MonadThrow m
     , MonadMVar  m
     , Ord peeraddr
     , Exception exception
     )
  => StrictTVar m (Config peeraddr)
  -> PeerActionsDNS peeraddr resolver exception m
  -> PeerSelectionActionsArgs peeraddr peerconn exception m
  -> WithLedgerPeersArgs m
  -> PeerSelectionActionsDiffusionMode peeraddr peerconn m
  -> (   (Async m Void, Async m Void)
      -> PeerSelectionActions peeraddr peerconn m
      -> m a)
  -- ^ continuation, receives a handle to the local roots peer provider thread
  -- (only if local root peers were non-empty).
  -> m a
withPeerSelectionActions :: forall peeraddr peerconn resolver exception (m :: * -> *) a.
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 MonadMVar m, Ord peeraddr, Exception exception) =>
StrictTVar m (Config peeraddr)
-> PeerActionsDNS peeraddr resolver exception m
-> PeerSelectionActionsArgs peeraddr peerconn exception m
-> WithLedgerPeersArgs m
-> PeerSelectionActionsDiffusionMode peeraddr peerconn m
-> ((Async m Void, Async m Void)
    -> PeerSelectionActions peeraddr peerconn m -> m a)
-> m a
withPeerSelectionActions
  StrictTVar m (Config peeraddr)
localRootsVar
  paDNS :: PeerActionsDNS peeraddr resolver exception m
paDNS@PeerActionsDNS { paToPeerAddr :: forall peeraddr resolver exception (m :: * -> *).
PeerActionsDNS peeraddr resolver exception m
-> IP -> PortNumber -> peeraddr
paToPeerAddr = IP -> PortNumber -> peeraddr
toPeerAddr, paDnsActions :: forall peeraddr resolver exception (m :: * -> *).
PeerActionsDNS peeraddr resolver exception m
-> DNSActions resolver exception m
paDnsActions = DNSActions resolver exception m
dnsActions, paDnsSemaphore :: forall peeraddr resolver exception (m :: * -> *).
PeerActionsDNS peeraddr resolver exception m -> DNSSemaphore m
paDnsSemaphore = DNSSemaphore m
dnsSemaphore }
  PeerSelectionActionsArgs {
    psLocalRootPeersTracer :: forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> Tracer m (TraceLocalRootPeers peeraddr exception)
psLocalRootPeersTracer = Tracer m (TraceLocalRootPeers peeraddr exception)
localTracer,
    psPublicRootPeersTracer :: forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> Tracer m TracePublicRootPeers
psPublicRootPeersTracer = Tracer m TracePublicRootPeers
publicTracer,
    ConsensusModePeerTargets
peerTargets :: forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> ConsensusModePeerTargets
peerTargets :: ConsensusModePeerTargets
peerTargets,
    psReadTargets :: forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> STM m PeerSelectionTargets
psReadTargets = STM m PeerSelectionTargets
selectionTargets,
    LedgerPeersConsensusInterface m
getLedgerStateCtx :: forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> LedgerPeersConsensusInterface m
getLedgerStateCtx :: LedgerPeersConsensusInterface m
getLedgerStateCtx,
    psReadLocalRootPeers :: forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> STM
     m [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
psReadLocalRootPeers = STM
  m [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
localRootPeers,
    psReadPublicRootPeers :: forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> STM m (Map RelayAccessPoint PeerAdvertise)
psReadPublicRootPeers = STM m (Map RelayAccessPoint PeerAdvertise)
publicRootPeers,
    psReadUseBootstrapPeers :: forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> STM m UseBootstrapPeers
psReadUseBootstrapPeers = STM m UseBootstrapPeers
useBootstrapped,
    psPeerSharing :: forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> PeerSharing
psPeerSharing = PeerSharing
sharing,
    psPeerConnToPeerSharing :: forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> peerconn -> PeerSharing
psPeerConnToPeerSharing = peerconn -> PeerSharing
peerConnToPeerSharing,
    psReadPeerSharingController :: forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> STM m (Map peeraddr (PeerSharingController peeraddr m))
psReadPeerSharingController = STM m (Map peeraddr (PeerSharingController peeraddr m))
sharingController,
    psReadInboundPeers :: forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> m (Map peeraddr PeerSharing)
psReadInboundPeers = m (Map peeraddr PeerSharing)
readInboundPeers,
    psUpdateOutboundConnectionsState :: forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> OutboundConnectionsState -> STM m ()
psUpdateOutboundConnectionsState = OutboundConnectionsState -> STM m ()
updateOutboundConnectionsState,
    STM m (Maybe LedgerPeerSnapshot)
readLedgerPeerSnapshot :: forall peeraddr peerconn exception (m :: * -> *).
PeerSelectionActionsArgs peeraddr peerconn exception m
-> STM m (Maybe LedgerPeerSnapshot)
readLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot)
readLedgerPeerSnapshot }
  WithLedgerPeersArgs m
ledgerPeersArgs
  PeerSelectionActionsDiffusionMode { psPeerStateActions :: forall peeraddr peerhandle (m :: * -> *).
PeerSelectionActionsDiffusionMode peeraddr peerhandle m
-> PeerStateActions peeraddr peerhandle m
psPeerStateActions = PeerStateActions peeraddr peerconn m
peerStateActions }
  (Async m Void, Async m Void)
-> PeerSelectionActions peeraddr peerconn m -> m a
k = do
    PeerActionsDNS peeraddr resolver exception m
-> WithLedgerPeersArgs m
-> ((NumberOfPeers
     -> LedgerPeersKind -> m (Maybe (Set peeraddr, DiffTime)))
    -> Async m Void -> m a)
-> m a
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
paDNS
      WithLedgerPeersArgs m
ledgerPeersArgs
      (\NumberOfPeers
-> LedgerPeersKind -> m (Maybe (Set peeraddr, DiffTime))
getLedgerPeers Async m Void
lpThread -> do
          let peerSelectionActions :: PeerSelectionActions peeraddr peerconn m
peerSelectionActions = PeerSelectionActions {
                                       readPeerSelectionTargets :: STM m PeerSelectionTargets
readPeerSelectionTargets = STM m PeerSelectionTargets
selectionTargets,
                                       readLocalRootPeers :: STM m (Config peeraddr)
readLocalRootPeers = StrictTVar m (Config peeraddr) -> STM m (Config peeraddr)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Config peeraddr)
localRootsVar,
                                       peerSharing :: PeerSharing
peerSharing = PeerSharing
sharing,
                                       peerConnToPeerSharing :: peerconn -> PeerSharing
peerConnToPeerSharing = peerconn -> PeerSharing
peerConnToPeerSharing,
                                       requestPublicRootPeers :: LedgerPeersKind -> Int -> m (PublicRootPeers peeraddr, DiffTime)
requestPublicRootPeers = \LedgerPeersKind
lpk Int
n -> LedgerPeersKind
-> Int
-> (NumberOfPeers
    -> LedgerPeersKind -> m (Maybe (Set peeraddr, DiffTime)))
-> m (PublicRootPeers peeraddr, DiffTime)
requestPublicRootPeers LedgerPeersKind
lpk Int
n NumberOfPeers
-> LedgerPeersKind -> m (Maybe (Set peeraddr, DiffTime))
getLedgerPeers,
                                       PeerSharingAmount -> peeraddr -> m (PeerSharingResult peeraddr)
requestPeerShare :: PeerSharingAmount -> peeraddr -> m (PeerSharingResult peeraddr)
requestPeerShare :: PeerSharingAmount -> peeraddr -> m (PeerSharingResult peeraddr)
requestPeerShare,
                                       PeerStateActions peeraddr peerconn m
peerStateActions :: PeerStateActions peeraddr peerconn m
peerStateActions :: PeerStateActions peeraddr peerconn m
peerStateActions,
                                       ConsensusModePeerTargets
peerTargets :: ConsensusModePeerTargets
peerTargets :: ConsensusModePeerTargets
peerTargets,
                                       readUseBootstrapPeers :: STM m UseBootstrapPeers
readUseBootstrapPeers = STM m UseBootstrapPeers
useBootstrapped,
                                       m (Map peeraddr PeerSharing)
readInboundPeers :: m (Map peeraddr PeerSharing)
readInboundPeers :: m (Map peeraddr PeerSharing)
readInboundPeers,
                                       LedgerPeersConsensusInterface m
getLedgerStateCtx :: LedgerPeersConsensusInterface m
getLedgerStateCtx :: LedgerPeersConsensusInterface m
getLedgerStateCtx,
                                       OutboundConnectionsState -> STM m ()
updateOutboundConnectionsState :: OutboundConnectionsState -> STM m ()
updateOutboundConnectionsState :: OutboundConnectionsState -> STM m ()
updateOutboundConnectionsState,
                                       STM m (Maybe LedgerPeerSnapshot)
readLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot)
readLedgerPeerSnapshot :: STM m (Maybe LedgerPeerSnapshot)
readLedgerPeerSnapshot }
          m Void -> (Async m Void -> m a) -> m a
forall a b. m a -> (Async m a -> m b) -> m b
forall (m :: * -> *) a b.
MonadAsync m =>
m a -> (Async m a -> m b) -> m b
withAsync
            (Tracer m (TraceLocalRootPeers peeraddr exception)
-> (IP -> PortNumber -> peeraddr)
-> ResolvConf
-> DNSActions resolver exception m
-> STM
     m [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
-> StrictTVar m (Config peeraddr)
-> m Void
forall (m :: * -> *) peerAddr resolver exception.
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 Ord peerAddr) =>
Tracer m (TraceLocalRootPeers peerAddr exception)
-> (IP -> PortNumber -> peerAddr)
-> ResolvConf
-> DNSActions resolver exception m
-> STM
     m [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
-> StrictTVar
     m [(HotValency, WarmValency, Map peerAddr LocalRootConfig)]
-> m Void
localRootPeersProvider
              Tracer m (TraceLocalRootPeers peeraddr exception)
localTracer
              IP -> PortNumber -> peeraddr
toPeerAddr
              -- NOTE: we don't set `resolvConcurrent` because
              -- of https://github.com/kazu-yamamoto/dns/issues/174
              ResolvConf
DNS.defaultResolvConf
              DNSActions resolver exception m
dnsActions
              STM
  m [(HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)]
localRootPeers
              StrictTVar m (Config peeraddr)
localRootsVar)
            (\Async m Void
lrppThread -> (Async m Void, Async m Void)
-> PeerSelectionActions peeraddr peerconn m -> m a
k (Async m Void
lpThread, Async m Void
lrppThread) PeerSelectionActions peeraddr peerconn m
peerSelectionActions))
  where
    -- We start by reading the current ledger state judgement, if it is
    -- YoungEnough we only care about fetching for ledger peers, otherwise we
    -- aim to fetch bootstrap peers.
    requestPublicRootPeers
      :: LedgerPeersKind
      -> Int
      -> (NumberOfPeers -> LedgerPeersKind -> m (Maybe (Set peeraddr, DiffTime)))
      -> m (PublicRootPeers peeraddr, DiffTime)
    requestPublicRootPeers :: LedgerPeersKind
-> Int
-> (NumberOfPeers
    -> LedgerPeersKind -> m (Maybe (Set peeraddr, DiffTime)))
-> m (PublicRootPeers peeraddr, DiffTime)
requestPublicRootPeers LedgerPeersKind
ledgerPeersKind Int
n NumberOfPeers
-> LedgerPeersKind -> m (Maybe (Set peeraddr, DiffTime))
getLedgerPeers = do
      -- Check if the node is in a sensitive state
      usingBootstrapPeers <- STM m Bool -> m Bool
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically
                           (STM m Bool -> m Bool) -> STM m Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ UseBootstrapPeers -> LedgerStateJudgement -> Bool
requiresBootstrapPeers (UseBootstrapPeers -> LedgerStateJudgement -> Bool)
-> STM m UseBootstrapPeers -> STM m (LedgerStateJudgement -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> STM m UseBootstrapPeers
useBootstrapped
                                                    STM m (LedgerStateJudgement -> Bool)
-> STM m LedgerStateJudgement -> STM m Bool
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 -> STM m LedgerStateJudgement
forall (m :: * -> *).
LedgerPeersConsensusInterface m -> STM m LedgerStateJudgement
lpGetLedgerStateJudgement LedgerPeersConsensusInterface m
getLedgerStateCtx
      if usingBootstrapPeers
         then do
          -- If the ledger state is in sensitive state we should get trustable peers.
          (bootstrapPeers, dt) <- requestConfiguredBootstrapPeers n
          pure (PublicRootPeers.fromBootstrapPeers bootstrapPeers, dt)
         else do
          -- If the ledger state is not in a sensitive state we should get ledger
          -- peers, the Nothing case should not happen but there can be a race
          -- condition. If that's the case we try again soon enough.
          mbLedgerPeers <- getLedgerPeers (NumberOfPeers $ fromIntegral n) ledgerPeersKind
          case mbLedgerPeers of
            -- no peers from the ledger
            Maybe (Set peeraddr, DiffTime)
Nothing -> do
              (publicRootPeers', dt) <- Int -> m (Map peeraddr PeerAdvertise, DiffTime)
requestConfiguredPublicRootPeers Int
n
              pure (PublicRootPeers.fromPublicRootPeers publicRootPeers', dt)
            Just (Set peeraddr
ledgerPeers, DiffTime
dt) ->
              case LedgerPeersKind
ledgerPeersKind of
                LedgerPeersKind
AllLedgerPeers ->
                  (PublicRootPeers peeraddr, DiffTime)
-> m (PublicRootPeers peeraddr, DiffTime)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set peeraddr -> PublicRootPeers peeraddr
forall peeraddr. Set peeraddr -> PublicRootPeers peeraddr
PublicRootPeers.fromLedgerPeers Set peeraddr
ledgerPeers, DiffTime
dt)
                LedgerPeersKind
BigLedgerPeers ->
                  (PublicRootPeers peeraddr, DiffTime)
-> m (PublicRootPeers peeraddr, DiffTime)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Set peeraddr -> PublicRootPeers peeraddr
forall peeraddr. Set peeraddr -> PublicRootPeers peeraddr
PublicRootPeers.fromBigLedgerPeers Set peeraddr
ledgerPeers, DiffTime
dt)

    -- For each call we re-initialise the dns library which forces reading
    -- `/etc/resolv.conf`:
    -- https://github.com/intersectmbo/cardano-node/issues/731
    requestConfiguredPublicRootPeers :: Int -> m (Map peeraddr PeerAdvertise, DiffTime)
    requestConfiguredPublicRootPeers :: Int -> m (Map peeraddr PeerAdvertise, DiffTime)
requestConfiguredPublicRootPeers Int
n =
      -- NOTE: we don't set `resolvConcurrent` because of
      -- https://github.com/kazu-yamamoto/dns/issues/174
      Tracer m TracePublicRootPeers
-> (IP -> PortNumber -> peeraddr)
-> DNSSemaphore m
-> ResolvConf
-> STM m (Map RelayAccessPoint PeerAdvertise)
-> DNSActions resolver exception m
-> ((Int -> m (Map peeraddr PeerAdvertise, DiffTime))
    -> m (Map peeraddr PeerAdvertise, DiffTime))
-> m (Map peeraddr PeerAdvertise, DiffTime)
forall peerAddr resolver exception a (m :: * -> *).
(MonadThrow m, MonadAsync m, Exception exception, Ord peerAddr) =>
Tracer m TracePublicRootPeers
-> (IP -> PortNumber -> peerAddr)
-> DNSSemaphore m
-> ResolvConf
-> STM m (Map RelayAccessPoint PeerAdvertise)
-> DNSActions resolver exception m
-> ((Int -> m (Map peerAddr PeerAdvertise, DiffTime)) -> m a)
-> m a
publicRootPeersProvider Tracer m TracePublicRootPeers
publicTracer
                              IP -> PortNumber -> peeraddr
toPeerAddr
                              DNSSemaphore m
dnsSemaphore
                              -- NOTE: we don't set `resolveConcurrent` because
                              -- of https://github.com/kazu-yamamoto/dns/issues/174
                              ResolvConf
DNS.defaultResolvConf
                              STM m (Map RelayAccessPoint PeerAdvertise)
publicRootPeers
                              DNSActions resolver exception m
dnsActions
                              ((Int -> m (Map peeraddr PeerAdvertise, DiffTime))
-> Int -> m (Map peeraddr PeerAdvertise, DiffTime)
forall a b. (a -> b) -> a -> b
$ Int
n)

    requestConfiguredBootstrapPeers :: Int -> m (Set peeraddr, DiffTime)
    requestConfiguredBootstrapPeers :: Int -> m (Set peeraddr, DiffTime)
requestConfiguredBootstrapPeers Int
n = do
      let readBootstrapPeersMap :: STM m (Map RelayAccessPoint PeerAdvertise)
readBootstrapPeersMap =
            (UseBootstrapPeers -> Map RelayAccessPoint PeerAdvertise)
-> STM m UseBootstrapPeers
-> STM m (Map RelayAccessPoint PeerAdvertise)
forall a b. (a -> b) -> STM m a -> STM m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\case
                    UseBootstrapPeers
DontUseBootstrapPeers     -> Map RelayAccessPoint PeerAdvertise
forall k a. Map k a
Map.empty
                    UseBootstrapPeers [RelayAccessPoint]
domains ->
                      [(RelayAccessPoint, PeerAdvertise)]
-> Map RelayAccessPoint PeerAdvertise
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((,PeerAdvertise
DoNotAdvertisePeer) (RelayAccessPoint -> (RelayAccessPoint, PeerAdvertise))
-> [RelayAccessPoint] -> [(RelayAccessPoint, PeerAdvertise)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RelayAccessPoint]
domains)
                 )
                 STM m UseBootstrapPeers
useBootstrapped

      Tracer m TracePublicRootPeers
-> (IP -> PortNumber -> peeraddr)
-> DNSSemaphore m
-> ResolvConf
-> STM m (Map RelayAccessPoint PeerAdvertise)
-> DNSActions resolver exception m
-> ((Int -> m (Map peeraddr PeerAdvertise, DiffTime))
    -> m (Set peeraddr, DiffTime))
-> m (Set peeraddr, DiffTime)
forall peerAddr resolver exception a (m :: * -> *).
(MonadThrow m, MonadAsync m, Exception exception, Ord peerAddr) =>
Tracer m TracePublicRootPeers
-> (IP -> PortNumber -> peerAddr)
-> DNSSemaphore m
-> ResolvConf
-> STM m (Map RelayAccessPoint PeerAdvertise)
-> DNSActions resolver exception m
-> ((Int -> m (Map peerAddr PeerAdvertise, DiffTime)) -> m a)
-> m a
publicRootPeersProvider Tracer m TracePublicRootPeers
publicTracer
                              IP -> PortNumber -> peeraddr
toPeerAddr
                              DNSSemaphore m
dnsSemaphore
                              ResolvConf
DNS.defaultResolvConf
                              STM m (Map RelayAccessPoint PeerAdvertise)
readBootstrapPeersMap
                              DNSActions resolver exception m
dnsActions
                              (((Map peeraddr PeerAdvertise, DiffTime)
 -> (Set peeraddr, DiffTime))
-> m (Map peeraddr PeerAdvertise, DiffTime)
-> m (Set peeraddr, DiffTime)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Map peeraddr PeerAdvertise -> Set peeraddr)
-> (Map peeraddr PeerAdvertise, DiffTime)
-> (Set peeraddr, DiffTime)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Map peeraddr PeerAdvertise -> Set peeraddr
forall k a. Map k a -> Set k
Map.keysSet) (m (Map peeraddr PeerAdvertise, DiffTime)
 -> m (Set peeraddr, DiffTime))
-> ((Int -> m (Map peeraddr PeerAdvertise, DiffTime))
    -> m (Map peeraddr PeerAdvertise, DiffTime))
-> (Int -> m (Map peeraddr PeerAdvertise, DiffTime))
-> m (Set peeraddr, DiffTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int -> m (Map peeraddr PeerAdvertise, DiffTime))
-> Int -> m (Map peeraddr PeerAdvertise, DiffTime)
forall a b. (a -> b) -> a -> b
$ Int
n))

    requestPeerShare :: PeerSharingAmount -> peeraddr -> m (PeerSharingResult peeraddr)
    requestPeerShare :: PeerSharingAmount -> peeraddr -> m (PeerSharingResult peeraddr)
requestPeerShare PeerSharingAmount
amount peeraddr
peer = do
      controllerMap <- STM m (Map peeraddr (PeerSharingController peeraddr m))
-> m (Map peeraddr (PeerSharingController peeraddr m))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m (Map peeraddr (PeerSharingController peeraddr m))
sharingController
      case Map.lookup peer controllerMap of
        -- Peer Registering happens asynchronously with respect to
        -- requestPeerShare. This means that there's a possible race where the
        -- Peer Selection Governor can decide to peer share request to a peer
        -- for the peer is registered. When this happens this map lookup is
        -- going to fail, so instead of erroring we report this to the governor
        -- so it can deal with this particular case accordingly.
        Maybe (PeerSharingController peeraddr m)
Nothing -> PeerSharingResult peeraddr -> m (PeerSharingResult peeraddr)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return PeerSharingResult peeraddr
forall peerAddress. PeerSharingResult peerAddress
PeerSharingNotRegisteredYet
        Just PeerSharingController peeraddr m
psController ->
          [peeraddr] -> PeerSharingResult peeraddr
forall peerAddress. [peerAddress] -> PeerSharingResult peerAddress
PeerSharingResult ([peeraddr] -> PeerSharingResult peeraddr)
-> m [peeraddr] -> m (PeerSharingResult peeraddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PeerSharingController peeraddr m
-> PeerSharingAmount -> m [peeraddr]
forall (m :: * -> *) peer.
(MonadMVar m, MonadSTM m) =>
PeerSharingController peer m -> PeerSharingAmount -> m [peer]
requestPeers PeerSharingController peeraddr m
psController PeerSharingAmount
amount