{-# LANGUAGE RecordWildCards #-}
module Network.DNS.LookupRaw (
lookup
, lookupAuth
, lookupRaw
, lookupRawAD
, fromDNSMessage
, fromDNSFormat
) where
import Data.Time (getCurrentTime, addUTCTime)
import Prelude hiding (lookup)
import Network.DNS.IO
import Network.DNS.Imports hiding (lookup)
import Network.DNS.Memo
import Network.DNS.Transport
import Network.DNS.Types
import Network.DNS.Types.Internal
lookup :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData])
lookup = lookupSection Answer
lookupAuth :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData])
lookupAuth = lookupSection Authority
lookupSection :: Section
-> Resolver
-> Domain
-> TYPE
-> IO (Either DNSError [RData])
lookupSection section rlv dom typ
| section == Authority = lookupFreshSection rlv dom typ section
| otherwise = case mcacheConf of
Nothing -> lookupFreshSection rlv dom typ section
Just cacheconf -> lookupCacheSection rlv dom typ cacheconf
where
mcacheConf = resolvCache $ resolvconf $ resolvseed rlv
lookupFreshSection :: Resolver
-> Domain
-> TYPE
-> Section
-> IO (Either DNSError [RData])
lookupFreshSection rlv dom typ section = do
eans <- lookupRaw rlv dom typ
case eans of
Left err -> return $ Left err
Right ans -> return $ fromDNSMessage ans toRData
where
correct ResourceRecord{..} = rrtype == typ
toRData = map rdata . filter correct . sectionF
sectionF = case section of
Answer -> answer
Authority -> authority
lookupCacheSection :: Resolver
-> Domain
-> TYPE
-> CacheConf
-> IO (Either DNSError [RData])
lookupCacheSection rlv dom typ cconf = do
mx <- lookupCache (dom,typ) c
case mx of
Nothing -> do
eans <- lookupRaw rlv dom typ
case eans of
Left err ->
return $ Left err
Right ans -> do
let ex = fromDNSMessage ans toRR
case ex of
Left NameError -> do
let v = Left NameError
cacheNegative cconf c key v ans
return v
Left e -> return $ Left e
Right [] -> do
let v = Right []
cacheNegative cconf c key v ans
return v
Right rss -> do
cachePositive cconf c key rss
return $ Right $ map rdata rss
Just (_,x) -> return x
where
toRR = filter (typ `isTypeOf`) . answer
Just c = cache rlv
key = (dom,typ)
cachePositive :: CacheConf -> Cache -> Key -> [ResourceRecord] -> IO ()
cachePositive cconf c key rss
| ttl == 0 = return ()
| otherwise = insertPositive cconf c key (Right rds) ttl
where
rds = map rdata rss
ttl = minimum $ map rrttl rss
insertPositive :: CacheConf -> Cache -> Key -> Entry -> TTL -> IO ()
insertPositive CacheConf{..} c k v ttl = when (ttl /= 0) $ do
tim <- addUTCTime life <$> getCurrentTime
insertCache k tim v c
where
life = fromIntegral (maximumTTL `min` ttl)
cacheNegative :: CacheConf -> Cache -> Key -> Entry -> DNSMessage -> IO ()
cacheNegative cconf c key v ans = case soas of
[] -> return ()
soa:_ -> insertNegative cconf c key v $ rrttl soa
where
soas = filter (SOA `isTypeOf`) $ authority ans
insertNegative :: CacheConf -> Cache -> Key -> Entry -> TTL -> IO ()
insertNegative CacheConf{..} c k v ttl = when (ttl /= 0) $ do
tim <- addUTCTime life <$> getCurrentTime
insertCache k tim v c
where
life = fromIntegral ttl
isTypeOf :: TYPE -> ResourceRecord -> Bool
isTypeOf t ResourceRecord{..} = rrtype == t
lookupRaw :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage)
lookupRaw rslv dom typ = resolve dom typ rslv False receive
lookupRawAD :: Resolver -> Domain -> TYPE -> IO (Either DNSError DNSMessage)
lookupRawAD rslv dom typ = resolve dom typ rslv True receive
fromDNSMessage :: DNSMessage -> (DNSMessage -> a) -> Either DNSError a
fromDNSMessage ans conv = case errcode ans of
NoErr -> Right $ conv ans
FormatErr -> Left FormatError
ServFail -> Left ServerFailure
NameErr -> Left NameError
NotImpl -> Left NotImplemented
Refused -> Left OperationRefused
BadOpt -> Left BadOptRecord
_ -> Left UnknownDNSError
where
errcode = rcode . flags . header
{-# DEPRECATED fromDNSFormat "Use fromDNSMessage instead" #-}
fromDNSFormat :: DNSMessage -> (DNSMessage -> a) -> Either DNSError a
fromDNSFormat = fromDNSMessage