1 module PowerDns ( RRType(..)
10 import Data.Text.Lazy (splitOn, pack)
11 import Data.Map.Lazy (foldrWithKey)
12 import Data.Default.Class (def)
16 data RRType = RRTypeSRV | RRTypeA | RRTypeAAAA | RRTypeCNAME
17 | RRTypeDNAME | RRTypeSOA | RRTypeRP | RRTypeLOC
18 | RRTypeNS | RRTypeDS | RRTypeMX | RRTypeTLSA
19 | RRTypeANY | RRTypeError String
21 instance Show RRType where
22 show RRTypeSRV = "SRV"
24 show RRTypeAAAA = "AAAA"
25 show RRTypeCNAME = "CNAME"
26 show RRTypeDNAME = "DNAME"
27 show RRTypeSOA = "SOA"
29 show RRTypeLOC = "LOC"
33 show RRTypeTLSA = "TLSA"
34 show RRTypeANY = "ANY"
35 show (RRTypeError s) = "Unknown RR type: " ++ (show s)
37 rrType qt = case qt of
41 "CNAME" -> RRTypeCNAME
42 "DNAME" -> RRTypeDNAME
53 data PdnsRequest = PdnsRequestQ
57 , remoteIpAddress :: String
58 , localIpAddress :: Maybe String
59 , ednsSubnetAddress :: Maybe String
65 -- | Parse request string read from the core PowerDNS process
66 pdnsParse :: Int -> String -> Either String PdnsRequest
69 getInt s = case reads s :: [(Int, String)] of
73 | ver >= 2 = case xs of
78 | ver >= 3 = case xs of
84 "PING":[] -> Right PdnsRequestPing
85 "AXFR":x:[] -> Right (PdnsRequestAXFR (getInt x))
86 "Q":qn:"IN":qt:id:rip:xs -> case rrType qt of
88 Left $ "Unrecognized RR type: " ++ e
94 , remoteIpAddress = rip
95 , localIpAddress = getLIp ver xs
96 , ednsSubnetAddress = getRIp ver xs
98 _ -> Left $ "Unparseable PDNS Request: " ++ s
100 -- | Produce LOG entry followed by FAIL
101 pdnsReport :: String -> String
102 pdnsReport err = "LOG\tError: " ++ err ++ "\nFAIL\n"
104 -- | Produce answer to the Q request
105 pdnsOutQ :: Int -> Int -> Int -> String -> RRType -> Either String NmcDom -> String
106 pdnsOutQ ver id gen name rrt edom =
109 RRTypeANY -> [ RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME
110 , RRTypeDNAME, RRTypeRP, RRTypeLOC, RRTypeNS
111 , RRTypeDS, RRTypeMX -- SOA not included
117 pdnsReport $ err ++ " in the " ++ (show rrt) ++ " query for " ++ name
119 formatDom ver id gen rrl name dom "END\n"
121 -- | Produce answer to the AXFR request
122 pdnsOutXfr :: Int -> Int -> Int -> String -> Either String NmcDom -> String
123 pdnsOutXfr ver id gen name edom =
125 allrrs = [ RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME
126 , RRTypeDNAME, RRTypeRP, RRTypeLOC, RRTypeNS
127 , RRTypeDS, RRTypeMX, RRTypeSOA
129 walkDom f acc name dom =
130 f name dom $ case domSubmap dom of
133 foldrWithKey (\n d a -> walkDom f a (n ++ "." ++ name) d) acc dm
137 pdnsReport $ err ++ " in the AXFR request for " ++ name
139 walkDom (formatDom ver id gen allrrs) "END\n" name dom
141 formatDom ver id gen rrl name dom acc =
142 foldr (\x a -> (formatRR ver id gen name dom x) ++ a) acc rrl
144 formatRR ver id gen name dom rrtype =
145 foldr (\x a -> "DATA\t" ++ v3ext ++ name ++ "\tIN\t" ++ (show rrtype)
146 ++ "\t" ++ ttl ++ "\t" ++ (show id) ++ "\t" ++ x ++ "\n" ++ a)
147 "" $ dataRR rrtype gen name dom
154 justl accessor _ _ dom = case accessor dom of
158 justv accessor _ _ dom = case accessor dom of
163 let (aname, adom) = break (== '@') addr
166 _ -> aname ++ "." ++ (tail adom) ++ "."
168 dataRR RRTypeSRV = \ _ _ dom ->
171 Just srvs -> map srvStr srvs
173 srvStr x = (show (srvPrio x)) ++ "\t"
174 ++ (show (srvWeight x)) ++ " "
175 ++ (show (srvPort x)) ++ " "
178 dataRR RRTypeMX = justl domMx
179 dataRR RRTypeTLSA = \ _ _ dom ->
182 Just tlsas -> map tlsaStr tlsas
185 ++ (show (tlsMatchType x)) ++ " "
186 ++ (tlsMatchValue x) ++ ")"
187 -- tlsIncSubdoms is not displayed, it is used for `propagate`.
189 dataRR RRTypeA = justl domIp
190 dataRR RRTypeAAAA = justl domIp6
191 dataRR RRTypeCNAME = justv domAlias
192 dataRR RRTypeDNAME = justv domTranslate
193 dataRR RRTypeSOA = \ gen name dom ->
195 ns = case domNs dom of
198 email = case domEmail dom of
199 Nothing -> "hostmaster." ++ name ++ "."
200 Just addr -> dotmail addr
202 if dom == def then []
204 -- Follows a relatively ugly hack to figure if we are at the top
205 -- level domain ("something.bit"). Only in such case we provide
206 -- the synthetic SOA RR. Otherwise yield empty.
207 -- Alternative would be to carry "top-ness" as a parameter through
208 -- all the calls from the very top where we split the fqdn.
209 case splitOn (pack ".") (pack name) of
210 [_,_] -> [ns ++ " " ++ email ++ " " ++ (show gen)
211 ++ " 10800 3600 604800 86400"]
213 dataRR RRTypeRP = \ _ _ dom ->
216 Just addr -> [(dotmail addr) ++ " ."]
217 dataRR RRTypeLOC = justv domLoc
218 dataRR RRTypeNS = justl domNs
219 dataRR RRTypeDS = \ _ _ dom ->
222 Just dss -> map dsStr dss
224 dsStr x = (show (dsKeyTag x)) ++ " "
225 ++ (show (dsAlgo x)) ++ " "
226 ++ (show (dsHashType x)) ++ " "
228 -- This only comes into play when data arrived _not_ from a PDNS request:
229 dataRR (RRTypeError e) = \ _ _ _ ->
230 ["; No data for bad request type " ++ e]