{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

module Ouroboros.Network.PeerSelection.RootPeersDNS.LocalRootPeers
  ( -- * DNS based provider for local root peers
    localRootPeersProvider
  , TraceLocalRootPeers (..)
  , ttlForResults
  , ttlForDnsError
  ) where

import Data.Bifunctor (second)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe)
import Data.Void (Void, absurd)
import System.Random

import Control.Applicative (Alternative, (<|>))
import Control.Concurrent.Class.MonadSTM.Strict
import Control.Monad (when)
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTimer.SI
import Control.Tracer (Tracer (..), contramap, traceWith)

import Network.DNS qualified as DNS

import Ouroboros.Network.PeerSelection.RelayAccessPoint
import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
import Ouroboros.Network.PeerSelection.RootPeersDNS.DNSSemaphore (DNSSemaphore,
           newDNSLocalRootSemaphore, withDNSSemaphore)
import Ouroboros.Network.PeerSelection.State.LocalRootPeers (HotValency,
           LocalRootConfig, WarmValency)
import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers

data TraceLocalRootPeers extraFlags peerAddr =
       TraceLocalRootDomains (LocalRootPeers.Config extraFlags RelayAccessPoint)
       -- ^ 'Int' is the configured valency for the local producer groups
     | TraceLocalRootWaiting RelayAccessPoint DiffTime
     | TraceLocalRootGroups  (LocalRootPeers.Config extraFlags peerAddr)
       -- ^ This traces the results of the local root peer provider
     | TraceLocalRootDNSMap  (Map RelayAccessPoint [peerAddr])
       -- ^ This traces the results of the domain name resolution
     | TraceLocalRootReconfigured (LocalRootPeers.Config extraFlags RelayAccessPoint) -- ^ Old value
                                  (LocalRootPeers.Config extraFlags RelayAccessPoint) -- ^ New value
     | TraceLocalRootFailure RelayAccessPoint DNSorIOError
       --TODO: classify DNS errors, config error vs transitory
     | TraceLocalRootError DNS.Domain SomeException
  deriving Int -> TraceLocalRootPeers extraFlags peerAddr -> ShowS
[TraceLocalRootPeers extraFlags peerAddr] -> ShowS
TraceLocalRootPeers extraFlags peerAddr -> String
(Int -> TraceLocalRootPeers extraFlags peerAddr -> ShowS)
-> (TraceLocalRootPeers extraFlags peerAddr -> String)
-> ([TraceLocalRootPeers extraFlags peerAddr] -> ShowS)
-> Show (TraceLocalRootPeers extraFlags peerAddr)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall extraFlags peerAddr.
(Show extraFlags, Show peerAddr) =>
Int -> TraceLocalRootPeers extraFlags peerAddr -> ShowS
forall extraFlags peerAddr.
(Show extraFlags, Show peerAddr) =>
[TraceLocalRootPeers extraFlags peerAddr] -> ShowS
forall extraFlags peerAddr.
(Show extraFlags, Show peerAddr) =>
TraceLocalRootPeers extraFlags peerAddr -> String
$cshowsPrec :: forall extraFlags peerAddr.
(Show extraFlags, Show peerAddr) =>
Int -> TraceLocalRootPeers extraFlags peerAddr -> ShowS
showsPrec :: Int -> TraceLocalRootPeers extraFlags peerAddr -> ShowS
$cshow :: forall extraFlags peerAddr.
(Show extraFlags, Show peerAddr) =>
TraceLocalRootPeers extraFlags peerAddr -> String
show :: TraceLocalRootPeers extraFlags peerAddr -> String
$cshowList :: forall extraFlags peerAddr.
(Show extraFlags, Show peerAddr) =>
[TraceLocalRootPeers extraFlags peerAddr] -> ShowS
showList :: [TraceLocalRootPeers extraFlags peerAddr] -> ShowS
Show

-- | Resolve 'RelayAddress'-es of local root peers using dns if needed.  Local
-- roots are provided wrapped in a 'StrictTVar', which value might change
-- (re-read form a config file).  The resolved dns names are available through
-- the output 'StrictTVar'.
--
localRootPeersProvider
  :: forall m extraFlags peerAddr resolver.
     ( Alternative (STM m)
     , MonadAsync m
     , MonadDelay m
     , MonadThrow m
     , Ord peerAddr
     , Eq extraFlags
     )
  => Tracer m (TraceLocalRootPeers extraFlags peerAddr)
  -> PeerActionsDNS peerAddr resolver m
  -> DNS.ResolvConf
  -> StdGen
  -> STM m [( HotValency
            , WarmValency
            , Map RelayAccessPoint (LocalRootConfig extraFlags))]
  -- ^ input
  -> StrictTVar m [( HotValency
                   , WarmValency
                   , Map peerAddr (LocalRootConfig extraFlags))]
  -- ^ output 'TVar'
  -> m Void
