{-# 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 (..)
  ) where

import Data.Bifunctor (second)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Void (Void, absurd)
import Data.Word (Word32)
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.MonadTime.SI
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 exception =
       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 exception)
       --TODO: classify DNS errors, config error vs transitory
     | TraceLocalRootError DNS.Domain SomeException
  deriving Int -> TraceLocalRootPeers extraFlags peerAddr exception -> ShowS
[TraceLocalRootPeers extraFlags peerAddr exception] -> ShowS
TraceLocalRootPeers extraFlags peerAddr exception -> String
(Int -> TraceLocalRootPeers extraFlags peerAddr exception -> ShowS)
-> (TraceLocalRootPeers extraFlags peerAddr exception -> String)
-> ([TraceLocalRootPeers extraFlags peerAddr exception] -> ShowS)
-> Show (TraceLocalRootPeers extraFlags peerAddr exception)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall extraFlags peerAddr exception.
(Show extraFlags, Show peerAddr, Show exception) =>
Int -> TraceLocalRootPeers extraFlags peerAddr exception -> ShowS
forall extraFlags peerAddr exception.
(Show extraFlags, Show peerAddr, Show exception) =>
[TraceLocalRootPeers extraFlags peerAddr exception] -> ShowS
forall extraFlags peerAddr exception.
(Show extraFlags, Show peerAddr, Show exception) =>
TraceLocalRootPeers extraFlags peerAddr exception -> String
$cshowsPrec :: forall extraFlags peerAddr exception.
(Show extraFlags, Show peerAddr, Show exception) =>
Int -> TraceLocalRootPeers extraFlags peerAddr exception -> ShowS
showsPrec :: Int -> TraceLocalRootPeers extraFlags peerAddr exception -> ShowS
$cshow :: forall extraFlags peerAddr exception.
(Show extraFlags, Show peerAddr, Show exception) =>
TraceLocalRootPeers extraFlags peerAddr exception -> String
show :: TraceLocalRootPeers extraFlags peerAddr exception -> String
$cshowList :: forall extraFlags peerAddr exception.
(Show extraFlags, Show peerAddr, Show exception) =>
[TraceLocalRootPeers extraFlags peerAddr exception] -> ShowS
showList :: [TraceLocalRootPeers extraFlags peerAddr exception] -> 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 exception.
     ( Alternative (STM m)
     , MonadAsync m
     , MonadDelay m
     , MonadThrow m
     , Ord peerAddr
     , Eq extraFlags
     )
  => Tracer m (TraceLocalRootPeers extraFlags peerAddr exception)
  -> PeerActionsDNS peerAddr resolver exception 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 exception.
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 Ord peerAddr, Eq extraFlags) =>
Tracer m (TraceLocalRootPeers extraFlags peerAddr exception)
-> PeerActionsDNS peerAddr resolver exception 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 exception)
tracer
                       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 peeraddr resolver exception m
paDnsActions = DNSActions {
                           ResolvConf
-> m (Resource m (Either (DNSorIOError exception) resolver))
dnsAsyncResolverResource :: ResolvConf
-> m (Resource m (Either (DNSorIOError exception) resolver))
dnsAsyncResolverResource :: forall peerAddr resolver exception (m :: * -> *).
DNSActions peerAddr resolver exception m
-> ResolvConf
-> m (Resource m (Either (DNSorIOError exception) resolver))
dnsAsyncResolverResource,
                           DNSPeersKind
-> RelayAccessPoint
-> ResolvConf
-> resolver
-> StdGen
-> m (DNSLookupResult peerAddr)
dnsLookupWithTTL :: DNSPeersKind
-> RelayAccessPoint
-> ResolvConf
-> resolver
-> StdGen
-> m (DNSLookupResult peerAddr)
dnsLookupWithTTL :: forall peerAddr resolver exception (m :: * -> *).
DNSActions peerAddr resolver exception 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 =
      STM
  m
  (StrictTVar m StdGen, DNSSemaphore m,
   [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> m (StrictTVar m StdGen, DNSSemaphore m,
      [(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig extraFlags))])
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically do
        domainsGroups <- STM
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig extraFlags))]
readLocalRootPeers
        writeTVar rootPeersGroupVar (getLocalRootPeersGroups Map.empty domainsGroups)
        (,,) <$> newTVar rng0 <*> newDNSLocalRootSemaphore <*> pure domainsGroups
  m (StrictTVar m StdGen, DNSSemaphore m,
   [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> ((StrictTVar m StdGen, DNSSemaphore m,
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))])
    -> m Void)
