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

module Ouroboros.Network.PeerSelection.RootPeersDNS
  ( -- * DNS based actions for local and public root providers
    DNSActions (..)
    -- * DNS resolver IO auxiliar functions
  , constantResource
    -- ** DNSActions IO
  , ioDNSActions
  , LookupReqs (..)
    -- * DNS based provider for local root peers
  , localRootPeersProvider
  , DomainAccessPoint (..)
  , RelayAccessPoint (..)
  , IP.IP (..)
  , TraceLocalRootPeers (..)
    -- * DNS based provider for public root peers
  , publicRootPeersProvider
  , TracePublicRootPeers (..)
    -- DNS lookup support
  , resolveDomainAccessPoint
    -- * DNS type re-exports
  , DNS.ResolvConf
  , DNS.Domain
  , DNS.TTL
    -- * Socket type re-exports
  , Socket.PortNumber
  ) where

import           Data.Foldable (foldlM)
import           Data.List (elemIndex)
import           Data.List.NonEmpty (NonEmpty (..))
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import           Data.Set (Set)
import qualified Data.Set as Set
import           Data.Void (Void, absurd)
import           Data.Word (Word32)

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


import qualified Data.IP as IP
import qualified Network.DNS as DNS
import qualified Network.Socket as Socket

import           Ouroboros.Network.PeerSelection.RelayAccessPoint
import           Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
                     (DNSActions (..), DNSorIOError (..), LookupReqs (..),
                     Resource (..), constantResource, ioDNSActions,
                     withResource')
import           Ouroboros.Network.PeerSelection.Types

-----------------------------------------------
-- local root peer set provider based on DNS
--

data TraceLocalRootPeers peerAddr exception =
       TraceLocalRootDomains [(Int, Map RelayAccessPoint PeerAdvertise)]
       -- ^ 'Int' is the configured valency for the local producer groups
     | TraceLocalRootWaiting DomainAccessPoint DiffTime
     | TraceLocalRootResult  DomainAccessPoint [(IP, DNS.TTL)]
     | TraceLocalRootGroups  (Seq (Int, Map peerAddr PeerAdvertise))
       -- ^ This traces the results of the local root peer provider
     | 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
showList :: [TraceLocalRootPeers peerAddr exception] -> ShowS
$cshowList :: forall peerAddr exception.
(Show peerAddr, Show exception) =>
[TraceLocalRootPeers peerAddr exception] -> ShowS
show :: TraceLocalRootPeers peerAddr exception -> String
$cshow :: forall peerAddr exception.
(Show peerAddr, Show exception) =>
TraceLocalRootPeers peerAddr exception -> String
showsPrec :: Int -> TraceLocalRootPeers peerAddr exception -> ShowS
$cshowsPrec :: forall peerAddr exception.
(Show peerAddr, Show exception) =>
Int -> 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.
     ( MonadAsync m
     , MonadDelay m
     , Eq (Async m Void)
     , Ord peerAddr
     )
  => Tracer m (TraceLocalRootPeers peerAddr exception)
  -> (IP -> Socket.PortNumber -> peerAddr)
  -> DNS.ResolvConf
  -> DNSActions resolver exception m
  -> STM m [(Int, Map RelayAccessPoint PeerAdvertise)]
  -- ^ input
  -> StrictTVar m (Seq (Int, Map peerAddr PeerAdvertise))
  -- ^ output 'TVar'
  -> m Void
localRootPeersProvider :: Tracer m (TraceLocalRootPeers peerAddr exception)
-> (IP -> PortNumber -> peerAddr)
-> ResolvConf
-> DNSActions resolver exception m
-> STM m [(Int, Map RelayAccessPoint PeerAdvertise)]
-> StrictTVar m (Seq (Int, Map peerAddr PeerAdvertise))
-> m Void
localRootPeersProvider Tracer m (TraceLocalRootPeers peerAddr exception)
tracer
                       IP -> PortNumber -> peerAddr
toPeerAddr
                       ResolvConf
resolvConf
                       DNSActions {
                         ResolvConf -> m (Resource m (DNSorIOError exception) resolver)
dnsAsyncResolverResource :: forall resolver exception (m :: * -> *).
DNSActions resolver exception m
-> ResolvConf -> m (Resource m (DNSorIOError exception) resolver)
dnsAsyncResolverResource :: ResolvConf -> m (Resource m (DNSorIOError exception) resolver)
dnsAsyncResolverResource,
                         ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, TTL)])
dnsLookupWithTTL :: forall resolver exception (m :: * -> *).
DNSActions resolver exception m
-> ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, TTL)])
dnsLookupWithTTL :: ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, TTL)])
dnsLookupWithTTL
                       }
                       STM m [(Int, Map RelayAccessPoint PeerAdvertise)]
readDomainsGroups
                       StrictTVar m (Seq (Int, Map peerAddr PeerAdvertise))
rootPeersGroupsVar =
    STM m [(Int, Map RelayAccessPoint PeerAdvertise)]
-> m [(Int, Map RelayAccessPoint PeerAdvertise)]
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m [(Int, Map RelayAccessPoint PeerAdvertise)]
readDomainsGroups m [(Int, Map RelayAccessPoint PeerAdvertise)]
-> ([(Int, Map RelayAccessPoint PeerAdvertise)] -> m Void)
-> m Void
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(Int, Map RelayAccessPoint PeerAdvertise)] -> m Void
forall b. [(Int, Map RelayAccessPoint PeerAdvertise)] -> m b
loop
  where
    loop :: [(Int, Map RelayAccessPoint PeerAdvertise)] -> m b
loop [(Int, Map RelayAccessPoint PeerAdvertise)]
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 ([(Int, Map RelayAccessPoint PeerAdvertise)]
-> TraceLocalRootPeers peerAddr exception
forall peerAddr exception.
[(Int, Map RelayAccessPoint PeerAdvertise)]
-> TraceLocalRootPeers peerAddr exception
TraceLocalRootDomains [(Int, Map RelayAccessPoint PeerAdvertise)]
domainsGroups)
      Resource m (DNSorIOError exception) resolver
rr <- ResolvConf -> m (Resource m (DNSorIOError exception) resolver)
dnsAsyncResolverResource ResolvConf
resolvConf
      let
          -- Flatten the local root peers groups and associate its index to
          -- each DomainAddress to be monitorized.
          -- NOTE: We need to pair the index because the resulting list can be
          -- sparse.
          domains :: [(Int, DomainAccessPoint, PeerAdvertise)]
          domains :: [(Int, DomainAccessPoint, PeerAdvertise)]
