{-# 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 (NonEmpty AddrInfo -> ResolvSeed)
-> IO (NonEmpty AddrInfo) -> IO ResolvSeed
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 -> (AddrInfo -> [AddrInfo] -> NonEmpty AddrInfo
forall a. a -> [a] -> NonEmpty a
:| []) (AddrInfo -> NonEmpty AddrInfo)
-> IO AddrInfo -> IO (NonEmpty AddrInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostName -> Maybe PortNumber -> IO AddrInfo
makeAddrInfo HostName
numhost Maybe PortNumber
forall a. Maybe a
Nothing
RCHostPort HostName
numhost PortNumber
mport -> (AddrInfo -> [AddrInfo] -> NonEmpty AddrInfo
forall a. a -> [a] -> NonEmpty a
:| []) (AddrInfo -> NonEmpty AddrInfo)
-> IO AddrInfo -> IO (NonEmpty AddrInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostName -> Maybe PortNumber -> IO AddrInfo
makeAddrInfo HostName
numhost (PortNumber -> Maybe PortNumber
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 IO [HostName]
-> ([HostName] -> IO (NonEmpty AddrInfo)) -> IO (NonEmpty AddrInfo)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [HostName] -> IO (NonEmpty AddrInfo)
mkAddrs
mkAddrs :: [HostName] -> IO (NonEmpty AddrInfo)
mkAddrs [] = DNSError -> IO (NonEmpty AddrInfo)
forall e a. Exception e => e -> IO a
E.throwIO DNSError
BadConfiguration
mkAddrs (HostName
l:[HostName]
ls) = AddrInfo -> [AddrInfo] -> NonEmpty AddrInfo
forall a. a -> [a] -> NonEmpty a
(:|) (AddrInfo -> [AddrInfo] -> NonEmpty AddrInfo)
-> IO AddrInfo -> IO ([AddrInfo] -> NonEmpty AddrInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostName -> Maybe PortNumber -> IO AddrInfo
makeAddrInfo HostName
l Maybe PortNumber
forall a. Maybe a
Nothing IO ([AddrInfo] -> NonEmpty AddrInfo)
-> IO [AddrInfo] -> IO (NonEmpty AddrInfo)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [HostName] -> (HostName -> IO AddrInfo) -> IO [AddrInfo]
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` Maybe PortNumber
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 = HostName
-> (PortNumber -> HostName) -> Maybe PortNumber -> HostName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HostName
"53" PortNumber -> HostName
forall a. Show a => a -> HostName
show Maybe PortNumber
mport
[AddrInfo] -> AddrInfo
forall a. [a] -> a
head ([AddrInfo] -> AddrInfo) -> IO [AddrInfo] -> IO AddrInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe HostName -> Maybe HostName -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (HostName -> Maybe HostName
forall a. a -> Maybe a
Just HostName
addr) (HostName -> Maybe HostName
forall a. a -> Maybe a
Just HostName
serv)
withResolver :: ResolvSeed -> (Resolver -> IO a) -> IO a
withResolver :: ResolvSeed -> (Resolver -> IO a) -> IO a
withResolver ResolvSeed
seed Resolver -> IO a
f = ResolvSeed -> IO Resolver
makeResolver ResolvSeed
seed IO Resolver -> (Resolver -> IO a) -> IO a
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 :: [ResolvSeed] -> ([Resolver] -> IO a) -> IO a
withResolvers [ResolvSeed]
seeds [Resolver] -> IO a
f = (ResolvSeed -> IO Resolver) -> [ResolvSeed] -> IO [Resolver]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ResolvSeed -> IO Resolver
makeResolver [ResolvSeed]
seeds IO [Resolver] -> ([Resolver] -> IO a) -> IO a
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 = NonEmpty AddrInfo -> Int
forall a. NonEmpty a -> Int
NE.length (NonEmpty AddrInfo -> Int) -> NonEmpty AddrInfo -> Int
forall a b. (a -> b) -> a -> b
$ ResolvSeed -> NonEmpty AddrInfo
nameservers ResolvSeed
seed
[IORef ChaChaDRG]
refs <- Int -> IO (IORef ChaChaDRG) -> IO [IORef ChaChaDRG]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (IO ChaChaDRG
forall (randomly :: * -> *).
MonadRandom randomly =>
randomly ChaChaDRG
C.drgNew IO ChaChaDRG
-> (ChaChaDRG -> IO (IORef ChaChaDRG)) -> IO (IORef ChaChaDRG)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ChaChaDRG -> IO (IORef ChaChaDRG)
forall a. a -> IO (IORef a)
I.newIORef)
let gens :: NonEmpty (IO Word16)
gens = [IO Word16] -> NonEmpty (IO Word16)
forall a. [a] -> NonEmpty a
NE.fromList ([IO Word16] -> NonEmpty (IO Word16))
-> [IO Word16] -> NonEmpty (IO Word16)
forall a b. (a -> b) -> a -> b
$ (IORef ChaChaDRG -> IO Word16) -> [IORef ChaChaDRG] -> [IO Word16]
forall a b. (a -> b) -> [a] -> [b]
map IORef ChaChaDRG -> IO Word16
getRandom [IORef ChaChaDRG]
refs
case ResolvConf -> Maybe CacheConf
resolvCache (ResolvConf -> Maybe CacheConf) -> ResolvConf -> Maybe CacheConf
forall a b. (a -> b) -> a -> b
$ ResolvSeed -> ResolvConf
resolvconf ResolvSeed
seed of
Just CacheConf
cacheconf -> do
Cache
c <- Int -> IO Cache
newCache (Int -> IO Cache) -> Int -> IO Cache
forall a b. (a -> b) -> a -> b
$ CacheConf -> Int
pruningDelay CacheConf
cacheconf
Resolver -> IO Resolver
forall (m :: * -> *) a. Monad m => a -> m a
return (Resolver -> IO Resolver) -> Resolver -> IO Resolver
forall a b. (a -> b) -> a -> b
$ ResolvSeed -> NonEmpty (IO Word16) -> Maybe Cache -> Resolver
Resolver ResolvSeed
seed NonEmpty (IO Word16)
gens (Maybe Cache -> Resolver) -> Maybe Cache -> Resolver
forall a b. (a -> b) -> a -> b
$ Cache -> Maybe Cache
forall a. a -> Maybe a
Just Cache
c
Maybe CacheConf
Nothing -> Resolver -> IO Resolver
forall (m :: * -> *) a. Monad m => a -> m a
return (Resolver -> IO Resolver) -> Resolver -> IO Resolver
forall a b. (a -> b) -> a -> b
$ ResolvSeed -> NonEmpty (IO Word16) -> Maybe Cache -> Resolver
Resolver ResolvSeed
seed NonEmpty (IO Word16)
gens Maybe Cache
forall a. Maybe a
Nothing
getRandom :: IORef C.ChaChaDRG -> IO Word16
getRandom :: IORef ChaChaDRG -> IO Word16
getRandom IORef ChaChaDRG
ref = IORef ChaChaDRG -> (ChaChaDRG -> (ChaChaDRG, Word16)) -> IO Word16
forall a b. IORef a -> (a -> (a, b)) -> IO b
I.atomicModifyIORef' IORef ChaChaDRG
ref ((ChaChaDRG -> (ChaChaDRG, Word16)) -> IO Word16)
-> (ChaChaDRG -> (ChaChaDRG, Word16)) -> IO Word16
forall a b. (a -> b) -> a -> b
$ \ChaChaDRG
gen ->
let (ByteString
bs, ChaChaDRG
gen') = Int -> ChaChaDRG -> (ByteString, ChaChaDRG)
forall gen byteArray.
(DRG gen, ByteArray byteArray) =>
Int -> gen -> (byteArray, gen)
C.randomBytesGenerate Int
2 ChaChaDRG
gen
[Word16
u,Word16
l] = (Word8 -> Word16) -> [Word8] -> [Word16]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> [Word16]) -> [Word8] -> [Word16]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack ByteString
bs
!seqno :: Word16
seqno = Word16
u Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
* Word16
256 Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
l
in (ChaChaDRG
gen', Word16
seqno)