From 2ad29ac97637f25aea0a7ac0ee31afa72221a938 Mon Sep 17 00:00:00 2001
From: Eugene Crosser <crosser@average.org>
Date: Sun, 13 Apr 2014 23:34:21 +0400
Subject: [PATCH] SRV hack part 3 and final - works now

---
 NmcDom.hs   | 16 +++++++++++++++-
 PowerDns.hs | 19 +++++++++++++++----
 d/extra1    |  2 +-
 3 files changed, 31 insertions(+), 6 deletions(-)

diff --git a/NmcDom.hs b/NmcDom.hs
index 3f6c7bc..c94e8af 100644
--- a/NmcDom.hs
+++ b/NmcDom.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module NmcDom   ( NmcDom(..)
+                , NmcRRService(..)
                 , emptyNmcDom
                 , seedNmcDom
                 , descendNmcDom
@@ -97,6 +98,7 @@ data NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]
                         , domTls         :: Maybe (Map String
                                                     (Map String [[String]]))
                         , domDs          :: Maybe [[String]]
+                        , domMx          :: Maybe [String] -- Synthetic
                         } deriving (Show, Eq)
 
 instance FromJSON NmcDom where
@@ -132,6 +134,7 @@ instance FromJSON NmcDom where
                 <*> o .:? "fingerprint"
                 <*> o .:? "tls"
                 <*> o .:? "ds"
+                <*> return Nothing -- domMx not parsed
         parseJSON _ = empty
 
 instance Mergeable NmcDom where
@@ -153,6 +156,7 @@ instance Mergeable NmcDom where
                                 , domFingerprint = mergelm domFingerprint
                                 , domTls =         mergelm domTls
                                 , domDs =          mergelm domDs
+                                , domMx =          mergelm domMx
                                 }
           where
                 mergelm x = merge (x sub) (x dom)
@@ -167,6 +171,7 @@ instance Mergeable NmcDom where
 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
                      Nothing Nothing Nothing Nothing Nothing Nothing
                      Nothing Nothing Nothing Nothing Nothing Nothing
+                     Nothing
 
 -- | Perform query and return error string or parsed domain object
 queryNmcDom ::
@@ -242,7 +247,16 @@ normalizeDom dom = foldr id dom [ srvNormalizer
     translateNormalizer dom = case domTranslate dom of
       Nothing  -> dom
       Just tr  -> dom { domMap = Nothing }
-    srvNormalizer dom = dom { domService = Nothing }
+    srvNormalizer dom = dom { domService = Nothing, domMx = makemx }
+      where
+        makemx = case domService dom of
+          Nothing  -> Nothing
+          Just svl -> Just $ map makerec (filter needed svl)
+            where
+              needed sr = srvName sr == "smtp"
+                        && srvProto sr == "tcp"
+                        && srvPort sr == 25
+              makerec sr = (show (srvPrio sr)) ++ " " ++ (srvHost sr)
 
 -- | Merge imports and Selfs and follow the maps tree to get dom
 descendNmcDom ::
diff --git a/PowerDns.hs b/PowerDns.hs
index 8962e94..77c5149 100644
--- a/PowerDns.hs
+++ b/PowerDns.hs
@@ -9,7 +9,7 @@ import NmcDom
 
 data RRType = RRTypeSRV   | RRTypeA   | RRTypeAAAA | RRTypeCNAME
             | RRTypeDNAME | RRTypeSOA | RRTypeRP   | RRTypeLOC
-            | RRTypeNS    | RRTypeDS
+            | RRTypeNS    | RRTypeDS  | RRTypeMX
             | RRTypeANY   | RRTypeError String 
         deriving (Show)
 
@@ -38,6 +38,7 @@ pdnsParse ver s =
       "LOC"     -> RRTypeLOC
       "NS"      -> RRTypeNS    
       "DS"      -> RRTypeDS
+      "MX"      -> RRTypeMX
       "ANY"     -> RRTypeANY
       _         -> RRTypeError qt
     getLIp ver xs
@@ -85,9 +86,10 @@ pdnsOut ver id name rrtype edom =
 nmc2pdns :: String -> RRType -> NmcDom -> [(String, String, String)]
 nmc2pdns name RRTypeANY   dom =
   foldr (\r accum -> (nmc2pdns name r dom) ++ accum) []
-    [RRTypeA, RRTypeAAAA, RRTypeCNAME, RRTypeDNAME, -- no SRV here!
-     RRTypeSOA, RRTypeRP, RRTypeLOC, RRTypeNS, RRTypeDS]
-nmc2pdns name RRTypeSRV   dom = [] -- FIXME
+    [RRTypeSRV, RRTypeA, RRTypeAAAA, RRTypeCNAME, RRTypeDNAME,
+     RRTypeSOA, RRTypeRP, RRTypeLOC, RRTypeNS, RRTypeDS, RRTypeMX]
+nmc2pdns name RRTypeSRV   dom = makesrv name "SRV" $ domService dom
+nmc2pdns name RRTypeMX    dom = mapto name "MX" $ domMx dom
 nmc2pdns name RRTypeA     dom = mapto name "A" $ domIp dom
 nmc2pdns name RRTypeAAAA  dom = mapto name "AAAA" $ domIp6 dom
 nmc2pdns name RRTypeCNAME dom = takejust name "CNAME" $ domAlias dom
@@ -116,3 +118,12 @@ mapto name rrstr maybel = case maybel of
 takejust name rrstr maybestr = case maybestr of
   Nothing  -> []
   Just str -> [(name, rrstr, str)]
+
+makesrv name 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)
diff --git a/d/extra1 b/d/extra1
index ff6c7ef..b0fdcf5 100644
--- a/d/extra1
+++ b/d/extra1
@@ -1 +1 @@
-{"service":[["smtp", "tcp", 0, 0, 143, "mail.host.com."]],"import":"d/extra2","ip":["1.2.3.4"],"alias":"extra1alias"}
+{"service":[["smtp", "tcp", 0, 0, 25, "mail.host.com."]],"import":"d/extra2","ip":["1.2.3.4"],"alias":"extra1alias"}
-- 
2.43.0