From: Eugene Crosser Date: Fri, 18 Apr 2014 22:37:18 +0000 (+0400) Subject: refactor pdnsOut X-Git-Tag: 0.9.0.0~47 X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=commitdiff_plain;h=a8d263736c3b3f68ce8a70c4eb2c7c4024a9506a refactor pdnsOut --- diff --git a/PowerDns.hs b/PowerDns.hs index 61fdc21..09b6383 100644 --- a/PowerDns.hs +++ b/PowerDns.hs @@ -6,13 +6,29 @@ module PowerDns ( RRType(..) , pdnsOutXfr ) where +import Data.Text.Lazy (splitOn, pack) + import NmcDom data RRType = RRTypeSRV | RRTypeA | RRTypeAAAA | RRTypeCNAME | RRTypeDNAME | RRTypeSOA | RRTypeRP | RRTypeLOC | RRTypeNS | RRTypeDS | RRTypeMX | RRTypeANY | RRTypeError String - deriving (Show) + +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 RRTypeANY = "ANY" + show (RRTypeError s) = "RR type error: " ++ (show s) data PdnsRequest = PdnsRequestQ { qName :: String @@ -26,21 +42,23 @@ data PdnsRequest = PdnsRequestQ | PdnsRequestPing deriving (Show) +-- | Parse request string read from the core PowerDNS process +pdnsParse :: Int -> String -> Either String PdnsRequest pdnsParse ver s = let getInt s = case reads s :: [(Int, String)] of [(x, _)] -> x _ -> -1 getQt qt = case qt of - "SRV" -> RRTypeSRV + "SRV" -> RRTypeSRV "A" -> RRTypeA "AAAA" -> RRTypeAAAA "CNAME" -> RRTypeCNAME "DNAME" -> RRTypeDNAME - "SOA" -> RRTypeSOA - "RP" -> RRTypeRP + "SOA" -> RRTypeSOA + "RP" -> RRTypeRP "LOC" -> RRTypeLOC - "NS" -> RRTypeNS + "NS" -> RRTypeNS "DS" -> RRTypeDS "MX" -> RRTypeMX "ANY" -> RRTypeANY @@ -69,70 +87,87 @@ pdnsParse ver s = }) _ -> Left $ "Unparseable PDNS Request: " ++ s +-- | Produce LOG entry followed by FAIL pdnsReport :: String -> String -pdnsReport err = - "LOG\tError: " ++ err ++ "\nFAIL\n" +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 query for " ++ name - Right dom -> foldr addLine "END\n" $ n2p rrtype - where - addLine (nm, ty, dt) accum = - "DATA\t" ++ v3ext ++ nm ++ "\tIN\t" ++ ty ++ "\t" ++ ttl ++ - "\t" ++ (show id) ++ "\t" ++ dt ++ "\n" ++ accum - v3ext = case ver of - 3 -> "0\t1\t" - _ -> "" - ttl = show 3600 - - n2p RRTypeANY = - foldr (\r accum -> (n2p r) ++ accum) [] + 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] - n2p RRTypeSRV = mapto "SRV" $ domSrv dom - n2p RRTypeMX = mapto "MX" $ domMx dom - n2p RRTypeA = mapto "A" $ domIp dom - n2p RRTypeAAAA = mapto "AAAA" $ domIp6 dom - n2p RRTypeCNAME = takejust "CNAME" $ domAlias dom - n2p RRTypeDNAME = takejust "DNAME" $ domTranslate dom - n2p RRTypeSOA = -- FIXME generate only for top domain + _ -> (formatRR ver id name dom rrtype) ++ "END\n" + +-- | Produce answer to the AXFR request +pdnsOutXfr :: Int -> Int -> String -> Either String NmcDom -> String +pdnsOutXfr ver id name edom = "" -- FIXME + +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 = justl domSrv +dataRR RRTypeMX = justl domMx +dataRR RRTypeA = justl domIp +dataRR RRTypeAAAA = justl domIp6 +dataRR RRTypeCNAME = justv domAlias +dataRR RRTypeDNAME = justv domTranslate +dataRR RRTypeSOA = soa + where + soa name dom = -- FIXME generate only for top domain -- FIXME make realistic version field -- FIXME make realistic nameserver field - if dom == emptyNmcDom then [] - else [(name, "SOA", "ns " ++ email ++ " 99999 10800 3600 604800 86400")] - where - email = case domEmail dom of - Nothing -> "hostmaster." ++ name - Just addr -> dotmail addr - n2p RRTypeRP = case domEmail dom of - Nothing -> [] - Just addr -> [(name, "RP", (dotmail addr) ++ " .")] - n2p RRTypeLOC = takejust "LOC" $ domLoc dom - n2p RRTypeNS = mapto "NS" $ domNs dom - n2p RRTypeDS = case domDs dom of - Nothing -> [] - Just dss -> map (\x -> (name, "DS", dsStr x)) dss - where - dsStr x = (show (dsKeyTag x)) ++ " " - ++ (show (dsAlgo x)) ++ " " - ++ (show (dsHashType x)) ++ " " - ++ (dsHashValue x) - - dotmail addr = - let (aname, adom) = break (== '@') addr - in case adom of - "" -> aname - _ -> aname ++ "." ++ (tail adom) - - 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)] + -- 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. + case splitOn (pack ".") (pack name) of + [_,_] -> + if dom == emptyNmcDom then [] + else ["ns " ++ email ++ " 99999 10800 3600 604800 86400"] + where + email = case domEmail dom of + Nothing -> "hostmaster." ++ name + Just addr -> dotmail addr + _ -> [] +dataRR RRTypeRP = rp + where + rp _ dom = case domEmail dom of + Nothing -> [] + Just addr -> [(dotmail addr) ++ " ."] +dataRR RRTypeLOC = justv domLoc +dataRR RRTypeNS = justl domNs +dataRR RRTypeDS = ds + where + ds _ 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) -pdnsOutXfr :: Int -> Int -> String -> Either String NmcDom -> String -pdnsOutXfr ver id name edom = case edom of - Left err -> pdnsReport $ err ++ " in a query for " ++ name - Right dom -> pdnsReport $ "AXFR unsupported in a query for " ++ name +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 diff --git a/pdns-pipe-nmc.hs b/pdns-pipe-nmc.hs index a0d5fa2..2ef82c2 100644 --- a/pdns-pipe-nmc.hs +++ b/pdns-pipe-nmc.hs @@ -110,11 +110,13 @@ mainPdnsNmc = do PdnsRequestQ qname qtype id _ _ _ -> do io $ queryDom (queryOpNmc cfg mgr id) qname >>= putStr . (pdnsOut ver count qname qtype) + -- debug io $ putStrLn $ "LOG\tRequest number " ++ (show count) ++ " id: " ++ (show id) ++ " qname: " ++ qname ++ " qtype: " ++ (show qtype) ++ " cache size: " ++ (show (size cache)) + -- end debug put (if count >= 99 then 0 else count + 1, newcache count qname cache) PdnsRequestAXFR xrq ->