{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}

module Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
  ( -- * DNS based actions for local and public root providers
    DNSActions (..)
  , PeerActionsDNS (..)
    -- * DNSActions IO
  , ioDNSActions
  , DNSLookupType (..)
  , DNSLookupResult
    -- * Utils
    -- ** Resource
  , Resource (..)
  , retryResource
  , constantResource
    -- ** Exposed for testing purposes
  , dispatchLookupWithTTL
    -- ** Error type
  , DNSorIOError (..)
    -- * Tracing types
  , DNSTrace (..)
  , DNSPeersKind (..)
  ) where

import Data.ByteString.Char8 qualified as BS
import Data.Foldable qualified as Fold
import Data.Function (fix)
import Data.List (sortOn)
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as Map
import Data.Maybe (fromJust, listToMaybe)
import Data.Word (Word16)

import Control.Exception (IOException)
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork
import Control.Monad.Class.Trans ()

import Control.Concurrent.Class.MonadSTM.Strict

import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime.SI
import Control.Monad.Class.MonadTimer.SI
#if MIN_VERSION_mtl(2,3,0)
import Control.Monad.Except
#else
import Control.Monad.Except hiding (fix)
#endif
import Control.Tracer (Tracer (..), traceWith)

#if !defined(mingw32_HOST_OS)
import System.Directory (getModificationTime)
#endif

import Network.DNS (DNSError, DNSMessage)
import Network.DNS qualified as DNS
import System.Random

import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerPeersKind)
import Ouroboros.Network.PeerSelection.RelayAccessPoint

-- | Bundled with DNS lookup trace for observability
--
data DNSPeersKind = DNSLocalPeer | DNSPublicPeer | DNSLedgerPeer !LedgerPeersKind
  deriving (Int -> DNSPeersKind -> ShowS
[DNSPeersKind] -> ShowS
DNSPeersKind -> String
(Int -> DNSPeersKind -> ShowS)
-> (DNSPeersKind -> String)
-> ([DNSPeersKind] -> ShowS)
-> Show DNSPeersKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DNSPeersKind -> ShowS
showsPrec :: Int -> DNSPeersKind -> ShowS
$cshow :: DNSPeersKind -> String
show :: DNSPeersKind -> String
$cshowList :: [DNSPeersKind] -> ShowS
showList :: [DNSPeersKind] -> ShowS
Show)

-- | Provides DNS lookup trace information
--
data DNSTrace = DNSResult
                  DNSPeersKind
                  DNS.Domain
                  -- ^ source of addresses
                  (Maybe DNS.Domain)
                  -- ^ SRV domain, if relevant
                  [(IP, PortNumber, DNS.TTL)]
                  -- ^ payload
              | DNSTraceLookupError !DNSPeersKind !(Maybe DNSLookupType) !DNS.Domain !DNS.DNSError
              | DNSSRVFail
                 !DNSPeersKind
                 !DNS.Domain -- ^ SRV domain
  deriving (Int -> DNSTrace -> ShowS
[DNSTrace] -> ShowS
DNSTrace -> String
(Int -> DNSTrace -> ShowS)
-> (DNSTrace -> String) -> ([DNSTrace] -> ShowS) -> Show DNSTrace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DNSTrace -> ShowS
showsPrec :: Int -> DNSTrace -> ShowS
$cshow :: DNSTrace -> String
show :: DNSTrace -> String
$cshowList :: [DNSTrace] -> ShowS
showList :: [DNSTrace] -> ShowS
Show)

data DNSLookupType = LookupReqAOnly
                   | LookupReqAAAAOnly
                   | LookupReqAAndAAAA
                   deriving Int -> DNSLookupType -> ShowS
[DNSLookupType] -> ShowS
DNSLookupType -> String
(Int -> DNSLookupType -> ShowS)
-> (DNSLookupType -> String)
-> ([DNSLookupType] -> ShowS)
-> Show DNSLookupType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DNSLookupType -> ShowS
showsPrec :: Int -> DNSLookupType -> ShowS
$cshow :: DNSLookupType -> String
show :: DNSLookupType -> String
$cshowList :: [DNSLookupType] -> ShowS
showList :: [DNSLookupType] -> ShowS
Show

data DNSorIOError exception
    = DNSError !DNSError
    | IOError  !exception
  deriving Int -> DNSorIOError exception -> ShowS
[DNSorIOError exception] -> ShowS
DNSorIOError exception -> String
(Int -> DNSorIOError exception -> ShowS)
-> (DNSorIOError exception -> String)
-> ([DNSorIOError exception] -> ShowS)
-> Show (DNSorIOError exception)
forall exception.
Show exception =>
Int -> DNSorIOError exception -> ShowS
forall exception.
Show exception =>
[DNSorIOError exception] -> ShowS
forall exception.
Show exception =>
DNSorIOError exception -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall exception.
Show exception =>
Int -> DNSorIOError exception -> ShowS
showsPrec :: Int -> DNSorIOError exception -> ShowS
$cshow :: forall exception.
Show exception =>
DNSorIOError exception -> String
show :: DNSorIOError exception -> String
$cshowList :: forall exception.
Show exception =>
[DNSorIOError exception] -> ShowS
showList :: [DNSorIOError exception] -> ShowS
Show

-- | Wraps lookup result for client code
--
type DNSLookupResult peerAddr =
    Either [DNS.DNSError] [(peerAddr, DNS.TTL)]

instance Exception exception => Exception (DNSorIOError exception) where

-----------------------------------------------
-- Resource
--

-- | Evolving resource; We use it to reinitialise the DNS library if the
-- `/etc/resolv.conf` file was modified.
--
-- Note: `constantResource` and `retryResource` are written using a simplified approach
-- inspired by _"The Different Aspects of Monads and Mixins"_, by Bruno C. d S.
-- Oliveira, see https://www.youtube.com/watch?v=pfwP4hXM5hA.
--
newtype Resource m a = Resource {
    forall (m :: * -> *) a. Resource m a -> m (a, Resource m a)
withResource :: m (a, Resource m a)
  }
  deriving (forall a b. (a -> b) -> Resource m a -> Resource m b)
-> (forall a b. a -> Resource m b -> Resource m a)
-> Functor (Resource m)
forall a b. a -> Resource m b -> Resource m a
forall a b. (a -> b) -> Resource m a -> Resource m b
forall (m :: * -> *) a b.
Functor m =>
a -> Resource m b -> Resource m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Resource m a -> Resource m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> Resource m a -> Resource m b
fmap :: forall a b. (a -> b) -> Resource m a -> Resource m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> Resource m b -> Resource m a
<$ :: forall a b. a -> Resource m b -> Resource m a
Functor

constantResource :: forall m a. Applicative m => a -> Resource m a
constantResource :: forall (m :: * -> *) a. Applicative m => a -> Resource m a
constantResource = ((a -> Resource m a) -> a -> Resource m a) -> a -> Resource m a
forall a. (a -> a) -> a
fix (a -> Resource m a) -> a -> Resource m a
go
  where
    go :: (a -> Resource m a)
       -> (a -> Resource m a)
    go :: (a -> Resource m a) -> a -> Resource m a
go a -> Resource m a
this a
a = m (a, Resource m a) -> Resource m a
forall (m :: * -> *) a. m (a, Resource m a) -> Resource m a
Resource (m (a, Resource m a) -> Resource m a)
-> m (a, Resource m a) -> Resource m a
forall a b. (a -> b) -> a -> b
$ (a, Resource m a) -> m (a, Resource m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, a -> Resource m a
this a
a)

-- | A 'Resource` which will exhibit the given `Resource` but retry it with
-- a given delay until a success. On first success it will reset the delays.
--
retryResource :: forall m e a. MonadDelay m
              => Tracer m e
              -> NonEmpty DiffTime
              -> Resource m (Either e a)
              -> Resource m a
retryResource :: forall (m :: * -> *) e a.
MonadDelay m =>
Tracer m e
-> NonEmpty DiffTime -> Resource m (Either e a) -> Resource m a
retryResource Tracer m e
tracer NonEmpty DiffTime
ds0 = ((NonEmpty DiffTime -> Resource m (Either e a) -> Resource m a)
 -> NonEmpty DiffTime -> Resource m (Either e a) -> Resource m a)
-> NonEmpty DiffTime -> Resource m (Either e a) -> Resource m a
forall a. (a -> a) -> a
fix (NonEmpty DiffTime -> Resource m (Either e a) -> Resource m a)
-> NonEmpty DiffTime -> Resource m (Either e a) -> Resource m a
step NonEmpty DiffTime
ds0
  where
    step :: (NonEmpty DiffTime -> Resource m (Either e a) -> Resource m a)
         -> (NonEmpty DiffTime -> Resource m (Either e a) -> Resource m a)
    step :: (NonEmpty DiffTime -> Resource m (Either e a) -> Resource m a)
-> NonEmpty DiffTime -> Resource m (Either e a) -> Resource m a
step NonEmpty DiffTime -> Resource m (Either e a) -> Resource m a
rec_ ds :: NonEmpty DiffTime
ds@(DiffTime
d :| [DiffTime]
_) Resource m (Either e a)
resource = m (a, Resource m a) -> Resource m a
forall (m :: * -> *) a. m (a, Resource m a) -> Resource m a
Resource (m (a, Resource m a) -> Resource m a)
-> m (a, Resource m a) -> Resource m a
forall a b. (a -> b) -> a -> b
$ do
        ea <- Resource m (Either e a) -> m (Either e a, Resource m (Either e a))