localRootPeersProvider :: forall (m :: * -> *) extraFlags peerAddr resolver.
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 Ord peerAddr, Eq extraFlags) =>
Tracer m (TraceLocalRootPeers extraFlags peerAddr)
-> PeerActionsDNS peerAddr resolver m
-> ResolvConf
-> StdGen
-> STM
     m
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> StrictTVar
     m
     [(HotValency, WarmValency,
       Map peerAddr (LocalRootConfig extraFlags))]
-> m Void
localRootPeersProvider Tracer m (TraceLocalRootPeers extraFlags peerAddr)
tracer
                       PeerActionsDNS {
                         paToPeerAddr :: forall peeraddr resolver (m :: * -> *).
PeerActionsDNS peeraddr resolver m -> IP -> PortNumber -> peeraddr
paToPeerAddr = IP -> PortNumber -> peerAddr
toPeerAddr,
                         paDnsActions :: forall peeraddr resolver (m :: * -> *).
PeerActionsDNS peeraddr resolver m
-> DNSActions peeraddr resolver m
paDnsActions = DNSActions {
                           ResolvConf -> m (Resource m (Either DNSorIOError resolver))
dnsAsyncResolverResource :: ResolvConf -> m (Resource m (Either DNSorIOError resolver))
dnsAsyncResolverResource :: forall peerAddr resolver (m :: * -> *).
DNSActions peerAddr resolver m
-> ResolvConf -> m (Resource m (Either DNSorIOError resolver))
dnsAsyncResolverResource,
                           DNSPeersKind
-> RelayAccessPoint
-> ResolvConf
-> resolver
-> StdGen
-> m (DNSLookupResult peerAddr)
dnsLookupWithTTL :: DNSPeersKind
-> RelayAccessPoint
-> ResolvConf
-> resolver
-> StdGen
-> m (DNSLookupResult peerAddr)
dnsLookupWithTTL :: forall peerAddr resolver (m :: * -> *).
DNSActions peerAddr resolver m
-> DNSPeersKind
-> RelayAccessPoint
-> ResolvConf
-> resolver
-> StdGen
-> m (DNSLookupResult peerAddr)
dnsLookupWithTTL
                         }
                       }
                       ResolvConf
resolvConf
                       StdGen
rng0
                       STM
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig extraFlags))]
readLocalRootPeers
                       StrictTVar
  m
  [(HotValency, WarmValency,
    Map peerAddr (LocalRootConfig extraFlags))]
rootPeersGroupVar = do
    (varRng, dnsSemaphore) <- STM m (StrictTVar m StdGen, DNSSemaphore m)
-> m (StrictTVar m StdGen, DNSSemaphore m)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically ((,) (StrictTVar m StdGen
 -> DNSSemaphore m -> (StrictTVar m StdGen, DNSSemaphore m))
-> STM m (StrictTVar m StdGen)
-> STM m (DNSSemaphore m -> (StrictTVar m StdGen, DNSSemaphore m))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StdGen -> STM m (StrictTVar m StdGen)
forall (m :: * -> *) a. MonadSTM m => a -> STM m (StrictTVar m a)
newTVar StdGen
rng0 STM m (DNSSemaphore m -> (StrictTVar m StdGen, DNSSemaphore m))
-> STM m (DNSSemaphore m)
-> STM m (StrictTVar m StdGen, DNSSemaphore m)
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 (DNSSemaphore m)
forall (m :: * -> *). MonadSTM m => STM m (DNSSemaphore m)
newDNSLocalRootSemaphore)
    loop varRng dnsSemaphore Nothing Map.empty
  where
    -- | Loop function that monitors DNS Domain resolution threads and restarts
    -- if either these threads fail or detects the local configuration changed.
    --
    loop :: StrictTVar m StdGen
         -> DNSSemaphore m
         -> Maybe [(HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig extraFlags))]
         -- ^ the configuration the previous iteration applied
         -> Map RelayAccessPoint [peerAddr]
         -- ^ the addresses it had resolved when its lookup threads were stopped
         -> m Void
    loop :: StrictTVar m StdGen
-> DNSSemaphore m
-> Maybe
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> Map RelayAccessPoint [peerAddr]
-> m Void
loop StrictTVar m StdGen
varRng DNSSemaphore m
dnsSemaphore Maybe
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig extraFlags))]
previous Map RelayAccessPoint [peerAddr]
resolved = do
      -- Read the configuration and apply it in one transaction, before
      -- anything that can fail: its IP addresses need no resolution, and a
      -- configuration without domain names would otherwise never be applied.
      -- A domain the previous iteration had resolved keeps its addresses
      -- until its new lookup thread gets an answer, so the governor does not
      -- see it removed; a failed lookup keeps the last addresses in any
      -- iteration. Every other domain starts unresolved.
      (domainsGroups, dnsDomainMap, written, rootPeersGroups) <- STM
  m
  ([(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))],
   Map RelayAccessPoint [peerAddr], Bool,
   [(HotValency, WarmValency,
     Map peerAddr (LocalRootConfig extraFlags))])
