1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
{-# LANGUAGE RecordWildCards #-}
module Network.DNS.Memo where
import qualified Control.Reaper as R
import qualified Data.ByteString as B
import qualified Data.CaseInsensitive as CI
import Data.Hourglass (Elapsed)
import Data.OrdPSQ (OrdPSQ)
import qualified Data.OrdPSQ as PSQ
import Time.System (timeCurrent)
import Network.DNS.Imports
import Network.DNS.Types.Internal
data Section = Answer | Authority deriving (Eq, Ord, Show)
type Key = (ByteString
,TYPE)
type Prio = Elapsed
type Entry = Either DNSError [RData]
type DB = OrdPSQ Key Prio Entry
type Cache = R.Reaper DB (Key,Prio,Entry)
newCache :: Int -> IO Cache
newCache delay = R.mkReaper R.defaultReaperSettings {
R.reaperEmpty = PSQ.empty
, R.reaperCons = \(k, tim, v) psq -> PSQ.insert k tim v psq
, R.reaperAction = prune
, R.reaperDelay = delay * 1000000
, R.reaperNull = PSQ.null
}
lookupCache :: Key -> Cache -> IO (Maybe (Prio, Entry))
lookupCache key reaper = PSQ.lookup key <$> R.reaperRead reaper
insertCache :: Key -> Prio -> Entry -> Cache -> IO ()
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
-- functions. So, we need to do this redundant way.
prune :: DB -> IO (DB -> DB)
prune oldpsq = do
tim <- timeCurrent
let (_, pruned) = PSQ.atMostView tim oldpsq
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 bytes) = RD_NULL $ B.copy bytes
copy (RD_MX prf dom) = RD_MX prf $ B.copy dom
copy (RD_TXT txt) = RD_TXT $ B.copy txt
copy (RD_RP mbox dname) = RD_RP (B.copy mbox) (B.copy dname)
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_CDS t a dt dv) = RD_CDS t a dt $ B.copy dv
copy (RD_NSEC dom ts) = RD_NSEC (B.copy dom) ts
copy (RD_DNSKEY f p a k) = RD_DNSKEY f p a $ B.copy k
copy (RD_CDNSKEY f p a k) = RD_CDNSKEY f p a $ B.copy k
copy (RD_TLSA a b c dgst) = RD_TLSA a b c $ B.copy dgst
copy (RD_NSEC3 a b c s h t) = RD_NSEC3 a b c (B.copy s) (B.copy h) t
copy (RD_NSEC3PARAM a b c salt) = RD_NSEC3PARAM a b c $ B.copy salt
copy (RD_RRSIG sig) = RD_RRSIG $ copysig sig
where
copysig s@RDREP_RRSIG{..} =
s { rrsigZone = B.copy rrsigZone
, rrsigValue = B.copy rrsigValue }
copy (RD_CAA f t v) = RD_CAA f (CI.mk (B.copy (CI.original t))) (B.copy v)
copy (UnknownRData is) = UnknownRData $ B.copy is
copyOData :: OData -> OData
copyOData (OD_ECSgeneric family srcBits scpBits bs) =
OD_ECSgeneric family srcBits scpBits $ B.copy bs
copyOData (OD_NSID nsid) = OD_NSID $ B.copy nsid
copyOData (UnknownOData c b) = UnknownOData c $ B.copy b
-- No copying required for the rest, but avoiding a wildcard pattern match
-- so that if more option types are added in the future, the compiler will
-- complain about a partial function.
--
copyOData o@OD_ClientSubnet {} = o
copyOData o@OD_DAU {} = o
copyOData o@OD_DHU {} = o
copyOData o@OD_N3U {} = o
|