forall (m :: * -> *) a. Resource m a -> m (a, Resource m a)
withResource Resource m (Either e a)
resource
        case ea of
          (Left e
e, Resource m (Either e a)
resource') -> do
            Tracer m e -> e -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m e
tracer e
e
            DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay DiffTime
d
            -- continue with next delays and `resource'`
            Resource m a -> m (a, Resource m a)
forall (m :: * -> *) a. Resource m a -> m (a, Resource m a)
withResource (NonEmpty DiffTime -> Resource m (Either e a) -> Resource m a
rec_ (NonEmpty DiffTime -> NonEmpty DiffTime
forall x. NonEmpty x -> NonEmpty x
dropHead NonEmpty DiffTime
ds) Resource m (Either e a)
resource')
          (Right a
a, Resource m (Either e a)
resource') ->
            -- reset delays, continue with `resource'`
            (a, Resource m a) -> m (a, Resource m a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, NonEmpty DiffTime -> Resource m (Either e a) -> Resource m a
rec_ NonEmpty DiffTime
ds0 Resource m (Either e a)
resource')

    dropHead :: forall x. NonEmpty x -> NonEmpty x
    dropHead :: forall x. NonEmpty x -> NonEmpty x
dropHead xs :: NonEmpty x
xs@(x
_ :| [])  = NonEmpty x
xs
    dropHead (x
_ :| x
x : [x]
xs) = x
x x -> [x] -> NonEmpty x
forall a. a -> [a] -> NonEmpty a
:| [x]
xs

#if !defined(mingw32_HOST_OS)
type TimeStamp = UTCTime
#else
type TimeStamp = Time
#endif

#if defined(mingw32_HOST_OS)
-- | on Windows we will reinitialise the dns library every 60s.
--
dns_REINITIALISE_INTERVAL :: DiffTime
dns_REINITIALISE_INTERVAL = 60
#endif

getTimeStamp :: FilePath
             -> IO TimeStamp
#if !defined(mingw32_HOST_OS)
getTimeStamp :: String -> IO TimeStamp
getTimeStamp = String -> IO TimeStamp
getModificationTime
#else
getTimeStamp _ = addTime dns_REINITIALISE_INTERVAL <$> getMonotonicTime
#endif


-- | Strict version of 'Maybe' adjusted to the needs ot
-- 'asyncResolverResource'.
--
data TimedResolver
    = TimedResolver !DNS.Resolver !TimeStamp
    | NoResolver

-- | Dictionary of DNS actions vocabulary
--
data DNSActions peerAddr resolver exception m = DNSActions {

    -- |
    --
    -- TODO: it could be useful for `publicRootPeersProvider`.
    --
    forall peerAddr resolver exception (m :: * -> *).
DNSActions peerAddr resolver exception m
-> ResolvConf
-> m (Resource m (Either (DNSorIOError exception) resolver))
dnsResolverResource      :: DNS.ResolvConf
                             -> m (Resource m (Either (DNSorIOError exception) resolver)),

    -- | `Resource` which passes the 'DNS.Resolver' (or abstract resolver type)
    -- through a 'StrictTVar'. Better than 'resolverResource' when using in
    -- multiple threads.
    --
    -- On /Windows/ we use a different implementation which always returns
    -- a newly initialised 'DNS.Resolver' at each step.  This is because on
    -- /Windows/ we don't have a way to check that the network configuration has
    -- changed.  The 'dns' library is using 'GetNetworkParams@ win32 api call
    -- to get the list of default dns servers.
    forall peerAddr resolver exception (m :: * -> *).
DNSActions peerAddr resolver exception m
-> ResolvConf
-> m (Resource m (Either (DNSorIOError exception) resolver))
dnsAsyncResolverResource :: DNS.ResolvConf
                             -> m (Resource m (Either (DNSorIOError exception) resolver)),

    -- | Like 'DNS.lookupA' but also return the TTL for the results.
    --
    -- DNS library timeouts do not work reliably on Windows (#1873), hence the
    -- additional timeout.
    --
    forall peerAddr resolver exception (m :: * -> *).
DNSActions peerAddr resolver exception m
-> DNSPeersKind
-> RelayAccessPoint
-> ResolvConf
-> resolver
-> StdGen
-> m (DNSLookupResult peerAddr)
dnsLookupWithTTL         :: DNSPeersKind
                             -> RelayAccessPoint
                             -> DNS.ResolvConf
                             -> resolver
                             -> StdGen
                             -> m (DNSLookupResult peerAddr)
  }


-- | Record of some parameters that are commonly used together
--
-- TODO: rename as `PeerDNSActions`; can we bundle `paToPeerAddr` with
-- `DNSActions`?
data PeerActionsDNS peeraddr resolver exception m = PeerActionsDNS {
  forall peeraddr resolver exception (m :: * -> *).
PeerActionsDNS peeraddr resolver exception m
-> IP -> PortNumber -> peeraddr
paToPeerAddr :: IP -> PortNumber -> peeraddr,
  forall peeraddr resolver exception (m :: * -> *).
PeerActionsDNS peeraddr resolver exception m
-> DNSActions peeraddr resolver exception m
paDnsActions :: DNSActions peeraddr resolver exception m
  }



-- | Get a resolver from 'DNS.ResolvConf'.
--
-- 'DNS.withResolver' is written in continuation passing style, there's no
-- handler with closes in anyway when it returns, hence 'getResolver' does not
-- break it.
--
getResolver :: DNS.ResolvConf -> IO DNS.Resolver
getResolver :: ResolvConf -> IO Resolver
getResolver ResolvConf
resolvConf = do
    rs <- ResolvConf -> IO ResolvSeed
DNS.makeResolvSeed ResolvConf
resolvConf
    DNS.withResolver rs return


-- | IO DNSActions which resolve domain names with 'DNS.Resolver'.
--
-- The IPv4 and IPv6 addresses the node will be using should determine the
-- LookupReqs so that we can avoid lookups for address types that wont be used.
--
-- It guarantees that returned TTLs are strictly greater than 0.
--
ioDNSActions :: Tracer IO DNSTrace
             -> DNSLookupType
             -> (IP -> PortNumber -> peerAddr)
             -> DNSActions peerAddr DNS.Resolver IOException IO
ioDNSActions :: forall peerAddr.
Tracer IO DNSTrace
-> DNSLookupType
-> (IP -> PortNumber -> peerAddr)
-> DNSActions peerAddr Resolver IOException IO
ioDNSActions Tracer IO DNSTrace
tracer DNSLookupType
lookupType IP -> PortNumber -> peerAddr
toPeerAddr =
    DNSActions {
      dnsResolverResource :: ResolvConf
-> IO (Resource IO (Either (DNSorIOError IOException) Resolver))
dnsResolverResource      = ResolvConf
-> IO (Resource IO (Either (DNSorIOError IOException) Resolver))
resolverResource,
      dnsAsyncResolverResource :: ResolvConf
-> IO (Resource IO (Either (DNSorIOError IOException) Resolver))
dnsAsyncResolverResource = ResolvConf
-> IO (Resource IO (Either (DNSorIOError IOException) Resolver))
asyncResolverResource,
      dnsLookupWithTTL :: DNSPeersKind
-> RelayAccessPoint
-> ResolvConf
-> Resolver
-> StdGen
-> IO (DNSLookupResult peerAddr)
dnsLookupWithTTL         = DNSLookupType
-> (Resolver
    -> ResolvConf
    -> Domain
    -> TYPE
    -> IO (Maybe (Either DNSError DNSMessage)))
-> Tracer IO DNSTrace
-> (IP -> PortNumber -> peerAddr)
-> DNSPeersKind
-> RelayAccessPoint
-> ResolvConf
-> Resolver
-> StdGen
-> IO (DNSLookupResult peerAddr)
forall (m :: * -> *) resolver resolvConf peerAddr.
MonadAsync m =>
DNSLookupType
-> (resolver
    -> resolvConf
    -> Domain
    -> TYPE
    -> m (Maybe (Either DNSError DNSMessage)))
-> Tracer m DNSTrace
-> (IP -> PortNumber -> peerAddr)
-> DNSPeersKind
-> RelayAccessPoint
-> resolvConf
-> resolver
-> StdGen
-> m (DNSLookupResult peerAddr)
dispatchLookupWithTTL DNSLookupType
lookupType Resolver
-> ResolvConf
-> Domain
-> TYPE
-> IO (Maybe (Either DNSError DNSMessage))
mkResolveDNSIOAction Tracer IO DNSTrace
tracer IP -> PortNumber -> peerAddr
toPeerAddr
      }
  where
    mkResolveDNSIOAction :: Resolver
-> ResolvConf
-> Domain
-> TYPE
-> IO (Maybe (Either DNSError DNSMessage))
mkResolveDNSIOAction Resolver
resolver ResolvConf
resolvConf Domain
domain TYPE
ofType =
      DiffTime
-> IO (Either DNSError DNSMessage)
-> IO (Maybe (Either DNSError DNSMessage))
forall a. DiffTime -> IO a -> IO (Maybe a)
forall (m :: * -> *) a.
MonadTimer m =>
DiffTime -> m a -> m (Maybe a)
timeout (Int -> DiffTime
microsecondsAsIntToDiffTime
               (Int -> DiffTime) -> Int -> DiffTime
forall a b. (a -> b) -> a -> b
$ ResolvConf -> Int
DNS.resolvTimeout ResolvConf
resolvConf)
              (Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage)
DNS.lookupRaw Resolver
resolver Domain
domain TYPE
ofType)

    -- |
    --
    -- TODO: it could be useful for `publicRootPeersProvider`.
    --
    resolverResource :: DNS.ResolvConf
                     -> IO (Resource IO (Either (DNSorIOError IOException) DNS.Resolver))
    resolverResource :: ResolvConf
-> IO (Resource IO (Either (DNSorIOError IOException) Resolver))
resolverResource ResolvConf
resolvConf = do
        rs <- ResolvConf -> IO ResolvSeed
DNS.makeResolvSeed ResolvConf
resolvConf
        case DNS.resolvInfo resolvConf of
          DNS.RCFilePath String
filePath ->
            Resource IO (Either (DNSorIOError IOException) Resolver)
-> IO (Resource IO (Either (DNSorIOError IOException) Resolver))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resource IO (Either (DNSorIOError IOException) Resolver)
 -> IO (Resource IO (Either (DNSorIOError IOException) Resolver)))
-> Resource IO (Either (DNSorIOError IOException) Resolver)
-> IO (Resource IO (Either (DNSorIOError IOException) Resolver))
forall a b. (a -> b) -> a -> b
$ String
-> TimedResolver
-> Resource IO (Either (DNSorIOError IOException) Resolver)
go String
filePath TimedResolver
NoResolver

          FileOrNumericHost
_ -> ResolvSeed
-> (Resolver
    -> IO (Resource IO (Either (DNSorIOError IOException) Resolver)))
-> IO (Resource IO (Either (DNSorIOError IOException) Resolver))
forall a. ResolvSeed -> (Resolver -> IO a) -> IO a
DNS.withResolver ResolvSeed
rs (Resource IO (Either (DNSorIOError IOException) Resolver)
-> IO (Resource IO (Either (DNSorIOError IOException) Resolver))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resource IO (Either (DNSorIOError IOException) Resolver)
 -> IO (Resource IO (Either (DNSorIOError IOException) Resolver)))
-> (Resolver
    -> Resource IO (Either (DNSorIOError IOException) Resolver))
-> Resolver
-> IO (Resource IO (Either (DNSorIOError IOException) Resolver))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Resolver -> Either (DNSorIOError IOException) Resolver)
-> Resource IO Resolver
-> Resource IO (Either (DNSorIOError IOException) Resolver)
forall a b. (a -> b) -> Resource IO a -> Resource IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Resolver -> Either (DNSorIOError IOException) Resolver
forall a b. b -> Either a b
Right (Resource IO Resolver
 -> Resource IO (Either (DNSorIOError IOException) Resolver))
-> (Resolver -> Resource IO Resolver)
-> Resolver
-> Resource IO (Either (DNSorIOError IOException) Resolver)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resolver -> Resource IO Resolver
forall (m :: * -> *) a. Applicative m => a -> Resource m a
constantResource)

      where
        handlers :: [ Handler IO (Either (DNSorIOError IOException) a) ]
        handlers :: forall a. [Handler IO (Either (DNSorIOError IOException) a)]
handlers  = [ (IOException -> IO (Either (DNSorIOError IOException) a))
-> Handler IO (Either (DNSorIOError IOException) a)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((IOException -> IO (Either (DNSorIOError IOException) a))
 -> Handler IO (Either (DNSorIOError IOException) a))
-> (IOException -> IO (Either (DNSorIOError IOException) a))
-> Handler IO (Either (DNSorIOError IOException) a)
forall a b. (a -> b) -> a -> b
$ Either (DNSorIOError IOException) a
-> IO (Either (DNSorIOError IOException) a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (DNSorIOError IOException) a
 -> IO (Either (DNSorIOError IOException) a))
-> (IOException -> Either (DNSorIOError IOException) a)
-> IOException
-> IO (Either (DNSorIOError IOException) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSorIOError IOException -> Either (DNSorIOError IOException) a
forall a b. a -> Either a b
Left (DNSorIOError IOException -> Either (DNSorIOError IOException) a)
-> (IOException -> DNSorIOError IOException)
-> IOException
-> Either (DNSorIOError IOException) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> DNSorIOError IOException
forall exception. exception -> DNSorIOError exception
IOError
                    , (DNSError -> IO (Either (DNSorIOError IOException) a))
-> Handler IO (Either (DNSorIOError IOException) a)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((DNSError -> IO (Either (DNSorIOError IOException) a))
 -> Handler IO (Either (DNSorIOError IOException) a))
-> (DNSError -> IO (Either (DNSorIOError IOException) a))
-> Handler IO (Either (DNSorIOError IOException) a)
forall a b. (a -> b) -> a -> b
$ Either (DNSorIOError IOException) a
-> IO (Either (DNSorIOError IOException) a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (DNSorIOError IOException) a
 -> IO (Either (DNSorIOError IOException) a))
-> (DNSError -> Either (DNSorIOError IOException) a)
-> DNSError
-> IO (Either (DNSorIOError IOException) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSorIOError IOException -> Either (DNSorIOError IOException) a
forall a b. a -> Either a b
Left (DNSorIOError IOException -> Either (DNSorIOError IOException) a)
-> (DNSError -> DNSorIOError IOException)
-> DNSError
-> Either (DNSorIOError IOException) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSError -> DNSorIOError IOException
forall exception. DNSError -> DNSorIOError exception
DNSError
                    ]

        go :: FilePath
           -> TimedResolver
           -> Resource IO (Either (DNSorIOError IOException) DNS.Resolver)
        go :: String
-> TimedResolver
-> Resource IO (Either (DNSorIOError IOException) Resolver)
go String
filePath tr :: TimedResolver
tr@TimedResolver
NoResolver = IO
  (Either (DNSorIOError IOException) Resolver,
   Resource IO (Either (DNSorIOError IOException) Resolver))
-> Resource IO (Either (DNSorIOError IOException) Resolver)
forall (m :: * -> *) a. m (a, Resource m a) -> Resource m a
Resource (IO
   (Either (DNSorIOError IOException) Resolver,
    Resource IO (Either (DNSorIOError IOException) Resolver))
 -> Resource IO (Either (DNSorIOError IOException) Resolver))
-> IO
     (Either (DNSorIOError IOException) Resolver,
      Resource IO (Either (DNSorIOError IOException) Resolver))
-> Resource IO (Either (DNSorIOError IOException) Resolver)
forall a b. (a -> b) -> a -> b
$
          do
            result
              <- (((TimeStamp, Resolver)
 -> Either (DNSorIOError IOException) (TimeStamp, Resolver))
-> TimeStamp
-> Resolver
-> Either (DNSorIOError IOException) (TimeStamp, Resolver)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (TimeStamp, Resolver)
-> Either (DNSorIOError IOException) (TimeStamp, Resolver)
forall a b. b -> Either a b
Right
                   (TimeStamp
 -> Resolver
 -> Either (DNSorIOError IOException) (TimeStamp, Resolver))
-> IO TimeStamp
-> IO
     (Resolver
      -> Either (DNSorIOError IOException) (TimeStamp, Resolver))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO TimeStamp
getTimeStamp String
filePath
                   IO
  (Resolver
   -> Either (DNSorIOError IOException) (TimeStamp, Resolver))
-> IO Resolver
-> IO (Either (DNSorIOError IOException) (TimeStamp, Resolver))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ResolvConf -> IO Resolver
getResolver ResolvConf
resolvConf)
                 IO (Either (DNSorIOError IOException) (TimeStamp, Resolver))
-> [Handler
      IO (Either (DNSorIOError IOException) (TimeStamp, Resolver))]
-> IO (Either (DNSorIOError IOException) (TimeStamp, Resolver))
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches` [Handler
   IO (Either (DNSorIOError IOException) (TimeStamp, Resolver))]
forall a. [Handler IO (Either (DNSorIOError IOException) a)]
handlers
            case result of
              Left DNSorIOError IOException
err ->
                (Either (DNSorIOError IOException) Resolver,
 Resource IO (Either (DNSorIOError IOException) Resolver))
-> IO
     (Either (DNSorIOError IOException) Resolver,
      Resource IO (Either (DNSorIOError IOException) Resolver))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DNSorIOError IOException
-> Either (DNSorIOError IOException) Resolver
forall a b. a -> Either a b
Left DNSorIOError IOException
err, String
-> TimedResolver
-> Resource IO (Either (DNSorIOError IOException) Resolver)
go String
filePath TimedResolver
tr)
              Right (TimeStamp
modTime, Resolver
resolver) -> do
                (Either (DNSorIOError IOException) Resolver,
 Resource IO (Either (DNSorIOError IOException) Resolver))
-> IO
     (Either (DNSorIOError IOException) Resolver,
      Resource IO (Either (DNSorIOError IOException) Resolver))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resolver -> Either (DNSorIOError IOException) Resolver
forall a b. b -> Either a b
Right Resolver
resolver, String
-> TimedResolver
-> Resource IO (Either (DNSorIOError IOException) Resolver)
go String
filePath (Resolver -> TimeStamp -> TimedResolver
TimedResolver Resolver
resolver TimeStamp
modTime))

        go String
filePath tr :: TimedResolver
tr@(TimedResolver Resolver
resolver TimeStamp
modTime) = IO
  (Either (DNSorIOError IOException) Resolver,
   Resource IO (Either (DNSorIOError IOException) Resolver))
-> Resource IO (Either (DNSorIOError IOException) Resolver)
forall (m :: * -> *) a. m (a, Resource m a) -> Resource m a
Resource (IO
   (Either (DNSorIOError IOException) Resolver,
    Resource IO (Either (DNSorIOError IOException) Resolver))
 -> Resource IO (Either (DNSorIOError IOException) Resolver))
-> IO
     (Either (DNSorIOError IOException) Resolver,
      Resource IO (Either (DNSorIOError IOException) Resolver))
-> Resource IO (Either (DNSorIOError IOException) Resolver)
forall a b. (a -> b) -> a -> b
$ do
          result <- ExceptT (DNSorIOError IOException) IO (Resolver, TimeStamp)
-> IO (Either (DNSorIOError IOException) (Resolver, TimeStamp))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (DNSorIOError IOException) IO (Resolver, TimeStamp)
 -> IO (Either (DNSorIOError IOException) (Resolver, TimeStamp)))
-> ExceptT (DNSorIOError IOException) IO (Resolver, TimeStamp)
-> IO (Either (DNSorIOError IOException) (Resolver, TimeStamp))
forall a b. (a -> b) -> a -> b
$ do
            modTime' <- IO (Either (DNSorIOError IOException) TimeStamp)
-> ExceptT (DNSorIOError IOException) IO TimeStamp
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either (DNSorIOError IOException) TimeStamp)
 -> ExceptT (DNSorIOError IOException) IO TimeStamp)
-> IO (Either (DNSorIOError IOException) TimeStamp)
-> ExceptT (DNSorIOError IOException) IO TimeStamp
forall a b. (a -> b) -> a -> b
$ (TimeStamp -> Either (DNSorIOError IOException) TimeStamp
forall a b. b -> Either a b
Right (TimeStamp -> Either (DNSorIOError IOException) TimeStamp)
-> IO TimeStamp -> IO (Either (DNSorIOError IOException) TimeStamp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO TimeStamp
getTimeStamp String
filePath)
                                  IO (Either (DNSorIOError IOException) TimeStamp)
-> [Handler IO (Either (DNSorIOError IOException) TimeStamp)]
-> IO (Either (DNSorIOError IOException) TimeStamp)
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches` [Handler IO (Either (DNSorIOError IOException) TimeStamp)]
forall a. [Handler IO (Either (DNSorIOError IOException) a)]
handlers
            if modTime' <= modTime
              then return (resolver, modTime)
              else do
                resolver' <- ExceptT $ (Right <$> getResolver resolvConf)
                                       `catches` handlers
                return (resolver', modTime')
          case result of
            Left DNSorIOError IOException
err ->
              (Either (DNSorIOError IOException) Resolver,
 Resource IO (Either (DNSorIOError IOException) Resolver))
-> IO
     (Either (DNSorIOError IOException) Resolver,
      Resource IO (Either (DNSorIOError IOException) Resolver))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSorIOError IOException
-> Either (DNSorIOError IOException) Resolver
forall a b. a -> Either a b
Left DNSorIOError IOException
err, String
-> TimedResolver
-> Resource IO (Either (DNSorIOError IOException) Resolver)
go String
filePath TimedResolver
tr)
            Right (Resolver
resolver', TimeStamp
modTime') ->
              (Either (DNSorIOError IOException) Resolver,
 Resource IO (Either (DNSorIOError IOException) Resolver))
-> IO
     (Either (DNSorIOError IOException) Resolver,
      Resource IO (Either (DNSorIOError IOException) Resolver))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Resolver -> Either (DNSorIOError IOException) Resolver
forall a b. b -> Either a b
Right Resolver
resolver', String
-> TimedResolver
-> Resource IO (Either (DNSorIOError IOException) Resolver)
go String
filePath (Resolver -> TimeStamp -> TimedResolver
TimedResolver Resolver
resolver' TimeStamp
modTime'))


    -- | `Resource` which passes the 'DNS.Resolver' through a 'StrictTVar'.  Better
    -- than 'resolverResource' when using in multiple threads.
    --
    asyncResolverResource :: DNS.ResolvConf
                          -> IO (Resource IO (Either (DNSorIOError IOException) DNS.Resolver))

    asyncResolverResource :: ResolvConf
-> IO (Resource IO (Either (DNSorIOError IOException) Resolver))
asyncResolverResource ResolvConf
resolvConf =
        case ResolvConf -> FileOrNumericHost
DNS.resolvInfo ResolvConf
resolvConf of
          DNS.RCFilePath String
filePath -> do
            resourceVar <- TimedResolver -> IO (StrictTVar IO TimedResolver)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO TimedResolver
NoResolver
            pure $ go filePath resourceVar
          FileOrNumericHost
_ -> do
            (Resolver -> Either (DNSorIOError IOException) Resolver)
-> Resource IO Resolver
-> Resource IO (Either (DNSorIOError IOException) Resolver)
forall a b. (a -> b) -> Resource IO a -> Resource IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Resolver -> Either (DNSorIOError IOException) Resolver
forall a b. b -> Either a b
Right (Resource IO Resolver
 -> Resource IO (Either (DNSorIOError IOException) Resolver))
-> (Resolver -> Resource IO Resolver)
-> Resolver
-> Resource IO (Either (DNSorIOError IOException) Resolver)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resolver -> Resource IO Resolver
forall (m :: * -> *) a. Applicative m => a -> Resource m a
constantResource (Resolver
 -> Resource IO (Either (DNSorIOError IOException) Resolver))
-> IO Resolver
-> IO (Resource IO (Either (DNSorIOError IOException) Resolver))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ResolvConf -> IO Resolver
getResolver ResolvConf
resolvConf
      where
        handlers :: [ Handler IO (Either (DNSorIOError IOException) a) ]
        handlers :: forall a. [Handler IO (Either (DNSorIOError IOException) a)]
handlers  = [ (IOException -> IO (Either (DNSorIOError IOException) a))
-> Handler IO (Either (DNSorIOError IOException) a)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((IOException -> IO (Either (DNSorIOError IOException) a))
 -> Handler IO (Either (DNSorIOError IOException) a))
-> (IOException -> IO (Either (DNSorIOError IOException) a))
-> Handler IO (Either (DNSorIOError IOException) a)
forall a b. (a -> b) -> a -> b
$ Either (DNSorIOError IOException) a
-> IO (Either (DNSorIOError IOException) a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (DNSorIOError IOException) a
 -> IO (Either (DNSorIOError IOException) a))
-> (IOException -> Either (DNSorIOError IOException) a)
-> IOException
-> IO (Either (DNSorIOError IOException) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSorIOError IOException -> Either (DNSorIOError IOException) a
forall a b. a -> Either a b
Left (DNSorIOError IOException -> Either (DNSorIOError IOException) a)
-> (IOException -> DNSorIOError IOException)
-> IOException
-> Either (DNSorIOError IOException) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOException -> DNSorIOError IOException
forall exception. exception -> DNSorIOError exception
IOError
                    , (DNSError -> IO (Either (DNSorIOError IOException) a))
-> Handler IO (Either (DNSorIOError IOException) a)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((DNSError -> IO (Either (DNSorIOError IOException) a))
 -> Handler IO (Either (DNSorIOError IOException) a))
-> (DNSError -> IO (Either (DNSorIOError IOException) a))
-> Handler IO (Either (DNSorIOError IOException) a)
forall a b. (a -> b) -> a -> b
$ Either (DNSorIOError IOException) a
-> IO (Either (DNSorIOError IOException) a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (DNSorIOError IOException) a
 -> IO (Either (DNSorIOError IOException) a))
-> (DNSError -> Either (DNSorIOError IOException) a)
-> DNSError
-> IO (Either (DNSorIOError IOException) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSorIOError IOException -> Either (DNSorIOError IOException) a
forall a b. a -> Either a b
Left (DNSorIOError IOException -> Either (DNSorIOError IOException) a)
-> (DNSError -> DNSorIOError IOException)
-> DNSError
-> Either (DNSorIOError IOException) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSError -> DNSorIOError IOException
forall exception. DNSError -> DNSorIOError exception
DNSError
                    ]

        go :: FilePath -> StrictTVar IO TimedResolver
           -> Resource IO (Either (DNSorIOError IOException) DNS.Resolver)
        go :: String
-> StrictTVar IO TimedResolver
-> Resource IO (Either (DNSorIOError IOException) Resolver)
go String
filePath StrictTVar IO TimedResolver
resourceVar = IO
  (Either (DNSorIOError IOException) Resolver,
   Resource IO (Either (DNSorIOError IOException) Resolver))
-> Resource IO (Either (DNSorIOError IOException) Resolver)
forall (m :: * -> *) a. m (a, Resource m a) -> Resource m a
Resource (IO
   (Either (DNSorIOError IOException) Resolver,
    Resource IO (Either (DNSorIOError IOException) Resolver))
 -> Resource IO (Either (DNSorIOError IOException) Resolver))
-> IO
     (Either (DNSorIOError IOException) Resolver,
      Resource IO (Either (DNSorIOError IOException) Resolver))
-> Resource IO (Either (DNSorIOError IOException) Resolver)
forall a b. (a -> b) -> a -> b
$ do
          r <- StrictTVar IO TimedResolver -> IO TimedResolver
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> m a
readTVarIO StrictTVar IO TimedResolver
resourceVar
          case r of
            TimedResolver
NoResolver ->
              do
                result
                  <- (((TimeStamp, Resolver)
 -> Either (DNSorIOError IOException) (TimeStamp, Resolver))
-> TimeStamp
-> Resolver
-> Either (DNSorIOError IOException) (TimeStamp, Resolver)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (TimeStamp, Resolver)
-> Either (DNSorIOError IOException) (TimeStamp, Resolver)
forall a b. b -> Either a b
Right
                       (TimeStamp
 -> Resolver
 -> Either (DNSorIOError IOException) (TimeStamp, Resolver))
-> IO TimeStamp
-> IO
     (Resolver
      -> Either (DNSorIOError IOException) (TimeStamp, Resolver))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO TimeStamp
getTimeStamp String
filePath
                       IO
  (Resolver
   -> Either (DNSorIOError IOException) (TimeStamp, Resolver))
-> IO Resolver
-> IO (Either (DNSorIOError IOException) (TimeStamp, Resolver))
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ResolvConf -> IO Resolver
getResolver ResolvConf
resolvConf)
                     IO (Either (DNSorIOError IOException) (TimeStamp, Resolver))
-> [Handler
      IO (Either (DNSorIOError IOException) (TimeStamp, Resolver))]
-> IO (Either (DNSorIOError IOException) (TimeStamp, Resolver))
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches` [Handler
   IO (Either (DNSorIOError IOException) (TimeStamp, Resolver))]
forall a. [Handler IO (Either (DNSorIOError IOException) a)]
handlers
                case result of
                  Left DNSorIOError IOException
err ->
                    (Either (DNSorIOError IOException) Resolver,
 Resource IO (Either (DNSorIOError IOException) Resolver))
-> IO
     (Either (DNSorIOError IOException) Resolver,
      Resource IO (Either (DNSorIOError IOException) Resolver))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DNSorIOError IOException
-> Either (DNSorIOError IOException) Resolver
forall a b. a -> Either a b
Left DNSorIOError IOException
err, String
-> StrictTVar IO TimedResolver
-> Resource IO (Either (DNSorIOError IOException) Resolver)
go String
filePath StrictTVar IO TimedResolver
resourceVar)
                  Right (TimeStamp
modTime, Resolver
resolver) -> do
                    STM IO () -> IO ()
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar IO TimedResolver -> TimedResolver -> STM IO ()
forall (m :: * -> *) a.
MonadSTM m =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar IO TimedResolver
resourceVar (Resolver -> TimeStamp -> TimedResolver
TimedResolver Resolver
resolver TimeStamp
modTime))
                    (Either (DNSorIOError IOException) Resolver,
 Resource IO (Either (DNSorIOError IOException) Resolver))
-> IO
     (Either (DNSorIOError IOException) Resolver,
      Resource IO (Either (DNSorIOError IOException) Resolver))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resolver -> Either (DNSorIOError IOException) Resolver
forall a b. b -> Either a b
Right Resolver
resolver, String
-> StrictTVar IO TimedResolver
-> Resource IO (Either (DNSorIOError IOException) Resolver)
go String
filePath StrictTVar IO TimedResolver
resourceVar)

            TimedResolver Resolver
resolver TimeStamp
modTime -> do
              result <- ExceptT (DNSorIOError IOException) IO Resolver
-> IO (Either (DNSorIOError IOException) Resolver)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (DNSorIOError IOException) IO Resolver
 -> IO (Either (DNSorIOError IOException) Resolver))
-> ExceptT (DNSorIOError IOException) IO Resolver
-> IO (Either (DNSorIOError IOException) Resolver)
forall a b. (a -> b) -> a -> b
$ do
                modTime' <- IO (Either (DNSorIOError IOException) TimeStamp)
-> ExceptT (DNSorIOError IOException) IO TimeStamp
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either (DNSorIOError IOException) TimeStamp)
 -> ExceptT (DNSorIOError IOException) IO TimeStamp)
-> IO (Either (DNSorIOError IOException) TimeStamp)
-> ExceptT (DNSorIOError IOException) IO TimeStamp
forall a b. (a -> b) -> a -> b
$ (TimeStamp -> Either (DNSorIOError IOException) TimeStamp
forall a b. b -> Either a b
Right (TimeStamp -> Either (DNSorIOError IOException) TimeStamp)
-> IO TimeStamp -> IO (Either (DNSorIOError IOException) TimeStamp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO TimeStamp
getTimeStamp String
filePath)
                                      IO (Either (DNSorIOError IOException) TimeStamp)
-> [Handler IO (Either (DNSorIOError IOException) TimeStamp)]
-> IO (Either (DNSorIOError IOException) TimeStamp)
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches` [Handler IO (Either (DNSorIOError IOException) TimeStamp)]
forall a. [Handler IO (Either (DNSorIOError IOException) a)]
handlers
                if modTime' <= modTime
                  then return resolver
                  else do
                  resolver' <- ExceptT $ (Right <$> getResolver resolvConf)
                                         `catches` handlers
                  atomically (writeTVar (castStrictTVar resourceVar)
                             (TimedResolver resolver' modTime'))
                  return resolver'
              case result of
                Left DNSorIOError IOException
err ->
                  (Either (DNSorIOError IOException) Resolver,
 Resource IO (Either (DNSorIOError IOException) Resolver))
-> IO
     (Either (DNSorIOError IOException) Resolver,
      Resource IO (Either (DNSorIOError IOException) Resolver))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSorIOError IOException
-> Either (DNSorIOError IOException) Resolver
forall a b. a -> Either a b
Left DNSorIOError IOException
err, String
-> StrictTVar IO TimedResolver
-> Resource IO (Either (DNSorIOError IOException) Resolver)
go String
filePath StrictTVar IO TimedResolver
resourceVar)
                Right Resolver
resolver' ->
                  (Either (DNSorIOError IOException) Resolver,
 Resource IO (Either (DNSorIOError IOException) Resolver))
-> IO
     (Either (DNSorIOError IOException) Resolver,
      Resource IO (Either (DNSorIOError IOException) Resolver))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Resolver -> Either (DNSorIOError IOException) Resolver
forall a b. b -> Either a b
Right Resolver
resolver', String
-> StrictTVar IO TimedResolver
-> Resource IO (Either (DNSorIOError IOException) Resolver)
go String
filePath StrictTVar IO TimedResolver
resourceVar)

-- NB: A deliberately limited subset of SRV is supported.
-- An SRV record is resolved into a list of follow-up
-- candidate lookups. Targets marked "." are filtered out,
-- and the result is sorted and grouped by priority levels.
-- Only the top priority level (ie. lowest numerical value)
-- is considered. A weighted random sampling is then performed to
-- draw a domain to retrieve the final addresses from. If the lookup
-- fails, the SRV lookup is not resumed.
-- (cf. https://www.ietf.org/rfc/rfc2782.txt)
--
srvRecordLookupWithTTL :: forall peerAddr m. (MonadAsync m)
                       => DNSLookupType
                       -> Tracer m DNSTrace
                       -> (IP -> PortNumber -> peerAddr)
                       -> DNSPeersKind
                       -> DNS.Domain
                       -> (   DNS.Domain
                           -> DNS.TYPE
                       -> m (Maybe (Either DNSError DNSMessage)))
                       -> StdGen
                       -> m (DNSLookupResult peerAddr)
srvRecordLookupWithTTL :: forall peerAddr (m :: * -> *).
MonadAsync m =>
DNSLookupType
-> Tracer m DNSTrace
-> (IP -> PortNumber -> peerAddr)
-> DNSPeersKind
-> Domain
-> (Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage)))
-> StdGen
-> m (DNSLookupResult peerAddr)
srvRecordLookupWithTTL DNSLookupType
ofType Tracer m DNSTrace
tracer IP -> PortNumber -> peerAddr
toPeerAddr DNSPeersKind
peerType Domain
domainSRV Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage))
resolveDNS StdGen
rng = do
    reply <- Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage))
