{-# LANGUAGE BangPatterns        #-}
{-# 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.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 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 Data.Bifunctor (second)
import Ouroboros.Network.PeerSelection.RelayAccessPoint
import Ouroboros.Network.PeerSelection.RootPeersDNS (PeerActionsDNS (..))
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 DomainAccessPoint DiffTime
     | TraceLocalRootResult  DomainAccessPoint [(IP, DNS.TTL)]
     | TraceLocalRootGroups  (LocalRootPeers.Config extraFlags peerAddr)
       -- ^ This traces the results of the local root peer provider
     | TraceLocalRootDNSMap  (Map DomainAccessPoint [peerAddr])
       -- ^ This traces the results of the domain name resolution
     | TraceLocalRootReconfigured (LocalRootPeers.Config extraFlags RelayAccessPoint) -- ^ Old value
                                  (LocalRootPeers.Config extraFlags RelayAccessPoint) -- ^ New value
     | TraceLocalRootFailure DomainAccessPoint (DNSorIOError exception)
       --TODO: classify DNS errors, config error vs transitory
     | TraceLocalRootError   DomainAccessPoint 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
  -> 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
-> 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 resolver exception m
paDnsActions = DNSActions {
                           ResolvConf
-> m (Resource m (Either (DNSorIOError exception) resolver))
dnsAsyncResolverResource :: ResolvConf
-> m (Resource m (Either (DNSorIOError exception) resolver))
dnsAsyncResolverResource :: forall resolver exception (m :: * -> *).
DNSActions resolver exception m
-> ResolvConf
-> m (Resource m (Either (DNSorIOError exception) resolver))
dnsAsyncResolverResource,
                           ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, Word32)])
dnsLookupWithTTL :: ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, Word32)])
dnsLookupWithTTL :: forall resolver exception (m :: * -> *).
DNSActions resolver exception m
-> ResolvConf
-> resolver
-> Domain
-> m ([DNSError], [(IP, Word32)])
dnsLookupWithTTL
                         }
                       }
                       ResolvConf
resolvConf
                       STM
  m
  [(HotValency, WarmValency,
    Map RelayAccessPoint (LocalRootConfig extraFlags))]
readLocalRootPeers
                       StrictTVar
  m
  [(HotValency, WarmValency,
    Map peerAddr (LocalRootConfig extraFlags))]