-> m ([(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig extraFlags))],
      Map RelayAccessPoint [peerAddr], Bool,
      [(HotValency, WarmValency,
        Map peerAddr (LocalRootConfig extraFlags))])
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   ([(HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig extraFlags))],
    Map RelayAccessPoint [peerAddr], Bool,
    [(HotValency, WarmValency,
      Map peerAddr (LocalRootConfig extraFlags))])
 -> m ([(HotValency, WarmValency,
         Map RelayAccessPoint (LocalRootConfig extraFlags))],
       Map RelayAccessPoint [peerAddr], Bool,
       [(HotValency, WarmValency,
         Map peerAddr (LocalRootConfig extraFlags))]))
-> STM
     m
     ([(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig extraFlags))],
      Map RelayAccessPoint [peerAddr], Bool,
      [(HotValency, WarmValency,
        Map peerAddr (LocalRootConfig extraFlags))])
-> m ([(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig extraFlags))],
      Map RelayAccessPoint [peerAddr], Bool,
      [(HotValency, WarmValency,
        Map peerAddr (LocalRootConfig extraFlags))])
forall a b. (a -> b) -> a -> b
$ do
        domainsGroups <- STM
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig extraFlags))]
readLocalRootPeers
        let dnsDomainMap = Map RelayAccessPoint [peerAddr]
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> Map RelayAccessPoint [peerAddr]
initialDNSDomainMap Map RelayAccessPoint [peerAddr]
resolved [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups
        (written, rootPeersGroups) <- publishGroups dnsDomainMap domainsGroups
        return (domainsGroups, dnsDomainMap, written, rootPeersGroups)
      -- A reconfiguration is traced once it is applied, so one that changed
      -- again while the previous iteration was stopping its monitors is traced
      -- as it stands now; a restart that finds the configuration unchanged is
      -- marked by the domains trace alone.
      case previous of
        Just [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups0
          | [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups0 [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> Bool
forall a. Eq a => a -> a -> Bool
/= [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups
          -> Tracer m (TraceLocalRootPeers extraFlags peerAddr)
-> TraceLocalRootPeers extraFlags peerAddr -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalRootPeers extraFlags peerAddr)
tracer ([(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> TraceLocalRootPeers extraFlags peerAddr
forall extraFlags peerAddr.
Config extraFlags RelayAccessPoint
-> Config extraFlags RelayAccessPoint
-> TraceLocalRootPeers extraFlags peerAddr
TraceLocalRootReconfigured [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups0 [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups)
        Maybe
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig extraFlags))]
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      traceWith tracer (TraceLocalRootDomains domainsGroups)
      when written $
        traceWith tracer (TraceLocalRootGroups rootPeersGroups)

      rr <- dnsAsyncResolverResource resolvConf

      -- Create TVar to store DNS lookup results
      dnsDomainMapVar <- newTVarIO dnsDomainMap

      traceWith tracer (TraceLocalRootDNSMap dnsDomainMap)

      -- Launch DomainAddress monitoring threads and wait for threads to error
      -- or for local configuration changes.
      --
      -- Each thread receives the DNS Domain Map TVar so it can update it with
      -- its current DNS lookup result. The way we build the resulting local
      -- root groups is:
      --
      -- After that each thread resolves its domain, it is going to read the
      -- static local root peers groups and for each domain it finds, it is
      -- going to lookup into the new DNS Domain Map and replace that entry
      -- with the lookup result.
      withAsyncAllWithCtx (monitorDomain rr dnsSemaphore dnsDomainMapVar varRng `map` Map.keys dnsDomainMap) $ \[(Domain, Async m Void)]
as -> do
          let tagErrWithDomain :: (t, b, Either a Void) -> Maybe (t, a)
tagErrWithDomain (t
domain, b
_, Either a Void
res) = (a -> Maybe (t, a))
-> (Void -> Maybe (t, a)) -> Either a Void -> Maybe (t, a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((t, a) -> Maybe (t, a)
forall a. a -> Maybe a
Just ((t, a) -> Maybe (t, a)) -> (a -> (t, a)) -> a -> Maybe (t, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t
domain,)) Void -> Maybe (t, a)
forall a. Void -> a
absurd Either a Void
res
          res <- STM m (Maybe (Domain, SomeException))
-> m (Maybe (Domain, SomeException))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Maybe (Domain, SomeException))
 -> m (Maybe (Domain, SomeException)))
-> STM m (Maybe (Domain, SomeException))
-> m (Maybe (Domain, SomeException))
forall a b. (a -> b) -> a -> b
$
                  -- wait until any of the monitoring threads errors
                  ((Domain, Async m Void, Either SomeException Void)
-> Maybe (Domain, SomeException)
forall {t} {b} {a}. (t, b, Either a Void) -> Maybe (t, a)
tagErrWithDomain ((Domain, Async m Void, Either SomeException Void)
 -> Maybe (Domain, SomeException))
-> STM m (Domain, Async m Void, Either SomeException Void)
-> STM m (Maybe (Domain, SomeException))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Domain, Async m Void)]
-> STM m (Domain, Async m Void, Either SomeException Void)
forall (m :: * -> *) ctx a.
MonadAsync m =>
[(ctx, Async m a)]
-> STM m (ctx, Async m a, Either SomeException a)
waitAnyCatchSTMWithCtx [(Domain, Async m Void)]
as)
              STM m (Maybe (Domain, SomeException))
-> STM m (Maybe (Domain, SomeException))
-> STM m (Maybe (Domain, SomeException))
forall a. STM m a -> STM m a -> STM m a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                  -- wait for configuration changes
                  (do a <- STM
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig extraFlags))]
readLocalRootPeers
                      -- wait until the input domains groups changes
                      check (a /= domainsGroups)
                      return Nothing)
          case res of
            Just (Domain
domain, SomeException
err) -> Tracer m (TraceLocalRootPeers extraFlags peerAddr)
-> TraceLocalRootPeers extraFlags peerAddr -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalRootPeers extraFlags peerAddr)
tracer (Domain -> SomeException -> TraceLocalRootPeers extraFlags peerAddr
forall extraFlags peerAddr.
Domain -> SomeException -> TraceLocalRootPeers extraFlags peerAddr
TraceLocalRootError Domain
domain SomeException
err)
            Maybe (Domain, SomeException)