resolveDNS Domain
domainSRV TYPE
DNS.SRV
    case reply of
      Maybe (Either DNSError DNSMessage)
Nothing          -> do
        Tracer m DNSTrace -> DNSTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DNSTrace
tracer (DNSTrace -> m ()) -> DNSTrace -> m ()
forall a b. (a -> b) -> a -> b
$ DNSPeersKind
-> Maybe DNSLookupType -> Domain -> DNSError -> DNSTrace
DNSTraceLookupError DNSPeersKind
peerType Maybe DNSLookupType
forall a. Maybe a
Nothing Domain
domainSRV DNSError
DNS.TimeoutExpired
        DNSLookupResult peerAddr -> m (DNSLookupResult peerAddr)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSLookupResult peerAddr -> m (DNSLookupResult peerAddr))
-> ([DNSError] -> DNSLookupResult peerAddr)
-> [DNSError]
-> m (DNSLookupResult peerAddr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DNSError] -> DNSLookupResult peerAddr
forall a b. a -> Either a b
Left ([DNSError] -> m (DNSLookupResult peerAddr))
-> [DNSError] -> m (DNSLookupResult peerAddr)
forall a b. (a -> b) -> a -> b
$ [DNSError
DNS.TimeoutExpired]
      Just (Left  DNSError
err) -> do
        Tracer m DNSTrace -> DNSTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DNSTrace
