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

module Ouroboros.Cardano.PeerSelection.PeerSelectionActions (requestPublicRootPeers) where


import Cardano.Network.PeerSelection.Bootstrap (UseBootstrapPeers (..),
           requiresBootstrapPeers)
import Cardano.Network.Types (LedgerStateJudgement)
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad.Class.MonadAsync (MonadAsync)
import Control.Monad.Class.MonadThrow (Exception, MonadThrow)
import Control.Monad.Class.MonadTime.SI
import Control.Tracer (Tracer)
import Data.Bifunctor (first)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Set (Set)
import Network.DNS qualified as DNS
import Ouroboros.Cardano.Network.PublicRootPeers qualified as Cardano
import Ouroboros.Cardano.Network.Types (CardanoPublicRootPeers)
import Ouroboros.Network.PeerSelection.LedgerPeers hiding (getLedgerPeers)
import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise (..))
import Ouroboros.Network.PeerSelection.PeerSelectionActions qualified as Ouroboros
import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers
import Ouroboros.Network.PeerSelection.RootPeersDNS (PeerActionsDNS (..))
import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore (DNSSemaphore)
import Ouroboros.Network.PeerSelection.RootPeersDNS.PublicRootPeers

-- 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
  :: forall m peeraddr resolver exception .
    ( MonadThrow m
    , MonadAsync m
    , Exception exception
    , Ord peeraddr
    )
  => Tracer m TracePublicRootPeers
  -> STM m UseBootstrapPeers
  -> STM m LedgerStateJudgement
  -> STM m (Map RelayAccessPoint PeerAdvertise)
  -> PeerActionsDNS peeraddr resolver exception m
  -> DNSSemaphore m
  -> (Map peeraddr PeerAdvertise -> Cardano.ExtraPeers peeraddr)
  -- ^ Function to convert DNS result into extra peers
  -> (NumberOfPeers -> LedgerPeersKind -> m (Maybe (Set peeraddr, DiffTime)))
  -> LedgerPeersKind
  -> Int
  -> m (CardanoPublicRootPeers peeraddr, DiffTime)
requestPublicRootPeers :: forall (m :: * -> *) peeraddr resolver exception.
(MonadThrow m, MonadAsync m, Exception exception, Ord peeraddr) =>
Tracer m TracePublicRootPeers
-> STM m UseBootstrapPeers
-> STM m LedgerStateJudgement
-> STM m (Map RelayAccessPoint PeerAdvertise)
-> PeerActionsDNS peeraddr resolver exception m
-> DNSSemaphore m
-> (Map peeraddr PeerAdvertise -> ExtraPeers peeraddr)
-> (NumberOfPeers
    -> LedgerPeersKind -> m (Maybe (Set peeraddr, DiffTime)))
-> LedgerPeersKind
-> Int
-> m (CardanoPublicRootPeers peeraddr, DiffTime)
requestPublicRootPeers
  Tracer m TracePublicRootPeers
publicTracer STM m UseBootstrapPeers
useBootstrapped
  STM m LedgerStateJudgement
getLedgerStateJudgement STM m (Map RelayAccessPoint PeerAdvertise)
readPublicRootPeers
  pad :: PeerActionsDNS peeraddr resolver exception m
pad@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
                     }
  DNSSemaphore m
dnsSemaphore
  Map peeraddr PeerAdvertise -> ExtraPeers peeraddr
toExtraPeers
  NumberOfPeers
-> LedgerPeersKind -> m (Maybe (Set peeraddr, DiffTime))
getLedgerPeers LedgerPeersKind
ledgerPeersKind Int
n = 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
<*> STM m LedgerStateJudgement
getLedgerStateJudgement
  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
      Ouroboros.requestPublicRootPeers
        publicTracer
        readPublicRootPeers
        pad
        dnsSemaphore
        toExtraPeers
        getLedgerPeers
        ledgerPeersKind n
  where
    requestConfiguredBootstrapPeers :: Int -> m (Set peeraddr, DiffTime)
    requestConfiguredBootstrapPeers :: Int -> m (Set peeraddr, DiffTime)
requestConfiguredBootstrapPeers Int
x = 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
x))