{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Ouroboros.Network.PeerSelection.RootPeersDNS.DNSActions
(
DNSActions (..)
, ioDNSActions
, LookupReqs (..)
, Resource (..)
, withResource'
, constantResource
, DNSorIOError (..)
) where
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import Control.Exception (IOException)
import Control.Monad.Class.MonadAsync
#if !defined(mingw32_HOST_OS)
import Control.Monad.Class.MonadSTM.Strict
#endif
import Control.Monad.Class.MonadThrow
import Control.Monad.Class.MonadTime
import Control.Monad.Class.MonadTimer
import Control.Tracer (Tracer (..), traceWith)
import System.Directory (getModificationTime)
import Data.IP (IP (..))
import Network.DNS (DNSError)
import qualified Network.DNS as DNS
data LookupReqs = LookupReqAOnly
| LookupReqAAAAOnly
| LookupReqAAndAAAA
deriving Int -> LookupReqs -> ShowS
[LookupReqs] -> ShowS
LookupReqs -> String
(Int -> LookupReqs -> ShowS)
-> (LookupReqs -> String)
-> ([LookupReqs] -> ShowS)
-> Show LookupReqs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LookupReqs] -> ShowS
$cshowList :: [LookupReqs] -> ShowS
show :: LookupReqs -> String
$cshow :: LookupReqs -> String
showsPrec :: Int -> LookupReqs -> ShowS
$cshowsPrec :: Int -> LookupReqs -> 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
showList :: [DNSorIOError exception] -> ShowS
$cshowList :: forall exception.
Show exception =>
[DNSorIOError exception] -> ShowS
show :: DNSorIOError exception -> String
$cshow :: forall exception.
Show exception =>
DNSorIOError exception -> String
showsPrec :: Int -> DNSorIOError exception -> ShowS
$cshowsPrec :: forall exception.
Show exception =>
Int -> DNSorIOError exception -> ShowS
Show
instance Exception exception => Exception (DNSorIOError exception) where
newtype Resource m err a = Resource {
Resource m err a -> m (Either err a, Resource m err a)
withResource :: m (Either err a, Resource m err a)
}
withResource' :: MonadDelay m
=> Tracer m err
-> NonEmpty DiffTime
-> Resource m err a
-> m (a, Resource m err a)
withResource' :: Tracer m err
-> NonEmpty DiffTime -> Resource m err a -> m (a, Resource m err a)
withResource' Tracer m err
tracer = NonEmpty DiffTime -> Resource m err a -> m (a, Resource m err a)
forall a.
NonEmpty DiffTime -> Resource m err a -> m (a, Resource m err a)
go
where
dropHead :: NonEmpty a -> NonEmpty a
dropHead :: NonEmpty a -> NonEmpty a
dropHead as :: NonEmpty a
as@(a
_ :| []) = NonEmpty a
as
dropHead (a
_ :| a
a : [a]
as) = a
a a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
as
go :: NonEmpty DiffTime -> Resource m err a -> m (a, Resource m err a)
go !NonEmpty DiffTime
delays Resource m err a
resource = do
(Either err a, Resource m err a)
er <- Resource m err a -> m (Either err a, Resource m err a)
forall (m :: * -> *) err a.
Resource m err a -> m (Either err a, Resource m err a)
withResource Resource m err a
resource
case (Either err a, Resource m err a)
er of
(Left err
err, Resource m err a
resource') -> do
Tracer m err -> err -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m err
tracer err
err
DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (NonEmpty DiffTime -> DiffTime
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty DiffTime
delays)
Tracer m err
-> NonEmpty DiffTime -> Resource m err a -> m (a, Resource m err a)
forall (m :: * -> *) err a.
MonadDelay m =>
Tracer m err
-> NonEmpty DiffTime -> Resource m err a -> m (a, Resource m err a)
withResource' Tracer m err
tracer (NonEmpty DiffTime -> NonEmpty DiffTime
forall a. NonEmpty a -> NonEmpty a
dropHead NonEmpty DiffTime
delays) Resource m err a
resource'
(Right a
r, Resource m err a
resource') ->
(a, Resource m err a) -> m (a, Resource m err a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
r, Resource m err a
resource')
constantResource :: Applicative m => a -> Resource m err a
constantResource :: a -> Resource m err a
constantResource a
a = m (Either err a, Resource m err a) -> Resource m err a
forall (m :: * -> *) err a.
m (Either err a, Resource m err a) -> Resource m err a
Resource ((Either err a, Resource m err a)
-> m (Either err a, Resource m err a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either err a
forall a b. b -> Either a b
Right a
a, a -> Resource m err a
forall (m :: * -> *) a err. Applicative m => a -> Resource m err a
constantResource a
a))
data TimedResolver
= TimedResolver !DNS.Resolver !UTCTime
| NoResolver
data DNSActions resolver exception m = DNSActions {
DNSActions resolver exception m
-> ResolvConf -> m (Resource m (DNSorIOError exception) resolver)
dnsResolverResource :: DNS.ResolvConf
-> m (Resource m (DNSorIOError exception) resolver),
DNSActions resolver exception m
-> ResolvConf -> m (Resource m (DNSorIOError exception) resolver)
dnsAsyncResolverResource :: DNS.ResolvConf
-> m (Resource m (DNSorIOError exception) resolver),
DNSActions resolver exception m
-> ResolvConf -> resolver -> Domain -> m ([DNSError], [(IP, TTL)])
dnsLookupWithTTL :: DNS.ResolvConf
-> resolver
-> DNS.Domain
-> m ([DNS.DNSError], [(IP, DNS.TTL)])
}
resolverResource :: DNS.ResolvConf
-> IO (Resource IO (DNSorIOError IOException) DNS.Resolver)
resolverResource :: ResolvConf -> IO (Resource IO (DNSorIOError IOException) Resolver)
resolverResource ResolvConf
resolvConf = do
ResolvSeed
rs <- ResolvConf -> IO ResolvSeed
DNS.makeResolvSeed ResolvConf
resolvConf
case ResolvConf -> FileOrNumericHost
DNS.resolvInfo ResolvConf
resolvConf of
DNS.RCFilePath String
filePath ->
Resource IO (DNSorIOError IOException) Resolver
-> IO (Resource IO (DNSorIOError IOException) Resolver)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resource IO (DNSorIOError IOException) Resolver
-> IO (Resource IO (DNSorIOError IOException) Resolver))
-> Resource IO (DNSorIOError IOException) Resolver
-> IO (Resource IO (DNSorIOError IOException) Resolver)
forall a b. (a -> b) -> a -> b
$ String
-> TimedResolver -> Resource IO (DNSorIOError IOException) Resolver
go String
filePath TimedResolver
NoResolver
FileOrNumericHost
_ -> ResolvSeed
-> (Resolver
-> IO (Resource IO (DNSorIOError IOException) Resolver))
-> IO (Resource IO (DNSorIOError IOException) Resolver)
forall a. ResolvSeed -> (Resolver -> IO a) -> IO a
DNS.withResolver ResolvSeed
rs (Resource IO (DNSorIOError IOException) Resolver
-> IO (Resource IO (DNSorIOError IOException) Resolver)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resource IO (DNSorIOError IOException) Resolver
-> IO (Resource IO (DNSorIOError IOException) Resolver))
-> (Resolver -> Resource IO (DNSorIOError IOException) Resolver)
-> Resolver
-> IO (Resource IO (DNSorIOError IOException) Resolver)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resolver -> Resource IO (DNSorIOError IOException) Resolver
forall (m :: * -> *) a err. Applicative m => a -> Resource m err a
constantResource)
where
handlers :: FilePath
-> TimedResolver
-> [Handler IO
( Either (DNSorIOError IOException) DNS.Resolver
, Resource IO (DNSorIOError IOException) DNS.Resolver)]
handlers :: String
-> TimedResolver
-> [Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)]
handlers String
filePath TimedResolver
tr =
[ (IOException
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((IOException
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> (IOException
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall a b. (a -> b) -> a -> b
$
\(IOException
err :: IOException) ->
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DNSorIOError IOException
-> Either (DNSorIOError IOException) Resolver
forall a b. a -> Either a b
Left (IOException -> DNSorIOError IOException
forall exception. exception -> DNSorIOError exception
IOError IOException
err), String
-> TimedResolver -> Resource IO (DNSorIOError IOException) Resolver
go String
filePath TimedResolver
tr)
, (DNSError
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((DNSError
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> (DNSError
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall a b. (a -> b) -> a -> b
$
\(DNSError
err :: DNS.DNSError) ->
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DNSorIOError IOException
-> Either (DNSorIOError IOException) Resolver
forall a b. a -> Either a b
Left (DNSError -> DNSorIOError IOException
forall exception. DNSError -> DNSorIOError exception
DNSError DNSError
err), String
-> TimedResolver -> Resource IO (DNSorIOError IOException) Resolver
go String
filePath TimedResolver
tr)
]
go :: FilePath
-> TimedResolver
-> Resource IO (DNSorIOError IOException) DNS.Resolver
go :: String
-> TimedResolver -> Resource IO (DNSorIOError IOException) Resolver
go String
filePath tr :: TimedResolver
tr@TimedResolver
NoResolver = IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> Resource IO (DNSorIOError IOException) Resolver
forall (m :: * -> *) err a.
m (Either err a, Resource m err a) -> Resource m err a
Resource (IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> Resource IO (DNSorIOError IOException) Resolver)
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> Resource IO (DNSorIOError IOException) Resolver
forall a b. (a -> b) -> a -> b
$
do
UTCTime
modTime <- String -> IO UTCTime
getModificationTime String
filePath
ResolvSeed
rs <- ResolvConf -> IO ResolvSeed
DNS.makeResolvSeed ResolvConf
resolvConf
ResolvSeed
-> (Resolver
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall a. ResolvSeed -> (Resolver -> IO a) -> IO a
DNS.withResolver ResolvSeed
rs
(\Resolver
resolver ->
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
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 (DNSorIOError IOException) Resolver
go String
filePath (Resolver -> UTCTime -> TimedResolver
TimedResolver Resolver
resolver UTCTime
modTime)))
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> [Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)]
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches` String
-> TimedResolver
-> [Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)]
handlers String
filePath TimedResolver
tr
go String
filePath tr :: TimedResolver
tr@(TimedResolver Resolver
resolver UTCTime
modTime) = IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> Resource IO (DNSorIOError IOException) Resolver
forall (m :: * -> *) err a.
m (Either err a, Resource m err a) -> Resource m err a
Resource (IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> Resource IO (DNSorIOError IOException) Resolver)
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> Resource IO (DNSorIOError IOException) Resolver
forall a b. (a -> b) -> a -> b
$
do
UTCTime
modTime' <- String -> IO UTCTime
getModificationTime String
filePath
if UTCTime
modTime' UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
modTime
then (Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
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 (DNSorIOError IOException) Resolver
go String
filePath (Resolver -> UTCTime -> TimedResolver
TimedResolver Resolver
resolver UTCTime
modTime))
else do
ResolvSeed
rs <- ResolvConf -> IO ResolvSeed
DNS.makeResolvSeed ResolvConf
resolvConf
ResolvSeed
-> (Resolver
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall a. ResolvSeed -> (Resolver -> IO a) -> IO a
DNS.withResolver ResolvSeed
rs
(\Resolver
resolver' ->
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
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 (DNSorIOError IOException) Resolver
go String
filePath (Resolver -> UTCTime -> TimedResolver
TimedResolver Resolver
resolver' UTCTime
modTime')))
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> [Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)]
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches` String
-> TimedResolver
-> [Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)]
handlers String
filePath TimedResolver
tr
asyncResolverResource :: DNS.ResolvConf
-> IO (Resource IO (DNSorIOError IOException)
DNS.Resolver)
#if !defined(mingw32_HOST_OS)
asyncResolverResource :: ResolvConf -> IO (Resource IO (DNSorIOError IOException) Resolver)
asyncResolverResource ResolvConf
resolvConf =
case ResolvConf -> FileOrNumericHost
DNS.resolvInfo ResolvConf
resolvConf of
DNS.RCFilePath String
filePath -> do
StrictTVar IO TimedResolver
resourceVar <- TimedResolver -> IO (StrictTVar IO TimedResolver)
forall (m :: * -> *) a. MonadSTM m => a -> m (StrictTVar m a)
newTVarIO TimedResolver
NoResolver
Resource IO (DNSorIOError IOException) Resolver
-> IO (Resource IO (DNSorIOError IOException) Resolver)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resource IO (DNSorIOError IOException) Resolver
-> IO (Resource IO (DNSorIOError IOException) Resolver))
-> Resource IO (DNSorIOError IOException) Resolver
-> IO (Resource IO (DNSorIOError IOException) Resolver)
forall a b. (a -> b) -> a -> b
$ String
-> StrictTVar IO TimedResolver
-> Resource IO (DNSorIOError IOException) Resolver
go String
filePath StrictTVar IO TimedResolver
resourceVar
FileOrNumericHost
_ -> do
ResolvSeed
rs <- ResolvConf -> IO ResolvSeed
DNS.makeResolvSeed ResolvConf
resolvConf
ResolvSeed
-> (Resolver
-> IO (Resource IO (DNSorIOError IOException) Resolver))
-> IO (Resource IO (DNSorIOError IOException) Resolver)
forall a. ResolvSeed -> (Resolver -> IO a) -> IO a
DNS.withResolver ResolvSeed
rs (Resource IO (DNSorIOError IOException) Resolver
-> IO (Resource IO (DNSorIOError IOException) Resolver)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Resource IO (DNSorIOError IOException) Resolver
-> IO (Resource IO (DNSorIOError IOException) Resolver))
-> (Resolver -> Resource IO (DNSorIOError IOException) Resolver)
-> Resolver
-> IO (Resource IO (DNSorIOError IOException) Resolver)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Resolver -> Resource IO (DNSorIOError IOException) Resolver
forall (m :: * -> *) a err. Applicative m => a -> Resource m err a
constantResource)
where
handlers :: FilePath -> StrictTVar IO TimedResolver
-> [Handler IO
( Either (DNSorIOError IOException) DNS.Resolver
, Resource IO (DNSorIOError IOException) DNS.Resolver)]
handlers :: String
-> StrictTVar IO TimedResolver
-> [Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)]
handlers String
filePath StrictTVar IO TimedResolver
resourceVar =
[ (IOException
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((IOException
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> (IOException
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall a b. (a -> b) -> a -> b
$
\(IOException
err :: IOException) ->
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DNSorIOError IOException
-> Either (DNSorIOError IOException) Resolver
forall a b. a -> Either a b
Left (IOException -> DNSorIOError IOException
forall exception. exception -> DNSorIOError exception
IOError IOException
err), String
-> StrictTVar IO TimedResolver
-> Resource IO (DNSorIOError IOException) Resolver
go String
filePath StrictTVar IO TimedResolver
resourceVar)
, (DNSError
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((DNSError
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> (DNSError
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall a b. (a -> b) -> a -> b
$
\(DNSError
err :: DNS.DNSError) ->
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DNSorIOError IOException
-> Either (DNSorIOError IOException) Resolver
forall a b. a -> Either a b
Left (DNSError -> DNSorIOError IOException
forall exception. DNSError -> DNSorIOError exception
DNSError DNSError
err), String
-> StrictTVar IO TimedResolver
-> Resource IO (DNSorIOError IOException) Resolver
go String
filePath StrictTVar IO TimedResolver
resourceVar)
]
go :: FilePath -> StrictTVar IO TimedResolver
-> Resource IO (DNSorIOError IOException) DNS.Resolver
go :: String
-> StrictTVar IO TimedResolver
-> Resource IO (DNSorIOError IOException) Resolver
go String
filePath StrictTVar IO TimedResolver
resourceVar = IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> Resource IO (DNSorIOError IOException) Resolver
forall (m :: * -> *) err a.
m (Either err a, Resource m err a) -> Resource m err a
Resource (IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> Resource IO (DNSorIOError IOException) Resolver)
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> Resource IO (DNSorIOError IOException) Resolver
forall a b. (a -> b) -> a -> b
$ do
TimedResolver
r <- STM IO TimedResolver -> IO TimedResolver
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar IO TimedResolver -> STM IO TimedResolver
forall (m :: * -> *) a. MonadSTM m => StrictTVar m a -> STM m a
readTVar StrictTVar IO TimedResolver
resourceVar)
case TimedResolver
r of
TimedResolver
NoResolver ->
do
UTCTime
modTime <- String -> IO UTCTime
getModificationTime String
filePath
ResolvSeed
rs <- ResolvConf -> IO ResolvSeed
DNS.makeResolvSeed ResolvConf
resolvConf
ResolvSeed
-> (Resolver
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall a. ResolvSeed -> (Resolver -> IO a) -> IO a
DNS.withResolver ResolvSeed
rs ((Resolver
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> (Resolver
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall a b. (a -> b) -> a -> b
$ \Resolver
resolver -> do
STM IO () -> IO ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar IO TimedResolver -> TimedResolver -> STM IO ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar IO TimedResolver
resourceVar (Resolver -> UTCTime -> TimedResolver
TimedResolver Resolver
resolver UTCTime
modTime))
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
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 (DNSorIOError IOException) Resolver
go String
filePath StrictTVar IO TimedResolver
resourceVar)
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> [Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)]
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches` String
-> StrictTVar IO TimedResolver
-> [Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)]
handlers String
filePath StrictTVar IO TimedResolver
resourceVar
TimedResolver Resolver
resolver UTCTime
modTime ->
do
UTCTime
modTime' <- String -> IO UTCTime
getModificationTime String
filePath
if UTCTime
modTime' UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
<= UTCTime
modTime
then (Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
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 (DNSorIOError IOException) Resolver
go String
filePath StrictTVar IO TimedResolver
resourceVar)
else do
ResolvSeed
rs <- ResolvConf -> IO ResolvSeed
DNS.makeResolvSeed ResolvConf
resolvConf
ResolvSeed
-> (Resolver
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall a. ResolvSeed -> (Resolver -> IO a) -> IO a
DNS.withResolver ResolvSeed
rs ((Resolver
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> (Resolver
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver))
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall a b. (a -> b) -> a -> b
$ \Resolver
resolver' -> do
STM IO () -> IO ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (StrictTVar IO TimedResolver -> TimedResolver -> STM IO ()
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
StrictTVar m a -> a -> STM m ()
writeTVar StrictTVar IO TimedResolver
resourceVar (Resolver -> UTCTime -> TimedResolver
TimedResolver Resolver
resolver' UTCTime
modTime'))
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
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 (DNSorIOError IOException) Resolver
go String
filePath StrictTVar IO TimedResolver
resourceVar)
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
-> [Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)]
-> IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)
forall (m :: * -> *) a. MonadCatch m => m a -> [Handler m a] -> m a
`catches` String
-> StrictTVar IO TimedResolver
-> [Handler
IO
(Either (DNSorIOError IOException) Resolver,
Resource IO (DNSorIOError IOException) Resolver)]
handlers String
filePath StrictTVar IO TimedResolver
resourceVar
#else
asyncResolverResource resolvConf = return go
where
go = Resource $
do
rs <- DNS.makeResolvSeed resolvConf
DNS.withResolver rs $ \resolver -> pure (Right resolver, go)
`catches` handlers
handlers :: [Handler IO
( Either (DNSorIOError IOException) DNS.Resolver
, Resource IO (DNSorIOError IOException) DNS.Resolver)]
handlers =
[ Handler $
\(err :: IOException) ->
pure (Left (IOError err), go)
, Handler $
\(err :: DNS.DNSError) ->
pure (Left (DNSError err), go)
]
#endif
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
Maybe (Either DNSError DNSMessage)
reply <- DiffTime
-> IO (Either DNSError DNSMessage)
-> IO (Maybe (Either DNSError DNSMessage))
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 Maybe (Either DNSError DNSMessage)
reply of
Maybe (Either DNSError DNSMessage)
Nothing -> Either DNSError [(IP, TTL)] -> IO (Either DNSError [(IP, TTL)])
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 (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 (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)
where
selectA :: DNSMessage -> [(IP, TTL)]
selectA DNS.DNSMessage { [ResourceRecord]
answer :: DNSMessage -> [ResourceRecord]
answer :: [ResourceRecord]
DNS.answer } =
[ (IPv4 -> IP
IPv4 IPv4
addr, TTL
ttl)
| DNS.ResourceRecord {
rdata :: ResourceRecord -> RData
DNS.rdata = DNS.RD_A IPv4
addr,
rrttl :: ResourceRecord -> TTL
DNS.rrttl = TTL
ttl
} <- [ResourceRecord]
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
Maybe (Either DNSError DNSMessage)
reply <- DiffTime
-> IO (Either DNSError DNSMessage)
-> IO (Maybe (Either DNSError DNSMessage))
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 Maybe (Either DNSError DNSMessage)
reply of
Maybe (Either DNSError DNSMessage)
Nothing -> Either DNSError [(IP, TTL)] -> IO (Either DNSError [(IP, TTL)])
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 (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 (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)
where
selectAAAA :: DNSMessage -> [(IP, TTL)]
selectAAAA DNS.DNSMessage { [ResourceRecord]
answer :: [ResourceRecord]
answer :: DNSMessage -> [ResourceRecord]
DNS.answer } =
[ (IPv6 -> IP
IPv6 IPv6
addr, TTL
ttl)
| DNS.ResourceRecord {
rdata :: ResourceRecord -> RData
DNS.rdata = DNS.RD_AAAA IPv6
addr,
rrttl :: ResourceRecord -> TTL
DNS.rrttl = TTL
ttl
} <- [ResourceRecord]
answer
]
lookupWithTTL :: LookupReqs
-> DNS.ResolvConf
-> DNS.Resolver
-> DNS.Domain
-> IO ([DNS.DNSError], [(IP, DNS.TTL)])
lookupWithTTL :: LookupReqs
-> ResolvConf -> Resolver -> Domain -> IO ([DNSError], [(IP, TTL)])
lookupWithTTL LookupReqs
LookupReqAOnly ResolvConf
resolvConf Resolver
resolver Domain
domain = do
Either DNSError [(IP, TTL)]
res <- ResolvConf
-> Resolver -> Domain -> IO (Either DNSError [(IP, TTL)])
lookupAWithTTL ResolvConf
resolvConf Resolver
resolver Domain
domain
case Either DNSError [(IP, TTL)]
res of
Left DNSError
err -> ([DNSError], [(IP, TTL)]) -> IO ([DNSError], [(IP, TTL)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([DNSError
err], [])
Right [(IP, TTL)]
r -> ([DNSError], [(IP, TTL)]) -> IO ([DNSError], [(IP, TTL)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [(IP, TTL)]
r)
lookupWithTTL LookupReqs
LookupReqAAAAOnly ResolvConf
resolvConf Resolver
resolver Domain
domain = do
Either DNSError [(IP, TTL)]
res <- ResolvConf
-> Resolver -> Domain -> IO (Either DNSError [(IP, TTL)])
lookupAAAAWithTTL ResolvConf
resolvConf Resolver
resolver Domain
domain
case Either DNSError [(IP, TTL)]
res of
Left DNSError
err -> ([DNSError], [(IP, TTL)]) -> IO ([DNSError], [(IP, TTL)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([DNSError
err], [])
Right [(IP, TTL)]
r -> ([DNSError], [(IP, TTL)]) -> IO ([DNSError], [(IP, TTL)])
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [(IP, TTL)]
r)
lookupWithTTL LookupReqs
LookupReqAAndAAAA ResolvConf
resolvConf Resolver
resolver Domain
domain = do
(Either DNSError [(IP, TTL)]
r_ipv6, Either DNSError [(IP, TTL)]
r_ipv4) <- IO (Either DNSError [(IP, TTL)])
-> IO (Either DNSError [(IP, TTL)])
-> IO (Either DNSError [(IP, TTL)], Either DNSError [(IP, TTL)])
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 (Either DNSError [(IP, TTL)]
r_ipv6, Either DNSError [(IP, TTL)]
r_ipv4) of
(Left DNSError
e6, Left DNSError
e4) -> ([DNSError], [(IP, TTL)]) -> IO ([DNSError], [(IP, TTL)])
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 (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 (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 (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)
ioDNSActions :: LookupReqs
-> DNSActions DNS.Resolver IOException IO
ioDNSActions :: LookupReqs -> DNSActions Resolver IOException IO
ioDNSActions LookupReqs
reqs =
DNSActions :: forall resolver exception (m :: * -> *).
(ResolvConf -> m (Resource m (DNSorIOError exception) resolver))
-> (ResolvConf -> m (Resource m (DNSorIOError exception) resolver))
-> (ResolvConf
-> resolver -> Domain -> m ([DNSError], [(IP, TTL)]))
-> DNSActions resolver exception m
DNSActions {
dnsResolverResource :: ResolvConf -> IO (Resource IO (DNSorIOError IOException) Resolver)
dnsResolverResource = ResolvConf -> IO (Resource IO (DNSorIOError IOException) Resolver)
resolverResource,
dnsAsyncResolverResource :: ResolvConf -> IO (Resource IO (DNSorIOError IOException) Resolver)
dnsAsyncResolverResource = ResolvConf -> IO (Resource IO (DNSorIOError IOException) Resolver)
asyncResolverResource,
dnsLookupWithTTL :: ResolvConf -> Resolver -> Domain -> IO ([DNSError], [(IP, TTL)])
dnsLookupWithTTL = LookupReqs
-> ResolvConf -> Resolver -> Domain -> IO ([DNSError], [(IP, TTL)])
lookupWithTTL LookupReqs
reqs
}