tracer (DNSTrace -> m ()) -> DNSTrace -> m ()
forall a b. (a -> b) -> a -> b
$ DNSPeersKind
-> Maybe DNSLookupType -> Domain -> DNSError -> DNSTrace
DNSTraceLookupError DNSPeersKind
peerType Maybe DNSLookupType
forall a. Maybe a
Nothing Domain
domainSRV DNSError
err
        DNSLookupResult peerAddr -> m (DNSLookupResult peerAddr)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSLookupResult peerAddr -> m (DNSLookupResult peerAddr))
-> ([DNSError] -> DNSLookupResult peerAddr)
-> [DNSError]
-> m (DNSLookupResult peerAddr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DNSError] -> DNSLookupResult peerAddr
forall a b. a -> Either a b
Left ([DNSError] -> m (DNSLookupResult peerAddr))
-> [DNSError] -> m (DNSLookupResult peerAddr)
forall a b. (a -> b) -> a -> b
$ [DNSError
err]
      Just (Right DNSMessage
msg) ->
        case DNSMessage
-> (DNSMessage -> [(Domain, Word16, Word16, Word16, TTL)])
-> Either DNSError [(Domain, Word16, Word16, Word16, TTL)]
forall a. DNSMessage -> (DNSMessage -> a) -> Either DNSError a
DNS.fromDNSMessage DNSMessage
msg DNSMessage -> [(Domain, Word16, Word16, Word16, TTL)]
selectSRV of
          Left DNSError
