1 module PowerDns ( RRType(..)
10 import Data.Text.Lazy (splitOn, pack)
11 import Data.Map.Lazy (foldrWithKey)
15 data RRType = RRTypeSRV | RRTypeA | RRTypeAAAA | RRTypeCNAME
16 | RRTypeDNAME | RRTypeSOA | RRTypeRP | RRTypeLOC
17 | RRTypeNS | RRTypeDS | RRTypeMX
18 | RRTypeANY | RRTypeError String
20 instance Show RRType where
21 show RRTypeSRV = "SRV"
23 show RRTypeAAAA = "AAAA"
24 show RRTypeCNAME = "CNAME"
25 show RRTypeDNAME = "DNAME"
26 show RRTypeSOA = "SOA"
28 show RRTypeLOC = "LOC"
32 show RRTypeANY = "ANY"
33 show (RRTypeError s) = "Unknown RR type: " ++ (show s)
35 rrType qt = case qt of
39 "CNAME" -> RRTypeCNAME
40 "DNAME" -> RRTypeDNAME
50 data PdnsRequest = PdnsRequestQ
54 , remoteIpAddress :: String
55 , localIpAddress :: Maybe String
56 , ednsSubnetAddress :: Maybe String
62 -- | Parse request string read from the core PowerDNS process
63 pdnsParse :: Int -> String -> Either String PdnsRequest
66 getInt s = case reads s :: [(Int, String)] of
70 | ver >= 2 = case xs of
75 | ver >= 3 = case xs of
81 "PING":[] -> Right PdnsRequestPing
82 "AXFR":x:[] -> Right (PdnsRequestAXFR (getInt x))
83 "Q":qn:"IN":qt:id:rip:xs -> case rrType qt of
85 Left $ "Unrecognized RR type: " ++ e
91 , remoteIpAddress = rip
92 , localIpAddress = getLIp ver xs
93 , ednsSubnetAddress = getRIp ver xs
95 _ -> Left $ "Unparseable PDNS Request: " ++ s
97 -- | Produce LOG entry followed by FAIL
98 pdnsReport :: String -> String
99 pdnsReport err = "LOG\tError: " ++ err ++ "\nFAIL\n"
101 -- | Produce answer to the Q request
102 pdnsOutQ :: Int -> Int -> Int -> String -> RRType -> Either String NmcDom -> String
103 pdnsOutQ ver id gen name rrt edom =
106 RRTypeANY -> [ RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME
107 , RRTypeDNAME, RRTypeRP, RRTypeLOC, RRTypeNS
108 , RRTypeDS, RRTypeMX -- SOA not included
114 pdnsReport $ err ++ " in the " ++ (show rrt) ++ " query for " ++ name
116 formatDom ver id gen rrl name dom "END\n"
118 -- | Produce answer to the AXFR request
119 pdnsOutXfr :: Int -> Int -> Int -> String -> Either String NmcDom -> String
120 pdnsOutXfr ver id gen name edom =
122 allrrs = [ RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME
123 , RRTypeDNAME, RRTypeRP, RRTypeLOC, RRTypeNS
124 , RRTypeDS, RRTypeMX, RRTypeSOA
126 walkDom f acc name dom =
127 f name dom $ case domMap dom of
130 foldrWithKey (\n d a -> walkDom f a (n ++ "." ++ name) d) acc dm
134 pdnsReport $ err ++ " in the AXFR request for " ++ name
136 walkDom (formatDom ver id gen allrrs) "END\n" name dom
138 formatDom ver id gen rrl name dom acc =
139 foldr (\x a -> (formatRR ver id gen name dom x) ++ a) acc rrl
141 formatRR ver id gen name dom rrtype =
142 foldr (\x a -> "DATA\t" ++ v3ext ++ name ++ "\tIN\t" ++ (show rrtype)
143 ++ "\t" ++ ttl ++ "\t" ++ (show id) ++ "\t" ++ x ++ "\n" ++ a)
144 "" $ dataRR rrtype gen name dom
151 justl accessor _ _ dom = case accessor dom of
155 justv accessor _ _ dom = case accessor dom of
160 let (aname, adom) = break (== '@') addr
163 _ -> aname ++ "." ++ (tail adom) ++ "."
165 dataRR RRTypeSRV = justl domSrv
166 dataRR RRTypeMX = justl domMx
167 dataRR RRTypeA = justl domIp
168 dataRR RRTypeAAAA = justl domIp6
169 dataRR RRTypeCNAME = justv domAlias
170 dataRR RRTypeDNAME = justv domTranslate
171 dataRR RRTypeSOA = \ gen name dom ->
173 ns = case domNs dom of
176 email = case domEmail dom of
177 Nothing -> "hostmaster." ++ name ++ "."
178 Just addr -> dotmail addr
180 if dom == emptyNmcDom then []
182 -- Follows a relatively ugly hack to figure if we are at the top
183 -- level domain ("something.bit"). Only in such case we provide
184 -- the synthetic SOA RR. Otherwise yield empty.
185 -- Alternative would be to carry "top-ness" as a parameter through
186 -- all the calls from the very top where we split the fqdn.
187 case splitOn (pack ".") (pack name) of
188 [_,_] -> [ns ++ " " ++ email ++ " " ++ (show gen)
189 ++ " 10800 3600 604800 86400"]
191 dataRR RRTypeRP = \ _ _ dom ->
194 Just addr -> [(dotmail addr) ++ " ."]
195 dataRR RRTypeLOC = justv domLoc
196 dataRR RRTypeNS = justl domNs
197 dataRR RRTypeDS = \ _ _ dom ->
200 Just dss -> map dsStr dss
202 dsStr x = (show (dsKeyTag x)) ++ " "
203 ++ (show (dsAlgo x)) ++ " "
204 ++ (show (dsHashType x)) ++ " "
206 -- This only comes into play when data arrived _not_ from a PDNS request:
207 dataRR (RRTypeError e) = \ _ _ _ ->
208 ["; No data for bad request type " ++ e]