{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
module Network.DNS.Resolver (
ResolvConf
, defaultResolvConf
, resolvInfo
, resolvTimeout
, resolvRetry
, resolvConcurrent
, resolvCache
, resolvQueryControls
, FileOrNumericHost(..)
, CacheConf
, defaultCacheConf
, maximumTTL
, pruningDelay
, ResolvSeed
, makeResolvSeed
, Resolver
, withResolver
, withResolvers
) where
import Control.Exception as E
import qualified Crypto.Random as C
import qualified Data.ByteString as BS
import Data.IORef (IORef)
import qualified Data.IORef as I
import qualified Data.List.NonEmpty as NE
import Network.Socket (AddrInfoFlag(..), AddrInfo(..), PortNumber, HostName, SocketType(Datagram), getAddrInfo, defaultHints)
import Prelude
import Network.DNS.Imports
import Network.DNS.Memo
import Network.DNS.Resolver.Internal
import Network.DNS.Transport
import Network.DNS.Types.Internal
import Network.DNS.Types.Resolver
makeResolvSeed :: ResolvConf -> IO ResolvSeed
makeResolvSeed :: ResolvConf -> IO ResolvSeed
makeResolvSeed ResolvConf
conf = ResolvConf -> NonEmpty AddrInfo -> ResolvSeed
ResolvSeed ResolvConf
conf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (NonEmpty AddrInfo)
findAddresses
where
findAddresses :: IO (NonEmpty AddrInfo)
findAddresses :: IO (NonEmpty AddrInfo)
findAddresses = case ResolvConf -> FileOrNumericHost
resolvInfo ResolvConf
conf of
RCHostName HostName
numhost -> (forall a. a -> [a] -> NonEmpty a
:| []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostName -> Maybe PortNumber -> IO AddrInfo
makeAddrInfo HostName
numhost forall a. Maybe a
Nothing
RCHostPort HostName
numhost PortNumber
mport -> (forall a. a -> [a] -> NonEmpty a
:| []) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostName -> Maybe PortNumber -> IO AddrInfo
makeAddrInfo HostName
numhost (forall a. a -> Maybe a
Just PortNumber
mport)
RCHostNames [HostName]
nss -> [HostName] -> IO (NonEmpty AddrInfo)
mkAddrs [HostName]
nss
RCFilePath HostName
file -> HostName -> IO [HostName]
getDefaultDnsServers HostName
file forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [HostName] -> IO (NonEmpty AddrInfo)
mkAddrs
mkAddrs :: [HostName] -> IO (NonEmpty AddrInfo)
mkAddrs [] = forall e a. Exception e => e -> IO a
E.throwIO DNSError
BadConfiguration
mkAddrs (HostName
l:[HostName]
ls) = forall a. a -> [a] -> NonEmpty a
(:|) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostName -> Maybe PortNumber -> IO AddrInfo
makeAddrInfo HostName
l forall a. Maybe a
Nothing forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [HostName]
ls (HostName -> Maybe PortNumber -> IO AddrInfo
`makeAddrInfo` forall a. Maybe a
Nothing)
makeAddrInfo :: HostName -> Maybe PortNumber -> IO AddrInfo
makeAddrInfo :: HostName -> Maybe PortNumber -> IO AddrInfo
makeAddrInfo HostName
addr Maybe PortNumber
mport = do
let hints :: AddrInfo
hints = AddrInfo
defaultHints {
addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_ADDRCONFIG, AddrInfoFlag
AI_NUMERICHOST, AddrInfoFlag
AI_NUMERICSERV, AddrInfoFlag
AI_PASSIVE]
, addrSocketType :: SocketType
addrSocketType = SocketType
Datagram
}
serv :: HostName
serv = forall b a. b -> (a -> b) -> Maybe a -> b
maybe HostName
"53" forall a. Show a => a -> HostName
show Maybe PortNumber
mport
forall a. [a] -> a
head forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe HostName -> Maybe HostName -> IO [AddrInfo]
getAddrInfo (forall a. a -> Maybe a
Just AddrInfo
hints) (forall a. a -> Maybe a
Just HostName
addr) (forall a. a -> Maybe a
Just HostName
serv)
withResolver :: ResolvSeed -> (Resolver -> IO a) -> IO a
withResolver :: forall a. ResolvSeed -> (Resolver -> IO a) -> IO a
withResolver ResolvSeed
seed Resolver -> IO a
f = ResolvSeed -> IO Resolver
makeResolver ResolvSeed
seed forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Resolver -> IO a
f
{-# DEPRECATED withResolvers "Use withResolver with resolvConcurrent set to True" #-}
withResolvers :: [ResolvSeed] -> ([Resolver] -> IO a) -> IO a
withResolvers :: forall a. [ResolvSeed] -> ([Resolver] -> IO a) -> IO a
withResolvers [ResolvSeed]
seeds [Resolver] -> IO a
f = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ResolvSeed -> IO Resolver
makeResolver [ResolvSeed]
seeds forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Resolver] -> IO a
f
makeResolver :: ResolvSeed -> IO Resolver
makeResolver :: ResolvSeed -> IO Resolver
makeResolver ResolvSeed
seed = do
let n :: Int
n = forall a. NonEmpty a -> Int
NE.length forall a b. (a -> b) -> a -> b
$ ResolvSeed -> NonEmpty AddrInfo
nameservers ResolvSeed
seed
[IORef ChaChaDRG]
refs <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (forall (randomly :: * -> *).
MonadRandom randomly =>
randomly ChaChaDRG
C.drgNew forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO (IORef a)
I.newIORef)
let gens :: NonEmpty (IO Word16)
gens = forall a. [a] -> NonEmpty a
NE.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map IORef ChaChaDRG -> IO Word16
getRandom [IORef ChaChaDRG]
refs
case ResolvConf -> Maybe CacheConf
resolvCache forall a b. (a -> b) -> a -> b
$ ResolvSeed -> ResolvConf
resolvconf ResolvSeed
seed of
Just CacheConf
cacheconf -> do
Cache
c <- Int -> IO Cache
newCache forall a b. (a -> b) -> a -> b
$ CacheConf -> Int
pruningDelay CacheConf
cacheconf
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ResolvSeed -> NonEmpty (IO Word16) -> Maybe Cache -> Resolver
Resolver ResolvSeed
seed NonEmpty (IO Word16)
gens forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Cache
c
Maybe CacheConf
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ResolvSeed -> NonEmpty (IO Word16) -> Maybe Cache -> Resolver
Resolver ResolvSeed
seed NonEmpty (IO Word16)
gens forall a. Maybe a
Nothing
getRandom :: IORef C.ChaChaDRG -> IO Word16
getRandom :: IORef ChaChaDRG -> IO Word16
getRandom IORef ChaChaDRG
ref = forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef' IORef ChaChaDRG
ref forall a b. (a -> b) -> a -> b
$ \ChaChaDRG
gen ->
let (ByteString
bs, ChaChaDRG
gen') = forall gen byteArray.
(DRG gen, ByteArray byteArray) =>
Int -> gen -> (byteArray, gen)
C.randomBytesGenerate Int
2 ChaChaDRG
gen
[Word16
u,Word16
l] = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack ByteString
bs
!seqno :: Word16
seqno = Word16
u forall a. Num a => a -> a -> a
* Word16
256 forall a. Num a => a -> a -> a
+ Word16
l
in (ChaChaDRG
gen', Word16
seqno)