err -> do
            Tracer m DNSTrace -> DNSTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DNSTrace
tracer (DNSTrace -> m ()) -> DNSTrace -> m ()
forall a b. (a -> b) -> a -> b
$ DNSPeersKind
-> Maybe DNSLookupType -> Domain -> DNSError -> DNSTrace
DNSTraceLookupError DNSPeersKind
peerType Maybe DNSLookupType
forall a. Maybe a
Nothing Domain
domainSRV DNSError
err
            DNSLookupResult peerAddr -> m (DNSLookupResult peerAddr)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSLookupResult peerAddr -> m (DNSLookupResult peerAddr))
-> ([DNSError] -> DNSLookupResult peerAddr)
-> [DNSError]
-> m (DNSLookupResult peerAddr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DNSError] -> DNSLookupResult peerAddr
forall a b. a -> Either a b
Left ([DNSError] -> m (DNSLookupResult peerAddr))
-> [DNSError] -> m (DNSLookupResult peerAddr)
forall a b. (a -> b) -> a -> b
$ [DNSError
err]
          Right [(Domain, Word16, Word16, Word16, TTL)]
services -> do
            let srvByPriority :: [(Domain, Word16, Word16, Word16, TTL)]
srvByPriority = ((Domain, Word16, Word16, Word16, TTL) -> Bool)
-> [(Domain, Word16, Word16, Word16, TTL)]
-> [(Domain, Word16, Word16, Word16, TTL)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> Domain
BS.pack String
"." Domain -> Domain -> Bool
forall a. Eq a => a -> a -> Bool
/=) (Domain -> Bool)
-> ((Domain, Word16, Word16, Word16, TTL) -> Domain)
-> (Domain, Word16, Word16, Word16, TTL)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Domain, Word16, Word16, Word16, TTL) -> Domain
forall {a} {b} {c} {d} {e}. (a, b, c, d, e) -> a
pickDomain) ([(Domain, Word16, Word16, Word16, TTL)]
 -> [(Domain, Word16, Word16, Word16, TTL)])
-> [(Domain, Word16, Word16, Word16, TTL)]
-> [(Domain, Word16, Word16, Word16, TTL)]
forall a b. (a -> b) -> a -> b
$ ((Domain, Word16, Word16, Word16, TTL) -> Word16)
-> [(Domain, Word16, Word16, Word16, TTL)]
-> [(Domain, Word16, Word16, Word16, TTL)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Domain, Word16, Word16, Word16, TTL) -> Word16
forall {a} {b} {c} {d} {e}. (a, b, c, d, e) -> b
priority [(Domain, Word16, Word16, Word16, TTL)]
services
                grouped :: [NonEmpty (Domain, Word16, Word16, Word16, TTL)]
grouped       = ((Domain, Word16, Word16, Word16, TTL) -> Word16)
-> [(Domain, Word16, Word16, Word16, TTL)]
-> [NonEmpty (Domain, Word16, Word16, Word16, TTL)]
forall (f :: * -> *) b a.
(Foldable f, Eq b) =>
(a -> b) -> f a -> [NonEmpty a]
NE.groupWith (Domain, Word16, Word16, Word16, TTL) -> Word16
forall {a} {b} {c} {d} {e}. (a, b, c, d, e) -> b
priority [(Domain, Word16, Word16, Word16, TTL)]
srvByPriority
            (result, domain) <- do
              case [NonEmpty (Domain, Word16, Word16, Word16, TTL)]
-> Maybe (NonEmpty (Domain, Word16, Word16, Word16, TTL))
forall a. [a] -> Maybe a
listToMaybe [NonEmpty (Domain, Word16, Word16, Word16, TTL)]
grouped of
                Just NonEmpty (Domain, Word16, Word16, Word16, TTL)
topPriority ->
                  case NonEmpty (Domain, Word16, Word16, Word16, TTL)
topPriority of
                    (Domain
domain, Word16
_, Word16
_, Word16
port, TTL
ttl) NE.:| [] -> do -- fast path
                      result <- Tracer m DNSTrace
-> DNSLookupType
-> Domain
-> DNSPeersKind
-> (Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage)))
-> m (Either [DNSError] [(IP, TTL)])
forall (m :: * -> *).
MonadAsync m =>
Tracer m DNSTrace
-> DNSLookupType
-> Domain
-> DNSPeersKind
-> (Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage)))
-> m (Either [DNSError] [(IP, TTL)])
domainLookupWithTTL Tracer m DNSTrace
tracer DNSLookupType
ofType Domain
domain DNSPeersKind
peerType Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage))
resolveDNS
                      let result' = Word16 -> TTL -> [(IP, TTL)] -> [(IP, PortNumber, TTL)]
