{-# 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 (..)
  , SRVPrefix
    -- * 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.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 =
  -- | DNS lookup result
    DNSLookupResult
      DNSPeersKind
      DNS.Domain
      -- ^ source of addresses
      (Maybe DNS.Domain)
      -- ^ SRV domain, if relevant
      [(IP, PortNumber, DNS.TTL)]
      -- ^ payload

    -- | `DNS` lookup error
  | DNSLookupError
      DNSPeersKind
      (Maybe DNSLookupType)
      DNS.Domain
      DNS.DNSError

  | SRVLookupResult
      DNSPeersKind
      DNS.Domain
      [(DNS.Domain, Word16, Word16, Word16, DNS.TTL)]

    -- | `SRV` resolution errors, all dns errors are traced with
    -- `DNSLookupError`
  | SRVLookupError
     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
    = DNSError !DNSError
    | IOError  !IOError
  deriving Int -> DNSorIOError -> ShowS
[DNSorIOError] -> ShowS
DNSorIOError -> String
(Int -> DNSorIOError -> ShowS)
-> (DNSorIOError -> String)
-> ([DNSorIOError] -> ShowS)
-> Show DNSorIOError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DNSorIOError -> ShowS
showsPrec :: Int -> DNSorIOError -> ShowS
$cshow :: DNSorIOError -> String
show :: DNSorIOError -> String
$cshowList :: [DNSorIOError] -> ShowS
showList :: [DNSorIOError] -> ShowS
Show

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

instance Exception DNSorIOError 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 m = DNSActions {

    -- |
    --
    -- TODO: it could be useful for `publicRootPeersProvider`.
    --
    forall peerAddr resolver (m :: * -> *).
DNSActions peerAddr resolver m
-> ResolvConf -> m (Resource m (Either DNSorIOError resolver))
dnsResolverResource      :: DNS.ResolvConf
                             -> m (Resource m (Either DNSorIOError 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 (m :: * -> *).
DNSActions peerAddr resolver m
-> ResolvConf -> m (Resource m (Either DNSorIOError resolver))
dnsAsyncResolverResource :: DNS.ResolvConf
                             -> m (Resource m (Either DNSorIOError 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 (m :: * -> *).
DNSActions peerAddr resolver 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 m = PeerActionsDNS {
    forall peeraddr resolver (m :: * -> *).
PeerActionsDNS peeraddr resolver m -> IP -> PortNumber -> peeraddr
paToPeerAddr :: IP -> PortNumber -> peeraddr,
    forall peeraddr resolver (m :: * -> *).
PeerActionsDNS peeraddr resolver m
-> DNSActions peeraddr resolver m
paDnsActions :: DNSActions peeraddr resolver 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 IO
ioDNSActions :: forall peerAddr.
Tracer IO DNSTrace
-> DNSLookupType
-> (IP -> PortNumber -> peerAddr)
-> DNSActions peerAddr Resolver IO
ioDNSActions Tracer IO DNSTrace
tracer DNSLookupType
lookupType IP -> PortNumber -> peerAddr
toPeerAddr =
    DNSActions {
      dnsResolverResource :: ResolvConf -> IO (Resource IO (Either DNSorIOError Resolver))
dnsResolverResource      = ResolvConf -> IO (Resource IO (Either DNSorIOError Resolver))
resolverResource,
      dnsAsyncResolverResource :: ResolvConf -> IO (Resource IO (Either DNSorIOError Resolver))
dnsAsyncResolverResource = ResolvConf -> IO (Resource IO (Either DNSorIOError 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 DNS.Resolver))
    resolverResource :: ResolvConf -> IO (Resource IO (Either DNSorIOError 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 Resolver)
-> IO (Resource IO (Either DNSorIOError Resolver))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resource IO (Either DNSorIOError Resolver)
 -> IO (Resource IO (Either DNSorIOError Resolver)))
-> Resource IO (Either DNSorIOError Resolver)
-> IO (Resource IO (Either DNSorIOError Resolver))
forall a b. (a -> b) -> a -> b
$ String
-> TimedResolver -> Resource IO (Either DNSorIOError Resolver)
go String
filePath TimedResolver
NoResolver

          FileOrNumericHost
_ -> ResolvSeed
-> (Resolver -> IO (Resource IO (Either DNSorIOError Resolver)))
-> IO (Resource IO (Either DNSorIOError Resolver))
forall a. ResolvSeed -> (Resolver -> IO a) -> IO a
DNS.withResolver ResolvSeed
rs (Resource IO (Either DNSorIOError Resolver)
-> IO (Resource IO (Either DNSorIOError Resolver))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resource IO (Either DNSorIOError Resolver)
 -> IO (Resource IO (Either DNSorIOError Resolver)))
-> (Resolver -> Resource IO (Either DNSorIOError Resolver))
-> Resolver
-> IO (Resource IO (Either DNSorIOError Resolver))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Resolver -> Either DNSorIOError Resolver)
-> Resource IO Resolver
-> Resource IO (Either DNSorIOError 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 Resolver
forall a b. b -> Either a b
Right (Resource IO Resolver
 -> Resource IO (Either DNSorIOError Resolver))
-> (Resolver -> Resource IO Resolver)
-> Resolver
-> Resource IO (Either DNSorIOError 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 a) ]
        handlers :: forall a. [Handler IO (Either DNSorIOError a)]
handlers  = [ (IOError -> IO (Either DNSorIOError a))
-> Handler IO (Either DNSorIOError a)
forall {k} (m :: k -> *) (a :: k) e.
Exception e =>
(e -> m a) -> Handler m a
Handler ((IOError -> IO (Either DNSorIOError a))
 -> Handler IO (Either DNSorIOError a))
-> (IOError -> IO (Either DNSorIOError a))
-> Handler IO (Either DNSorIOError a)
forall a b. (a -> b) -> a -> b
$ Either DNSorIOError a -> IO (Either DNSorIOError a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DNSorIOError a -> IO (Either DNSorIOError a))
-> (IOError -> Either DNSorIOError a)
-> IOError
-> IO (Either DNSorIOError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSorIOError -> Either DNSorIOError a
forall a b. a -> Either a b
Left (DNSorIOError -> Either DNSorIOError a)
-> (IOError -> DNSorIOError) -> IOError -> Either DNSorIOError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> DNSorIOError
IOError
                    , (DNSError -> IO (Either DNSorIOError a))
-> Handler IO (Either DNSorIOError a)
forall {k} (m :: k -> *) (a :: k) e.
Exception e =>
(e -> m a) -> Handler m a
Handler ((DNSError -> IO (Either DNSorIOError a))
 -> Handler IO (Either DNSorIOError a))
-> (DNSError -> IO (Either DNSorIOError a))
-> Handler IO (Either DNSorIOError a)
forall a b. (a -> b) -> a -> b
$ Either DNSorIOError a -> IO (Either DNSorIOError a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DNSorIOError a -> IO (Either DNSorIOError a))
-> (DNSError -> Either DNSorIOError a)
-> DNSError
-> IO (Either DNSorIOError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSorIOError -> Either DNSorIOError a
forall a b. a -> Either a b
Left (DNSorIOError -> Either DNSorIOError a)
-> (DNSError -> DNSorIOError) -> DNSError -> Either DNSorIOError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSError -> DNSorIOError
DNSError
                    ]

        go :: FilePath
           -> TimedResolver
           -> Resource IO (Either DNSorIOError DNS.Resolver)
        go :: String
-> TimedResolver -> Resource IO (Either DNSorIOError Resolver)
go String
filePath tr :: TimedResolver
tr@TimedResolver
NoResolver = IO
  (Either DNSorIOError Resolver,
   Resource IO (Either DNSorIOError Resolver))
-> Resource IO (Either DNSorIOError Resolver)
forall (m :: * -> *) a. m (a, Resource m a) -> Resource m a
Resource (IO
   (Either DNSorIOError Resolver,
    Resource IO (Either DNSorIOError Resolver))
 -> Resource IO (Either DNSorIOError Resolver))
-> IO
     (Either DNSorIOError Resolver,
      Resource IO (Either DNSorIOError Resolver))
-> Resource IO (Either DNSorIOError Resolver)
forall a b. (a -> b) -> a -> b
$
          do
            result
              <- (((TimeStamp, Resolver)
 -> Either DNSorIOError (TimeStamp, Resolver))
-> TimeStamp
-> Resolver
-> Either DNSorIOError (TimeStamp, Resolver)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (TimeStamp, Resolver) -> Either DNSorIOError (TimeStamp, Resolver)
forall a b. b -> Either a b
Right
                   (TimeStamp
 -> Resolver -> Either DNSorIOError (TimeStamp, Resolver))
-> IO TimeStamp
-> IO (Resolver -> Either DNSorIOError (TimeStamp, Resolver))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO TimeStamp
getTimeStamp String
filePath
                   IO (Resolver -> Either DNSorIOError (TimeStamp, Resolver))
-> IO Resolver -> IO (Either DNSorIOError (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 (TimeStamp, Resolver))
-> [Handler IO (Either DNSorIOError (TimeStamp, Resolver))]
-> IO (Either DNSorIOError (TimeStamp, Resolver))
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches` [Handler IO (Either DNSorIOError (TimeStamp, Resolver))]
forall a. [Handler IO (Either DNSorIOError a)]
handlers
            case result of
              Left DNSorIOError
err ->
                (Either DNSorIOError Resolver,
 Resource IO (Either DNSorIOError Resolver))
-> IO
     (Either DNSorIOError Resolver,
      Resource IO (Either DNSorIOError Resolver))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DNSorIOError -> Either DNSorIOError Resolver
forall a b. a -> Either a b
Left DNSorIOError
err, String
-> TimedResolver -> Resource IO (Either DNSorIOError Resolver)
go String
filePath TimedResolver
tr)
              Right (TimeStamp
modTime, Resolver
resolver) -> do
                (Either DNSorIOError Resolver,
 Resource IO (Either DNSorIOError Resolver))
-> IO
     (Either DNSorIOError Resolver,
      Resource IO (Either DNSorIOError Resolver))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resolver -> Either DNSorIOError Resolver
forall a b. b -> Either a b
Right Resolver
resolver, String
-> TimedResolver -> Resource IO (Either DNSorIOError 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 Resolver,
   Resource IO (Either DNSorIOError Resolver))
-> Resource IO (Either DNSorIOError Resolver)
forall (m :: * -> *) a. m (a, Resource m a) -> Resource m a
Resource (IO
   (Either DNSorIOError Resolver,
    Resource IO (Either DNSorIOError Resolver))
 -> Resource IO (Either DNSorIOError Resolver))
-> IO
     (Either DNSorIOError Resolver,
      Resource IO (Either DNSorIOError Resolver))
-> Resource IO (Either DNSorIOError Resolver)
forall a b. (a -> b) -> a -> b
$ do
          result <- ExceptT DNSorIOError IO (Resolver, TimeStamp)
-> IO (Either DNSorIOError (Resolver, TimeStamp))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT DNSorIOError IO (Resolver, TimeStamp)
 -> IO (Either DNSorIOError (Resolver, TimeStamp)))
-> ExceptT DNSorIOError IO (Resolver, TimeStamp)
-> IO (Either DNSorIOError (Resolver, TimeStamp))
forall a b. (a -> b) -> a -> b
$ do
            modTime' <- IO (Either DNSorIOError TimeStamp)
-> ExceptT DNSorIOError IO TimeStamp
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either DNSorIOError TimeStamp)
 -> ExceptT DNSorIOError IO TimeStamp)
-> IO (Either DNSorIOError TimeStamp)
-> ExceptT DNSorIOError IO TimeStamp
forall a b. (a -> b) -> a -> b
$ (TimeStamp -> Either DNSorIOError TimeStamp
forall a b. b -> Either a b
Right (TimeStamp -> Either DNSorIOError TimeStamp)
-> IO TimeStamp -> IO (Either DNSorIOError TimeStamp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO TimeStamp
getTimeStamp String
filePath)
                                  IO (Either DNSorIOError TimeStamp)
-> [Handler IO (Either DNSorIOError TimeStamp)]
-> IO (Either DNSorIOError TimeStamp)
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches` [Handler IO (Either DNSorIOError TimeStamp)]
forall a. [Handler IO (Either DNSorIOError 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
err ->
              (Either DNSorIOError Resolver,
 Resource IO (Either DNSorIOError Resolver))
-> IO
     (Either DNSorIOError Resolver,
      Resource IO (Either DNSorIOError Resolver))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSorIOError -> Either DNSorIOError Resolver
forall a b. a -> Either a b
Left DNSorIOError
err, String
-> TimedResolver -> Resource IO (Either DNSorIOError Resolver)
go String
filePath TimedResolver
tr)
            Right (Resolver
resolver', TimeStamp
modTime') ->
              (Either DNSorIOError Resolver,
 Resource IO (Either DNSorIOError Resolver))
-> IO
     (Either DNSorIOError Resolver,
      Resource IO (Either DNSorIOError Resolver))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Resolver -> Either DNSorIOError Resolver
forall a b. b -> Either a b
Right Resolver
resolver', String
-> TimedResolver -> Resource IO (Either DNSorIOError 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 DNS.Resolver))

    asyncResolverResource :: ResolvConf -> IO (Resource IO (Either DNSorIOError 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 Resolver)
-> Resource IO Resolver
-> Resource IO (Either DNSorIOError 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 Resolver
forall a b. b -> Either a b
Right (Resource IO Resolver
 -> Resource IO (Either DNSorIOError Resolver))
-> (Resolver -> Resource IO Resolver)
-> Resolver
-> Resource IO (Either DNSorIOError 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 Resolver))
-> IO Resolver -> IO (Resource IO (Either DNSorIOError 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 a) ]
        handlers :: forall a. [Handler IO (Either DNSorIOError a)]
handlers  = [ (IOError -> IO (Either DNSorIOError a))
-> Handler IO (Either DNSorIOError a)
forall {k} (m :: k -> *) (a :: k) e.
Exception e =>
(e -> m a) -> Handler m a
Handler ((IOError -> IO (Either DNSorIOError a))
 -> Handler IO (Either DNSorIOError a))
-> (IOError -> IO (Either DNSorIOError a))
-> Handler IO (Either DNSorIOError a)
forall a b. (a -> b) -> a -> b
$ Either DNSorIOError a -> IO (Either DNSorIOError a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DNSorIOError a -> IO (Either DNSorIOError a))
-> (IOError -> Either DNSorIOError a)
-> IOError
-> IO (Either DNSorIOError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSorIOError -> Either DNSorIOError a
forall a b. a -> Either a b
Left (DNSorIOError -> Either DNSorIOError a)
-> (IOError -> DNSorIOError) -> IOError -> Either DNSorIOError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IOError -> DNSorIOError
IOError
                    , (DNSError -> IO (Either DNSorIOError a))
-> Handler IO (Either DNSorIOError a)
forall {k} (m :: k -> *) (a :: k) e.
Exception e =>
(e -> m a) -> Handler m a
Handler ((DNSError -> IO (Either DNSorIOError a))
 -> Handler IO (Either DNSorIOError a))
-> (DNSError -> IO (Either DNSorIOError a))
-> Handler IO (Either DNSorIOError a)
forall a b. (a -> b) -> a -> b
$ Either DNSorIOError a -> IO (Either DNSorIOError a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either DNSorIOError a -> IO (Either DNSorIOError a))
-> (DNSError -> Either DNSorIOError a)
-> DNSError
-> IO (Either DNSorIOError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSorIOError -> Either DNSorIOError a
forall a b. a -> Either a b
Left (DNSorIOError -> Either DNSorIOError a)
-> (DNSError -> DNSorIOError) -> DNSError -> Either DNSorIOError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DNSError -> DNSorIOError
DNSError
                    ]

        go :: FilePath -> StrictTVar IO TimedResolver
           -> Resource IO (Either DNSorIOError DNS.Resolver)
        go :: String
-> StrictTVar IO TimedResolver
-> Resource IO (Either DNSorIOError Resolver)
go String
filePath StrictTVar IO TimedResolver
resourceVar = IO
  (Either DNSorIOError Resolver,
   Resource IO (Either DNSorIOError Resolver))
-> Resource IO (Either DNSorIOError Resolver)
forall (m :: * -> *) a. m (a, Resource m a) -> Resource m a
Resource (IO
   (Either DNSorIOError Resolver,
    Resource IO (Either DNSorIOError Resolver))
 -> Resource IO (Either DNSorIOError Resolver))
-> IO
     (Either DNSorIOError Resolver,
      Resource IO (Either DNSorIOError Resolver))
-> Resource IO (Either DNSorIOError 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 (TimeStamp, Resolver))
-> TimeStamp
-> Resolver
-> Either DNSorIOError (TimeStamp, Resolver)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (TimeStamp, Resolver) -> Either DNSorIOError (TimeStamp, Resolver)
forall a b. b -> Either a b
Right
                       (TimeStamp
 -> Resolver -> Either DNSorIOError (TimeStamp, Resolver))
-> IO TimeStamp
-> IO (Resolver -> Either DNSorIOError (TimeStamp, Resolver))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO TimeStamp
getTimeStamp String
filePath
                       IO (Resolver -> Either DNSorIOError (TimeStamp, Resolver))
-> IO Resolver -> IO (Either DNSorIOError (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 (TimeStamp, Resolver))
-> [Handler IO (Either DNSorIOError (TimeStamp, Resolver))]
-> IO (Either DNSorIOError (TimeStamp, Resolver))
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches` [Handler IO (Either DNSorIOError (TimeStamp, Resolver))]
forall a. [Handler IO (Either DNSorIOError a)]
handlers
                case result of
                  Left DNSorIOError
err ->
                    (Either DNSorIOError Resolver,
 Resource IO (Either DNSorIOError Resolver))
-> IO
     (Either DNSorIOError Resolver,
      Resource IO (Either DNSorIOError Resolver))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DNSorIOError -> Either DNSorIOError Resolver
forall a b. a -> Either a b
Left DNSorIOError
err, String
-> StrictTVar IO TimedResolver
-> Resource IO (Either DNSorIOError 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 Resolver,
 Resource IO (Either DNSorIOError Resolver))
-> IO
     (Either DNSorIOError Resolver,
      Resource IO (Either DNSorIOError Resolver))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resolver -> Either DNSorIOError Resolver
forall a b. b -> Either a b
Right Resolver
resolver, String
-> StrictTVar IO TimedResolver
-> Resource IO (Either DNSorIOError Resolver)
go String
filePath StrictTVar IO TimedResolver
resourceVar)

            TimedResolver Resolver
resolver TimeStamp
modTime -> do
              result <- ExceptT DNSorIOError IO Resolver
-> IO (Either DNSorIOError Resolver)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT DNSorIOError IO Resolver
 -> IO (Either DNSorIOError Resolver))
-> ExceptT DNSorIOError IO Resolver
-> IO (Either DNSorIOError Resolver)
forall a b. (a -> b) -> a -> b
$ do
                modTime' <- IO (Either DNSorIOError TimeStamp)
-> ExceptT DNSorIOError IO TimeStamp
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either DNSorIOError TimeStamp)
 -> ExceptT DNSorIOError IO TimeStamp)
-> IO (Either DNSorIOError TimeStamp)
-> ExceptT DNSorIOError IO TimeStamp
forall a b. (a -> b) -> a -> b
$ (TimeStamp -> Either DNSorIOError TimeStamp
forall a b. b -> Either a b
Right (TimeStamp -> Either DNSorIOError TimeStamp)
-> IO TimeStamp -> IO (Either DNSorIOError TimeStamp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO TimeStamp
getTimeStamp String
filePath)
                                      IO (Either DNSorIOError TimeStamp)
-> [Handler IO (Either DNSorIOError TimeStamp)]
-> IO (Either DNSorIOError TimeStamp)
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches` [Handler IO (Either DNSorIOError TimeStamp)]
forall a. [Handler IO (Either DNSorIOError 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
err ->
                  (Either DNSorIOError Resolver,
 Resource IO (Either DNSorIOError Resolver))
-> IO
     (Either DNSorIOError Resolver,
      Resource IO (Either DNSorIOError Resolver))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DNSorIOError -> Either DNSorIOError Resolver
forall a b. a -> Either a b
Left DNSorIOError
err, String
-> StrictTVar IO TimedResolver
-> Resource IO (Either DNSorIOError Resolver)
go String
filePath StrictTVar IO TimedResolver
resourceVar)
                Right Resolver
resolver' ->
                  (Either DNSorIOError Resolver,
 Resource IO (Either DNSorIOError Resolver))
-> IO
     (Either DNSorIOError Resolver,
      Resource IO (Either DNSorIOError Resolver))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Resolver -> Either DNSorIOError Resolver
forall a b. b -> Either a b
Right Resolver
resolver', String
-> StrictTVar IO TimedResolver
-> Resource IO (Either DNSorIOError 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
DNSLookupError 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
DNSLookupError 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
DNSLookupError 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
            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 -> [(Domain, Word16, Word16, Word16, TTL)] -> DNSTrace
SRVLookupResult DNSPeersKind
peerType Domain
domainSRV [(Domain, Word16, Word16, Word16, TTL)]
services
            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
SRVLookupError 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
DNSLookupResult 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 . DNSLookupResult 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
DNSLookupError 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
DNSLookupError 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
DNSLookupError
                                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
DNSLookupError
                                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
DNSLookupError
                                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
DNSLookupError
                                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