{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
  ( -- * DNS based actions for local and public root providers
    DNSActions (..)
    -- * DNSActions IO
  , ioDNSActions
  , DNSLookupType (..)
    -- * Utils
    -- ** Resource
  , Resource (..)
  , retryResource
  , constantResource
    -- ** Error type
  , DNSorIOError (..)
  ) where

import Data.Function (fix)
import Data.List.NonEmpty (NonEmpty (..))

import Control.Exception (IOException)
import Control.Monad.Class.MonadAsync
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 Data.IP (IP (..))
import Network.DNS (DNSError)
import Network.DNS qualified as DNS


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

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 resolver exception m = DNSActions {

    -- |
    --
    -- TODO: it could be useful for `publicRootPeersProvider`.
    --
    forall resolver exception (m :: * -> *).
DNSActions 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 resolver exception (m :: * -> *).
DNSActions 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 resolver exception (m :: * -> *).
DNSActions resolver exception m
-> ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, TTL)])
dnsLookupWithTTL         :: DNS.ResolvConf
                             -> resolver
                             -> DNS.Domain
                             -> m ([DNS.DNSError], [(IP, DNS.TTL)])
  }



-- | 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 :: DNSLookupType
             -> DNSActions DNS.Resolver IOException IO
ioDNSActions :: DNSLookupType -> DNSActions Resolver IOException IO
ioDNSActions =
    \DNSLookupType
reqs -> 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 :: ResolvConf -> Resolver -> Domain -> IO ([DNSError], [(IP, TTL)])
dnsLookupWithTTL         = DNSLookupType
-> ResolvConf -> Resolver -> Domain -> IO ([DNSError], [(IP, TTL)])
lookupWithTTL DNSLookupType
reqs
             }
  where
    -- |
    --
    -- 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)


    -- | 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.
    --
    lookupAWithTTL :: DNS.ResolvConf
                   -> DNS.Resolver
                   -> DNS.Domain
                   -> IO (Either DNS.DNSError [(IP, DNS.TTL)])
    lookupAWithTTL :: ResolvConf
-> Resolver -> Domain -> IO (Either DNSError [(IP, TTL)])
lookupAWithTTL ResolvConf
resolvConf Resolver
resolver Domain
domain = do
        reply <- 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
DNS.A)
        case reply of
          Maybe (Either DNSError DNSMessage)
Nothing          -> Either DNSError [(IP, TTL)] -> IO (Either DNSError [(IP, TTL)])
forall a. a -> IO 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)] -> IO (Either DNSError [(IP, TTL)])
forall a. a -> IO 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)] -> IO (Either DNSError [(IP, TTL)])
forall a. a -> IO 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 :: Answers
answer :: DNSMessage -> 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
          ]


    lookupAAAAWithTTL :: DNS.ResolvConf
                      -> DNS.Resolver
                      -> DNS.Domain
                      -> IO (Either DNS.DNSError [(IP, DNS.TTL)])
    lookupAAAAWithTTL :: ResolvConf
-> Resolver -> Domain -> IO (Either DNSError [(IP, TTL)])
lookupAAAAWithTTL ResolvConf
resolvConf Resolver
resolver Domain
domain = do
        reply <- 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
DNS.AAAA)
        case reply of
          Maybe (Either DNSError DNSMessage)
Nothing          -> Either DNSError [(IP, TTL)] -> IO (Either DNSError [(IP, TTL)])
forall a. a -> IO 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)] -> IO (Either DNSError [(IP, TTL)])
forall a. a -> IO 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)] -> IO (Either DNSError [(IP, TTL)])
forall a. a -> IO 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
          ]


    lookupWithTTL :: DNSLookupType
                  -> DNS.ResolvConf
                  -> DNS.Resolver
                  -> DNS.Domain
                  -> IO ([DNS.DNSError], [(IP, DNS.TTL)])
    lookupWithTTL :: DNSLookupType
-> ResolvConf -> Resolver -> Domain -> IO ([DNSError], [(IP, TTL)])
lookupWithTTL DNSLookupType
LookupReqAOnly ResolvConf
resolvConf Resolver
resolver Domain
domain = do
        res <- ResolvConf
-> Resolver -> Domain -> IO (Either DNSError [(IP, TTL)])
lookupAWithTTL ResolvConf
resolvConf Resolver
resolver Domain
domain
        case res of
             Left DNSError
err -> ([DNSError], [(IP, TTL)]) -> IO ([DNSError], [(IP, TTL)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DNSError
err], [])
             Right [(IP, TTL)]
r  -> ([DNSError], [(IP, TTL)]) -> IO ([DNSError], [(IP, TTL)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [(IP, TTL)]
r)

    lookupWithTTL DNSLookupType
LookupReqAAAAOnly ResolvConf
resolvConf Resolver
resolver Domain
domain = do
        res <- ResolvConf
-> Resolver -> Domain -> IO (Either DNSError [(IP, TTL)])
lookupAAAAWithTTL ResolvConf
resolvConf Resolver
resolver Domain
domain
        case res of
             Left DNSError
err -> ([DNSError], [(IP, TTL)]) -> IO ([DNSError], [(IP, TTL)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DNSError
err], [])
             Right [(IP, TTL)]
r  -> ([DNSError], [(IP, TTL)]) -> IO ([DNSError], [(IP, TTL)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [(IP, TTL)]
r)

    lookupWithTTL DNSLookupType
LookupReqAAndAAAA ResolvConf
resolvConf Resolver
resolver Domain
domain = do
        (r_ipv6, r_ipv4) <- IO (Either DNSError [(IP, TTL)])
-> IO (Either DNSError [(IP, TTL)])
-> IO (Either DNSError [(IP, TTL)], Either DNSError [(IP, TTL)])
forall a b. IO a -> IO b -> IO (a, b)
forall (m :: * -> *) a b. MonadAsync m => m a -> m b -> m (a, b)
concurrently (ResolvConf
-> Resolver -> Domain -> IO (Either DNSError [(IP, TTL)])
lookupAAAAWithTTL ResolvConf
resolvConf Resolver
resolver Domain
domain)
                                         (ResolvConf
-> Resolver -> Domain -> IO (Either DNSError [(IP, TTL)])
lookupAWithTTL ResolvConf
resolvConf Resolver
resolver Domain
domain)
        case (r_ipv6, r_ipv4) of
             (Left  DNSError
e6, Left  DNSError
e4) -> ([DNSError], [(IP, TTL)]) -> IO ([DNSError], [(IP, TTL)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DNSError
e6, DNSError
e4], [])
             (Right [(IP, TTL)]
r6, Left  DNSError
e4) -> ([DNSError], [(IP, TTL)]) -> IO ([DNSError], [(IP, TTL)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DNSError
e4], [(IP, TTL)]
r6)
             (Left  DNSError
e6, Right [(IP, TTL)]
r4) -> ([DNSError], [(IP, TTL)]) -> IO ([DNSError], [(IP, TTL)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([DNSError
e6], [(IP, TTL)]
r4)
             (Right [(IP, TTL)]
r6, Right [(IP, TTL)]
r4) -> ([DNSError], [(IP, TTL)]) -> IO ([DNSError], [(IP, TTL)])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [(IP, TTL)]
r6 [(IP, TTL)] -> [(IP, TTL)] -> [(IP, TTL)]
forall a. Semigroup a => a -> a -> a
<> [(IP, TTL)]
r4)


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