forall {a} {b} {c} {a} {b}.
(Integral a, Num b) =>
a -> c -> [(a, b)] -> [(a, b, c)]
ipsttlsWithPort Word16
port TTL
ttl ([(IP, TTL)] -> [(IP, PortNumber, TTL)])
-> Either [DNSError] [(IP, TTL)]
-> Either [DNSError] [(IP, PortNumber, TTL)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either [DNSError] [(IP, TTL)]
result
                      return (result', domain)
                    NonEmpty (Domain, Word16, Word16, Word16, TTL)
many -> -- general path
                      NonEmpty (Domain, Word16, Word16, Word16, TTL)
-> m (Either [DNSError] [(IP, PortNumber, TTL)], Domain)
runWeightedLookup NonEmpty (Domain, Word16, Word16, Word16, TTL)
many
                Maybe (NonEmpty (Domain, Word16, Word16, Word16, TTL))
Nothing -> (Either [DNSError] [(IP, PortNumber, TTL)], Domain)
-> m (Either [DNSError] [(IP, PortNumber, TTL)], Domain)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(IP, PortNumber, TTL)]
-> Either [DNSError] [(IP, PortNumber, TTL)]
forall a b. b -> Either a b
Right [], Domain
"")
            case result of
              Left {} -> Tracer m DNSTrace -> DNSTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DNSTrace
tracer (DNSTrace -> m ()) -> DNSTrace -> m ()
forall a b. (a -> b) -> a -> b
$ DNSPeersKind -> Domain -> DNSTrace
DNSSRVFail DNSPeersKind
peerType Domain
domainSRV
              Right [(IP, PortNumber, TTL)]
ipsttls ->
                Tracer m DNSTrace -> DNSTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DNSTrace
tracer (DNSTrace -> m ()) -> DNSTrace -> m ()
forall a b. (a -> b) -> a -> b
$ DNSPeersKind
-> Domain -> Maybe Domain -> [(IP, PortNumber, TTL)] -> DNSTrace
DNSResult DNSPeersKind
peerType Domain
domain (Domain -> Maybe Domain
forall a. a -> Maybe a
Just Domain
domainSRV) [(IP, PortNumber, TTL)]
ipsttls
            return $ map (\(IP
ip, PortNumber
port, TTL
ttl) -> (IP -> PortNumber -> peerAddr
toPeerAddr IP
ip PortNumber
port, TTL
ttl)) <$> result

      where
        ipsttlsWithPort :: a -> c -> [(a, b)] -> [(a, b, c)]
ipsttlsWithPort a
port c
ttl = ((a, b) -> (a, b, c)) -> [(a, b)] -> [(a, b, c)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
ip, b
_ttl) -> (a
ip, a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
port, c
ttl))

        runWeightedLookup :: NonEmpty (DNS.Domain, Word16, Word16, Word16, DNS.TTL)
                          -> m (Either [DNSError] [(IP, PortNumber, DNS.TTL)], DNS.Domain)
        runWeightedLookup :: NonEmpty (Domain, Word16, Word16, Word16, TTL)
-> m (Either [DNSError] [(IP, PortNumber, TTL)], Domain)
runWeightedLookup NonEmpty (Domain, Word16, Word16, Word16, TTL)
services =
           let (Word16
upperBound, [(Word16, (Domain, Word16, Word16, Word16, TTL))]
cdf) = ((Word16, [(Word16, (Domain, Word16, Word16, Word16, TTL))])
 -> (Domain, Word16, Word16, Word16, TTL)
 -> (Word16, [(Word16, (Domain, Word16, Word16, Word16, TTL))]))
-> (Word16, [(Word16, (Domain, Word16, Word16, Word16, TTL))])
-> NonEmpty (Domain, Word16, Word16, Word16, TTL)
-> (Word16, [(Word16, (Domain, Word16, Word16, Word16, TTL))])
forall b a. (b -> a -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Fold.foldl' (Word16, [(Word16, (Domain, Word16, Word16, Word16, TTL))])
-> (Domain, Word16, Word16, Word16, TTL)
-> (Word16, [(Word16, (Domain, Word16, Word16, Word16, TTL))])
forall {a} {a} {b} {d} {e}.
Num a =>
(a, [(a, (a, b, a, d, e))])
-> (a, b, a, d, e) -> (a, [(a, (a, b, a, d, e))])
aggregate (Word16
0, []) NonEmpty (Domain, Word16, Word16, Word16, TTL)
services
               mapCdf :: Map Word16 (Domain, Word16, Word16, Word16, TTL)
mapCdf = [(Word16, (Domain, Word16, Word16, Word16, TTL))]
-> Map Word16 (Domain, Word16, Word16, Word16, TTL)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Word16, (Domain, Word16, Word16, Word16, TTL))]
cdf
               (Word16
pick, StdGen
_) = (Word16, Word16) -> StdGen -> (Word16, StdGen)
forall g. RandomGen g => (Word16, Word16) -> g -> (Word16, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Word16
0, Word16
upperBound) StdGen
rng
               (Domain
domain, Word16
_, Word16
_, Word16
port, TTL
ttl) = (Word16, (Domain, Word16, Word16, Word16, TTL))
-> (Domain, Word16, Word16, Word16, TTL)
forall a b. (a, b) -> b
snd ((Word16, (Domain, Word16, Word16, Word16, TTL))
 -> (Domain, Word16, Word16, Word16, TTL))
-> (Maybe (Word16, (Domain, Word16, Word16, Word16, TTL))
    -> (Word16, (Domain, Word16, Word16, Word16, TTL)))
-> Maybe (Word16, (Domain, Word16, Word16, Word16, TTL))
-> (Domain, Word16, Word16, Word16, TTL)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Word16, (Domain, Word16, Word16, Word16, TTL))
-> (Word16, (Domain, Word16, Word16, Word16, TTL))
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Word16, (Domain, Word16, Word16, Word16, TTL))
 -> (Domain, Word16, Word16, Word16, TTL))
-> Maybe (Word16, (Domain, Word16, Word16, Word16, TTL))
-> (Domain, Word16, Word16, Word16, TTL)
forall a b. (a -> b) -> a -> b
$ Word16
-> Map Word16 (Domain, Word16, Word16, Word16, TTL)
-> Maybe (Word16, (Domain, Word16, Word16, Word16, TTL))
forall k v. Ord k => k -> Map k v -> Maybe (k, v)
Map.lookupGE Word16
pick Map Word16 (Domain, Word16, Word16, Word16, TTL)
mapCdf
           in (,Domain
domain) (Either [DNSError] [(IP, PortNumber, TTL)]
 -> (Either [DNSError] [(IP, PortNumber, TTL)], Domain))
-> (Either [DNSError] [(IP, TTL)]
    -> Either [DNSError] [(IP, PortNumber, TTL)])
-> Either [DNSError] [(IP, TTL)]
-> (Either [DNSError] [(IP, PortNumber, TTL)], Domain)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(IP, TTL)] -> [(IP, PortNumber, TTL)])
-> Either [DNSError] [(IP, TTL)]
-> Either [DNSError] [(IP, PortNumber, TTL)]
forall a b. (a -> b) -> Either [DNSError] a -> Either [DNSError] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word16 -> TTL -> [(IP, TTL)] -> [(IP, PortNumber, TTL)]
forall {a} {b} {c} {a} {b}.
(Integral a, Num b) =>
a -> c -> [(a, b)] -> [(a, b, c)]
ipsttlsWithPort Word16
port TTL
ttl) (Either [DNSError] [(IP, TTL)]
 -> (Either [DNSError] [(IP, PortNumber, TTL)], Domain))
-> m (Either [DNSError] [(IP, TTL)])
-> m (Either [DNSError] [(IP, PortNumber, TTL)], Domain)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tracer m DNSTrace
-> DNSLookupType
-> Domain
-> DNSPeersKind
-> (Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage)))
-> m (Either [DNSError] [(IP, TTL)])
forall (m :: * -> *).
MonadAsync m =>
Tracer m DNSTrace
-> DNSLookupType
-> Domain
-> DNSPeersKind
-> (Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage)))
-> m (Either [DNSError] [(IP, TTL)])
domainLookupWithTTL Tracer m DNSTrace
tracer DNSLookupType
ofType Domain
domain DNSPeersKind
peerType Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage))
resolveDNS

        aggregate :: (a, [(a, (a, b, a, d, e))])
-> (a, b, a, d, e) -> (a, [(a, (a, b, a, d, e))])
aggregate (!a
upper, ![(a, (a, b, a, d, e))]
cdf) (a, b, a, d, e)
srv =
          let upper' :: a
upper' = (a, b, a, d, e) -> a
forall {a} {b} {c} {d} {e}. (a, b, c, d, e) -> c
weight (a, b, a, d, e)
srv a -> a -> a
forall a. Num a => a -> a -> a
+ a
upper
           in (a
upper', (a
upper', (a, b, a, d, e)
srv)(a, (a, b, a, d, e))
-> [(a, (a, b, a, d, e))] -> [(a, (a, b, a, d, e))]
forall a. a -> [a] -> [a]
:[(a, (a, b, a, d, e))]
cdf)

        selectSRV :: DNSMessage -> [(Domain, Word16, Word16, Word16, TTL)]
selectSRV DNS.DNSMessage { Answers
answer :: Answers
answer :: DNSMessage -> Answers
DNS.answer } =
          [ (Domain
domain', Word16
priority', Word16
weight', Word16
port, TTL
ttl)
          | DNS.ResourceRecord {
              rdata :: ResourceRecord -> RData
DNS.rdata = DNS.RD_SRV Word16
priority' Word16
weight' Word16
port Domain
domain',
              rrttl :: ResourceRecord -> TTL
DNS.rrttl = TTL
ttl
            } <- Answers
answer
          ]

        weight :: (a, b, c, d, e) -> c
weight   (a
_, b
_, c
w, d
_, e
_)   = c
w
        priority :: (a, b, c, d, e) -> b
priority (a
_, b
p, c
_, d
_, e
_)   = b
p
        pickDomain :: (a, b, c, d, e) -> a
pickDomain (a
d, b
_, c
_, d
_, e
_) = a
d


dispatchLookupWithTTL :: (MonadAsync m)
                      => DNSLookupType
                      -> (   resolver
                          -> resolvConf
                          -> DNS.Domain
                          -> DNS.TYPE
                          -> m (Maybe (Either DNSError DNSMessage)))
                      -> Tracer m DNSTrace
                      -> (IP -> PortNumber -> peerAddr)
                      -> DNSPeersKind
                      -> RelayAccessPoint
                      -> resolvConf
                      -> resolver
                      -> StdGen
                      -> m (DNSLookupResult peerAddr)
