{-# 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 Network.Socket qualified as Socket

import Data.Bifunctor (second)
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 peerAddr exception =
       TraceLocalRootDomains (LocalRootPeers.Config RelayAccessPoint)
       -- ^ 'Int' is the configured valency for the local producer groups
     | TraceLocalRootWaiting DomainAccessPoint DiffTime
     | TraceLocalRootResult  DomainAccessPoint [(IP, DNS.TTL)]
     | TraceLocalRootGroups  (LocalRootPeers.Config 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 RelayAccessPoint) -- ^ Old value
                                  (LocalRootPeers.Config RelayAccessPoint) -- ^ New value
     | TraceLocalRootFailure DomainAccessPoint (DNSorIOError exception)
       --TODO: classify DNS errors, config error vs transitory
     | TraceLocalRootError   DomainAccessPoint SomeException
  deriving Int -> TraceLocalRootPeers peerAddr exception -> ShowS
[TraceLocalRootPeers peerAddr exception] -> ShowS
TraceLocalRootPeers peerAddr exception -> String
(Int -> TraceLocalRootPeers peerAddr exception -> ShowS)
-> (TraceLocalRootPeers peerAddr exception -> String)
-> ([TraceLocalRootPeers peerAddr exception] -> ShowS)
-> Show (TraceLocalRootPeers peerAddr exception)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall peerAddr exception.
(Show peerAddr, Show exception) =>
Int -> TraceLocalRootPeers peerAddr exception -> ShowS
forall peerAddr exception.
(Show peerAddr, Show exception) =>
[TraceLocalRootPeers peerAddr exception] -> ShowS
forall peerAddr exception.
(Show peerAddr, Show exception) =>
TraceLocalRootPeers peerAddr exception -> String
$cshowsPrec :: forall peerAddr exception.
(Show peerAddr, Show exception) =>
Int -> TraceLocalRootPeers peerAddr exception -> ShowS
showsPrec :: Int -> TraceLocalRootPeers peerAddr exception -> ShowS
$cshow :: forall peerAddr exception.
(Show peerAddr, Show exception) =>
TraceLocalRootPeers peerAddr exception -> String
show :: TraceLocalRootPeers peerAddr exception -> String
$cshowList :: forall peerAddr exception.
(Show peerAddr, Show exception) =>
[TraceLocalRootPeers peerAddr exception] -> ShowS
showList :: [TraceLocalRootPeers 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 peerAddr resolver exception.
     ( Alternative (STM m)
     , MonadAsync m
     , MonadDelay m
     , MonadThrow m
     , Ord peerAddr
     )
  => Tracer m (TraceLocalRootPeers peerAddr exception)
  -> (IP -> Socket.PortNumber -> peerAddr)
  -> DNS.ResolvConf
  -> DNSActions resolver exception m
  -> STM m [( HotValency
            , WarmValency
            , Map RelayAccessPoint LocalRootConfig)]
  -- ^ input
  -> StrictTVar m [( HotValency
                   , WarmValency
                   , Map peerAddr LocalRootConfig)]
  -- ^ output 'TVar'
  -> m Void
localRootPeersProvider :: forall (m :: * -> *) peerAddr resolver exception.
(Alternative (STM m), MonadAsync m, MonadDelay m, MonadThrow m,
 Ord peerAddr) =>
Tracer m (TraceLocalRootPeers peerAddr exception)
-> (IP -> PortNumber -> peerAddr)
-> ResolvConf
-> DNSActions resolver exception m
-> STM m (Config RelayAccessPoint)
-> StrictTVar
     m [(HotValency, WarmValency, Map peerAddr LocalRootConfig)]
-> m Void
localRootPeersProvider Tracer m (TraceLocalRootPeers peerAddr exception)
tracer
                       IP -> PortNumber -> peerAddr
toPeerAddr
                       ResolvConf
resolvConf
                       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
                       }
                       STM m (Config RelayAccessPoint)
readLocalRootPeers
                       StrictTVar
  m [(HotValency, WarmValency, Map peerAddr LocalRootConfig)]
rootPeersGroupVar =
        STM m (DNSSemaphore m, Config RelayAccessPoint)
-> m (DNSSemaphore m, Config RelayAccessPoint)
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (do domainsGroups <- STM m (Config RelayAccessPoint)
readLocalRootPeers
                       writeTVar rootPeersGroupVar (getLocalRootPeersGroups Map.empty domainsGroups)
                       dnsSemaphore <- newDNSLocalRootSemaphore
                       return (dnsSemaphore, domainsGroups))
    m (DNSSemaphore m, Config RelayAccessPoint)
-> ((DNSSemaphore m, Config RelayAccessPoint) -> 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 -> Config RelayAccessPoint -> m Void)
-> (DNSSemaphore m, Config RelayAccessPoint) -> m Void
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry DNSSemaphore m -> Config RelayAccessPoint -> 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)]
         -> m Void
    loop :: DNSSemaphore m -> Config RelayAccessPoint -> m Void
