{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
module Network.DNS.Resolver (
ResolvConf
, defaultResolvConf
, resolvInfo
, resolvTimeout
, resolvRetry
, resolvEDNS
, resolvConcurrent
, resolvCache
, FileOrNumericHost(..)
, CacheConf
, defaultCacheConf
, maximumTTL
, pruningDelay
, ResolvSeed
, makeResolvSeed
, 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
makeResolvSeed :: ResolvConf -> IO ResolvSeed
makeResolvSeed conf = ResolvSeed conf <$> findAddresses
where
findAddresses :: IO (NonEmpty AddrInfo)
findAddresses = case resolvInfo conf of
RCHostName numhost -> (:| []) <$> makeAddrInfo numhost Nothing
RCHostPort numhost mport -> (:| []) <$> makeAddrInfo numhost (Just mport)
RCHostNames nss -> mkAddrs nss
RCFilePath file -> getDefaultDnsServers file >>= mkAddrs
mkAddrs [] = E.throwIO BadConfiguration
mkAddrs (l:ls) = (:|) <$> makeAddrInfo l Nothing <*> forM ls (`makeAddrInfo` 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
return mempty
#else
getDefaultDnsServers file = toAddresses <$> readFile file
where
toAddresses :: String -> [String]
toAddresses cs = map extract (filter ("nameserver" `isPrefixOf`) (lines cs))
extract = reverse . dropWhile isSpace . reverse . dropWhile isSpace . drop 11
#endif
makeAddrInfo :: HostName -> Maybe PortNumber -> IO AddrInfo
makeAddrInfo addr mport = do
let flgs = [AI_ADDRCONFIG, AI_NUMERICHOST, AI_PASSIVE]
hints = defaultHints {
addrFlags = if isJust mport then AI_NUMERICSERV : flgs else flgs
, addrSocketType = Datagram
}
serv = maybe "domain" show mport
head <$> getAddrInfo (Just hints) (Just addr) (Just serv)
withResolver :: ResolvSeed -> (Resolver -> IO a) -> IO a
withResolver seed f = makeResolver seed >>= f
{-# DEPRECATED withResolvers "Use withResolver with resolvConcurrent set to True" #-}
withResolvers :: [ResolvSeed] -> ([Resolver] -> IO a) -> IO a
withResolvers seeds f = mapM makeResolver seeds >>= f
makeResolver :: ResolvSeed -> IO Resolver
makeResolver seed = do
let n = NE.length $ nameservers seed
refs <- replicateM n (C.drgNew >>= I.newIORef)
let gens = NE.fromList $ map getRandom refs
case resolvCache $ resolvconf seed of
Just cacheconf -> do
c <- newCache $ pruningDelay cacheconf
return $ Resolver seed gens $ Just c
Nothing -> return $ Resolver seed gens Nothing
getRandom :: IORef C.ChaChaDRG -> IO Word16
getRandom ref = I.atomicModifyIORef' ref $ \gen ->
let (bs, gen') = C.randomBytesGenerate 2 gen
[u,l] = map fromIntegral $ BS.unpack bs
!seqno = u * 256 + l
in (gen', seqno)