Nothing            -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      -- we continue the loop outside of 'withAsyncAll',  this makes sure that
      -- all the monitoring threads are killed, so the map is final.
      dnsDomainMap' <- readTVarIO dnsDomainMapVar
      loop varRng dnsSemaphore (Just domainsGroups) dnsDomainMap'

    -- | The DNS Domain Map an iteration starts from: each domain of the
    -- configuration with the addresses 'resolved' holds for it, if any.
    initialDNSDomainMap :: Map RelayAccessPoint [peerAddr]
                        -> [(HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig extraFlags))]
                        -> Map RelayAccessPoint [peerAddr]
    initialDNSDomainMap :: Map RelayAccessPoint [peerAddr]
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> Map RelayAccessPoint [peerAddr]
initialDNSDomainMap Map RelayAccessPoint [peerAddr]
resolved [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups =
      [(RelayAccessPoint, [peerAddr])] -> Map RelayAccessPoint [peerAddr]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        [ (RelayAccessPoint
rap, [peerAddr]
-> RelayAccessPoint
-> Map RelayAccessPoint [peerAddr]
-> [peerAddr]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] RelayAccessPoint
rap Map RelayAccessPoint [peerAddr]
resolved)
        | (HotValency
_, WarmValency
_, Map RelayAccessPoint (LocalRootConfig extraFlags)
m) <- [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups
        , RelayAccessPoint
rap <- Map RelayAccessPoint (LocalRootConfig extraFlags)
-> [RelayAccessPoint]
forall k a. Map k a -> [k]
Map.keys Map RelayAccessPoint (LocalRootConfig extraFlags)
m
        , Bool -> Bool
not (RelayAccessPoint -> Bool
isRelayAccessAddress RelayAccessPoint
rap)
        ]


    -- | Function that runs on a monitoring thread. This function will, every
    -- TTL, issue a DNS resolution request and collect the results for its
    -- particular domain in the DNS Domain Map TVar. After having the result it
    -- will construct the new view of the local root groups by replacing every
    -- domain name in the static configuration with the most up to date results
    -- from the DNS Domain Map.
    monitorDomain
      :: Resource m (Either DNSorIOError resolver)
      -> DNSSemaphore m
      -> StrictTVar m (Map RelayAccessPoint [peerAddr])
      -> StrictTVar m StdGen
      -> RelayAccessPoint
      -> (DNS.Domain, m Void)
    monitorDomain :: Resource m (Either DNSorIOError resolver)
-> DNSSemaphore m
-> StrictTVar m (Map RelayAccessPoint [peerAddr])
-> StrictTVar m StdGen
-> RelayAccessPoint
-> (Domain, m Void)
monitorDomain Resource m (Either DNSorIOError resolver)
rr0 DNSSemaphore m
dnsSemaphore StrictTVar m (Map RelayAccessPoint [peerAddr])
dnsDomainMapVar StrictTVar m StdGen
varRng RelayAccessPoint
domain =
        (Domain
domain', DiffTime -> Resource m resolver -> m Void
go DiffTime
0
                     (Tracer m DNSorIOError
-> NonEmpty DiffTime
-> Resource m (Either DNSorIOError resolver)
-> Resource m resolver
forall (m :: * -> *) e a.
MonadDelay m =>
Tracer m e
-> NonEmpty DiffTime -> Resource m (Either e a) -> Resource m a
retryResource (RelayAccessPoint
-> DNSorIOError -> TraceLocalRootPeers extraFlags peerAddr
forall extraFlags peerAddr.
RelayAccessPoint
-> DNSorIOError -> TraceLocalRootPeers extraFlags peerAddr
TraceLocalRootFailure RelayAccessPoint
domain (DNSorIOError -> TraceLocalRootPeers extraFlags peerAddr)
-> Tracer m (TraceLocalRootPeers extraFlags peerAddr)
-> Tracer m DNSorIOError
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
`contramap` Tracer m (TraceLocalRootPeers extraFlags peerAddr)
tracer)
                                    (DiffTime
1 DiffTime -> [DiffTime] -> NonEmpty DiffTime
forall a. a -> [a] -> NonEmpty a
:| [DiffTime
3, DiffTime
6, DiffTime
9, DiffTime
12])
                                    Resource m (Either DNSorIOError resolver)
rr0))
      where
        domain' :: Domain
domain' = Domain -> Maybe Domain -> Domain
forall a. a -> Maybe a -> a
fromMaybe (String -> Domain
forall a. HasCallStack => String -> a
error String
"LocalRootPeers.monitorDomain: impossible!")
                            (RelayAccessPoint -> Maybe Domain
relayAccessPointDomain RelayAccessPoint
domain)

        go :: DiffTime
           -> Resource m resolver
           -> m Void
        go :: DiffTime -> Resource m resolver -> m Void
go !DiffTime
ttl !Resource m resolver
rr = do
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DiffTime
ttl DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> DiffTime
0) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
            Tracer m (TraceLocalRootPeers extraFlags peerAddr)