loop DNSSemaphore m
dnsSemaphore Config RelayAccessPoint
domainsGroups = do
      Tracer m (TraceLocalRootPeers peerAddr exception)
-> TraceLocalRootPeers peerAddr exception -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalRootPeers peerAddr exception)
tracer (Config RelayAccessPoint -> TraceLocalRootPeers peerAddr exception
forall peerAddr exception.
Config RelayAccessPoint -> TraceLocalRootPeers peerAddr exception
TraceLocalRootDomains Config RelayAccessPoint
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
m) <- Config RelayAccessPoint
domainsGroups
                    , (RelayDomainAccessPoint DomainAccessPoint
domain, LocalRootConfig
_) <- Map RelayAccessPoint LocalRootConfig
-> [(RelayAccessPoint, LocalRootConfig)]
forall k a. Map k a -> [(k, a)]
Map.toList Map RelayAccessPoint LocalRootConfig
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) (Config RelayAccessPoint))
-> m (Either
        (DomainAccessPoint, SomeException) (Config RelayAccessPoint))
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) (Config RelayAccessPoint))
 -> m (Either
         (DomainAccessPoint, SomeException) (Config RelayAccessPoint)))
-> STM
     m
     (Either
        (DomainAccessPoint, SomeException) (Config RelayAccessPoint))
-> m (Either
        (DomainAccessPoint, SomeException) (Config RelayAccessPoint))
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) (Config RelayAccessPoint)
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) (Config RelayAccessPoint))
-> STM
     m (DomainAccessPoint, Async m Void, Either SomeException Void)
-> STM
     m
     (Either
        (DomainAccessPoint, SomeException) (Config RelayAccessPoint))
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) (Config RelayAccessPoint))
-> STM
     m
     (Either
        (DomainAccessPoint, SomeException) (Config RelayAccessPoint))
-> STM
     m
     (Either
        (DomainAccessPoint, SomeException) (Config RelayAccessPoint))
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 (Config RelayAccessPoint)
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 peerAddr exception)
-> TraceLocalRootPeers peerAddr exception -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalRootPeers peerAddr exception)
tracer (DomainAccessPoint
-> SomeException -> TraceLocalRootPeers peerAddr exception
forall peerAddr exception.
DomainAccessPoint
-> SomeException -> TraceLocalRootPeers peerAddr exception
TraceLocalRootError DomainAccessPoint
domain SomeException
err)
                                  -- current domain groups haven't changed, we
                                  -- can return them
                                  m () -> m (Config RelayAccessPoint) -> m (Config RelayAccessPoint)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Config RelayAccessPoint -> m (Config RelayAccessPoint)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Config RelayAccessPoint
domainsGroups
            Right Config RelayAccessPoint
domainsGroups'  -> Tracer m (TraceLocalRootPeers peerAddr exception)
-> TraceLocalRootPeers peerAddr exception -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalRootPeers peerAddr exception)
tracer (Config RelayAccessPoint
-> Config RelayAccessPoint
-> TraceLocalRootPeers peerAddr exception
forall peerAddr exception.
Config RelayAccessPoint
-> Config RelayAccessPoint
-> TraceLocalRootPeers peerAddr exception
TraceLocalRootReconfigured Config RelayAccessPoint
domainsGroups Config RelayAccessPoint
domainsGroups')
                                  -- current domain groups changed, we should
                                  -- return them
                                  m () -> m (Config RelayAccessPoint) -> m (Config RelayAccessPoint)
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Config RelayAccessPoint -> m (Config RelayAccessPoint)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Config RelayAccessPoint
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 peerAddr exception
forall peerAddr exception.
DomainAccessPoint
-> DNSorIOError exception -> TraceLocalRootPeers peerAddr exception
TraceLocalRootFailure DomainAccessPoint
domain (DNSorIOError exception -> TraceLocalRootPeers peerAddr exception)
-> Tracer m (TraceLocalRootPeers 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 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 peerAddr exception)
-> TraceLocalRootPeers peerAddr exception -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalRootPeers peerAddr exception)
tracer (DomainAccessPoint
-> DiffTime -> TraceLocalRootPeers peerAddr exception
forall peerAddr exception.
DomainAccessPoint
-> DiffTime -> TraceLocalRootPeers 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)],
   Map DomainAccessPoint [peerAddr])
