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
61 | PdnsRequestAXFR Int (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
88 [] -> Right $ (PdnsRequestAXFR (getInt x)) Nothing
89 _ -> Left $ "Extra arguments in AXFR (v 1-3): " ++ s
92 [z] -> Right $ (PdnsRequestAXFR (getInt x)) (Just z)
93 _ -> Left $ "Wrong arguments in AXFR (v 4+): " ++ s
94 "Q":qn:"IN":qt:id:rip:xs -> case rrType qt of
96 Left $ "Unrecognized RR type: " ++ e
102 , remoteIpAddress = rip
103 , localIpAddress = getLIp ver xs
104 , ednsSubnetAddress = getRIp ver xs
106 _ -> Left $ "Unparseable PDNS Request: " ++ s
108 -- | Produce LOG entry followed by FAIL
109 pdnsReport :: String -> String
110 pdnsReport err = "LOG\tError: " ++ err ++ "\nFAIL\n"
112 -- | Produce answer to the Q request
113 pdnsOutQ :: Int -> Int -> Int -> String -> RRType -> Either String NmcDom -> String
114 pdnsOutQ ver id gen name rrt edom =
117 RRTypeANY -> [ RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME
118 , RRTypeDNAME, RRTypeRP, RRTypeLOC, RRTypeNS
119 , RRTypeDS, RRTypeMX, RRTypeTLSA -- SOA not included
125 pdnsReport $ err ++ " in the " ++ (show rrt) ++ " query for " ++ name
127 formatDom ver id gen rrl name dom "END\n"
129 -- | Produce answer to the AXFR request
130 pdnsOutXfr :: Int -> Int -> Int -> String -> Either String NmcDom -> String
131 pdnsOutXfr ver id gen name edom =
133 allrrs = [ RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME
134 , RRTypeDNAME, RRTypeRP, RRTypeLOC, RRTypeNS
135 , RRTypeDS, RRTypeMX, RRTypeTLSA, RRTypeSOA
137 walkDom f acc name dom =
138 f name dom $ case domSubmap dom of
141 foldrWithKey (\n d a -> walkDom f a (n ++ "." ++ name) d) acc dm
145 pdnsReport $ err ++ " in the AXFR request for " ++ name
147 walkDom (formatDom ver id gen allrrs) "END\n" name dom
149 formatDom ver id gen rrl name dom acc =
150 foldr (\x a -> (formatRR ver id gen name dom x) ++ a) acc rrl
152 formatRR ver id gen name dom rrtype =
153 foldr (\x a -> "DATA\t" ++ v3ext ++ name ++ "\tIN\t" ++ (show rrtype)
154 ++ "\t" ++ ttl ++ "\t" ++ (show id) ++ "\t" ++ x ++ "\n" ++ a)
155 "" $ dataRR rrtype gen name dom
157 v3ext = if ver >= 3 then "0\t1\t" else ""
160 justl accessor _ _ dom = case accessor dom of
164 justv accessor _ _ dom = case accessor dom of
169 let (aname, adom) = break (== '@') addr
172 _ -> aname ++ "." ++ (tail adom) ++ "."
174 dataRR RRTypeSRV = \ _ _ dom ->
177 Just srvs -> map srvStr srvs
179 srvStr x = (show (srvPrio x)) ++ "\t"
180 ++ (show (srvWeight x)) ++ " "
181 ++ (show (srvPort x)) ++ " "
184 dataRR RRTypeMX = justl domMx
185 dataRR RRTypeTLSA = \ _ _ dom ->
188 Just tlsas -> map tlsaStr tlsas
191 ++ (show (tlsMatchType x)) ++ " "
192 ++ (tlsMatchValue x) ++ ")"
193 -- tlsIncSubdoms is not displayed, it is used for `propagate`.
195 dataRR RRTypeA = justl domIp
196 dataRR RRTypeAAAA = justl domIp6
197 dataRR RRTypeCNAME = justv domAlias
198 dataRR RRTypeDNAME = justv domTranslate
199 dataRR RRTypeSOA = \ gen name dom ->
201 ns = case domNs dom of
204 email = case domEmail dom of
205 Nothing -> "hostmaster." ++ name ++ "."
206 Just addr -> dotmail addr
208 if dom == def then []
210 -- Follows a relatively ugly hack to figure if we are at the top
211 -- level domain ("something.bit"). Only in such case we provide
212 -- the synthetic SOA RR. Otherwise yield empty.
213 -- Alternative would be to carry "top-ness" as a parameter through
214 -- all the calls from the very top where we split the fqdn.
215 case splitOn (pack ".") (pack name) of
216 [_,_] -> [ns ++ " " ++ email ++ " " ++ (show gen)
217 ++ " 10800 3600 604800 86400"]
219 dataRR RRTypeRP = \ _ _ dom ->
222 Just addr -> [(dotmail addr) ++ " ."]
223 dataRR RRTypeLOC = justv domLoc
224 dataRR RRTypeNS = justl domNs
225 dataRR RRTypeDS = \ _ _ dom ->
228 Just dss -> map dsStr dss
230 dsStr x = (show (dsKeyTag x)) ++ " "
231 ++ (show (dsAlgo x)) ++ " "
232 ++ (show (dsHashType x)) ++ " "
234 -- This only comes into play when data arrived _not_ from a PDNS request:
235 dataRR (RRTypeError e) = \ _ _ _ ->
236 ["; No data for bad request type " ++ e]