-> TraceLocalRootPeers extraFlags peerAddr -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalRootPeers extraFlags peerAddr)
tracer (RelayAccessPoint
-> DiffTime -> TraceLocalRootPeers extraFlags peerAddr
forall extraFlags peerAddr.
RelayAccessPoint
-> DiffTime -> TraceLocalRootPeers extraFlags peerAddr
TraceLocalRootWaiting RelayAccessPoint
domain DiffTime
ttl)
            DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
ttl

          (resolver, rr') <- Resource m resolver -> m (resolver, Resource m resolver)
forall (m :: * -> *) a. Resource m a -> m (a, Resource m a)
withResource Resource m resolver
rr

          --- Resolve 'domain'
          rng <- atomically . stateTVar varRng $ splitGen
          reply <- withDNSSemaphore dnsSemaphore
                                    (dnsLookupWithTTL
                                      DNSLocalPeer
                                      domain
                                      resolvConf
                                      resolver
                                      rng)

          case reply of
            Left [DNSError]
errs ->
              DiffTime -> Resource m resolver -> m Void
go ([DiffTime] -> DiffTime
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([DiffTime] -> DiffTime) -> [DiffTime] -> DiffTime
forall a b. (a -> b) -> a -> b
$ (DNSError -> DiffTime) -> [DNSError] -> [DiffTime]
forall a b. (a -> b) -> [a] -> [b]
map (DiffTime -> DNSError -> DiffTime
ttlForDnsError DiffTime
ttl) [DNSError]
errs)
                 Resource m resolver
rr'
            Right [(peerAddr, TTL)]
results -> do
              (newRootPeersGroups, newDNSDomainMap) <- STM
  m
  ([(HotValency, WarmValency,
     Map peerAddr (LocalRootConfig extraFlags))],
   Map RelayAccessPoint [peerAddr])
-> m ([(HotValency, WarmValency,
        Map peerAddr (LocalRootConfig extraFlags))],
      Map RelayAccessPoint [peerAddr])
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   ([(HotValency, WarmValency,
      Map peerAddr (LocalRootConfig extraFlags))],
    Map RelayAccessPoint [peerAddr])
 -> m ([(HotValency, WarmValency,
         Map peerAddr (LocalRootConfig extraFlags))],
       Map RelayAccessPoint [peerAddr]))
-> STM
     m
     ([(HotValency, WarmValency,
        Map peerAddr (LocalRootConfig extraFlags))],
      Map RelayAccessPoint [peerAddr])
-> m ([(HotValency, WarmValency,
        Map peerAddr (LocalRootConfig extraFlags))],
      Map RelayAccessPoint [peerAddr])
forall a b. (a -> b) -> a -> b
$ do
                -- Read current DNS Domain Map value
                dnsDomainMap <- StrictTVar m (Map RelayAccessPoint [peerAddr])
-> STM m (Map RelayAccessPoint [peerAddr])
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Map RelayAccessPoint [peerAddr])
dnsDomainMapVar

                let results' = ((peerAddr, TTL) -> peerAddr) -> [(peerAddr, TTL)] -> [peerAddr]
forall a b. (a -> b) -> [a] -> [b]
map (peerAddr, TTL) -> peerAddr
forall a b. (a, b) -> a
fst [(peerAddr, TTL)]
results
                    -- New DNS Resolution results, update the map
                    newDNSDomainMap =
                      RelayAccessPoint
