{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}

-- | Resolver related data types.
module Network.DNS.Resolver (
  -- * Configuration for resolver
    ResolvConf
  , defaultResolvConf
  -- ** Accessors
  , resolvInfo
  , resolvTimeout
  , resolvRetry
  , resolvConcurrent
  , resolvCache
  , resolvQueryControls
  -- ** Specifying DNS servers
  , FileOrNumericHost(..)
  -- ** Configuring cache
  , CacheConf
  , defaultCacheConf
  , maximumTTL
  , pruningDelay
  -- * Intermediate data type for resolver
  , ResolvSeed
  , makeResolvSeed
  -- * Type and function for resolver
  , 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

----------------------------------------------------------------

-- |  Make a 'ResolvSeed' from a 'ResolvConf'.
--
--    Examples:
--
--    >>> rs <- makeResolvSeed defaultResolvConf
--
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
          }
        -- 53 is the standard port number for domain name servers as assigned by IANA
        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)

----------------------------------------------------------------

-- | Giving a thread-safe 'Resolver' to the function of the second
--   argument.
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" #-}
-- | Giving thread-safe 'Resolver's to the function of the second
--   argument.  For each 'Resolver', multiple lookups must be done
--   sequentially.  'Resolver's can be used concurrently.
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)