dispatchLookupWithTTL :: forall (m :: * -> *) resolver resolvConf peerAddr.
MonadAsync m =>
DNSLookupType
-> (resolver
    -> resolvConf
    -> Domain
    -> TYPE
    -> m (Maybe (Either DNSError DNSMessage)))
-> Tracer m DNSTrace
-> (IP -> PortNumber -> peerAddr)
-> DNSPeersKind
-> RelayAccessPoint
-> resolvConf
-> resolver
-> StdGen
-> m (DNSLookupResult peerAddr)
dispatchLookupWithTTL DNSLookupType
lookupType resolver
-> resolvConf
-> Domain
-> TYPE
-> m (Maybe (Either DNSError DNSMessage))
mkResolveDNS Tracer m DNSTrace
tracer IP -> PortNumber -> peerAddr
toPeerAddr DNSPeersKind
peerType RelayAccessPoint
domain resolvConf
conf resolver
resolver StdGen
rng =
  let resolveDNS :: Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage))
resolveDNS = resolver
-> resolvConf
-> Domain
-> TYPE
-> m (Maybe (Either DNSError DNSMessage))
mkResolveDNS resolver
resolver resolvConf
conf
  in case RelayAccessPoint
domain of
    RelayAccessDomain Domain
d PortNumber
p -> do
      result <- Tracer m DNSTrace
-> DNSLookupType
-> Domain
-> DNSPeersKind
-> (Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage)))
-> m (Either [DNSError] [(IP, TTL)])
forall (m :: * -> *).
MonadAsync m =>
Tracer m DNSTrace
-> DNSLookupType
-> Domain
-> DNSPeersKind
-> (Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage)))
-> m (Either [DNSError] [(IP, TTL)])
domainLookupWithTTL Tracer m DNSTrace
tracer DNSLookupType
lookupType Domain
d DNSPeersKind
peerType Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage))
resolveDNS
      let trace = ((IP, TTL) -> (IP, PortNumber, TTL))
-> [(IP, TTL)] -> [(IP, PortNumber, TTL)]
forall a b. (a -> b) -> [a] -> [b]
map (\(IP
ip, TTL
ttl) -> (IP
ip, PortNumber
p, TTL
ttl)) ([(IP, TTL)] -> [(IP, PortNumber, TTL)])
-> Either [DNSError] [(IP, TTL)]
-> Either [DNSError] [(IP, PortNumber, TTL)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either [DNSError] [(IP, TTL)]
result
      Fold.traverse_ (traceWith tracer . DNSResult peerType d Nothing) trace
      return $ map (\(IP
ip, TTL
_ttl) -> (IP -> PortNumber -> peerAddr
toPeerAddr IP
ip PortNumber
p, TTL
_ttl)) <$> result
    RelayAccessSRVDomain Domain
d -> DNSLookupType
-> Tracer m DNSTrace
-> (IP -> PortNumber -> peerAddr)
-> DNSPeersKind
-> Domain
-> (Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage)))
-> StdGen
-> m (DNSLookupResult peerAddr)
forall peerAddr (m :: * -> *).
MonadAsync m =>
DNSLookupType
-> Tracer m DNSTrace
-> (IP -> PortNumber -> peerAddr)
-> DNSPeersKind
-> Domain
-> (Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage)))
-> StdGen
-> m (DNSLookupResult peerAddr)
srvRecordLookupWithTTL DNSLookupType
lookupType Tracer m DNSTrace
tracer IP -> PortNumber -> peerAddr
toPeerAddr DNSPeersKind
peerType Domain
d Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage))
resolveDNS StdGen
rng
    RelayAccessAddress IP
addr PortNumber
p  -> DNSLookupResult peerAddr -> m (DNSLookupResult peerAddr)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSLookupResult peerAddr -> m (DNSLookupResult peerAddr))
-> ([(peerAddr, TTL)] -> DNSLookupResult peerAddr)
-> [(peerAddr, TTL)]
-> m (DNSLookupResult peerAddr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(peerAddr, TTL)] -> DNSLookupResult peerAddr
forall a b. b -> Either a b
Right ([(peerAddr, TTL)] -> m (DNSLookupResult peerAddr))
-> [(peerAddr, TTL)] -> m (DNSLookupResult peerAddr)
forall a b. (a -> b) -> a -> b
$ [(IP -> PortNumber -> peerAddr
toPeerAddr IP
addr PortNumber
p, TTL
forall a. Bounded a => a
maxBound)]


domainLookupWithTTL :: (MonadAsync m)
                    => Tracer m DNSTrace
                    -> DNSLookupType
                    -> DNS.Domain
                    -> DNSPeersKind
                    -> (   DNS.Domain
                        -> DNS.TYPE
                    -> m (Maybe (Either DNSError DNSMessage)))
                    -> m (Either [DNSError] [(IP, DNS.TTL)])
domainLookupWithTTL :: forall (m :: * -> *).
MonadAsync m =>
Tracer m DNSTrace
-> DNSLookupType
-> Domain
-> DNSPeersKind
-> (Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage)))
-> m (Either [DNSError] [(IP, TTL)])
domainLookupWithTTL Tracer m DNSTrace
tracer look :: DNSLookupType
look@DNSLookupType
LookupReqAOnly Domain
d DNSPeersKind
peerType Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage))
resolveDNS = do
    res <- m (Maybe (Either DNSError DNSMessage))
-> m (Either DNSError [(IP, TTL)])
forall (m :: * -> *).
MonadThread m =>
m (Maybe (Either DNSError DNSMessage))
-> m (Either DNSError [(IP, TTL)])
domainALookupWithTTL (Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage))
resolveDNS Domain
d TYPE
DNS.A)
    case res of
         Left DNSError
err -> do
           Tracer m DNSTrace -> DNSTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DNSTrace
tracer (DNSTrace -> m ()) -> DNSTrace -> m ()
forall a b. (a -> b) -> a -> b
$ DNSPeersKind
-> Maybe DNSLookupType -> Domain -> DNSError -> DNSTrace
DNSTraceLookupError DNSPeersKind
peerType (DNSLookupType -> Maybe DNSLookupType
forall a. a -> Maybe a
Just DNSLookupType
look) Domain
d DNSError
err
           Either [DNSError] [(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [DNSError] [(IP, TTL)]
 -> m (Either [DNSError] [(IP, TTL)]))
-> ([DNSError] -> Either [DNSError] [(IP, TTL)])
-> [DNSError]
-> m (Either [DNSError] [(IP, TTL)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DNSError] -> Either [DNSError] [(IP, TTL)]
forall a b. a -> Either a b
Left ([DNSError] -> m (Either [DNSError] [(IP, TTL)]))
-> [DNSError] -> m (Either [DNSError] [(IP, TTL)])
forall a b. (a -> b) -> a -> b
$ [DNSError
err]
         Right [(IP, TTL)]
r  -> Either [DNSError] [(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [DNSError] [(IP, TTL)]
 -> m (Either [DNSError] [(IP, TTL)]))
-> ([(IP, TTL)] -> Either [DNSError] [(IP, TTL)])
-> [(IP, TTL)]
-> m (Either [DNSError] [(IP, TTL)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(IP, TTL)] -> Either [DNSError] [(IP, TTL)]
forall a b. b -> Either a b
Right ([(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)]))
-> [(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)])
forall a b. (a -> b) -> a -> b
$ [(IP, TTL)]
r

domainLookupWithTTL Tracer m DNSTrace
tracer look :: DNSLookupType
look@DNSLookupType
LookupReqAAAAOnly Domain
d DNSPeersKind
peerType Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage))
resolveDNS = do
    res <- m (Maybe (Either DNSError DNSMessage))
-> m (Either DNSError [(IP, TTL)])
forall (m :: * -> *).
MonadThread m =>
m (Maybe (Either DNSError DNSMessage))
-> m (Either DNSError [(IP, TTL)])
domainAAAALookupWithTTL (Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage))
resolveDNS Domain
d TYPE
DNS.AAAA)
    case res of
         Left DNSError
err -> do
           Tracer m DNSTrace -> DNSTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DNSTrace
tracer (DNSTrace -> m ()) -> DNSTrace -> m ()
forall a b. (a -> b) -> a -> b
$ DNSPeersKind
-> Maybe DNSLookupType -> Domain -> DNSError -> DNSTrace
DNSTraceLookupError DNSPeersKind
peerType (DNSLookupType -> Maybe DNSLookupType
forall a. a -> Maybe a
Just DNSLookupType
look) Domain
d DNSError
err
           Either [DNSError] [(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [DNSError] [(IP, TTL)]
 -> m (Either [DNSError] [(IP, TTL)]))
-> ([DNSError] -> Either [DNSError] [(IP, TTL)])
-> [DNSError]
-> m (Either [DNSError] [(IP, TTL)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DNSError] -> Either [DNSError] [(IP, TTL)]
forall a b. a -> Either a b
Left ([DNSError] -> m (Either [DNSError] [(IP, TTL)]))
-> [DNSError] -> m (Either [DNSError] [(IP, TTL)])
forall a b. (a -> b) -> a -> b
$ [DNSError
err] --([err], [])
         Right [(IP, TTL)]
r  -> Either [DNSError] [(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [DNSError] [(IP, TTL)]
 -> m (Either [DNSError] [(IP, TTL)]))
-> ([(IP, TTL)] -> Either [DNSError] [(IP, TTL)])
-> [(IP, TTL)]
-> m (Either [DNSError] [(IP, TTL)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(IP, TTL)] -> Either [DNSError] [(IP, TTL)]
forall a b. b -> Either a b
Right ([(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)]))
-> [(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)])
forall a b. (a -> b) -> a -> b
$ [(IP, TTL)]
r

domainLookupWithTTL Tracer m DNSTrace
tracer DNSLookupType
LookupReqAAndAAAA Domain
d DNSPeersKind
peerType Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage))
resolveDNS = do
    (r_ipv6, r_ipv4) <- m (Either DNSError [(IP, TTL)])