-> [peerAddr]
-> Map RelayAccessPoint [peerAddr]
-> Map RelayAccessPoint [peerAddr]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert RelayAccessPoint
domain [peerAddr]
results' Map RelayAccessPoint [peerAddr]
dnsDomainMap

                -- Only overwrite if it changed:
                when (results' /= dnsDomainMap Map.! domain) $
                  writeTVar dnsDomainMapVar newDNSDomainMap

                -- Read the static local roots configuration
                staticRootPeersGroups <- readLocalRootPeers

                (_, newRootPeersGroups) <-
                  publishGroups newDNSDomainMap staticRootPeersGroups

                return (newRootPeersGroups, newDNSDomainMap)

              traceWith tracer (TraceLocalRootGroups newRootPeersGroups)
              traceWith tracer (TraceLocalRootDNSMap newDNSDomainMap)

              go (ttlDiffTime $ ttlForResults (map snd results)) rr'

    -- | Resolves local root peers with a given dns map and writes the results
    -- to `rootPeersGroupVar` if changed.  Returns a boolean value indicating
    -- the change and the written value.
    --
    publishGroups :: Map RelayAccessPoint [peerAddr]
                  -> [( HotValency
                      , WarmValency
                      , Map RelayAccessPoint (LocalRootConfig extraFlags))]
                  -> STM m ( Bool
                           , [( HotValency
                              , WarmValency
                              , Map peerAddr (LocalRootConfig extraFlags))] )
    publishGroups :: Map RelayAccessPoint [peerAddr]
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> STM
     m
     (Bool,
      [(HotValency, WarmValency,
        Map peerAddr (LocalRootConfig extraFlags))])
publishGroups Map RelayAccessPoint [peerAddr]
dnsDomainMap [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
staticRootPeersGroups = do
      -- Read current root peers groups value
      oldRootPeersGroups <- StrictTVar
  m
  [(HotValency, WarmValency,
    Map peerAddr (LocalRootConfig extraFlags))]
-> STM
     m
     [(HotValency, WarmValency,
       Map peerAddr (LocalRootConfig extraFlags))]
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar
  m
  [(HotValency, WarmValency,
    Map peerAddr (LocalRootConfig extraFlags))]
rootPeersGroupVar

      -- Get possibly new value for root peers groups
      let newRootPeersGroups =
            Map RelayAccessPoint [peerAddr]
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> [(HotValency, WarmValency,
     Map peerAddr (LocalRootConfig extraFlags))]
getLocalRootPeersGroups Map RelayAccessPoint [peerAddr]
dnsDomainMap [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
staticRootPeersGroups
          changed = [(HotValency, WarmValency,
  Map peerAddr (LocalRootConfig extraFlags))]
oldRootPeersGroups [(HotValency, WarmValency,
  Map peerAddr (LocalRootConfig extraFlags))]
-> [(HotValency, WarmValency,
     Map peerAddr (LocalRootConfig extraFlags))]
-> Bool
forall a. Eq a => a -> a -> Bool
/= [(HotValency, WarmValency,
  Map peerAddr (LocalRootConfig extraFlags))]
newRootPeersGroups

      -- Only overwrite if it changed:
      when changed $
        writeTVar rootPeersGroupVar newRootPeersGroups

      return (changed, newRootPeersGroups)

    -- | Returns local root peers without any domain names, only 'peerAddr'
    -- (IP + PortNumber).
    --
    -- It does so by reading a DNS Domain Map and replacing all instances of a
    -- DomainAccessPoint in the static configuration with the values from the
    -- map.
    getLocalRootPeersGroups :: Map RelayAccessPoint [peerAddr]
                            -> [( HotValency
                                , WarmValency
                                , Map RelayAccessPoint (LocalRootConfig extraFlags))]
                            -> [( HotValency
                                , WarmValency
                                , Map peerAddr (LocalRootConfig extraFlags))]
    getLocalRootPeersGroups :: Map RelayAccessPoint [peerAddr]
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> [(HotValency, WarmValency,
     Map peerAddr (LocalRootConfig extraFlags))]
getLocalRootPeersGroups Map RelayAccessPoint [peerAddr]
dnsMap =
      -- The idea is to traverse the static configuration. Enter each local
      -- group and check if any of the RelayAccessPoint has a Domain Name.
      --
      -- If it does we make a lookup in the DNS Domain Map and get the new
      -- entries.
      --
      -- So in a nutshell we are traversing the static configuration and
      -- replacing every domain name for its resolved result (if it exists).
      ((HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))
 -> (HotValency, WarmValency,
     Map peerAddr (LocalRootConfig extraFlags)))
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> [(HotValency, WarmValency,
     Map peerAddr (LocalRootConfig extraFlags))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Map RelayAccessPoint (LocalRootConfig extraFlags)
 -> Map peerAddr (LocalRootConfig extraFlags))
-> (HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig extraFlags))
-> (HotValency, WarmValency,
    Map peerAddr (LocalRootConfig extraFlags))
forall b c a. (b -> c) -> (HotValency, a, b) -> (HotValency, a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((Map peerAddr (LocalRootConfig extraFlags)
 -> RelayAccessPoint
 -> LocalRootConfig extraFlags
 -> Map peerAddr (LocalRootConfig extraFlags))
-> Map peerAddr (LocalRootConfig extraFlags)
-> Map RelayAccessPoint (LocalRootConfig extraFlags)
-> Map peerAddr (LocalRootConfig extraFlags)
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey'
                      (\Map peerAddr (LocalRootConfig extraFlags)
accMap RelayAccessPoint
rap LocalRootConfig extraFlags
pa
                         -> case RelayAccessPoint
rap of
                             RelayAccessAddress IP
ip PortNumber
port ->
                               peerAddr
-> LocalRootConfig extraFlags
-> Map peerAddr (LocalRootConfig extraFlags)
-> Map peerAddr (LocalRootConfig extraFlags)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (IP -> PortNumber -> peerAddr
toPeerAddr IP
ip PortNumber
port) LocalRootConfig extraFlags
pa Map peerAddr (LocalRootConfig extraFlags)
accMap
                             RelayAccessPoint
dap ->
                               let newEntries :: Map peerAddr (LocalRootConfig extraFlags)
newEntries =
                                     Map peerAddr (LocalRootConfig extraFlags)
-> ([peerAddr] -> Map peerAddr (LocalRootConfig extraFlags))
-> Maybe [peerAddr]
-> Map peerAddr (LocalRootConfig extraFlags)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map peerAddr (LocalRootConfig extraFlags)
forall k a. Map k a
Map.empty ([(peerAddr, LocalRootConfig extraFlags)]
-> Map peerAddr (LocalRootConfig extraFlags)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(peerAddr, LocalRootConfig extraFlags)]
 -> Map peerAddr (LocalRootConfig extraFlags))
-> ([peerAddr] -> [(peerAddr, LocalRootConfig extraFlags)])
-> [peerAddr]
-> Map peerAddr (LocalRootConfig extraFlags)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (peerAddr -> (peerAddr, LocalRootConfig extraFlags))
-> [peerAddr] -> [(peerAddr, LocalRootConfig extraFlags)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, LocalRootConfig extraFlags
pa))
                                           (Maybe [peerAddr] -> Map peerAddr (LocalRootConfig extraFlags))
-> Maybe [peerAddr] -> Map peerAddr (LocalRootConfig extraFlags)
forall a b. (a -> b) -> a -> b
$ RelayAccessPoint
-> Map RelayAccessPoint [peerAddr] -> Maybe [peerAddr]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RelayAccessPoint
dap Map RelayAccessPoint [peerAddr]
dnsMap
                                in Map peerAddr (LocalRootConfig extraFlags)
accMap Map peerAddr (LocalRootConfig extraFlags)
-> Map peerAddr (LocalRootConfig extraFlags)
-> Map peerAddr (LocalRootConfig extraFlags)
forall a. Semigroup a => a -> a -> a
<> Map peerAddr (LocalRootConfig extraFlags)
newEntries
                      )
                   Map peerAddr (LocalRootConfig extraFlags)
forall k a. Map k a
Map.empty
                   )
           )

