X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=PowerDns.hs;h=457cdcae5b3be03b3160b0dc1f87e38b6b015bc6;hp=d45cd00ebaa52219ca971b1c21561f15dd785839;hb=c83bf5437e85fe671f6e113cfc6f0b4961f543c7;hpb=25bc11d9c647cba3b1cbd367358c564a4c191304 diff --git a/PowerDns.hs b/PowerDns.hs index d45cd00..457cdca 100644 --- a/PowerDns.hs +++ b/PowerDns.hs @@ -1,34 +1,51 @@ module PowerDns ( RRType(..) + , rrType , PdnsRequest(..) , pdnsParse , pdnsReport - , pdnsOut + , pdnsOutQ , pdnsOutXfr ) where import Data.Text.Lazy (splitOn, pack) +import Data.Map.Lazy (foldrWithKey) import NmcDom data RRType = RRTypeSRV | RRTypeA | RRTypeAAAA | RRTypeCNAME | RRTypeDNAME | RRTypeSOA | RRTypeRP | RRTypeLOC | RRTypeNS | RRTypeDS | RRTypeMX - | RRTypeANY | RRTypeError String + | RRTypeANY | RRTypeError String instance Show RRType where show RRTypeSRV = "SRV" show RRTypeA = "A" show RRTypeAAAA = "AAAA" show RRTypeCNAME = "CNAME" - show RRTypeDNAME = "DNAME" + show RRTypeDNAME = "DNAME" show RRTypeSOA = "SOA" show RRTypeRP = "RP" show RRTypeLOC = "LOC" - show RRTypeNS = "NS" + show RRTypeNS = "NS" show RRTypeDS = "DS" show RRTypeMX = "MX" show RRTypeANY = "ANY" - show (RRTypeError s) = "RR type error: " ++ (show s) + 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 + "ANY" -> RRTypeANY + _ -> RRTypeError qt data PdnsRequest = PdnsRequestQ { qName :: String @@ -48,21 +65,7 @@ pdnsParse ver s = let getInt s = case reads s :: [(Int, String)] of [(x, _)] -> x - _ -> -1 - 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 + _ -> (-1) getLIp ver xs | ver >= 2 = case xs of x:_ -> Just x @@ -77,9 +80,13 @@ pdnsParse ver s = case words s of "PING":[] -> Right PdnsRequestPing "AXFR":x:[] -> Right (PdnsRequestAXFR (getInt x)) - "Q":qn:"IN":qt:id:rip:xs -> Right (PdnsRequestQ + "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 + , qType = rrType qt , iD = getInt id , remoteIpAddress = rip , localIpAddress = getLIp ver xs @@ -92,30 +99,64 @@ pdnsReport :: String -> String pdnsReport err = "LOG\tError: " ++ err ++ "\nFAIL\n" -- | Produce answer to the Q request -pdnsOut :: Int -> Int -> String -> RRType -> Either String NmcDom -> String -pdnsOut ver id name rrtype edom = case edom of - Left err -> - pdnsReport $ err ++ " in a " ++ (show rrtype) ++ "query for " ++ name - Right dom -> - case rrtype of - RRTypeANY -> foldr (\x a -> (formatRR ver id name dom x) ++ a) "END\n" - [RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME, RRTypeDNAME, - RRTypeRP, RRTypeLOC, RRTypeNS, RRTypeDS, RRTypeMX] - _ -> (formatRR ver id name dom rrtype) ++ "END\n" +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 -> String -> Either String NmcDom -> String -pdnsOutXfr ver id name edom = "" -- FIXME +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 domMap 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 +justl accessor _ _ dom = case accessor dom of Nothing -> [] Just xs -> xs -justv accessor _ dom = case accessor dom of +justv accessor _ _ dom = case accessor dom of Nothing -> [] Just x -> [x] -dotmail addr = +dotmail addr = let (aname, adom) = break (== '@') addr in case adom of "" -> aname ++ "." @@ -127,10 +168,10 @@ dataRR RRTypeA = justl domIp dataRR RRTypeAAAA = justl domIp6 dataRR RRTypeCNAME = justv domAlias dataRR RRTypeDNAME = justv domTranslate -dataRR RRTypeSOA = \ name dom -> -- FIXME make realistic version field +dataRR RRTypeSOA = \ gen name dom -> let ns = case domNs dom of - Just (x:_) -> x -- FIXME Terminate with a dot? + Just (x:_) -> x _ -> "." email = case domEmail dom of Nothing -> "hostmaster." ++ name ++ "." @@ -144,15 +185,16 @@ dataRR RRTypeSOA = \ name dom -> -- FIXME make realistic version field -- 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 ++ " 99999 10800 3600 604800 86400"] + [_,_] -> [ns ++ " " ++ email ++ " " ++ (show gen) + ++ " 10800 3600 604800 86400"] _ -> [] -dataRR RRTypeRP = \ _ dom -> +dataRR RRTypeRP = \ _ _ dom -> case domEmail dom of Nothing -> [] Just addr -> [(dotmail addr) ++ " ."] dataRR RRTypeLOC = justv domLoc -dataRR RRTypeNS = justl domNs -- FIXME Terminate with a dot? -dataRR RRTypeDS = \ _ dom -> +dataRR RRTypeNS = justl domNs +dataRR RRTypeDS = \ _ _ dom -> case domDs dom of Nothing -> [] Just dss -> map dsStr dss @@ -161,13 +203,6 @@ dataRR RRTypeDS = \ _ dom -> ++ (show (dsAlgo x)) ++ " " ++ (show (dsHashType x)) ++ " " ++ (dsHashValue x) - -formatRR ver id 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 name dom - where - v3ext = case ver of - 3 -> "0\t1\t" - _ -> "" - ttl = show 3600 +-- This only comes into play when data arrived _not_ from a PDNS request: +dataRR (RRTypeError e) = \ _ _ _ -> + ["; No data for bad request type " ++ e]