mirror of
https://github.com/kazu-yamamoto/dns.git
synced 2024-10-06 10:40:07 +03:00
Merge cache fixes.
This commit is contained in:
Kazu Yamamoto
commit
c127cef270
@ -12,7 +12,6 @@ module Network.DNS.LookupRaw (
|
||||
) where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Data.ByteString.Short (toShort)
|
||||
import Data.Time (getCurrentTime, addUTCTime)
|
||||
|
||||
import Network.DNS.IO
|
||||
@ -33,31 +32,43 @@ import Prelude hiding (lookup)
|
||||
-- choose which section (answer, authority, or additional) you would like
|
||||
-- to inspect for the result.
|
||||
|
||||
lookupSection :: (DNSMessage -> [ResourceRecord])
|
||||
lookupSection :: Section
|
||||
-> Resolver
|
||||
-> Domain
|
||||
-> TYPE
|
||||
-> IO (Either DNSError [RData])
|
||||
lookupSection section rlv dom typ = case mcacheConf of
|
||||
Nothing -> do
|
||||
eans <- lookupRaw rlv dom typ
|
||||
case eans of
|
||||
Left err -> return $ Left err
|
||||
Right ans -> return $ fromDNSMessage ans toRData
|
||||
Just cacheconf -> lookupCacheSection section rlv dom typ cacheconf
|
||||
lookupSection section rlv dom typ
|
||||
| section == Authority = lookupFleshSection rlv dom typ section
|
||||
| otherwise = case mcacheConf of
|
||||
Nothing -> lookupFleshSection rlv dom typ section
|
||||
Just cacheconf -> lookupCacheSection rlv dom typ cacheconf
|
||||
where
|
||||
correct ResourceRecord{..} = rrtype == typ
|
||||
toRData = map rdata . filter correct . section
|
||||
mcacheConf = resolvCache $ resolvconf $ resolvseed rlv
|
||||
|
||||
lookupCacheSection :: (DNSMessage -> [ResourceRecord])
|
||||
-> Resolver
|
||||
lookupFleshSection :: Resolver
|
||||
-> Domain
|
||||
-> TYPE
|
||||
-> Section
|
||||
-> IO (Either DNSError [RData])
|
||||
lookupFleshSection 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 section rlv dom typ cconf = do
|
||||
mx <- lookupCache (sdom,typ) c
|
||||
lookupCacheSection rlv dom typ cconf = do
|
||||
mx <- lookupCache (dom,typ) c
|
||||
case mx of
|
||||
Nothing -> do
|
||||
eans <- lookupRaw rlv dom typ
|
||||
@ -67,30 +78,30 @@ lookupCacheSection section rlv dom typ cconf = do
|
||||
-- We do not cache anything.
|
||||
return $ Left err
|
||||
Right ans -> do
|
||||
let errs = fromDNSMessage ans toRR
|
||||
case errs of
|
||||
Left err -> do
|
||||
let v = Left err
|
||||
let ex = fromDNSMessage ans toRR
|
||||
case ex of
|
||||
Left NameError -> do
|
||||
let v = Left NameError
|
||||
case filter (SOA `isTypeOf`) $ authority ans of
|
||||
(ResourceRecord _ _ _ _ (RD_SOA _ _ _ _ _ _ ttl)):_
|
||||
-> insertNegative cconf c key v ttl
|
||||
_ -> return () -- does not cache anything
|
||||
soa:_ -> insertNegative cconf c key v $ rrttl soa
|
||||
_ -> return () -- does not cache anything
|
||||
return v
|
||||
Right rss -> do
|
||||
let rds = map rdata rss
|
||||
v = Right rds
|
||||
Left e -> return $ Left e
|
||||
Right rss0 -> do
|
||||
let rds0 = map rdata rss0
|
||||
rss = filter ((/= 0) . rrttl) rss0
|
||||
rds = map rdata rss
|
||||
case map rrttl rss of
|
||||
[] -> return () -- does not cache anything
|
||||
ttls -> let ttl = minimum ttls
|
||||
in insertPositive cconf c key v ttl
|
||||
return v
|
||||
in insertPositive cconf c key (Right rds) ttl
|
||||
return $ Right rds0
|
||||
Just (_,x) -> return x
|
||||
where
|
||||
isTypeOf t ResourceRecord{..} = rrtype == t
|
||||
toRR = filter (typ `isTypeOf`) . section
|
||||
toRR = filter (typ `isTypeOf`) . answer
|
||||
Just c = cache rlv
|
||||
sdom = toShort dom
|
||||
key = (sdom,typ)
|
||||
key = (dom,typ)
|
||||
|
||||
insertPositive :: CacheConf -> Cache -> Key -> Entry -> TTL -> IO ()
|
||||
insertPositive CacheConf{..} c k v ttl = when (ttl /= 0) $ do
|
||||
@ -141,15 +152,16 @@ fromDNSFormat = fromDNSMessage
|
||||
-- Right [93.184.216.34]
|
||||
--
|
||||
lookup :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData])
|
||||
lookup = lookupSection answer
|
||||
lookup = lookupSection Answer
|
||||
|
||||
-- | Look up resource records of a specified type for a domain,
|
||||
-- collecting the results
|
||||
-- from the AUTHORITY section of the response.
|
||||
-- See manual the manual of 'lookupRaw'
|
||||
-- to understand the concrete behavior.
|
||||
-- Cache is used even if 'resolvCache' is 'Just'.
|
||||
lookupAuth :: Resolver -> Domain -> TYPE -> IO (Either DNSError [RData])
|
||||
lookupAuth = lookupSection authority
|
||||
lookupAuth = lookupSection Authority
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
|
||||
@ -2,7 +2,8 @@ module Network.DNS.Memo where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import qualified Control.Reaper as R
|
||||
import Data.ByteString.Short (ShortByteString)
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as B
|
||||
import Data.List (foldl')
|
||||
import Data.OrdPSQ (OrdPSQ)
|
||||
import qualified Data.OrdPSQ as PSQ
|
||||
@ -10,7 +11,9 @@ import Data.Time (UTCTime, getCurrentTime)
|
||||
|
||||
import Network.DNS.Types
|
||||
|
||||
type Key = (ShortByteString -- avoiding memory fragmentation
|
||||
data Section = Answer | Authority deriving (Eq, Ord, Show)
|
||||
|
||||
type Key = (ByteString
|
||||
,TYPE)
|
||||
type Prio = UTCTime
|
||||
|
||||
@ -33,7 +36,12 @@ lookupCache :: Key -> Cache -> IO (Maybe (Prio, Entry))
|
||||
lookupCache key reaper = PSQ.lookup key <$> R.reaperRead reaper
|
||||
|
||||
insertCache :: Key -> Prio -> Entry -> Cache -> IO ()
|
||||
insertCache key tim ent reaper = R.reaperAdd reaper (key,tim,ent)
|
||||
insertCache (dom,typ) tim ent0 reaper = R.reaperAdd reaper (key,tim,ent)
|
||||
where
|
||||
key = (B.copy dom,typ)
|
||||
ent = case ent0 of
|
||||
l@(Left _) -> l
|
||||
(Right rds) -> Right $ map copy rds
|
||||
|
||||
-- Theoretically speaking, atMostView itself is good enough for pruning.
|
||||
-- But auto-update assumes a list based db which does not provide atMost
|
||||
@ -45,3 +53,25 @@ prune oldpsq = do
|
||||
return $ \newpsq -> foldl' ins pruned $ PSQ.toList newpsq
|
||||
where
|
||||
ins psq (k,p,v) = PSQ.insert k p v psq
|
||||
|
||||
copy :: RData -> RData
|
||||
copy r@(RD_A _) = r
|
||||
copy (RD_NS dom) = RD_NS $ B.copy dom
|
||||
copy (RD_CNAME dom) = RD_CNAME $ B.copy dom
|
||||
copy (RD_SOA mn mr a b c d e) = RD_SOA (B.copy mn) (B.copy mr) a b c d e
|
||||
copy (RD_PTR dom) = RD_PTR $ B.copy dom
|
||||
copy RD_NULL = RD_NULL
|
||||
copy (RD_MX prf dom) = RD_MX prf $ B.copy dom
|
||||
copy (RD_TXT txt) = RD_TXT $ B.copy txt
|
||||
copy r@(RD_AAAA _) = r
|
||||
copy (RD_SRV a b c dom) = RD_SRV a b c $ B.copy dom
|
||||
copy (RD_DNAME dom) = RD_DNAME $ B.copy dom
|
||||
copy (RD_OPT od) = RD_OPT $ map copyOData od
|
||||
copy (RD_DS t a dt dv) = RD_DS t a dt $ B.copy dv
|
||||
copy (RD_DNSKEY f p a k) = RD_DNSKEY f p a $ B.copy k
|
||||
copy (RD_TLSA a b c dgst) = RD_TLSA a b c $ B.copy dgst
|
||||
copy (UnknownRData is) = UnknownRData $ B.copy is
|
||||
|
||||
copyOData :: OData -> OData
|
||||
copyOData o@(OD_ClientSubnet _ _ _) = o
|
||||
copyOData (UnknownOData c b) = UnknownOData c $ B.copy b
|
||||
|
||||
Loading…
Reference in New Issue
Block a user