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

-- | Resolver related data types.
module Network.DNS.Resolver (
  -- * Configuration for resolver
    ResolvConf
  , defaultResolvConf
  -- ** Accessors
  , resolvInfo
  , resolvTimeout
  , resolvRetry
  , resolvEDNS
  , resolvConcurrent
  , resolvCache
  -- ** 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

#if !defined(mingw32_HOST_OS)
#define POSIX
#else
#define WIN
#endif

#if __GLASGOW_HASKELL__ < 709
#define GHC708
#endif

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 hiding (lookup)

#if defined(WIN)
import qualified Data.List.Split as Split
import Foreign.C.String
import Foreign.Marshal.Alloc (allocaBytes)
#else
import Data.Char (isSpace)
#endif

import Network.DNS.Imports
import Network.DNS.Memo
import Network.DNS.Transport
import Network.DNS.Types
import Network.DNS.Types.Internal

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

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

getDefaultDnsServers :: FilePath -> IO [String]
#if defined(WIN)
foreign import ccall "getWindowsDefDnsServers" getWindowsDefDnsServers :: CString -> Int -> IO Word32
getDefaultDnsServers _ = do
  allocaBytes 128 $ \cString -> do
     res <- getWindowsDefDnsServers cString 128
     case res of
       0 -> do
         addresses <- peekCString cString
         return $ filter (not . null) . Split.splitOn "," $ addresses
       _ -> do
         -- TODO: Do proper error handling here.
         return mempty
#else
getDefaultDnsServers :: HostName -> IO [HostName]
getDefaultDnsServers HostName
file = HostName -> [HostName]
toAddresses (HostName -> [HostName]) -> IO HostName -> IO [HostName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HostName -> IO HostName
readFile HostName
file
  where
    toAddresses :: String -> [String]
    toAddresses :: HostName -> [HostName]
toAddresses HostName
cs = (HostName -> HostName) -> [HostName] -> [HostName]
forall a b. (a -> b) -> [a] -> [b]
map HostName -> HostName
extract ((HostName -> Bool) -> [HostName] -> [HostName]
forall a. (a -> Bool) -> [a] -> [a]
filter (HostName
"nameserver" HostName -> HostName -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) (HostName -> [HostName]
lines HostName
cs))
    extract :: HostName -> HostName
extract = HostName -> HostName
forall a. [a] -> [a]
reverse (HostName -> HostName)
-> (HostName -> HostName) -> HostName -> HostName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> HostName -> HostName
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (HostName -> HostName)
-> (HostName -> HostName) -> HostName -> HostName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HostName -> HostName
forall a. [a] -> [a]
reverse (HostName -> HostName)
-> (HostName -> HostName) -> HostName -> HostName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> HostName -> HostName
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (HostName -> HostName)
-> (HostName -> HostName) -> HostName -> HostName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> HostName -> HostName
forall a. Int -> [a] -> [a]
drop Int
11
#endif

makeAddrInfo :: HostName -> Maybe PortNumber -> IO AddrInfo
makeAddrInfo :: HostName -> Maybe PortNumber -> IO AddrInfo
makeAddrInfo HostName
addr Maybe PortNumber
mport = do
    let flgs :: [AddrInfoFlag]
flgs = [AddrInfoFlag
AI_ADDRCONFIG, AddrInfoFlag
AI_NUMERICHOST, AddrInfoFlag
AI_PASSIVE]
        hints :: AddrInfo
hints = AddrInfo
defaultHints {
            addrFlags :: [AddrInfoFlag]
addrFlags = if Maybe PortNumber -> Bool
forall a. Maybe a -> Bool
isJust Maybe PortNumber
mport then AddrInfoFlag
AI_NUMERICSERV AddrInfoFlag -> [AddrInfoFlag] -> [AddrInfoFlag]
forall a. a -> [a] -> [a]
: [AddrInfoFlag]
flgs else [AddrInfoFlag]
flgs
          , 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
"domain" 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)

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

-- | Giving a thread-safe 'Resolver' to the function of the second
--   argument.
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" #-}
-- | 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 :: [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)