X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=PowerDns.hs;h=606c5ca09f0e1644715810b4d259e528327e366b;hp=796d97c5fa15a74445a05c600335098caa3f29c7;hb=f5e9870ed6d3307c08e583a7874d8c35e0ea6978;hpb=43f33df502cd65490ede22bc2e26e6a360ca4502 diff --git a/PowerDns.hs b/PowerDns.hs index 796d97c..606c5ca 100644 --- a/PowerDns.hs +++ b/PowerDns.hs @@ -1,46 +1,74 @@ module PowerDns ( RRType(..) + , rrType , PdnsRequest(..) , pdnsParse , pdnsReport - , pdnsOut + , pdnsOutQ + , pdnsOutXfr ) where +import Data.Text.Lazy (splitOn, pack) +import Data.Map.Lazy (foldrWithKey) +import Data.Default.Class (def) + import NmcDom data RRType = RRTypeSRV | RRTypeA | RRTypeAAAA | RRTypeCNAME | RRTypeDNAME | RRTypeSOA | RRTypeRP | RRTypeLOC - | RRTypeNS | RRTypeDS | RRTypeMX - | RRTypeANY | RRTypeError String - deriving (Show) + | RRTypeNS | RRTypeDS | RRTypeMX | RRTypeTLSA + | RRTypeANY | RRTypeError String + +instance Show RRType where + show RRTypeSRV = "SRV" + show RRTypeA = "A" + show RRTypeAAAA = "AAAA" + show RRTypeCNAME = "CNAME" + show RRTypeDNAME = "DNAME" + show RRTypeSOA = "SOA" + show RRTypeRP = "RP" + show RRTypeLOC = "LOC" + show RRTypeNS = "NS" + show RRTypeDS = "DS" + show RRTypeMX = "MX" + show RRTypeTLSA = "TLSA" + show RRTypeANY = "ANY" + show (RRTypeError s) = "Unknown RR type: " ++ (show s) + +rrType qt = case qt of + "SRV" -> RRTypeSRV + "A" -> RRTypeA + "AAAA" -> RRTypeAAAA + "CNAME" -> RRTypeCNAME + "DNAME" -> RRTypeDNAME + "SOA" -> RRTypeSOA + "RP" -> RRTypeRP + "LOC" -> RRTypeLOC + "NS" -> RRTypeNS + "DS" -> RRTypeDS + "MX" -> RRTypeMX + "TLSA" -> RRTypeTLSA + "ANY" -> RRTypeANY + _ -> RRTypeError qt data PdnsRequest = PdnsRequestQ { qName :: String , qType :: RRType - , iD :: String + , iD :: Int , remoteIpAddress :: String , localIpAddress :: Maybe String , ednsSubnetAddress :: Maybe String } - | PdnsRequestAXFR String + | PdnsRequestAXFR Int | PdnsRequestPing deriving (Show) +-- | Parse request string read from the core PowerDNS process +pdnsParse :: Int -> String -> Either String PdnsRequest pdnsParse ver s = let - getQt qt = case qt of - "SRV" -> RRTypeSRV - "A" -> RRTypeA - "AAAA" -> RRTypeAAAA - "CNAME" -> RRTypeCNAME - "DNAME" -> RRTypeDNAME - "SOA" -> RRTypeSOA - "RP" -> RRTypeRP - "LOC" -> RRTypeLOC - "NS" -> RRTypeNS - "DS" -> RRTypeDS - "MX" -> RRTypeMX - "ANY" -> RRTypeANY - _ -> RRTypeError qt + getInt s = case reads s :: [(Int, String)] of + [(x, _)] -> x + _ -> (-1) getLIp ver xs | ver >= 2 = case xs of x:_ -> Just x @@ -54,77 +82,149 @@ pdnsParse ver s = in case words s of "PING":[] -> Right PdnsRequestPing - "AXFR":x:[] -> Right (PdnsRequestAXFR x) - "Q":qn:"IN":qt:id:rip:xs -> Right (PdnsRequestQ + "AXFR":x:[] -> Right (PdnsRequestAXFR (getInt x)) + "Q":qn:"IN":qt:id:rip:xs -> case rrType qt of + RRTypeError e -> + Left $ "Unrecognized RR type: " ++ e + rt -> + Right (PdnsRequestQ { qName = qn - , qType = getQt qt - , iD = id + , qType = rrType qt + , iD = getInt id , remoteIpAddress = rip , localIpAddress = getLIp ver xs , ednsSubnetAddress = getRIp ver xs }) _ -> Left $ "Unparseable PDNS Request: " ++ s +-- | Produce LOG entry followed by FAIL pdnsReport :: String -> String -pdnsReport err = - "LOG\tError: " ++ err ++ "\nFAIL\n" - -pdnsOut :: Int -> String -> String -> RRType -> Either String NmcDom -> String -pdnsOut ver id name rrtype edom = - case edom of - Left err -> pdnsReport $ err ++ " in a query for " ++ name - Right dom -> foldr addLine "END\n" $ nmc2pdns name rrtype dom +pdnsReport err = "LOG\tError: " ++ err ++ "\nFAIL\n" + +-- | Produce answer to the Q request +pdnsOutQ :: Int -> Int -> Int -> String -> RRType -> Either String NmcDom -> String +pdnsOutQ ver id gen name rrt edom = + let + rrl = case rrt of + RRTypeANY -> [ RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME + , RRTypeDNAME, RRTypeRP, RRTypeLOC, RRTypeNS + , RRTypeDS, RRTypeMX -- SOA not included + ] + x -> [x] + in + case edom of + Left err -> + pdnsReport $ err ++ " in the " ++ (show rrt) ++ " query for " ++ name + Right dom -> + formatDom ver id gen rrl name dom "END\n" + +-- | Produce answer to the AXFR request +pdnsOutXfr :: Int -> Int -> Int -> String -> Either String NmcDom -> String +pdnsOutXfr ver id gen name edom = + let + allrrs = [ RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME + , RRTypeDNAME, RRTypeRP, RRTypeLOC, RRTypeNS + , RRTypeDS, RRTypeMX, RRTypeSOA + ] + walkDom f acc name dom = + f name dom $ case domSubmap dom of + Nothing -> acc + Just dm -> + foldrWithKey (\n d a -> walkDom f a (n ++ "." ++ name) d) acc dm + in + case edom of + Left err -> + pdnsReport $ err ++ " in the AXFR request for " ++ name + Right dom -> + walkDom (formatDom ver id gen allrrs) "END\n" name dom + +formatDom ver id gen rrl name dom acc = + foldr (\x a -> (formatRR ver id gen name dom x) ++ a) acc rrl + +formatRR ver id gen name dom rrtype = + foldr (\x a -> "DATA\t" ++ v3ext ++ name ++ "\tIN\t" ++ (show rrtype) + ++ "\t" ++ ttl ++ "\t" ++ (show id) ++ "\t" ++ x ++ "\n" ++ a) + "" $ dataRR rrtype gen name dom + where + v3ext = case ver of + 3 -> "0\t1\t" + _ -> "" + ttl = show 3600 + +justl accessor _ _ dom = case accessor dom of + Nothing -> [] + Just xs -> xs + +justv accessor _ _ dom = case accessor dom of + Nothing -> [] + Just x -> [x] + +dotmail addr = + let (aname, adom) = break (== '@') addr + in case adom of + "" -> aname ++ "." + _ -> aname ++ "." ++ (tail adom) ++ "." + +dataRR RRTypeSRV = \ _ _ dom -> + case domSrv dom of + Nothing -> [] + Just srvs -> map srvStr srvs where - addLine (nm, ty, dt) accum = - "DATA\t" ++ v3ext ++ nm ++ "\tIN\t" ++ ty ++ "\t" ++ ttl ++ - "\t" ++ id ++ "\t" ++ dt ++ "\n" ++ accum - v3ext = case ver of - 3 -> "0\t1\t" - _ -> "" - ttl = show 3600 - -nmc2pdns :: String -> RRType -> NmcDom -> [(String, String, String)] -nmc2pdns name RRTypeANY dom = - foldr (\r accum -> (nmc2pdns r) ++ accum) [] - [RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME, RRTypeDNAME, - RRTypeSOA, RRTypeRP, RRTypeLOC, RRTypeNS, RRTypeDS, RRTypeMX] - where - nmc2pdns RRTypeSRV = makesrv "SRV" $ domService dom - nmc2pdns RRTypeMX = mapto "MX" $ domMx dom - nmc2pdns RRTypeA = mapto "A" $ domIp dom - nmc2pdns RRTypeAAAA = mapto "AAAA" $ domIp6 dom - nmc2pdns RRTypeCNAME = takejust "CNAME" $ domAlias dom - nmc2pdns RRTypeDNAME = takejust "DNAME" $ domTranslate dom - nmc2pdns RRTypeSOA = -- FIXME generate only for top domain - if dom == emptyNmcDom then [] - else - let - email = case domEmail dom of - Nothing -> "hostmaster." ++ name - Just addr -> - let (aname, adom) = break (== '@') addr - in case adom of - "" -> aname - _ -> aname ++ "." ++ (tail adom) - in [(name, "SOA", email ++ " 99999999 10800 3600 604800 86400")] - nmc2pdns RRTypeRP = [] --FIXME - nmc2pdns RRTypeLOC = takejust "LOC" $ domLoc dom - nmc2pdns RRTypeNS = mapto "NS" $ domNs dom - nmc2pdns RRTypeDS = [] --FIXME - - mapto rrstr maybel = case maybel of - Nothing -> [] - Just l -> map (\x -> (name, rrstr, x)) l - - takejust rrstr maybestr = case maybestr of - Nothing -> [] - Just str -> [(name, rrstr, str)] + srvStr x = (show (srvPrio x)) ++ "\t" + ++ (show (srvWeight x)) ++ " " + ++ (show (srvPort x)) ++ " " + ++ (srvHost x) - makesrv rrstr mayberl = case mayberl of - Nothing -> [] - Just srl -> map (\x -> (name, rrstr, fmtsrv x)) srl - where - fmtsrv rl = (show (srvPrio rl)) ++ " " - ++ (show (srvWeight rl)) ++ " " - ++ (show (srvPort rl)) ++ " " - ++ (srvHost rl) +dataRR RRTypeMX = justl domMx +dataRR RRTypeTLSA = \ _ _ dom -> + case domTlsa dom of + Nothing -> [] + Just tlsas -> map tlsaStr tlsas + where + tlsaStr x = "(3 0 " + ++ (show (tlsMatchType x)) ++ " " + ++ (tlsMatchValue x) ++ ")" + -- tlsIncSubdoms is not displayed, it is used for `propagate`. + +dataRR RRTypeA = justl domIp +dataRR RRTypeAAAA = justl domIp6 +dataRR RRTypeCNAME = justv domAlias +dataRR RRTypeDNAME = justv domTranslate +dataRR RRTypeSOA = \ gen name dom -> + let + ns = case domNs dom of + Just (x:_) -> x + _ -> "." + email = case domEmail dom of + Nothing -> "hostmaster." ++ name ++ "." + Just addr -> dotmail addr + in + if dom == def then [] + else + -- Follows a relatively ugly hack to figure if we are at the top + -- level domain ("something.bit"). Only in such case we provide + -- the synthetic SOA RR. Otherwise yield empty. + -- Alternative would be to carry "top-ness" as a parameter through + -- all the calls from the very top where we split the fqdn. + case splitOn (pack ".") (pack name) of + [_,_] -> [ns ++ " " ++ email ++ " " ++ (show gen) + ++ " 10800 3600 604800 86400"] + _ -> [] +dataRR RRTypeRP = \ _ _ dom -> + case domEmail dom of + Nothing -> [] + Just addr -> [(dotmail addr) ++ " ."] +dataRR RRTypeLOC = justv domLoc +dataRR RRTypeNS = justl domNs +dataRR RRTypeDS = \ _ _ dom -> + case domDs dom of + Nothing -> [] + Just dss -> map dsStr dss + where + dsStr x = (show (dsKeyTag x)) ++ " " + ++ (show (dsAlgo x)) ++ " " + ++ (show (dsHashType x)) ++ " " + ++ (dsHashValue x) +-- This only comes into play when data arrived _not_ from a PDNS request: +dataRR (RRTypeError e) = \ _ _ _ -> + ["; No data for bad request type " ++ e]