-> m Void
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (StrictTVar m StdGen, DNSSemaphore m,
 [(HotValency, WarmValency,
   Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> m Void
loop'
  where
    loop' :: (StrictTVar m StdGen, DNSSemaphore m,
 [(HotValency, WarmValency,
   Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> m Void
loop' (StrictTVar m StdGen
varRng, DNSSemaphore m
sem, [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domGroups) = StrictTVar m StdGen
-> DNSSemaphore m
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> m Void
loop StrictTVar m StdGen
varRng DNSSemaphore m
sem [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domGroups
    -- | 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
         -> [(HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig extraFlags))]
         -> m Void
    loop :: StrictTVar m StdGen
-> DNSSemaphore m
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> m Void
loop StrictTVar m StdGen
varRng DNSSemaphore m
dnsSemaphore [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups = do
      Tracer m (TraceLocalRootPeers extraFlags peerAddr exception)
-> TraceLocalRootPeers extraFlags peerAddr exception -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalRootPeers extraFlags peerAddr exception)
tracer ([(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> TraceLocalRootPeers extraFlags peerAddr exception
forall extraFlags peerAddr exception.
Config extraFlags RelayAccessPoint
-> TraceLocalRootPeers extraFlags peerAddr exception
TraceLocalRootDomains [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups)
      rr <- ResolvConf
-> m (Resource m (Either (DNSorIOError exception) resolver))
dnsAsyncResolverResource ResolvConf
resolvConf
      let
          -- filter domains to monitor and perform DNS resolutions on
          domains :: [RelayAccessPoint]
          domains = [ RelayAccessPoint
rap
                    | (HotValency
_, WarmValency
_, Map RelayAccessPoint (LocalRootConfig extraFlags)
m) <- [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups
                    , (RelayAccessPoint
rap, LocalRootConfig extraFlags
_) <- Map RelayAccessPoint (LocalRootConfig extraFlags)
-> [(RelayAccessPoint, LocalRootConfig extraFlags)]
forall k a. Map k a -> [(k, a)]
Map.toList Map RelayAccessPoint (LocalRootConfig extraFlags)
m
                    , case RelayAccessPoint
rap of
                        RelayAccessAddress {} -> Bool
False
                        RelayAccessPoint
_otherwise            -> Bool
True
                    ]

          -- Initial DNS Domain Map has all domains entries empty
          initialDNSDomainMap :: Map RelayAccessPoint [peerAddr]
          initialDNSDomainMap =
            [(RelayAccessPoint, [peerAddr])] -> Map RelayAccessPoint [peerAddr]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(RelayAccessPoint, [peerAddr])]
 -> Map RelayAccessPoint [peerAddr])
-> [(RelayAccessPoint, [peerAddr])]
-> Map RelayAccessPoint [peerAddr]
forall a b. (a -> b) -> a -> b
$ (RelayAccessPoint -> (RelayAccessPoint, [peerAddr]))
-> [RelayAccessPoint] -> [(RelayAccessPoint, [peerAddr])]
forall a b. (a -> b) -> [a] -> [b]
map (, []) [RelayAccessPoint]
domains

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

      traceWith tracer (TraceLocalRootDNSMap initialDNSDomainMap)

      -- 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.
      domainsGroups' <-
        withAsyncAllWithCtx (monitorDomain rr dnsSemaphore dnsDomainMapVar varRng `map` domains) $ \[(Domain, Async m Void)]
as -> do
          let tagErrWithDomain :: (t, b, Either a Void) -> Either (t, a) b
tagErrWithDomain (t
domain, b
_, Either a Void
res) = (a -> Either (t, a) b)
-> (Void -> Either (t, a) b) -> Either a Void -> Either (t, a) b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((t, a) -> Either (t, a) b
forall a b. a -> Either a b
Left ((t, a) -> Either (t, a) b)
-> (a -> (t, a)) -> a -> Either (t, a) b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t
domain,)) Void -> Either (t, a) b
forall a. Void -> a
absurd Either a Void
res
          res <- STM
  m
  (Either
     (Domain, SomeException)
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> m (Either
        (Domain, SomeException)
        [(HotValency, WarmValency,
          Map RelayAccessPoint (LocalRootConfig extraFlags))])
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (Either
      (Domain, SomeException)
      [(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig extraFlags))])
 -> m (Either
         (Domain, SomeException)
         [(HotValency, WarmValency,
           Map RelayAccessPoint (LocalRootConfig extraFlags))]))
-> STM
     m
     (Either
        (Domain, SomeException)
        [(HotValency, WarmValency,
          Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> m (Either
        (Domain, SomeException)
        [(HotValency, WarmValency,
          Map RelayAccessPoint (LocalRootConfig extraFlags))])
forall a b. (a -> b) -> a -> b
$
                  -- wait until any of the monitoring threads errors
                  ((Domain, Async m Void, Either SomeException Void)
-> Either
     (Domain, SomeException)
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))]
forall {t} {b} {a} {b}. (t, b, Either a Void) -> Either (t, a) b
tagErrWithDomain ((Domain, Async m Void, Either SomeException Void)
 -> Either
      (Domain, SomeException)
      [(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> STM m (Domain, Async m Void, Either SomeException Void)
-> STM
     m
     (Either
        (Domain, SomeException)
        [(HotValency, WarmValency,
          Map RelayAccessPoint (LocalRootConfig extraFlags))])
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
  (Either
     (Domain, SomeException)
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> STM
     m
     (Either
        (Domain, SomeException)
        [(HotValency, WarmValency,
          Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> STM
     m
     (Either
        (Domain, SomeException)
        [(HotValency, WarmValency,
          Map RelayAccessPoint (LocalRootConfig extraFlags))])
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 (Right a))
          case res of
            Left (Domain
domain, SomeException
err)    -> Tracer m (TraceLocalRootPeers extraFlags peerAddr exception)
-> TraceLocalRootPeers extraFlags peerAddr exception -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalRootPeers extraFlags peerAddr exception)
tracer (Domain
-> SomeException
-> TraceLocalRootPeers extraFlags peerAddr exception
forall extraFlags peerAddr exception.
Domain
-> SomeException
-> TraceLocalRootPeers extraFlags peerAddr exception
TraceLocalRootError Domain
domain SomeException
err)
                                  -- current domain groups haven't changed, we
                                  -- can return them
                                  m ()
-> m [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> m [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))]
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> m [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups
            Right [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups'  -> Tracer m (TraceLocalRootPeers extraFlags peerAddr exception)
-> TraceLocalRootPeers extraFlags peerAddr exception -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalRootPeers extraFlags peerAddr exception)
tracer ([(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> TraceLocalRootPeers extraFlags peerAddr exception
forall extraFlags peerAddr exception.
Config extraFlags RelayAccessPoint
-> Config extraFlags RelayAccessPoint
-> TraceLocalRootPeers extraFlags peerAddr exception
TraceLocalRootReconfigured [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups')
                                  -- current domain groups changed, we should
                                  -- return them
                                  m ()
-> m [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> m [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))]
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> m [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups'
      -- we continue the loop outside of 'withAsyncAll',  this makes sure that
      -- all the monitoring threads are killed.
      loop varRng dnsSemaphore domainsGroups'


    -- | 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 exception) resolver)
      -> DNSSemaphore m
      -> StrictTVar m (Map RelayAccessPoint [peerAddr])
      -> StrictTVar m StdGen
      -> RelayAccessPoint
      -> (DNS.Domain, m Void)
    monitorDomain :: Resource m (Either (DNSorIOError exception) resolver)
-> DNSSemaphore m
-> StrictTVar m (Map RelayAccessPoint [peerAddr])
-> StrictTVar m StdGen
-> RelayAccessPoint
-> (Domain, m Void)
monitorDomain Resource m (Either (DNSorIOError exception) 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 exception)
-> NonEmpty DiffTime
-> Resource m (Either (DNSorIOError exception) 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 exception
-> TraceLocalRootPeers extraFlags peerAddr exception
forall extraFlags peerAddr exception.
RelayAccessPoint
-> DNSorIOError exception
-> TraceLocalRootPeers extraFlags peerAddr exception
TraceLocalRootFailure RelayAccessPoint
domain (DNSorIOError exception
 -> TraceLocalRootPeers extraFlags peerAddr exception)
-> Tracer m (TraceLocalRootPeers extraFlags peerAddr exception)
-> Tracer m (DNSorIOError exception)
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 exception)
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 exception) resolver)
rr0))
      where
        domain' :: Domain
domain' = case RelayAccessPoint
domain of
          RelayAccessDomain Domain
d PortNumber
_p -> Domain
d
          RelayAccessSRVDomain Domain
d -> Domain
d
          RelayAccessPoint
_otherwise             -> String -> Domain
forall a. HasCallStack => String -> a
error String
"LocalRootPeers.monitorDomain: impossible!"

        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 exception)
-> TraceLocalRootPeers extraFlags peerAddr exception -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalRootPeers extraFlags peerAddr exception)
tracer (RelayAccessPoint
-> DiffTime -> TraceLocalRootPeers extraFlags peerAddr exception
forall extraFlags peerAddr exception.
RelayAccessPoint
-> DiffTime -> TraceLocalRootPeers extraFlags peerAddr exception
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 $ split
          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, Word32)]
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, Word32) -> peerAddr)
-> [(peerAddr, Word32)] -> [peerAddr]
forall a b. (a -> b) -> [a] -> [b]
map (peerAddr, Word32) -> peerAddr
forall a b. (a, b) -> a
fst [(peerAddr, Word32)]
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

                -- Read current root peers groups value
                oldRootPeersGroups <- readTVar 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]
newDNSDomainMap
                                              [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
staticRootPeersGroups

                -- Only overwrite if it changed:
                when (oldRootPeersGroups /= newRootPeersGroups) $
                  writeTVar rootPeersGroupVar newRootPeersGroups

                return (newRootPeersGroups, newDNSDomainMap)

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

              go (ttlForResults (map snd results)) rr'

    -- | 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 :: [DNS.TTL] -> DiffTime

-- 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 :: [Word32] -> DiffTime
ttlForResults []   = DiffTime -> DNSError -> DiffTime
ttlForDnsError DiffTime
0 DNSError
DNS.NameError
ttlForResults [Word32]
ttls = DiffTime -> DiffTime
clipTTLBelow
                   (DiffTime -> DiffTime)
-> (Word32 -> DiffTime) -> Word32 -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffTime -> DiffTime
clipTTLAbove
                   (DiffTime -> DiffTime)
-> (Word32 -> DiffTime) -> Word32 -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word32 -> DiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Word32 -> DiffTime)
                   (Word32 -> DiffTime) -> Word32 -> DiffTime
forall a b. (a -> b) -> a -> b
$ [Word32] -> Word32
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Word32]
ttls

-- | Limit insane TTL choices.
clipTTLAbove, clipTTLBelow :: DiffTime -> DiffTime
clipTTLBelow :: DiffTime -> DiffTime
clipTTLBelow = DiffTime -> DiffTime -> DiffTime
forall a. Ord a => a -> a -> a
max DiffTime
60     -- between 1min
clipTTLAbove :: DiffTime -> DiffTime
clipTTLAbove = DiffTime -> DiffTime -> DiffTime
forall a. Ord a => a -> a -> a
min DiffTime
86400  -- and 24hrs

-- | Policy for TTL for negative results
-- Cache negative response for 3hrs
-- Otherwise, use exponential backoff, up to a limit
ttlForDnsError :: DiffTime -> DNS.DNSError -> DiffTime
ttlForDnsError :: DiffTime -> DNSError -> DiffTime
ttlForDnsError DiffTime
_   DNSError
DNS.NameError = DiffTime
10800
ttlForDnsError DiffTime
ttl DNSError
_             = DiffTime -> DiffTime
clipTTLAbove (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
        (showTracing 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 (showTracing stdoutTracer) x
      observer var x

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