domains = [ (Int
index, DomainAccessPoint
domain, PeerAdvertise
pa)
                    | (Int
index, (Int
_, Map RelayAccessPoint PeerAdvertise
m)) <- [Int]
-> [(Int, Map RelayAccessPoint PeerAdvertise)]
-> [(Int, (Int, Map RelayAccessPoint PeerAdvertise))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [(Int, Map RelayAccessPoint PeerAdvertise)]
domainsGroups
                    , (RelayDomainAccessPoint DomainAccessPoint
domain, PeerAdvertise
pa) <- Map RelayAccessPoint PeerAdvertise
-> [(RelayAccessPoint, PeerAdvertise)]
forall k a. Map k a -> [(k, a)]
Map.toList Map RelayAccessPoint PeerAdvertise
m ]
          -- Since we want to preserve the number of groups, the targets, and
          -- the addresses within each group, we fill the TVar with
          -- a placeholder list, in order for each monitored DomainAddress to
          -- be updated in the correct group.
          --
          -- This is the static configuration.
          rootPeersGroups :: Seq (Int, Map peerAddr PeerAdvertise)
          rootPeersGroups :: Seq (Int, Map peerAddr PeerAdvertise)
rootPeersGroups = [(Int, Map peerAddr PeerAdvertise)]
-> Seq (Int, Map peerAddr PeerAdvertise)
forall a. [a] -> Seq a
Seq.fromList ([(Int, Map peerAddr PeerAdvertise)]
 -> Seq (Int, Map peerAddr PeerAdvertise))
-> [(Int, Map peerAddr PeerAdvertise)]
-> Seq (Int, Map peerAddr PeerAdvertise)
forall a b. (a -> b) -> a -> b
$ ((Int, Map RelayAccessPoint PeerAdvertise)
 -> (Int, Map peerAddr PeerAdvertise))
-> [(Int, Map RelayAccessPoint PeerAdvertise)]
-> [(Int, Map peerAddr PeerAdvertise)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
target, Map RelayAccessPoint PeerAdvertise
m) -> (Int
target, Map RelayAccessPoint PeerAdvertise -> Map peerAddr PeerAdvertise
f Map RelayAccessPoint PeerAdvertise
m)) [(Int, Map RelayAccessPoint PeerAdvertise)]
domainsGroups
            where
               f :: Map RelayAccessPoint PeerAdvertise
                 -> Map peerAddr PeerAdvertise
               f :: Map RelayAccessPoint PeerAdvertise -> Map peerAddr PeerAdvertise
f = (RelayAccessPoint -> peerAddr)
-> Map RelayAccessPoint PeerAdvertise -> Map peerAddr PeerAdvertise
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys
                     (\RelayAccessPoint
k -> case RelayAccessPoint
k of
                       RelayAccessAddress IP
ip PortNumber
port ->
                         IP -> PortNumber -> peerAddr
toPeerAddr IP
ip PortNumber
port
                       RelayAccessPoint
_ ->
                         String -> peerAddr
forall a. HasCallStack => String -> a
error String
"localRootPeersProvider: impossible happened"
                     )
                 (Map RelayAccessPoint PeerAdvertise -> Map peerAddr PeerAdvertise)
-> (Map RelayAccessPoint PeerAdvertise
    -> Map RelayAccessPoint PeerAdvertise)
-> Map RelayAccessPoint PeerAdvertise
-> Map peerAddr PeerAdvertise
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RelayAccessPoint -> PeerAdvertise -> Bool)
-> Map RelayAccessPoint PeerAdvertise
-> Map RelayAccessPoint PeerAdvertise
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey
                     (\RelayAccessPoint
k PeerAdvertise
_ -> case RelayAccessPoint
k of
                       RelayAccessAddress {} -> Bool
True
                       RelayAccessDomain {}  -> Bool
False
                     )
      STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$
        StrictTVar m (Seq (Int, Map peerAddr PeerAdvertise))
-> Seq (Int, Map peerAddr PeerAdvertise) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Seq (Int, Map peerAddr PeerAdvertise))
rootPeersGroupsVar Seq (Int, Map peerAddr PeerAdvertise)
rootPeersGroups
      Tracer m (TraceLocalRootPeers peerAddr exception)
-> TraceLocalRootPeers peerAddr exception -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalRootPeers peerAddr exception)
tracer (Seq (Int, Map peerAddr PeerAdvertise)
-> TraceLocalRootPeers peerAddr exception
forall peerAddr exception.
Seq (Int, Map peerAddr PeerAdvertise)
-> TraceLocalRootPeers peerAddr exception
TraceLocalRootGroups Seq (Int, Map peerAddr PeerAdvertise)
rootPeersGroups)

      -- Launch DomainAddress monitoring threads and wait for threads to error
      -- or for local configuration changes.
      [(Int, Map RelayAccessPoint PeerAdvertise)]
domainsGroups' <-
        [m Void]
-> ([Async m Void]
    -> m [(Int, Map RelayAccessPoint PeerAdvertise)])
-> m [(Int, Map RelayAccessPoint PeerAdvertise)]
forall (m :: * -> *) a b.
MonadAsync m =>
[m a] -> ([Async m a] -> m b) -> m b
withAsyncAll (Resource m (DNSorIOError exception) resolver
-> Seq (Int, Map peerAddr PeerAdvertise)
-> (Int, DomainAccessPoint, PeerAdvertise)
-> m Void
monitorDomain Resource m (DNSorIOError exception) resolver
rr Seq (Int, Map peerAddr PeerAdvertise)
rootPeersGroups ((Int, DomainAccessPoint, PeerAdvertise) -> m Void)
-> [(Int, DomainAccessPoint, PeerAdvertise)] -> [m Void]
forall a b. (a -> b) -> [a] -> [b]
`map` [(Int, DomainAccessPoint, PeerAdvertise)]
domains) (([Async m Void] -> m [(Int, Map RelayAccessPoint PeerAdvertise)])
 -> m [(Int, Map RelayAccessPoint PeerAdvertise)])
-> ([Async m Void]
    -> m [(Int, Map RelayAccessPoint PeerAdvertise)])
-> m [(Int, Map RelayAccessPoint PeerAdvertise)]
forall a b. (a -> b) -> a -> b
$ \[Async m Void]
as -> do
          Either
  (DomainAccessPoint, SomeException)
  [(Int, Map RelayAccessPoint PeerAdvertise)]
res <- STM
  m
  (Either
     (DomainAccessPoint, SomeException)
     [(Int, Map RelayAccessPoint PeerAdvertise)])
-> m (Either
        (DomainAccessPoint, SomeException)
        [(Int, Map RelayAccessPoint PeerAdvertise)])
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM
   m
   (Either
      (DomainAccessPoint, SomeException)
      [(Int, Map RelayAccessPoint PeerAdvertise)])
 -> m (Either
         (DomainAccessPoint, SomeException)
         [(Int, Map RelayAccessPoint PeerAdvertise)]))
-> STM
     m
     (Either
        (DomainAccessPoint, SomeException)
        [(Int, Map RelayAccessPoint PeerAdvertise)])
-> m (Either
        (DomainAccessPoint, SomeException)
        [(Int, Map RelayAccessPoint PeerAdvertise)])