rootPeersGroupVar =
        STM
  m
  (DNSSemaphore m,
   [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> m (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)
                       dnsSemaphore <- newDNSLocalRootSemaphore
                       return (dnsSemaphore, domainsGroups))
    m (DNSSemaphore m,
   [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> ((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
>>= (DNSSemaphore m
 -> [(HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig extraFlags))]
 -> m Void)
-> (DNSSemaphore m,
    [(HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> m Void
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry DNSSemaphore m
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> m Void
loop
  where
    -- | Loop function that monitors DNS Domain resolution threads and restarts
    -- if either these threads fail or detects the local configuration changed.
    --
    loop :: DNSSemaphore m
         -> [(HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig extraFlags))]
         -> m Void
    loop :: DNSSemaphore m
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> m Void
loop 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
          -- Get only DomainAccessPoint to monitor and perform DNS resolution
          -- on them.
          domains :: [DomainAccessPoint]
          domains = [ DomainAccessPoint
domain
                    | (HotValency
_, WarmValency
_, Map RelayAccessPoint (LocalRootConfig extraFlags)
m) <- [(HotValency, WarmValency,
  Map RelayAccessPoint (LocalRootConfig extraFlags))]
domainsGroups
                    , (RelayDomainAccessPoint DomainAccessPoint
domain, LocalRootConfig extraFlags
_) <- Map RelayAccessPoint (LocalRootConfig extraFlags)
-> [(RelayAccessPoint, LocalRootConfig extraFlags)]
forall k a. Map k a -> [(k, a)]
Map.toList Map RelayAccessPoint (LocalRootConfig extraFlags)
m ]

          -- Initial DNS Domain Map has all domains entries empty
          initialDNSDomainMap :: Map DomainAccessPoint [peerAddr]
          initialDNSDomainMap =
            [(DomainAccessPoint, [peerAddr])]
-> Map DomainAccessPoint [peerAddr]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(DomainAccessPoint, [peerAddr])]
 -> Map DomainAccessPoint [peerAddr])
-> [(DomainAccessPoint, [peerAddr])]
-> Map DomainAccessPoint [peerAddr]
forall a b. (a -> b) -> a -> b
$ (DomainAccessPoint -> (DomainAccessPoint, [peerAddr]))
-> [DomainAccessPoint] -> [(DomainAccessPoint, [peerAddr])]
forall a b. (a -> b) -> [a] -> [b]
map (, []) [DomainAccessPoint]
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 `map` domains) $ \[(DomainAccessPoint, 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
     (DomainAccessPoint, SomeException)
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> m (Either
        (DomainAccessPoint, 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
      (DomainAccessPoint, SomeException)
      [(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig extraFlags))])
 -> m (Either
         (DomainAccessPoint, SomeException)
         [(HotValency, WarmValency,
           Map RelayAccessPoint (LocalRootConfig extraFlags))]))
-> STM
     m
     (Either
        (DomainAccessPoint, SomeException)
        [(HotValency, WarmValency,
          Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> m (Either
        (DomainAccessPoint, SomeException)
        [(HotValency, WarmValency,
          Map RelayAccessPoint (LocalRootConfig extraFlags))])
forall a b. (a -> b) -> a -> b
$
                  -- wait until any of the monitoring threads errors
                  ((DomainAccessPoint, Async m Void, Either SomeException Void)
-> Either
     (DomainAccessPoint, SomeException)
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))]
forall {t} {b} {a} {b}. (t, b, Either a Void) -> Either (t, a) b
tagErrWithDomain ((DomainAccessPoint, Async m Void, Either SomeException Void)
 -> Either
      (DomainAccessPoint, SomeException)
      [(HotValency, WarmValency,
        Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> STM
     m (DomainAccessPoint, Async m Void, Either SomeException Void)
-> STM
     m
     (Either
        (DomainAccessPoint, SomeException)
        [(HotValency, WarmValency,
          Map RelayAccessPoint (LocalRootConfig extraFlags))])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(DomainAccessPoint, Async m Void)]
-> STM
     m (DomainAccessPoint, 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 [(DomainAccessPoint, Async m Void)]
as)
              STM
  m
  (Either
     (DomainAccessPoint, SomeException)
     [(HotValency, WarmValency,
       Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> STM
     m
     (Either
        (DomainAccessPoint, SomeException)
        [(HotValency, WarmValency,
          Map RelayAccessPoint (LocalRootConfig extraFlags))])
-> STM
     m
     (Either
        (DomainAccessPoint, 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 (DomainAccessPoint
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 (DomainAccessPoint
-> SomeException
-> TraceLocalRootPeers extraFlags peerAddr exception
forall extraFlags peerAddr exception.
DomainAccessPoint
-> SomeException
-> TraceLocalRootPeers extraFlags peerAddr exception
TraceLocalRootError DomainAccessPoint
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 dnsSemaphore domainsGroups'

    resolveDomain
      :: DNSSemaphore m
      -> resolver
      -> DomainAccessPoint
      -> m (Either [DNS.DNSError] [(peerAddr, DNS.TTL)])
    resolveDomain :: DNSSemaphore m
-> resolver
-> DomainAccessPoint
-> m (Either [DNSError] [(peerAddr, Word32)])
resolveDomain DNSSemaphore m
dnsSemaphore resolver
resolver
                  domain :: DomainAccessPoint
domain@DomainAccessPoint {Domain
dapDomain :: Domain
dapDomain :: DomainAccessPoint -> Domain
dapDomain, PortNumber
dapPortNumber :: PortNumber
dapPortNumber :: DomainAccessPoint -> PortNumber
dapPortNumber} = do
      (errs, results) <- DNSSemaphore m
-> m ([DNSError], [(IP, Word32)]) -> m ([DNSError], [(IP, Word32)])
forall (m :: * -> *) a.
(MonadSTM m, MonadThrow m) =>
DNSSemaphore m -> m a -> m a
withDNSSemaphore DNSSemaphore m
dnsSemaphore
                                          (ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, Word32)])
dnsLookupWithTTL
                                            ResolvConf
resolvConf
                                            resolver
resolver
                                            Domain
dapDomain)
      mapM_ (traceWith tracer . TraceLocalRootFailure domain . DNSError)
            errs

      if null errs
         then do
           traceWith tracer (TraceLocalRootResult domain results)
           return $ Right [ ( toPeerAddr addr dapPortNumber
                            , _ttl)
                          | (addr, _ttl) <- results ]
         else return $ Left errs

    -- | 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 DomainAccessPoint [peerAddr])
      -> DomainAccessPoint
      -> (DomainAccessPoint, m Void)
    monitorDomain :: Resource m (Either (DNSorIOError exception) resolver)
-> DNSSemaphore m
-> StrictTVar m (Map DomainAccessPoint [peerAddr])
-> DomainAccessPoint
-> (DomainAccessPoint, m Void)
monitorDomain Resource m (Either (DNSorIOError exception) resolver)
rr0 DNSSemaphore m
dnsSemaphore StrictTVar m (Map DomainAccessPoint [peerAddr])
dnsDomainMapVar DomainAccessPoint
domain =
        (DomainAccessPoint
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 (DomainAccessPoint
-> DNSorIOError exception
-> TraceLocalRootPeers extraFlags peerAddr exception
forall extraFlags peerAddr exception.
DomainAccessPoint
-> DNSorIOError exception
-> TraceLocalRootPeers extraFlags peerAddr exception
TraceLocalRootFailure DomainAccessPoint
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
        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 (DomainAccessPoint
-> DiffTime -> TraceLocalRootPeers extraFlags peerAddr exception
forall extraFlags peerAddr exception.
DomainAccessPoint
-> DiffTime -> TraceLocalRootPeers extraFlags peerAddr exception
TraceLocalRootWaiting DomainAccessPoint
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'
          reply <- resolveDomain dnsSemaphore resolver domain
          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 (\DNSError
err -> DNSError -> DiffTime -> DiffTime
ttlForDnsError DNSError
err DiffTime
ttl) [DNSError]
errs)
                           Resource m resolver
rr'
            Right [(peerAddr, Word32)]
results -> do
              (newRootPeersGroups, newDNSDomainMap) <- STM
  m
  ([(HotValency, WarmValency,
     Map peerAddr (LocalRootConfig extraFlags))],
   Map DomainAccessPoint [peerAddr])
-> m ([(HotValency, WarmValency,
        Map peerAddr (LocalRootConfig extraFlags))],
      Map DomainAccessPoint [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 DomainAccessPoint [peerAddr])
 -> m ([(HotValency, WarmValency,
         Map peerAddr (LocalRootConfig extraFlags))],
       Map DomainAccessPoint [peerAddr]))
-> STM
     m
     ([(HotValency, WarmValency,
        Map peerAddr (LocalRootConfig extraFlags))],
      Map DomainAccessPoint [peerAddr])
-> m ([(HotValency, WarmValency,
        Map peerAddr (LocalRootConfig extraFlags))],
      Map DomainAccessPoint [peerAddr])
forall a b. (a -> b) -> a -> b
$ do
                -- Read current DNS Domain Map value
                dnsDomainMap <- StrictTVar m (Map DomainAccessPoint [peerAddr])
-> STM m (Map DomainAccessPoint [peerAddr])
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Map DomainAccessPoint [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 =
                      DomainAccessPoint
-> [peerAddr]
-> Map DomainAccessPoint [peerAddr]
-> Map DomainAccessPoint [peerAddr]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert DomainAccessPoint
domain [peerAddr]
results' Map DomainAccessPoint [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 DomainAccessPoint [peerAddr]
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> [(HotValency, WarmValency,
     Map peerAddr (LocalRootConfig extraFlags))]
getLocalRootPeersGroups Map DomainAccessPoint [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 DomainAccessPoint [peerAddr]
                            -> [( HotValency
                                , WarmValency
                                , Map RelayAccessPoint (LocalRootConfig extraFlags))]
                            -> [( HotValency
                                , WarmValency
                                , Map peerAddr (LocalRootConfig extraFlags))]
    getLocalRootPeersGroups :: Map DomainAccessPoint [peerAddr]
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))]
-> [(HotValency, WarmValency,
     Map peerAddr (LocalRootConfig extraFlags))]
getLocalRootPeersGroups Map DomainAccessPoint [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
                             RelayDomainAccessPoint DomainAccessPoint
dap ->
                               let newEntries :: Map peerAddr (LocalRootConfig extraFlags)
newEntries = Map peerAddr (LocalRootConfig extraFlags)
-> ([(peerAddr, LocalRootConfig extraFlags)]
    -> Map peerAddr (LocalRootConfig extraFlags))
-> Maybe [(peerAddr, LocalRootConfig extraFlags)]
-> 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
                                              (Maybe [(peerAddr, LocalRootConfig extraFlags)]
 -> Map peerAddr (LocalRootConfig extraFlags))
-> Maybe [(peerAddr, LocalRootConfig extraFlags)]
-> Map peerAddr (LocalRootConfig extraFlags)
forall a b. (a -> b) -> a -> b
$ (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)
                                              ([peerAddr] -> [(peerAddr, LocalRootConfig extraFlags)])
-> Maybe [peerAddr]
-> Maybe [(peerAddr, LocalRootConfig extraFlags)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DomainAccessPoint
-> Map DomainAccessPoint [peerAddr] -> Maybe [peerAddr]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup DomainAccessPoint
dap Map DomainAccessPoint [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 []   = DNSError -> DiffTime -> DiffTime
ttlForDnsError DNSError
DNS.NameError DiffTime
0
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 :: DNS.DNSError -> DiffTime -> DiffTime
ttlForDnsError :: DNSError -> DiffTime -> DiffTime
ttlForDnsError DNSError
DNS.NameError DiffTime
_ = DiffTime
10800
ttlForDnsError DNSError
_           DiffTime
ttl = 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
-}