-- * Aux

-- | Policy for TTL for positive results
ttlForResults :: [TTL] -> TTL

-- This case says we have a successful reply but there is no answer.
-- This covers for example non-existent TLDs since there is no authority
-- to say that they should not exist.
ttlForResults :: [TTL] -> TTL
ttlForResults []   = TTL
minTTL
ttlForResults [TTL]
ttls = [TTL] -> TTL
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [TTL]
ttls

-- | Policy for TTL for negative results
-- Cache negative response for 15min
-- Otherwise, use exponential backoff, up to a limit
ttlForDnsError :: DiffTime -> DNS.DNSError -> DiffTime
ttlForDnsError :: DiffTime -> DNSError -> DiffTime
ttlForDnsError DiffTime
_   DNSError
DNS.NameError = TTL -> DiffTime
ttlDiffTime   TTL
maxTTL
ttlForDnsError DiffTime
ttl DNSError
_             = TTL -> DiffTime
ttlDiffTime (TTL -> DiffTime) -> (DiffTime -> TTL) -> DiffTime -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> TTL
forall ttl. Real ttl => ttl -> TTL
mkClippedTTL (DiffTime -> DiffTime) -> DiffTime -> DiffTime
forall a b. (a -> b) -> a -> b
$ DiffTime
ttl DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
* DiffTime
2 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
5


