refactor pdnsOut

diff --git a/PowerDns.hs b/PowerDns.hs
index 61fdc21b307a1ef8c8af959c95ae58d0d64d3fb2..09b6383fa0a9678b7bcd1e1934f138b8a28cd517 100644 (file)
--- a/PowerDns.hs
+++ b/PowerDns.hs
@@ -6,13 +6,29 @@ module PowerDns ( RRType(..)
                 , pdnsOutXfr
                 ) where
 
                 , 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 
 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
 
 data PdnsRequest = PdnsRequestQ
                    { qName              :: String


@@ -26,21 +42,23 @@ data PdnsRequest = PdnsRequestQ
                  | PdnsRequestPing
         deriving (Show)
 
                  | 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
 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 
       "A"       -> RRTypeA
       "AAAA"    -> RRTypeAAAA
       "CNAME"   -> RRTypeCNAME
       "DNAME"   -> RRTypeDNAME 

-      "SOA"     -> RRTypeSOA 
-      "RP"      -> RRTypeRP   
+      "SOA"     -> RRTypeSOA
+      "RP"      -> RRTypeRP

       "LOC"     -> RRTypeLOC
       "LOC"     -> RRTypeLOC

-      "NS"      -> RRTypeNS    
+      "NS"      -> RRTypeNS   

       "DS"      -> RRTypeDS
       "MX"      -> RRTypeMX
       "ANY"     -> RRTypeANY
       "DS"      -> RRTypeDS
       "MX"      -> RRTypeMX
       "ANY"     -> RRTypeANY


@@ -69,70 +87,87 @@ pdnsParse ver s =
                                             })
       _                         -> Left $ "Unparseable PDNS Request: " ++ s
 
                                             })
       _                         -> Left $ "Unparseable PDNS Request: " ++ s
 

+-- | Produce LOG entry followed by FAIL

 pdnsReport :: String -> String
 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
 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]
           [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
                         -- 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 a0d5fa23d417dbf4203d6812382e350a9b959163..2ef82c239e837a484c28b4b180b106a265055dd4 100644 (file)
--- 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)
             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))
               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 ->
               put (if count >= 99 then 0 else count + 1,
                    newcache count qname cache)
             PdnsRequestAXFR xrq ->