{-# LANGUAGE CPP                 #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

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


import           Control.Monad.Class.MonadAsync
import           Control.Monad.Class.MonadSTM.Strict
import           Control.Monad.Class.MonadThrow
import           Control.Monad.Class.MonadTime
import           Control.Monad.Class.MonadTimer
import           Control.Tracer (Tracer)
import           Data.Foldable (toList)

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

import qualified Network.DNS as DNS
import qualified Network.Socket as Socket

import           Ouroboros.Network.PeerSelection.Governor.Types
import           Ouroboros.Network.PeerSelection.LedgerPeers
import           Ouroboros.Network.PeerSelection.RootPeersDNS
import           Ouroboros.Network.PeerSelection.Types (PeerAdvertise (..))


withPeerSelectionActions
  :: forall peeraddr peerconn resolver exception m a.
     ( MonadAsync m
     , MonadDelay m
     , MonadThrow m
     , Ord peeraddr
     , Exception exception
     , Eq (Async m Void)
     )
  => Tracer m (TraceLocalRootPeers peeraddr exception)
  -> Tracer m TracePublicRootPeers
  -> (IP -> Socket.PortNumber -> peeraddr)
  -> DNSActions resolver exception m
  -> STM m PeerSelectionTargets
  -> STM m [(Int, Map RelayAccessPoint PeerAdvertise)]
  -- ^ local root peers
  -> STM m [RelayAccessPoint]
  -- ^ public root peers
  -> PeerStateActions peeraddr peerconn m
  -> (NumberOfPeers -> m (Maybe (Set peeraddr, DiffTime)))
  -> (Maybe (Async m Void)
      -> PeerSelectionActions peeraddr peerconn m
      -> m a)
  -- ^ continuation, recieves a handle to the local roots peer provider thread
  -- (only if local root peers where non-empty).
  -> m a
withPeerSelectionActions :: Tracer m (TraceLocalRootPeers peeraddr exception)
-> Tracer m TracePublicRootPeers
-> (IP -> PortNumber -> peeraddr)
-> DNSActions resolver exception m
-> STM m PeerSelectionTargets
-> STM m [(Int, Map RelayAccessPoint PeerAdvertise)]
-> STM m [RelayAccessPoint]
-> PeerStateActions peeraddr peerconn m
-> (NumberOfPeers -> m (Maybe (Set peeraddr, DiffTime)))
-> (Maybe (Async m Void)
    -> PeerSelectionActions peeraddr peerconn m -> m a)
-> m a
withPeerSelectionActions
  Tracer m (TraceLocalRootPeers peeraddr exception)
localRootTracer
  Tracer m TracePublicRootPeers
publicRootTracer
  IP -> PortNumber -> peeraddr
toPeerAddr
  DNSActions resolver exception m
dnsActions
  STM m PeerSelectionTargets
readTargets
  STM m [(Int, Map RelayAccessPoint PeerAdvertise)]
readLocalRootPeers
  STM m [RelayAccessPoint]
readPublicRootPeers
  PeerStateActions peeraddr peerconn m
peerStateActions
  NumberOfPeers -> m (Maybe (Set peeraddr, DiffTime))
getLedgerPeers
  Maybe (Async m Void)
-> PeerSelectionActions peeraddr peerconn m -> m a
k = do
    StrictTVar m (Seq (Int, Map peeraddr PeerAdvertise))
localRootsVar <- Seq (Int, Map peeraddr PeerAdvertise)
-> m (StrictTVar m (Seq (Int, Map peeraddr PeerAdvertise)))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO Seq (Int, Map peeraddr PeerAdvertise)
forall a. Monoid a => a
mempty
    let peerSelectionActions :: PeerSelectionActions peeraddr peerconn m
peerSelectionActions = PeerSelectionActions :: forall peeraddr peerconn (m :: * -> *).
STM m PeerSelectionTargets
-> STM m [(Int, Map peeraddr PeerAdvertise)]
-> (Int -> m (Set peeraddr, DiffTime))
-> (peeraddr -> m [peeraddr])
-> PeerStateActions peeraddr peerconn m
-> PeerSelectionActions peeraddr peerconn m
PeerSelectionActions {
            readPeerSelectionTargets :: STM m PeerSelectionTargets
readPeerSelectionTargets = STM m PeerSelectionTargets
readTargets,
            readLocalRootPeers :: STM m [(Int, Map peeraddr PeerAdvertise)]
readLocalRootPeers = Seq (Int, Map peeraddr PeerAdvertise)
-> [(Int, Map peeraddr PeerAdvertise)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Seq (Int, Map peeraddr PeerAdvertise)
 -> [(Int, Map peeraddr PeerAdvertise)])
-> STM m (Seq (Int, Map peeraddr PeerAdvertise))
-> STM m [(Int, Map peeraddr PeerAdvertise)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictTVar m (Seq (Int, Map peeraddr PeerAdvertise))
-> STM m (Seq (Int, Map peeraddr PeerAdvertise))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Seq (Int, Map peeraddr PeerAdvertise))
localRootsVar,
            requestPublicRootPeers :: Int -> m (Set peeraddr, DiffTime)
requestPublicRootPeers = Int -> m (Set peeraddr, DiffTime)
requestPublicRootPeers,
            requestPeerGossip :: peeraddr -> m [peeraddr]
requestPeerGossip = \peeraddr
_ -> [peeraddr] -> m [peeraddr]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [],
            PeerStateActions peeraddr peerconn m
peerStateActions :: PeerStateActions peeraddr peerconn m
peerStateActions :: PeerStateActions peeraddr peerconn m
peerStateActions
          }
    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
      (Tracer m (TraceLocalRootPeers peeraddr exception)
-> (IP -> PortNumber -> peeraddr)
-> ResolvConf
-> DNSActions resolver exception m
-> STM m [(Int, Map RelayAccessPoint PeerAdvertise)]
-> StrictTVar m (Seq (Int, Map peeraddr PeerAdvertise))
-> m Void
forall (m :: * -> *) peerAddr resolver exception.
(MonadAsync m, MonadDelay m, Eq (Async m Void), Ord peerAddr) =>
Tracer m (TraceLocalRootPeers peerAddr exception)
-> (IP -> PortNumber -> peerAddr)
-> ResolvConf
-> DNSActions resolver exception m
-> STM m [(Int, Map RelayAccessPoint PeerAdvertise)]
-> StrictTVar m (Seq (Int, Map peerAddr PeerAdvertise))
-> m Void
localRootPeersProvider
        Tracer m (TraceLocalRootPeers peeraddr exception)
localRootTracer
        IP -> PortNumber -> peeraddr
toPeerAddr
        ResolvConf
DNS.defaultResolvConf
        DNSActions resolver exception m
dnsActions
        STM m [(Int, Map RelayAccessPoint PeerAdvertise)]
readLocalRootPeers
        StrictTVar m (Seq (Int, Map peeraddr PeerAdvertise))
localRootsVar)
      (\Async m Void
thread -> Maybe (Async m Void)
-> PeerSelectionActions peeraddr peerconn m -> m a
k (Async m Void -> Maybe (Async m Void)
forall a. a -> Maybe a
Just Async m Void
thread) PeerSelectionActions peeraddr peerconn m
peerSelectionActions)
  where
    -- We first try to get poublic root peers from the ledger, but if it fails
    -- (for example because the node hasn't synced far enough) we fall back
    -- to using the manually configured bootstrap root peers.
    requestPublicRootPeers :: Int -> m (Set peeraddr, DiffTime)
    requestPublicRootPeers :: Int -> m (Set peeraddr, DiffTime)
requestPublicRootPeers Int
n = do
      Maybe (Set peeraddr, DiffTime)
peers_m <- NumberOfPeers -> m (Maybe (Set peeraddr, DiffTime))
getLedgerPeers (Word16 -> NumberOfPeers
NumberOfPeers (Word16 -> NumberOfPeers) -> Word16 -> NumberOfPeers
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
      case Maybe (Set peeraddr, DiffTime)
peers_m of
           Maybe (Set peeraddr, DiffTime)
Nothing    -> Int -> m (Set peeraddr, DiffTime)
requestConfiguredRootPeers Int
n
           Just (Set peeraddr, DiffTime)
peers -> (Set peeraddr, DiffTime) -> m (Set peeraddr, DiffTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set peeraddr, DiffTime)
peers

    -- For each call we re-initialise the dns library which forces reading
    -- `/etc/resolv.conf`:
    -- https://github.com/input-output-hk/cardano-node/issues/731
    requestConfiguredRootPeers :: Int -> m (Set peeraddr, DiffTime)
    requestConfiguredRootPeers :: Int -> m (Set peeraddr, DiffTime)
requestConfiguredRootPeers Int
n =
      Tracer m TracePublicRootPeers
-> (IP -> PortNumber -> peeraddr)
-> ResolvConf
-> STM m [RelayAccessPoint]
-> DNSActions resolver exception m
-> ((Int -> m (Set peeraddr, 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)
-> ResolvConf
-> STM m [RelayAccessPoint]
-> DNSActions resolver exception m
-> ((Int -> m (Set peerAddr, DiffTime)) -> m a)
-> m a
publicRootPeersProvider Tracer m TracePublicRootPeers
publicRootTracer
                              IP -> PortNumber -> peeraddr
toPeerAddr
                              ResolvConf
DNS.defaultResolvConf
                              STM m [RelayAccessPoint]
readPublicRootPeers
                              DNSActions resolver exception m
dnsActions
                              ((Int -> m (Set peeraddr, DiffTime))
-> Int -> m (Set peeraddr, DiffTime)
forall a b. (a -> b) -> a -> b
$ Int
n)