-- | `withAsyncAll`, but the actions are tagged with a context
withAsyncAllWithCtx :: MonadAsync m => [(ctx, m a)] -> ([(ctx, Async m a)] -> m b) -> m b
withAsyncAllWithCtx :: forall (m :: * -> *) ctx a b.
MonadAsync m =>
[(ctx, m a)] -> ([(ctx, Async m a)] -> m b) -> m b
withAsyncAllWithCtx [(ctx, m a)]
contextualized [(ctx, Async m a)] -> m b
action = [(ctx, Async m a)] -> [(ctx, m a)] -> m b
go [] [(ctx, m a)]
contextualized
  where
    go :: [(ctx, Async m a)] -> [(ctx, m a)] -> m b
go [(ctx, Async m a)]
as []            = [(ctx, Async m a)] -> m b
action ([(ctx, Async m a)] -> [(ctx, Async m a)]
forall a. [a] -> [a]
reverse [(ctx, Async m a)]
as)
    go [(ctx, Async m a)]
as ((ctx
ctx, m a
x):[(ctx, m a)]
xs) = m a -> (Async m a -> m b) -> m b
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 m a
x (\Async m a
a -> [(ctx, Async m a)] -> [(ctx, m a)] -> m b
go ((ctx
ctx, Async m a
a)(ctx, Async m a) -> [(ctx, Async m a)] -> [(ctx, Async m a)]
forall a. a -> [a] -> [a]
:[(ctx, Async m a)]
as) [(ctx, m a)]
xs)

-- | `waitAnyCatchSTM`, but the asyncs are tagged with a context
waitAnyCatchSTMWithCtx :: MonadAsync m => [(ctx, Async m a)] -> STM m (ctx, Async m a, Either SomeException a)
waitAnyCatchSTMWithCtx :: forall (m :: * -> *) ctx a.
MonadAsync m =>
[(ctx, Async m a)]
-> STM m (ctx, Async m a, Either SomeException a)
waitAnyCatchSTMWithCtx = ((ctx, Async m a)
 -> STM m (ctx, Async m a, Either SomeException a)
 -> STM m (ctx, Async m a, Either SomeException a))
-> STM m (ctx, Async m a, Either SomeException a)
-> [(ctx, Async m a)]
-> STM m (ctx, Async m a, Either SomeException a)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (STM m (ctx, Async m a, Either SomeException a)
-> STM m (ctx, Async m a, Either SomeException a)
-> STM m (ctx, Async m a, Either SomeException a)
forall a. STM m a -> STM m a -> STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a -> STM m a -> STM m a
orElse (STM m (ctx, Async m a, Either SomeException a)
 -> STM m (ctx, Async m a, Either SomeException a)
 -> STM m (ctx, Async m a, Either SomeException a))
-> ((ctx, Async m a)
    -> STM m (ctx, Async m a, Either SomeException a))
-> (ctx, Async m a)
-> STM m (ctx, Async m a, Either SomeException a)
-> STM m (ctx, Async m a, Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ctx, Async m a) -> STM m (ctx, Async m a, Either SomeException a)
forall {m :: * -> *} {a} {a}.
MonadAsync m =>
(a, Async m a) -> STM m (a, Async m a, Either SomeException a)
waitWithCtx) STM m (ctx, Async m a, Either SomeException a)
forall a. STM m a
forall (m :: * -> *) a. MonadSTM m => STM m a
retry
  where
    waitWithCtx :: (a, Async m a) -> STM m (a, Async m a, Either SomeException a)
waitWithCtx (a
ctx, Async m a
a) =
      do
        r <- Async m a -> STM m (Either SomeException a)
forall a. Async m a -> STM m (Either SomeException a)
forall (m :: * -> *) a.
MonadAsync m =>
Async m a -> STM m (Either SomeException a)
waitCatchSTM Async m a
a
        pure (ctx, a, r)

---------------------------------------------
-- Examples
--
{-
exampleLocal :: [DomainAccessPoint] -> IO ()
exampleLocal domains = do
      rootPeersVar <- newTVarIO Map.empty
      withAsync (observer rootPeersVar Map.empty) $ \_ ->
        provider rootPeersVar
  where
    provider rootPeersVar =
      localRootPeersProvider
        (show >$< stdoutTracer)
        DNS.defaultResolvConf
        rootPeersVar
        (map (\d -> (d, DoAdvertisePeer)) domains)

    observer :: (Eq a, Show a) => StrictTVar IO a -> a -> IO ()
    observer var fingerprint = do
      x <- atomically $ do
        x <- readTVar var
        check (x /= fingerprint)
        return x
      traceWith (show >$< stdoutTracer) x
      observer var x

examplePublic :: [DomainAccessPoint] -> IO ()
examplePublic domains = do
    publicRootPeersProvider
      (show >$< stdoutTracer)
      DNS.defaultResolvConf
      domains $ \requestPublicRootPeers ->
        forever $ do
          (ips, ttl) <- requestPublicRootPeers 42
          traceWith (show >$< stdoutTracer) (ips, ttl)
          threadDelay ttl
-}