-> m (Either DNSError [(IP, TTL)])
-> m (Either DNSError [(IP, TTL)], Either DNSError [(IP, TTL)])
forall a b. m a -> m b -> m (a, b)
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m (a, b)
concurrently (m (Maybe (Either DNSError DNSMessage))
-> m (Either DNSError [(IP, TTL)])
forall (m :: * -> *).
MonadThread m =>
m (Maybe (Either DNSError DNSMessage))
-> m (Either DNSError [(IP, TTL)])
domainAAAALookupWithTTL (Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage))
resolveDNS Domain
d TYPE
DNS.AAAA))
                                     (m (Maybe (Either DNSError DNSMessage))
-> m (Either DNSError [(IP, TTL)])
forall (m :: * -> *).
MonadThread m =>
m (Maybe (Either DNSError DNSMessage))
-> m (Either DNSError [(IP, TTL)])
domainALookupWithTTL (Domain -> TYPE -> m (Maybe (Either DNSError DNSMessage))
resolveDNS Domain
d TYPE
DNS.A))
    case (r_ipv6, r_ipv4) of
         (Left  DNSError
e6, Left  DNSError
e4) -> do
           Tracer m DNSTrace -> DNSTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DNSTrace
tracer (DNSTrace -> m ()) -> DNSTrace -> m ()
forall a b. (a -> b) -> a -> b
$ DNSPeersKind
-> Maybe DNSLookupType -> Domain -> DNSError -> DNSTrace
DNSTraceLookupError
                                DNSPeersKind
peerType (DNSLookupType -> Maybe DNSLookupType
forall a. a -> Maybe a
Just DNSLookupType
LookupReqAOnly) Domain
d DNSError
e4
           Tracer m DNSTrace -> DNSTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DNSTrace
tracer (DNSTrace -> m ()) -> DNSTrace -> m ()
forall a b. (a -> b) -> a -> b
$ DNSPeersKind
-> Maybe DNSLookupType -> Domain -> DNSError -> DNSTrace
DNSTraceLookupError
                                DNSPeersKind
peerType (DNSLookupType -> Maybe DNSLookupType
forall a. a -> Maybe a
Just DNSLookupType
LookupReqAAAAOnly) Domain
d DNSError
e6
           Either [DNSError] [(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [DNSError] [(IP, TTL)]
 -> m (Either [DNSError] [(IP, TTL)]))
-> ([DNSError] -> Either [DNSError] [(IP, TTL)])
-> [DNSError]
-> m (Either [DNSError] [(IP, TTL)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DNSError] -> Either [DNSError] [(IP, TTL)]
forall a b. a -> Either a b
Left ([DNSError] -> m (Either [DNSError] [(IP, TTL)]))
-> [DNSError] -> m (Either [DNSError] [(IP, TTL)])
forall a b. (a -> b) -> a -> b
$ [DNSError
e6, DNSError
e4]
         (Right [(IP, TTL)]
r6, Left  DNSError
e4) -> do
           Tracer m DNSTrace -> DNSTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DNSTrace
tracer (DNSTrace -> m ()) -> DNSTrace -> m ()
forall a b. (a -> b) -> a -> b
$ DNSPeersKind
-> Maybe DNSLookupType -> Domain -> DNSError -> DNSTrace
DNSTraceLookupError
                                DNSPeersKind
peerType (DNSLookupType -> Maybe DNSLookupType
forall a. a -> Maybe a
Just DNSLookupType
LookupReqAOnly) Domain
d DNSError
e4
           Either [DNSError] [(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [DNSError] [(IP, TTL)]
 -> m (Either [DNSError] [(IP, TTL)]))
-> ([(IP, TTL)] -> Either [DNSError] [(IP, TTL)])
-> [(IP, TTL)]
-> m (Either [DNSError] [(IP, TTL)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(IP, TTL)] -> Either [DNSError] [(IP, TTL)]
forall a b. b -> Either a b
Right ([(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)]))
-> [(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)])
forall a b. (a -> b) -> a -> b
$ [(IP, TTL)]
r6
         (Left  DNSError
e6, Right [(IP, TTL)]
r4) -> do
           Tracer m DNSTrace -> DNSTrace -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m DNSTrace
tracer (DNSTrace -> m ()) -> DNSTrace -> m ()
forall a b. (a -> b) -> a -> b
$ DNSPeersKind
-> Maybe DNSLookupType -> Domain -> DNSError -> DNSTrace
DNSTraceLookupError
                                DNSPeersKind
peerType (DNSLookupType -> Maybe DNSLookupType
forall a. a -> Maybe a
Just DNSLookupType
LookupReqAAAAOnly) Domain
d DNSError
e6
           Either [DNSError] [(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [DNSError] [(IP, TTL)]
 -> m (Either [DNSError] [(IP, TTL)]))
-> ([(IP, TTL)] -> Either [DNSError] [(IP, TTL)])
-> [(IP, TTL)]
-> m (Either [DNSError] [(IP, TTL)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(IP, TTL)] -> Either [DNSError] [(IP, TTL)]
forall a b. b -> Either a b
Right ([(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)]))
-> [(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)])
forall a b. (a -> b) -> a -> b
$ [(IP, TTL)]
r4
         (Right [(IP, TTL)]
r6, Right [(IP, TTL)]
r4) -> Either [DNSError] [(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [DNSError] [(IP, TTL)]
 -> m (Either [DNSError] [(IP, TTL)]))
-> ([(IP, TTL)] -> Either [DNSError] [(IP, TTL)])
-> [(IP, TTL)]
-> m (Either [DNSError] [(IP, TTL)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(IP, TTL)] -> Either [DNSError] [(IP, TTL)]
forall a b. b -> Either a b
Right ([(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)]))
-> [(IP, TTL)] -> m (Either [DNSError] [(IP, TTL)])
forall a b. (a -> b) -> a -> b
$ [(IP, TTL)]
r6 [(IP, TTL)] -> [(IP, TTL)] -> [(IP, TTL)]
forall a. Semigroup a => a -> a -> a
<> [(IP, TTL)]
r4


-- | Like 'DNS.lookupA' but also return the TTL for the results.
--
-- DNS library timeouts do not work reliably on Windows (#1873), hence the
-- additional timeout.
--
domainALookupWithTTL :: (MonadThread m)
               => m (Maybe (Either DNSError DNSMessage))
               -> m (Either DNS.DNSError [(IP, DNS.TTL)])
domainALookupWithTTL :: forall (m :: * -> *).
MonadThread m =>
m (Maybe (Either DNSError DNSMessage))
-> m (Either DNSError [(IP, TTL)])
domainALookupWithTTL m (Maybe (Either DNSError DNSMessage))
action = do
    String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"domainALookupWithTTL"
    reply <- m (Maybe (Either DNSError DNSMessage))
action
    case reply of
      Maybe (Either DNSError DNSMessage)
Nothing          -> Either DNSError [(IP, TTL)] -> m (Either DNSError [(IP, TTL)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSError -> Either DNSError [(IP, TTL)]
forall a b. a -> Either a b
Left DNSError
DNS.TimeoutExpired)
      Just (Left  DNSError
err) -> Either DNSError [(IP, TTL)] -> m (Either DNSError [(IP, TTL)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSError -> Either DNSError [(IP, TTL)]
forall a b. a -> Either a b
Left DNSError
err)
      Just (Right DNSMessage
ans) -> Either DNSError [(IP, TTL)] -> m (Either DNSError [(IP, TTL)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSMessage
-> (DNSMessage -> [(IP, TTL)]) -> Either DNSError [(IP, TTL)]
forall a. DNSMessage -> (DNSMessage -> a) -> Either DNSError a
DNS.fromDNSMessage DNSMessage
ans DNSMessage -> [(IP, TTL)]
selectA)
      --TODO: we can get the SOA TTL on NXDOMAIN here if we want to
  where
    selectA :: DNSMessage -> [(IP, TTL)]
selectA DNS.DNSMessage { Answers
answer :: DNSMessage -> Answers
answer :: Answers
DNS.answer } =
      [ (IPv4 -> IP
IPv4 IPv4
addr, TTL -> TTL
fixupTTL TTL
ttl)
      | DNS.ResourceRecord {
          rdata :: ResourceRecord -> RData
DNS.rdata = DNS.RD_A IPv4
addr,
          rrttl :: ResourceRecord -> TTL
DNS.rrttl = TTL
ttl
        } <- Answers
answer
      ]


domainAAAALookupWithTTL :: (MonadThread m)
                  => m (Maybe (Either DNSError DNSMessage))
                  -> m (Either DNS.DNSError [(IP, DNS.TTL)])
domainAAAALookupWithTTL :: forall (m :: * -> *).
MonadThread m =>
m (Maybe (Either DNSError DNSMessage))
-> m (Either DNSError [(IP, TTL)])
domainAAAALookupWithTTL m (Maybe (Either DNSError DNSMessage))
action = do
    String -> m ()
forall (m :: * -> *). MonadThread m => String -> m ()
labelThisThread String
"domainAAAALookupWithTTL"
    reply <- m (Maybe (Either DNSError DNSMessage))
action
    case reply of
      Maybe (Either DNSError DNSMessage)
Nothing          -> Either DNSError [(IP, TTL)] -> m (Either DNSError [(IP, TTL)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSError -> Either DNSError [(IP, TTL)]
forall a b. a -> Either a b
Left DNSError
DNS.TimeoutExpired)
      Just (Left  DNSError
err) -> Either DNSError [(IP, TTL)] -> m (Either DNSError [(IP, TTL)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSError -> Either DNSError [(IP, TTL)]
forall a b. a -> Either a b
Left DNSError
err)
      Just (Right DNSMessage
ans) -> Either DNSError [(IP, TTL)] -> m (Either DNSError [(IP, TTL)])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSMessage
-> (DNSMessage -> [(IP, TTL)]) -> Either DNSError [(IP, TTL)]
forall a. DNSMessage -> (DNSMessage -> a) -> Either DNSError a
DNS.fromDNSMessage DNSMessage
ans DNSMessage -> [(IP, TTL)]
selectAAAA)
      --TODO: we can get the SOA TTL on NXDOMAIN here if we want to
  where
    selectAAAA :: DNSMessage -> [(IP, TTL)]
selectAAAA DNS.DNSMessage { Answers
answer :: DNSMessage -> Answers
answer :: Answers
DNS.answer } =
      [ (IPv6 -> IP
IPv6 IPv6
addr, TTL -> TTL
fixupTTL TTL
ttl)
      | DNS.ResourceRecord {
          rdata :: ResourceRecord -> RData
DNS.rdata = DNS.RD_AAAA IPv6
addr,
          rrttl :: ResourceRecord -> TTL
DNS.rrttl = TTL
ttl
        } <- Answers
answer
      ]

--
-- Utils
--


fixupTTL :: DNS.TTL -> DNS.TTL
fixupTTL :: TTL -> TTL
fixupTTL TTL
0 = TTL
forall a. Bounded a => a
maxBound
fixupTTL TTL
a = TTL
a TTL -> TTL -> TTL
forall a. Ord a => a -> a -> a
`max` TTL
30