forall a b. (a -> b) -> a -> b
$
                  -- wait until any of the monitoring threads errors
                  ((\(Async m Void
a, Either SomeException Void
res) ->
                      let domain :: DomainAccessPoint
                          domain :: DomainAccessPoint
domain = case Async m Void
a Async m Void -> [Async m Void] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` [Async m Void]
as of
                            Maybe Int
Nothing  -> String -> DomainAccessPoint
forall a. HasCallStack => String -> a
error String
"localRootPeersProvider: impossible happened"
                            Just Int
idx -> case ([(Int, DomainAccessPoint, PeerAdvertise)]
domains [(Int, DomainAccessPoint, PeerAdvertise)]
-> Int -> (Int, DomainAccessPoint, PeerAdvertise)
forall a. [a] -> Int -> a
!! Int
idx) of (Int
_, DomainAccessPoint
x, PeerAdvertise
_) -> DomainAccessPoint
x
                      in (SomeException
 -> Either
      (DomainAccessPoint, SomeException)
      [(Int, Map RelayAccessPoint PeerAdvertise)])
-> (Void
    -> Either
         (DomainAccessPoint, SomeException)
         [(Int, Map RelayAccessPoint PeerAdvertise)])
-> Either SomeException Void
-> Either
     (DomainAccessPoint, SomeException)
     [(Int, Map RelayAccessPoint PeerAdvertise)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((DomainAccessPoint, SomeException)
-> Either
     (DomainAccessPoint, SomeException)
     [(Int, Map RelayAccessPoint PeerAdvertise)]
forall a b. a -> Either a b
Left ((DomainAccessPoint, SomeException)
 -> Either
      (DomainAccessPoint, SomeException)
      [(Int, Map RelayAccessPoint PeerAdvertise)])
-> (SomeException -> (DomainAccessPoint, SomeException))
-> SomeException
-> Either
     (DomainAccessPoint, SomeException)
     [(Int, Map RelayAccessPoint PeerAdvertise)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DomainAccessPoint
domain,)) Void
-> Either
     (DomainAccessPoint, SomeException)
     [(Int, Map RelayAccessPoint PeerAdvertise)]
forall a. Void -> a
absurd Either SomeException Void
res)
                    -- the monitoring thread cannot return, it can only error
                    ((Async m Void, Either SomeException Void)
 -> Either
      (DomainAccessPoint, SomeException)
      [(Int, Map RelayAccessPoint PeerAdvertise)])
-> STM m (Async m Void, Either SomeException Void)
-> STM
     m
     (Either
        (DomainAccessPoint, SomeException)
        [(Int, Map RelayAccessPoint PeerAdvertise)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Async m Void] -> STM m (Async m Void, Either SomeException Void)
forall (m :: * -> *) a.
MonadAsync m =>
[Async m a] -> STM m (Async m a, Either SomeException a)
waitAnyCatchSTM [Async m Void]
as)
              STM
  m
  (Either
     (DomainAccessPoint, SomeException)
     [(Int, Map RelayAccessPoint PeerAdvertise)])
-> STM
     m
     (Either
        (DomainAccessPoint, SomeException)
        [(Int, Map RelayAccessPoint PeerAdvertise)])
-> STM
     m
     (Either
        (DomainAccessPoint, SomeException)
        [(Int, Map RelayAccessPoint PeerAdvertise)])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                  -- wait for configuraiton changes
                  (do [(Int, Map RelayAccessPoint PeerAdvertise)]
a <- STM m [(Int, Map RelayAccessPoint PeerAdvertise)]
readDomainsGroups
                      -- wait until the input domains groups changes
                      Bool -> STM m ()
forall (m :: * -> *). MonadSTM m => Bool -> STM m ()
check ([(Int, Map RelayAccessPoint PeerAdvertise)]
a [(Int, Map RelayAccessPoint PeerAdvertise)]
-> [(Int, Map RelayAccessPoint PeerAdvertise)] -> Bool
forall a. Eq a => a -> a -> Bool
/= [(Int, Map RelayAccessPoint PeerAdvertise)]
domainsGroups)
                      Either
  (DomainAccessPoint, SomeException)
  [(Int, Map RelayAccessPoint PeerAdvertise)]
-> STM
     m
     (Either
        (DomainAccessPoint, SomeException)
        [(Int, Map RelayAccessPoint PeerAdvertise)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Int, Map RelayAccessPoint PeerAdvertise)]
-> Either
     (DomainAccessPoint, SomeException)
     [(Int, Map RelayAccessPoint PeerAdvertise)]
forall a b. b -> Either a b
Right [(Int, Map RelayAccessPoint PeerAdvertise)]
a))
          case Either
  (DomainAccessPoint, SomeException)
  [(Int, Map RelayAccessPoint PeerAdvertise)]
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 [(Int, Map RelayAccessPoint PeerAdvertise)]
-> m [(Int, Map RelayAccessPoint PeerAdvertise)]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(Int, Map RelayAccessPoint PeerAdvertise)]
-> m [(Int, Map RelayAccessPoint PeerAdvertise)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int, Map RelayAccessPoint PeerAdvertise)]
domainsGroups
            Right [(Int, Map RelayAccessPoint PeerAdvertise)]
domainsGroups'  -> [(Int, Map RelayAccessPoint PeerAdvertise)]
-> m [(Int, Map RelayAccessPoint PeerAdvertise)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int, Map RelayAccessPoint PeerAdvertise)]
domainsGroups'
      -- we continue the loop outside of 'withAsyncAll',  this makes sure that
      -- all the monitoring threads are killed.
      [(Int, Map RelayAccessPoint PeerAdvertise)] -> m b
loop [(Int, Map RelayAccessPoint PeerAdvertise)]
domainsGroups'


    resolveDomain
      :: resolver
      -> DomainAccessPoint
      -> PeerAdvertise
      -> m (Either [DNS.DNSError] [((peerAddr, PeerAdvertise), DNS.TTL)])
    resolveDomain :: resolver
-> DomainAccessPoint
-> PeerAdvertise
-> m (Either [DNSError] [((peerAddr, PeerAdvertise), TTL)])
resolveDomain resolver
resolver
                  domain :: DomainAccessPoint
domain@DomainAccessPoint {Domain
dapDomain :: DomainAccessPoint -> Domain
dapDomain :: Domain
dapDomain, PortNumber
dapPortNumber :: DomainAccessPoint -> PortNumber
dapPortNumber :: PortNumber
dapPortNumber}
                  PeerAdvertise
advertisePeer = do
      ([DNSError]
errs, [(IP, TTL)]
results) <- ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, TTL)])
dnsLookupWithTTL ResolvConf
resolvConf resolver
resolver Domain
dapDomain
      (DNSError -> m ()) -> [DNSError] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Tracer m (TraceLocalRootPeers peerAddr exception)
-> TraceLocalRootPeers peerAddr exception -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalRootPeers peerAddr exception)
tracer (TraceLocalRootPeers peerAddr exception -> m ())
-> (DNSError -> TraceLocalRootPeers peerAddr exception)
-> DNSError
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DomainAccessPoint
-> DNSorIOError exception -> TraceLocalRootPeers peerAddr exception
forall peerAddr exception.
DomainAccessPoint
-> DNSorIOError exception -> TraceLocalRootPeers peerAddr exception
TraceLocalRootFailure DomainAccessPoint
domain (DNSorIOError exception -> TraceLocalRootPeers peerAddr exception)
-> (DNSError -> DNSorIOError exception)
-> DNSError
-> TraceLocalRootPeers peerAddr exception
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSError -> DNSorIOError exception
forall exception. DNSError -> DNSorIOError exception
DNSError)
            [DNSError]
errs

      if [DNSError] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DNSError]
errs
         then 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
-> [(IP, TTL)] -> TraceLocalRootPeers peerAddr exception
forall peerAddr exception.
DomainAccessPoint
-> [(IP, TTL)] -> TraceLocalRootPeers peerAddr exception
TraceLocalRootResult DomainAccessPoint
domain [(IP, TTL)]
results)
           Either [DNSError] [((peerAddr, PeerAdvertise), TTL)]
-> m (Either [DNSError] [((peerAddr, PeerAdvertise), TTL)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [DNSError] [((peerAddr, PeerAdvertise), TTL)]
 -> m (Either [DNSError] [((peerAddr, PeerAdvertise), TTL)]))
-> Either [DNSError] [((peerAddr, PeerAdvertise), TTL)]
-> m (Either [DNSError] [((peerAddr, PeerAdvertise), TTL)])
forall a b. (a -> b) -> a -> b
$ [((peerAddr, PeerAdvertise), TTL)]
-> Either [DNSError] [((peerAddr, PeerAdvertise), TTL)]
forall a b. b -> Either a b
Right [ (( IP -> PortNumber -> peerAddr
toPeerAddr IP
addr PortNumber
dapPortNumber
                            , PeerAdvertise
advertisePeer)
                            , TTL
_ttl)
                          | (IP
addr, TTL
_ttl) <- [(IP, TTL)]
results ]
         else Either [DNSError] [((peerAddr, PeerAdvertise), TTL)]
-> m (Either [DNSError] [((peerAddr, PeerAdvertise), TTL)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [DNSError] [((peerAddr, PeerAdvertise), TTL)]
 -> m (Either [DNSError] [((peerAddr, PeerAdvertise), TTL)]))
-> Either [DNSError] [((peerAddr, PeerAdvertise), TTL)]
-> m (Either [DNSError] [((peerAddr, PeerAdvertise), TTL)])
forall a b. (a -> b) -> a -> b
$ [DNSError] -> Either [DNSError] [((peerAddr, PeerAdvertise), TTL)]
forall a b. a -> Either a b
Left [DNSError]
errs

    monitorDomain
      :: Resource m (DNSorIOError exception) resolver
      -> Seq (Int, Map peerAddr PeerAdvertise)
      -- ^ Static configuration, this always comes from the source
      -- STM transaction 'readDomainGroups'.
      -> (Int, DomainAccessPoint, PeerAdvertise)
      -> m Void
    monitorDomain :: Resource m (DNSorIOError exception) resolver
-> Seq (Int, Map peerAddr PeerAdvertise)
-> (Int, DomainAccessPoint, PeerAdvertise)
-> m Void
monitorDomain Resource m (DNSorIOError exception) resolver
rr0 Seq (Int, Map peerAddr PeerAdvertise)
rpgStatic (Int
index, DomainAccessPoint
domain, PeerAdvertise
advertisePeer) =
        Resource m (DNSorIOError exception) resolver -> DiffTime -> m Void
go Resource m (DNSorIOError exception) resolver
rr0 DiffTime
0
      where
        go :: Resource m (DNSorIOError exception) resolver
           -> DiffTime
           -> m Void
        go :: Resource m (DNSorIOError exception) resolver -> DiffTime -> m Void
go !Resource m (DNSorIOError exception) resolver
rr !DiffTime
ttl = 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
resolver, Resource m (DNSorIOError exception) resolver
rrNext) <-
            Tracer m (DNSorIOError exception)
-> NonEmpty DiffTime
-> Resource m (DNSorIOError exception) resolver
-> m (resolver, Resource m (DNSorIOError exception) resolver)
forall (m :: * -> *) err a.
MonadDelay m =>
Tracer m err
-> NonEmpty DiffTime -> Resource m err a -> m (a, Resource m err a)
withResource' (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 (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> 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 (DNSorIOError exception) resolver
rr

          Either [DNSError] [((peerAddr, PeerAdvertise), TTL)]
reply <- resolver
-> DomainAccessPoint
-> PeerAdvertise
-> m (Either [DNSError] [((peerAddr, PeerAdvertise), TTL)])
resolveDomain resolver
resolver DomainAccessPoint
domain PeerAdvertise
advertisePeer
          case Either [DNSError] [((peerAddr, PeerAdvertise), TTL)]
reply of
            Left [DNSError]
errs -> Resource m (DNSorIOError exception) resolver -> DiffTime -> m Void
go Resource m (DNSorIOError exception) resolver
rrNext
                           ([DiffTime] -> DiffTime
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)
            Right [((peerAddr, PeerAdvertise), TTL)]
results -> do
              Seq (Int, Map peerAddr PeerAdvertise)
rootPeersGroups <- STM m (Seq (Int, Map peerAddr PeerAdvertise))
-> m (Seq (Int, Map peerAddr PeerAdvertise))
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Seq (Int, Map peerAddr PeerAdvertise))
 -> m (Seq (Int, Map peerAddr PeerAdvertise)))
-> STM m (Seq (Int, Map peerAddr PeerAdvertise))
-> m (Seq (Int, Map peerAddr PeerAdvertise))
forall a b. (a -> b) -> a -> b
$ do
                Seq (Int, Map peerAddr PeerAdvertise)
rootPeersGroups <- StrictTVar m (Seq (Int, Map peerAddr PeerAdvertise))
-> STM m (Seq (Int, Map peerAddr PeerAdvertise))
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Seq (Int, Map peerAddr PeerAdvertise))
rootPeersGroupsVar
                    -- We should get the entry from the static configuration in
                    -- order to garbage collect old lookup values for this
                    -- entry. It's important not to overwrite the statically
                    -- configured IPs, that's why we get the entry from the
                    -- statically configured rootPeersGroups list.
                    --
                let (Int
target, Map peerAddr PeerAdvertise
entry)  = Seq (Int, Map peerAddr PeerAdvertise)
rpgStatic Seq (Int, Map peerAddr PeerAdvertise)
-> Int -> (Int, Map peerAddr PeerAdvertise)
forall a. Seq a -> Int -> a
`Seq.index` Int
index
                    resultsMap :: Map peerAddr PeerAdvertise
resultsMap       = [(peerAddr, PeerAdvertise)] -> Map peerAddr PeerAdvertise
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((((peerAddr, PeerAdvertise), TTL) -> (peerAddr, PeerAdvertise))
-> [((peerAddr, PeerAdvertise), TTL)]
-> [(peerAddr, PeerAdvertise)]
forall a b. (a -> b) -> [a] -> [b]
map ((peerAddr, PeerAdvertise), TTL) -> (peerAddr, PeerAdvertise)
forall a b. (a, b) -> a
fst [((peerAddr, PeerAdvertise), TTL)]
results)
                    -- Discard old values and only keep current lookup result.
                    --
                    -- Since the 'loop' function always receives the groups read
                    -- from the source stm transaction 'readDomainGroups', we
                    -- need to merge against it (because it has the statically
                    -- configurated IPs) and not what is read from the TVar
                    -- 'rootPeersGroupsVar'.
                    entry' :: Map peerAddr PeerAdvertise
entry'           = Map peerAddr PeerAdvertise
resultsMap Map peerAddr PeerAdvertise
-> Map peerAddr PeerAdvertise -> Map peerAddr PeerAdvertise
forall a. Semigroup a => a -> a -> a
<> Map peerAddr PeerAdvertise
entry
                    rootPeersGroups' :: Seq (Int, Map peerAddr PeerAdvertise)
rootPeersGroups' =
                      Int
-> (Int, Map peerAddr PeerAdvertise)
-> Seq (Int, Map peerAddr PeerAdvertise)
-> Seq (Int, Map peerAddr PeerAdvertise)
forall a. Int -> a -> Seq a -> Seq a
Seq.update Int
index
                                 (Int
target, Map peerAddr PeerAdvertise
entry')
                                 Seq (Int, Map peerAddr PeerAdvertise)
rootPeersGroups

                -- Only overwrite if it changed:
                Bool -> STM m () -> STM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map peerAddr PeerAdvertise
entry Map peerAddr PeerAdvertise -> Map peerAddr PeerAdvertise -> Bool
forall a. Eq a => a -> a -> Bool
/= Map peerAddr PeerAdvertise
entry') (STM m () -> STM m ()) -> STM m () -> STM m ()
forall a b. (a -> b) -> a -> b
$
                  StrictTVar m (Seq (Int, Map peerAddr PeerAdvertise))
-> Seq (Int, Map peerAddr PeerAdvertise) -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Seq (Int, Map peerAddr PeerAdvertise))
rootPeersGroupsVar Seq (Int, Map peerAddr PeerAdvertise)
rootPeersGroups'

                Seq (Int, Map peerAddr PeerAdvertise)
-> STM m (Seq (Int, Map peerAddr PeerAdvertise))
forall (m :: * -> *) a. Monad m => a -> m a
return Seq (Int, Map peerAddr PeerAdvertise)
rootPeersGroups'

              Tracer m (TraceLocalRootPeers peerAddr exception)
-> TraceLocalRootPeers peerAddr exception -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceLocalRootPeers peerAddr exception)
tracer (Seq (Int, Map peerAddr PeerAdvertise)
-> TraceLocalRootPeers peerAddr exception
forall peerAddr exception.
Seq (Int, Map peerAddr PeerAdvertise)
-> TraceLocalRootPeers peerAddr exception
TraceLocalRootGroups Seq (Int, Map peerAddr PeerAdvertise)
rootPeersGroups)
              Resource m (DNSorIOError exception) resolver -> DiffTime -> m Void
go Resource m (DNSorIOError exception) resolver
rrNext ([TTL] -> DiffTime
ttlForResults ((((peerAddr, PeerAdvertise), TTL) -> TTL)
-> [((peerAddr, PeerAdvertise), TTL)] -> [TTL]
forall a b. (a -> b) -> [a] -> [b]
map ((peerAddr, PeerAdvertise), TTL) -> TTL
forall a b. (a, b) -> b
snd [((peerAddr, PeerAdvertise), TTL)]
results))

---------------------------------------------
-- Public root peer set provider using DNS
--

data TracePublicRootPeers =
       TracePublicRootRelayAccessPoint [RelayAccessPoint]
     | TracePublicRootDomains [DomainAccessPoint]
     | TracePublicRootResult  DNS.Domain [(IP, DNS.TTL)]
     | TracePublicRootFailure DNS.Domain DNS.DNSError
       --TODO: classify DNS errors, config error vs transitory
  deriving Int -> TracePublicRootPeers -> ShowS
[TracePublicRootPeers] -> ShowS
TracePublicRootPeers -> String
(Int -> TracePublicRootPeers -> ShowS)
-> (TracePublicRootPeers -> String)
-> ([TracePublicRootPeers] -> ShowS)
-> Show TracePublicRootPeers
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TracePublicRootPeers] -> ShowS
$cshowList :: [TracePublicRootPeers] -> ShowS
show :: TracePublicRootPeers -> String
$cshow :: TracePublicRootPeers -> String
showsPrec :: Int -> TracePublicRootPeers -> ShowS
$cshowsPrec :: Int -> TracePublicRootPeers -> ShowS
Show

-- |
-- TODO track PeerAdvertise
--
publicRootPeersProvider
  :: forall peerAddr resolver exception a m.
     (MonadThrow m, MonadAsync m, Exception exception,
      Ord peerAddr)
  => Tracer m TracePublicRootPeers
  -> (IP -> Socket.PortNumber -> peerAddr)
  -> DNS.ResolvConf
  -> STM m [RelayAccessPoint]
  -> DNSActions resolver exception m
  -> ((Int -> m (Set peerAddr, DiffTime)) -> m a)
  -> m a
publicRootPeersProvider :: Tracer m TracePublicRootPeers
-> (IP -> PortNumber -> peerAddr)
-> ResolvConf
-> STM m [RelayAccessPoint]
-> DNSActions resolver exception m
-> ((Int -> m (Set peerAddr, DiffTime)) -> m a)
-> m a
publicRootPeersProvider Tracer m TracePublicRootPeers
tracer
                        IP -> PortNumber -> peerAddr
toPeerAddr
                        ResolvConf
resolvConf
                        STM m [RelayAccessPoint]
readDomains
                        DNSActions {
                          ResolvConf -> m (Resource m (DNSorIOError exception) resolver)
dnsResolverResource :: forall resolver exception (m :: * -> *).
DNSActions resolver exception m
-> ResolvConf -> m (Resource m (DNSorIOError exception) resolver)
dnsResolverResource :: ResolvConf -> m (Resource m (DNSorIOError exception) resolver)
dnsResolverResource,
                          ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, TTL)])
dnsLookupWithTTL :: ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, TTL)])
dnsLookupWithTTL :: forall resolver exception (m :: * -> *).
DNSActions resolver exception m
-> ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, TTL)])
dnsLookupWithTTL
                        }
                        (Int -> m (Set peerAddr, DiffTime)) -> m a
action = do
    [RelayAccessPoint]
domains <- STM m [RelayAccessPoint] -> m [RelayAccessPoint]
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m [RelayAccessPoint]
readDomains
    Tracer m TracePublicRootPeers -> TracePublicRootPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TracePublicRootPeers
tracer ([RelayAccessPoint] -> TracePublicRootPeers
TracePublicRootRelayAccessPoint [RelayAccessPoint]
domains)
    Resource m (DNSorIOError exception) resolver
rr <- ResolvConf -> m (Resource m (DNSorIOError exception) resolver)
dnsResolverResource ResolvConf
resolvConf
    StrictTVar m (Resource m (DNSorIOError exception) resolver)
resourceVar <- Resource m (DNSorIOError exception) resolver
-> m (StrictTVar m (Resource m (DNSorIOError exception) resolver))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO Resource m (DNSorIOError exception) resolver
rr
    (Int -> m (Set peerAddr, DiffTime)) -> m a
action (StrictTVar m (Resource m (DNSorIOError exception) resolver)
-> Int -> m (Set peerAddr, DiffTime)
requestPublicRootPeers StrictTVar m (Resource m (DNSorIOError exception) resolver)
resourceVar)
  where
    processResult :: (DomainAccessPoint, ([DNS.DNSError], [(IP, DNS.TTL)]))
                  -> m (DomainAccessPoint, [(IP, DNS.TTL)])
    processResult :: (DomainAccessPoint, ([DNSError], [(IP, TTL)]))
-> m (DomainAccessPoint, [(IP, TTL)])
processResult (DomainAccessPoint
domain, ([DNSError]
errs, [(IP, TTL)]
result)) = do
        (DNSError -> m ()) -> [DNSError] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Tracer m TracePublicRootPeers -> TracePublicRootPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TracePublicRootPeers
tracer (TracePublicRootPeers -> m ())
-> (DNSError -> TracePublicRootPeers) -> DNSError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> DNSError -> TracePublicRootPeers
TracePublicRootFailure (DomainAccessPoint -> Domain
dapDomain DomainAccessPoint
domain))
              [DNSError]
errs
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(IP, TTL)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(IP, TTL)]
result) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            Tracer m TracePublicRootPeers -> TracePublicRootPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TracePublicRootPeers
tracer (TracePublicRootPeers -> m ()) -> TracePublicRootPeers -> m ()
forall a b. (a -> b) -> a -> b
$ Domain -> [(IP, TTL)] -> TracePublicRootPeers
TracePublicRootResult (DomainAccessPoint -> Domain
dapDomain DomainAccessPoint
domain) [(IP, TTL)]
result

        (DomainAccessPoint, [(IP, TTL)])
-> m (DomainAccessPoint, [(IP, TTL)])
forall (m :: * -> *) a. Monad m => a -> m a
return (DomainAccessPoint
domain, [(IP, TTL)]
result)

    requestPublicRootPeers
      :: StrictTVar m (Resource m (DNSorIOError exception) resolver)
      -> Int
      -> m (Set peerAddr, DiffTime)
    requestPublicRootPeers :: StrictTVar m (Resource m (DNSorIOError exception) resolver)
-> Int -> m (Set peerAddr, DiffTime)
requestPublicRootPeers StrictTVar m (Resource m (DNSorIOError exception) resolver)
resourceVar Int
_numRequested = do
        [RelayAccessPoint]
domains <- STM m [RelayAccessPoint] -> m [RelayAccessPoint]
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically STM m [RelayAccessPoint]
readDomains
        Tracer m TracePublicRootPeers -> TracePublicRootPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TracePublicRootPeers
tracer ([RelayAccessPoint] -> TracePublicRootPeers
TracePublicRootRelayAccessPoint [RelayAccessPoint]
domains)
        Resource m (DNSorIOError exception) resolver
rr <- STM m (Resource m (DNSorIOError exception) resolver)
-> m (Resource m (DNSorIOError exception) resolver)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Resource m (DNSorIOError exception) resolver)
 -> m (Resource m (DNSorIOError exception) resolver))
-> STM m (Resource m (DNSorIOError exception) resolver)
-> m (Resource m (DNSorIOError exception) resolver)
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Resource m (DNSorIOError exception) resolver)
-> STM m (Resource m (DNSorIOError exception) resolver)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Resource m (DNSorIOError exception) resolver)
resourceVar
        (Either (DNSorIOError exception) resolver
er, Resource m (DNSorIOError exception) resolver
rr') <- Resource m (DNSorIOError exception) resolver
-> m (Either (DNSorIOError exception) resolver,
      Resource m (DNSorIOError exception) resolver)
forall (m :: * -> *) err a.
Resource m err a -> m (Either err a, Resource m err a)
withResource Resource m (DNSorIOError exception) resolver
rr
        STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Resource m (DNSorIOError exception) resolver)
-> Resource m (DNSorIOError exception) resolver -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Resource m (DNSorIOError exception) resolver)
resourceVar Resource m (DNSorIOError exception) resolver
rr'
        case Either (DNSorIOError exception) resolver
er of
          Left (DNSError DNSError
err) -> DNSError -> m (Set peerAddr, DiffTime)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO DNSError
err
          Left (IOError  exception
err) -> exception -> m (Set peerAddr, DiffTime)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO exception
err
          Right resolver
resolver -> do
            let lookups :: [m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
lookups =
                  [ (,) (Domain -> PortNumber -> DomainAccessPoint
DomainAccessPoint Domain
domain PortNumber
port)
                      (([DNSError], [(IP, TTL)])
 -> (DomainAccessPoint, ([DNSError], [(IP, TTL)])))
-> m ([DNSError], [(IP, TTL)])
-> m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, TTL)])
dnsLookupWithTTL
                            ResolvConf
resolvConf
                            resolver
resolver
                            Domain
domain
                  | RelayAccessDomain Domain
domain PortNumber
port <- [RelayAccessPoint]
domains ]
            -- The timeouts here are handled by the 'lookupWithTTL'. They're
            -- configured via the DNS.ResolvConf resolvTimeout field and defaults
            -- to 3 sec.
            [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
results <- [m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
-> ([Async m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
    -> m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))])
-> m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
forall (m :: * -> *) a b.
MonadAsync m =>
[m a] -> ([Async m a] -> m b) -> m b
withAsyncAll [m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
lookups (STM m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
-> m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
 -> m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))])
-> ([Async m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
    -> STM m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))])
-> [Async m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
-> m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Async m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))
 -> STM m (DomainAccessPoint, ([DNSError], [(IP, TTL)])))
-> [Async m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
-> STM m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Async m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))
-> STM m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))
forall (m :: * -> *) a. MonadAsync m => Async m a -> STM m a
waitSTM)
            [(DomainAccessPoint, [(IP, TTL)])]
results' <- ((DomainAccessPoint, ([DNSError], [(IP, TTL)]))
 -> m (DomainAccessPoint, [(IP, TTL)]))
-> [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
-> m [(DomainAccessPoint, [(IP, TTL)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (DomainAccessPoint, ([DNSError], [(IP, TTL)]))
-> m (DomainAccessPoint, [(IP, TTL)])
processResult [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
results
            let successes :: [(peerAddr, TTL)]
successes = [ ( IP -> PortNumber -> peerAddr
toPeerAddr IP
ip PortNumber
dapPortNumber
                              , TTL
ipttl)
                            | ( DomainAccessPoint {PortNumber
dapPortNumber :: PortNumber
dapPortNumber :: DomainAccessPoint -> PortNumber
dapPortNumber}
                              , [(IP, TTL)]
ipttls) <- [(DomainAccessPoint, [(IP, TTL)])]
results'
                            , (IP
ip, TTL
ipttl) <- [(IP, TTL)]
ipttls
                            ]
                !domainsIps :: [peerAddr]
domainsIps = [IP -> PortNumber -> peerAddr
toPeerAddr IP
ip PortNumber
port
                              | RelayAccessAddress IP
ip PortNumber
port <- [RelayAccessPoint]
domains ]
                !ips :: Set peerAddr
ips      = [peerAddr] -> Set peerAddr
forall a. Ord a => [a] -> Set a
Set.fromList  (((peerAddr, TTL) -> peerAddr) -> [(peerAddr, TTL)] -> [peerAddr]
forall a b. (a -> b) -> [a] -> [b]
map (peerAddr, TTL) -> peerAddr
forall a b. (a, b) -> a
fst [(peerAddr, TTL)]
successes [peerAddr] -> [peerAddr] -> [peerAddr]
forall a. [a] -> [a] -> [a]
++ [peerAddr]
domainsIps)
                !ttl :: DiffTime
ttl      = [TTL] -> DiffTime
ttlForResults (((peerAddr, TTL) -> TTL) -> [(peerAddr, TTL)] -> [TTL]
forall a b. (a -> b) -> [a] -> [b]
map (peerAddr, TTL) -> TTL
forall a b. (a, b) -> b
snd [(peerAddr, TTL)]
successes)
            -- If all the lookups failed we'll return an empty set with a minimum
            -- TTL, and the governor will invoke its exponential backoff.
            (Set peerAddr, DiffTime) -> m (Set peerAddr, DiffTime)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set peerAddr
ips, DiffTime
ttl)

-- | Provides DNS resolution functionality.
--
resolveDomainAccessPoint
  :: forall exception resolver m.
     (MonadThrow m, MonadAsync m, Exception exception)
  => Tracer m TracePublicRootPeers
  -> DNS.ResolvConf
  -> DNSActions resolver exception m
  -> [DomainAccessPoint]
  -> m (Map DomainAccessPoint (Set Socket.SockAddr))
resolveDomainAccessPoint :: Tracer m TracePublicRootPeers
-> ResolvConf
-> DNSActions resolver exception m
-> [DomainAccessPoint]
-> m (Map DomainAccessPoint (Set SockAddr))
resolveDomainAccessPoint Tracer m TracePublicRootPeers
tracer
                         ResolvConf
resolvConf
                         DNSActions {
                            ResolvConf -> m (Resource m (DNSorIOError exception) resolver)
dnsResolverResource :: ResolvConf -> m (Resource m (DNSorIOError exception) resolver)
dnsResolverResource :: forall resolver exception (m :: * -> *).
DNSActions resolver exception m
-> ResolvConf -> m (Resource m (DNSorIOError exception) resolver)
dnsResolverResource,
                            ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, TTL)])
dnsLookupWithTTL :: ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, TTL)])
dnsLookupWithTTL :: forall resolver exception (m :: * -> *).
DNSActions resolver exception m
-> ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, TTL)])
dnsLookupWithTTL
                          }
                         [DomainAccessPoint]
domains
                         = do
    Tracer m TracePublicRootPeers -> TracePublicRootPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TracePublicRootPeers
tracer ([DomainAccessPoint] -> TracePublicRootPeers
TracePublicRootDomains [DomainAccessPoint]
domains)
    Resource m (DNSorIOError exception) resolver
rr <- ResolvConf -> m (Resource m (DNSorIOError exception) resolver)
dnsResolverResource ResolvConf
resolvConf
    StrictTVar m (Resource m (DNSorIOError exception) resolver)
resourceVar <- Resource m (DNSorIOError exception) resolver
-> m (StrictTVar m (Resource m (DNSorIOError exception) resolver))
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO Resource m (DNSorIOError exception) resolver
rr
    StrictTVar m (Resource m (DNSorIOError exception) resolver)
-> m (Map DomainAccessPoint (Set SockAddr))
requestPublicRootPeers StrictTVar m (Resource m (DNSorIOError exception) resolver)
resourceVar
  where
    requestPublicRootPeers
      :: StrictTVar m (Resource m (DNSorIOError exception) resolver)
      -> m (Map DomainAccessPoint (Set Socket.SockAddr))
    requestPublicRootPeers :: StrictTVar m (Resource m (DNSorIOError exception) resolver)
-> m (Map DomainAccessPoint (Set SockAddr))
requestPublicRootPeers StrictTVar m (Resource m (DNSorIOError exception) resolver)
resourceVar = do
        Resource m (DNSorIOError exception) resolver
rr <- STM m (Resource m (DNSorIOError exception) resolver)
-> m (Resource m (DNSorIOError exception) resolver)
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (Resource m (DNSorIOError exception) resolver)
 -> m (Resource m (DNSorIOError exception) resolver))
-> STM m (Resource m (DNSorIOError exception) resolver)
-> m (Resource m (DNSorIOError exception) resolver)
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Resource m (DNSorIOError exception) resolver)
-> STM m (Resource m (DNSorIOError exception) resolver)
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar m (Resource m (DNSorIOError exception) resolver)
resourceVar
        (Either (DNSorIOError exception) resolver
er, Resource m (DNSorIOError exception) resolver
rr') <- Resource m (DNSorIOError exception) resolver
-> m (Either (DNSorIOError exception) resolver,
      Resource m (DNSorIOError exception) resolver)
forall (m :: * -> *) err a.
Resource m err a -> m (Either err a, Resource m err a)
withResource Resource m (DNSorIOError exception) resolver
rr
        STM m () -> m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m () -> m ()) -> STM m () -> m ()
forall a b. (a -> b) -> a -> b
$ StrictTVar m (Resource m (DNSorIOError exception) resolver)
-> Resource m (DNSorIOError exception) resolver -> STM m ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar m (Resource m (DNSorIOError exception) resolver)
resourceVar Resource m (DNSorIOError exception) resolver
rr'
        case Either (DNSorIOError exception) resolver
er of
          Left (DNSError DNSError
err) -> DNSError -> m (Map DomainAccessPoint (Set SockAddr))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO DNSError
err
          Left (IOError  exception
err) -> exception -> m (Map DomainAccessPoint (Set SockAddr))
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO exception
err
          Right resolver
resolver -> do
            let lookups :: [m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
lookups =
                  [ (,) DomainAccessPoint
domain
                      (([DNSError], [(IP, TTL)])
 -> (DomainAccessPoint, ([DNSError], [(IP, TTL)])))
-> m ([DNSError], [(IP, TTL)])
-> m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, TTL)])
dnsLookupWithTTL
                            ResolvConf
resolvConf
                            resolver
resolver
                            (DomainAccessPoint -> Domain
dapDomain DomainAccessPoint
domain)
                  | DomainAccessPoint
domain <- [DomainAccessPoint]
domains ]
            -- The timeouts here are handled by the 'lookupWithTTL'. They're
            -- configured via the DNS.ResolvConf resolvTimeout field and defaults
            -- to 3 sec.
            [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
results <- [m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
-> ([Async m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
    -> m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))])
-> m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
forall (m :: * -> *) a b.
MonadAsync m =>
[m a] -> ([Async m a] -> m b) -> m b
withAsyncAll [m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
lookups (STM m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
-> m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
 -> m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))])
-> ([Async m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
    -> STM m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))])
-> [Async m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
-> m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Async m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))
 -> STM m (DomainAccessPoint, ([DNSError], [(IP, TTL)])))
-> [Async m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
-> STM m [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Async m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))
-> STM m (DomainAccessPoint, ([DNSError], [(IP, TTL)]))
forall (m :: * -> *) a. MonadAsync m => Async m a -> STM m a
waitSTM)
            (Map DomainAccessPoint (Set SockAddr)
 -> (DomainAccessPoint, ([DNSError], [(IP, TTL)]))
 -> m (Map DomainAccessPoint (Set SockAddr)))
-> Map DomainAccessPoint (Set SockAddr)
-> [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
-> m (Map DomainAccessPoint (Set SockAddr))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM Map DomainAccessPoint (Set SockAddr)
-> (DomainAccessPoint, ([DNSError], [(IP, TTL)]))
-> m (Map DomainAccessPoint (Set SockAddr))
processResult Map DomainAccessPoint (Set SockAddr)
forall k a. Map k a
Map.empty [(DomainAccessPoint, ([DNSError], [(IP, TTL)]))]
results

    processResult :: Map DomainAccessPoint (Set Socket.SockAddr)
                  -> (DomainAccessPoint, ([DNS.DNSError], [(IP, DNS.TTL)]))
                  -> m (Map DomainAccessPoint (Set Socket.SockAddr))
    processResult :: Map DomainAccessPoint (Set SockAddr)
-> (DomainAccessPoint, ([DNSError], [(IP, TTL)]))
-> m (Map DomainAccessPoint (Set SockAddr))
processResult Map DomainAccessPoint (Set SockAddr)
mr (DomainAccessPoint
domain, ([DNSError]
errs, [(IP, TTL)]
ipsttls)) = do
        (DNSError -> m ()) -> [DNSError] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Tracer m TracePublicRootPeers -> TracePublicRootPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TracePublicRootPeers
tracer (TracePublicRootPeers -> m ())
-> (DNSError -> TracePublicRootPeers) -> DNSError -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Domain -> DNSError -> TracePublicRootPeers
TracePublicRootFailure (DomainAccessPoint -> Domain
dapDomain DomainAccessPoint
domain))
              [DNSError]
errs
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(IP, TTL)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(IP, TTL)]
ipsttls) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            Tracer m TracePublicRootPeers -> TracePublicRootPeers -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m TracePublicRootPeers
tracer (TracePublicRootPeers -> m ()) -> TracePublicRootPeers -> m ()
forall a b. (a -> b) -> a -> b
$ Domain -> [(IP, TTL)] -> TracePublicRootPeers
TracePublicRootResult (DomainAccessPoint -> Domain
dapDomain DomainAccessPoint
domain) [(IP, TTL)]
ipsttls

        Map DomainAccessPoint (Set SockAddr)
-> m (Map DomainAccessPoint (Set SockAddr))
forall (m :: * -> *) a. Monad m => a -> m a
return (Map DomainAccessPoint (Set SockAddr)
 -> m (Map DomainAccessPoint (Set SockAddr)))
-> Map DomainAccessPoint (Set SockAddr)
-> m (Map DomainAccessPoint (Set SockAddr))
forall a b. (a -> b) -> a -> b
$ (Maybe (Set SockAddr) -> Maybe (Set SockAddr))
-> DomainAccessPoint
-> Map DomainAccessPoint (Set SockAddr)
-> Map DomainAccessPoint (Set SockAddr)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe (Set SockAddr) -> Maybe (Set SockAddr)
addFn DomainAccessPoint
domain Map DomainAccessPoint (Set SockAddr)
mr
      where
        addFn :: Maybe (Set Socket.SockAddr) -> Maybe (Set Socket.SockAddr)
        addFn :: Maybe (Set SockAddr) -> Maybe (Set SockAddr)
addFn Maybe (Set SockAddr)
Nothing =
            let ips :: [IP]
ips = ((IP, TTL) -> IP) -> [(IP, TTL)] -> [IP]
forall a b. (a -> b) -> [a] -> [b]
map (IP, TTL) -> IP
forall a b. (a, b) -> a
fst [(IP, TTL)]
ipsttls
                !addrs :: [SockAddr]
addrs = (IP -> SockAddr) -> [IP] -> [SockAddr]
forall a b. (a -> b) -> [a] -> [b]
map (\IP
ip -> (IP, PortNumber) -> SockAddr
IP.toSockAddr (IP
ip, DomainAccessPoint -> PortNumber
dapPortNumber DomainAccessPoint
domain))
                             [IP]
ips
                !addrSet :: Set SockAddr
addrSet = [SockAddr] -> Set SockAddr
forall a. Ord a => [a] -> Set a
Set.fromList [SockAddr]
addrs in
            Set SockAddr -> Maybe (Set SockAddr)
forall a. a -> Maybe a
Just Set SockAddr
addrSet
        addFn (Just Set SockAddr
addrSet) =
            let ips :: [IP]
ips = ((IP, TTL) -> IP) -> [(IP, TTL)] -> [IP]
forall a b. (a -> b) -> [a] -> [b]
map (IP, TTL) -> IP
forall a b. (a, b) -> a
fst [(IP, TTL)]
ipsttls
                !addrs :: [SockAddr]
addrs = (IP -> SockAddr) -> [IP] -> [SockAddr]
forall a b. (a -> b) -> [a] -> [b]
map (\IP
ip -> (IP, PortNumber) -> SockAddr
IP.toSockAddr (IP
ip, DomainAccessPoint -> PortNumber
dapPortNumber DomainAccessPoint
domain))
                             [IP]
ips
                !addrSet' :: Set SockAddr
addrSet' = Set SockAddr -> Set SockAddr -> Set SockAddr
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set SockAddr
addrSet ([SockAddr] -> Set SockAddr
forall a. Ord a => [a] -> Set a
Set.fromList [SockAddr]
addrs) in
            Set SockAddr -> Maybe (Set SockAddr)
forall a. a -> Maybe a
Just Set SockAddr
addrSet'


---------------------------------------------
-- Shared utils
--

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

-- | 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)

-- | 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

withAsyncAll :: MonadAsync m => [m a] -> ([Async m a] -> m b) -> m b
withAsyncAll :: [m a] -> ([Async m a] -> m b) -> m b
withAsyncAll [m a]
xs0 [Async m a] -> m b
action = [Async m a] -> [m a] -> m b
go [] [m a]
xs0
  where
    go :: [Async m a] -> [m a] -> m b
go [Async m a]
as []     = [Async m a] -> m b
action ([Async m a] -> [Async m a]
forall a. [a] -> [a]
reverse [Async m a]
as)
    go [Async m a]
as (m a
x:[m a]
xs) = 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 -> [Async m a] -> [m a] -> m b
go (Async m a
aAsync m a -> [Async m a] -> [Async m a]
forall a. a -> [a] -> [a]
:[Async m a]
as) [m a]
xs)

---------------------------------------------
-- 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
-}