update README to reflect current status

[pdns-pipe-nmc.git] / NmcDom.hs

diff --git a/NmcDom.hs b/NmcDom.hs
index fe87270c728d31a51064c35c50742ec69e8d3b48..c94e8af8bdd50970f9428ce5fd8a2dc8da4bed95 100644 (file)
--- a/NmcDom.hs
+++ b/NmcDom.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module NmcDom   ( NmcDom(..)
 {-# LANGUAGE OverloadedStrings #-}
 
 module NmcDom   ( NmcDom(..)

+                , NmcRRService(..)

                 , emptyNmcDom
                 , seedNmcDom
                 , descendNmcDom
                 , emptyNmcDom
                 , seedNmcDom
                 , descendNmcDom


@@ -41,8 +42,8 @@ instance Eq a => Mergeable [a] where
 data NmcRRService = NmcRRService
                         { srvName       :: String
                         , srvProto      :: String
 data NmcRRService = NmcRRService
                         { srvName       :: String
                         , srvProto      :: String

-                        , srvW1         :: Int
-                        , srvW2         :: Int
+                        , srvPrio       :: Int
+                        , srvWeight     :: Int

                         , srvPort       :: Int
                         , srvHost       :: String
                         } deriving (Show, Eq)
                         , srvPort       :: Int
                         , srvHost       :: String
                         } deriving (Show, Eq)


@@ -97,6 +98,7 @@ data NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]
                         , domTls         :: Maybe (Map String
                                                     (Map String [[String]]))
                         , domDs          :: Maybe [[String]]
                         , domTls         :: Maybe (Map String
                                                     (Map String [[String]]))
                         , domDs          :: Maybe [[String]]

+                        , domMx          :: Maybe [String] -- Synthetic

                         } deriving (Show, Eq)
 
 instance FromJSON NmcDom where
                         } deriving (Show, Eq)
 
 instance FromJSON NmcDom where


@@ -132,6 +134,7 @@ instance FromJSON NmcDom where
                 <*> o .:? "fingerprint"
                 <*> o .:? "tls"
                 <*> o .:? "ds"
                 <*> o .:? "fingerprint"
                 <*> o .:? "tls"
                 <*> o .:? "ds"

+                <*> return Nothing -- domMx not parsed

         parseJSON _ = empty
 
 instance Mergeable NmcDom where
         parseJSON _ = empty
 
 instance Mergeable NmcDom where


@@ -153,6 +156,7 @@ instance Mergeable NmcDom where
                                 , domFingerprint = mergelm domFingerprint
                                 , domTls =         mergelm domTls
                                 , domDs =          mergelm domDs
                                 , domFingerprint = mergelm domFingerprint
                                 , domTls =         mergelm domTls
                                 , domDs =          mergelm domDs

+                                , domMx =          mergelm domMx

                                 }
           where
                 mergelm x = merge (x sub) (x dom)
                                 }
           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
 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 ::
 
 -- | Perform query and return error string or parsed domain object
 queryNmcDom ::


@@ -186,20 +191,22 @@ queryNmcDom queryOp key = do
 --   imported objects are processed recursively until there are none.
 mergeImport ::
   (String -> IO (Either String ByteString)) -- ^ query operation action
 --   imported objects are processed recursively until there are none.
 mergeImport ::
   (String -> IO (Either String ByteString)) -- ^ query operation action

+  -> Int                                    -- ^ recursion counter

   -> NmcDom                                 -- ^ base domain
   -> IO (Either String NmcDom)              -- ^ result with merged import
   -> NmcDom                                 -- ^ base domain
   -> IO (Either String NmcDom)              -- ^ result with merged import

-mergeImport queryOp base = do
+mergeImport queryOp depth base = do

   let
     mbase = mergeSelf base
     base' = mbase {domImport = Nothing}
   -- print base
   let
     mbase = mergeSelf base
     base' = mbase {domImport = Nothing}
   -- print base

-  case domImport mbase of
+  if depth <= 0 then return $ Left "Nesting of imports is too deep"
+  else case domImport mbase of

     Nothing  -> return $ Right base'
     Just key -> do
       sub <- queryNmcDom queryOp key
       case sub of
         Left  e    -> return $ Left e
     Nothing  -> return $ Right base'
     Just key -> do
       sub <- queryNmcDom queryOp key
       case sub of
         Left  e    -> return $ Left e

-        Right sub' -> mergeImport queryOp $ sub' `merge` base'
+        Right sub' -> mergeImport queryOp (depth - 1) $ sub' `merge` base'

 
 -- | If there is an element in the map with key "", merge the contents
 --   and remove this element. Do this recursively.
 
 -- | If there is an element in the map with key "", merge the contents
 --   and remove this element. Do this recursively.


@@ -218,11 +225,20 @@ mergeSelf base =
         case M.lookup "" map' of
           Nothing  -> base'
           Just sub -> (mergeSelf sub) `merge` base'
         case M.lookup "" map' of
           Nothing  -> base'
           Just sub -> (mergeSelf sub) `merge` base'

+        -- recursion depth limited by the size of the record
+
+-- | SRV case - remove everyting and filter SRV records
+normalizeSrv :: String -> String -> NmcDom -> NmcDom
+normalizeSrv serv proto dom =
+  emptyNmcDom {domService = fmap (filter needed) (domService dom)}
+    where
+      needed r = srvName r == serv && srvProto r == proto

 
 -- | Presence of some elements require removal of some others
 normalizeDom :: NmcDom -> NmcDom
 
 -- | Presence of some elements require removal of some others
 normalizeDom :: NmcDom -> NmcDom

-normalizeDom dom = foldr id dom [ translateNormalizer
-                                -- , nsNormalizer -- FIXME retrun this
+normalizeDom dom = foldr id dom [ srvNormalizer
+                                , translateNormalizer
+                                , nsNormalizer

                                 ]
   where
     nsNormalizer dom = case domNs dom of
                                 ]
   where
     nsNormalizer dom = case domNs dom of


@@ -231,6 +247,16 @@ normalizeDom dom = foldr id dom [ translateNormalizer
     translateNormalizer dom = case domTranslate dom of
       Nothing  -> dom
       Just tr  -> dom { domMap = Nothing }
     translateNormalizer dom = case domTranslate dom of
       Nothing  -> dom
       Just tr  -> dom { domMap = 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 ::
 
 -- | Merge imports and Selfs and follow the maps tree to get dom
 descendNmcDom ::


@@ -239,9 +265,11 @@ descendNmcDom ::
   -> NmcDom                                 -- ^ base domain
   -> IO (Either String NmcDom)              -- ^ fully processed result
 descendNmcDom queryOp subdom base = do
   -> NmcDom                                 -- ^ base domain
   -> IO (Either String NmcDom)              -- ^ fully processed result
 descendNmcDom queryOp subdom base = do

-  base' <- mergeImport queryOp base
+  base' <- mergeImport queryOp 10 base

   case subdom of
     []   -> return $ fmap normalizeDom base'
   case subdom of
     []   -> return $ fmap normalizeDom base'

+    -- A hack to handle SRV records: don't descend if ["_prot","_serv"]
+    [('_':p),('_':s)] -> return $ fmap (normalizeSrv s p) base'

     d:ds ->
       case base' of
         Left err     -> return base'
     d:ds ->
       case base' of
         Left err     -> return base'