-> m ([(HotValency, WarmValency, Map peerAddr LocalRootConfig)],
      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)],
    Map DomainAccessPoint [peerAddr])
 -> m ([(HotValency, WarmValency, Map peerAddr LocalRootConfig)],
       Map DomainAccessPoint [peerAddr]))
-> STM
     m
     ([(HotValency, WarmValency, Map peerAddr LocalRootConfig)],
      Map DomainAccessPoint [peerAddr])
-> m ([(HotValency, WarmValency, Map peerAddr LocalRootConfig)],
      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]
-> Config RelayAccessPoint
-> [(HotValency, WarmValency, Map peerAddr LocalRootConfig)]
getLocalRootPeersGroups Map DomainAccessPoint [peerAddr]
newDNSDomainMap
                                              Config RelayAccessPoint
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)]
                            -> [( HotValency
                                , WarmValency
                                , Map peerAddr LocalRootConfig)]
    getLocalRootPeersGroups :: Map DomainAccessPoint [peerAddr]
-> Config RelayAccessPoint
-> [(HotValency, WarmValency, Map peerAddr LocalRootConfig)]
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)
 -> (HotValency, WarmValency, Map peerAddr LocalRootConfig))
-> Config RelayAccessPoint
-> [(HotValency, WarmValency, Map peerAddr LocalRootConfig)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Map RelayAccessPoint LocalRootConfig
 -> Map peerAddr LocalRootConfig)
-> (HotValency, WarmValency, Map RelayAccessPoint LocalRootConfig)
-> (HotValency, WarmValency, Map peerAddr LocalRootConfig)
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
 -> RelayAccessPoint
 -> LocalRootConfig
 -> Map peerAddr LocalRootConfig)
-> Map peerAddr LocalRootConfig
-> Map RelayAccessPoint LocalRootConfig
-> Map peerAddr LocalRootConfig
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey'
                      (\Map peerAddr LocalRootConfig
accMap RelayAccessPoint
rap LocalRootConfig
pa
                         -> case RelayAccessPoint
rap of
                             RelayAccessAddress IP
ip PortNumber
port ->
                               peerAddr
-> LocalRootConfig
-> Map peerAddr LocalRootConfig
-> Map peerAddr LocalRootConfig
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (IP -> PortNumber -> peerAddr
toPeerAddr IP
ip PortNumber
port) LocalRootConfig
pa Map peerAddr LocalRootConfig
accMap
                             RelayDomainAccessPoint DomainAccessPoint
dap ->
                               let newEntries :: Map peerAddr LocalRootConfig
newEntries = Map peerAddr LocalRootConfig
-> ([(peerAddr, LocalRootConfig)] -> Map peerAddr LocalRootConfig)
-> Maybe [(peerAddr, LocalRootConfig)]
-> Map peerAddr LocalRootConfig
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map peerAddr LocalRootConfig
forall k a. Map k a
Map.empty
                                                      [(peerAddr, LocalRootConfig)] -> Map peerAddr LocalRootConfig
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                                              (Maybe [(peerAddr, LocalRootConfig)]
 -> Map peerAddr LocalRootConfig)
-> Maybe [(peerAddr, LocalRootConfig)]
-> Map peerAddr LocalRootConfig
forall a b. (a -> b) -> a -> b
$ (peerAddr -> (peerAddr, LocalRootConfig))
-> [peerAddr] -> [(peerAddr, LocalRootConfig)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, LocalRootConfig
pa)
                                              ([peerAddr] -> [(peerAddr, LocalRootConfig)])
-> Maybe [peerAddr] -> Maybe [(peerAddr, LocalRootConfig)]
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
accMap Map peerAddr LocalRootConfig
-> Map peerAddr LocalRootConfig -> Map peerAddr LocalRootConfig
forall a. Semigroup a => a -> a -> a
<> Map peerAddr LocalRootConfig
newEntries
                      )
                   Map peerAddr LocalRootConfig
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
-}