X-Git-Url: http://www.average.org/gitweb/?p=pdns-pipe-nmc.git;a=blobdiff_plain;f=NmcDom.hs;h=11b77ac4a01905140f19161f0451d9f6501f7ecc;hp=3f6c7bc3e364fe633c0122cb5220364738be9306;hb=355038bc44ff6a9dbbc5a09739fba3fe4b073b32;hpb=778903b569e2a43c43758f1ebcb3e90ba1b6032d

diff --git a/NmcDom.hs b/NmcDom.hs
index 3f6c7bc..11b77ac 100644
--- a/NmcDom.hs
+++ b/NmcDom.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module NmcDom   ( NmcDom(..)
+                , NmcRRService(..)
                 , emptyNmcDom
                 , seedNmcDom
                 , descendNmcDom
@@ -8,20 +9,36 @@ module NmcDom   ( NmcDom(..)
 
 import Prelude hiding (length)
 import Data.ByteString.Lazy (ByteString)
-import qualified Data.Text as T (unpack)
+import Data.Text (Text, unpack)
 import Data.List as L (union)
 import Data.List.Split
 import Data.Char
-import Data.Map as M (Map, lookup, delete, size, union)
-import Data.Vector (toList,(!),length)
-import Control.Applicative ((<$>), (<*>), empty)
+import Data.Map as M (Map, lookup, delete, size, unionWith)
+import Data.Vector (toList,(!),length, singleton)
+import Control.Applicative ((<$>), (<*>), empty, pure)
 import Data.Aeson
 
+import qualified Data.HashMap.Strict as H
+import Data.Aeson.Types
+
+-- Variant of Aeson's `.:?` that interprets a String as a
+-- single-element list, so it is possible to have either
+--      "ip":["1.2.3.4"]
+-- or
+--      "ip":"1.2.3.4"
+-- with the same result.
+(.:/) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
+obj .:/ key = case H.lookup key obj of
+               Nothing -> pure Nothing
+               Just v  -> case v of
+                        String s -> parseJSON $ Array (singleton v)
+                        _        -> parseJSON v
+
 class Mergeable a where
         merge :: a -> a -> a -- bias towads second arg
 
-instance Ord k => Mergeable (Map k a) where
-        merge mx my = M.union my mx
+instance (Ord k, Mergeable a) => Mergeable (Map k a) where
+        merge mx my = M.unionWith merge my mx
 
 -- instance Mergeable String where
 --         merge _ b = b
@@ -78,6 +95,44 @@ instance FromJSON NmcRRI2p where
 instance Mergeable NmcRRI2p where
         merge _ b = b
 
+data NmcRRTls = NmcRRTls
+                        { tlsMatchType  :: Int -- 0:exact 1:sha256 2:sha512
+                        , tlsMatchValue :: String
+                        , tlsIncSubdoms :: Int -- 1:enforce on subdoms 0:no
+                        } deriving (Show, Eq)
+
+instance FromJSON NmcRRTls where
+        parseJSON (Array a) =
+                if length a == 3 then NmcRRTls
+                        <$> parseJSON (a ! 0)
+                        <*> parseJSON (a ! 1)
+                        <*> parseJSON (a ! 2)
+                else empty
+        parseJSON _ = empty
+
+instance Mergeable NmcRRTls where
+        merge _ b = b
+
+data NmcRRDs = NmcRRDs
+                        { dsKeyTag      :: Int
+                        , dsAlgo        :: Int
+                        , dsHashType    :: Int
+                        , dsHashValue   :: String
+                        } deriving (Show, Eq)
+
+instance FromJSON NmcRRDs where
+        parseJSON (Array a) =
+                if length a == 4 then NmcRRDs
+                        <$> parseJSON (a ! 0)
+                        <*> parseJSON (a ! 1)
+                        <*> parseJSON (a ! 2)
+                        <*> parseJSON (a ! 3)
+                else empty
+        parseJSON _ = empty
+
+instance Mergeable NmcRRDs where
+        merge _ b = b
+
 data NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]
                         , domIp          :: Maybe [String]
                         , domIp6         :: Maybe [String]
@@ -90,13 +145,14 @@ data NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]
                         , domLoc         :: Maybe String
                         , domInfo        :: Maybe Value
                         , domNs          :: Maybe [String]
-                        , domDelegate    :: Maybe [String]
+                        , domDelegate    :: Maybe String
                         , domImport      :: Maybe String
                         , domMap         :: Maybe (Map String NmcDom)
                         , domFingerprint :: Maybe [String]
                         , domTls         :: Maybe (Map String
-                                                    (Map String [[String]]))
-                        , domDs          :: Maybe [[String]]
+                                                    (Map String [NmcRRTls]))
+                        , domDs          :: Maybe [NmcRRDs]
+                        , domMx          :: Maybe [String] -- Synthetic
                         } deriving (Show, Eq)
 
 instance FromJSON NmcDom where
@@ -108,15 +164,15 @@ instance FromJSON NmcDom where
                             then emptyNmcDom { domIp = Just [s'] }
                             else emptyNmcDom
                           where
-                            s' = T.unpack s
+                            s' = unpack s
                             isIPv4 x = all isNibble $ splitOn "." x
                             isNibble x =
                               if all isDigit x then (read x :: Int) < 256
                               else False
         parseJSON (Object o) = NmcDom
                 <$> o .:? "service"
-                <*> o .:? "ip"
-                <*> o .:? "ip6"
+                <*> o .:/ "ip"
+                <*> o .:/ "ip6"
                 <*> o .:? "tor"
                 <*> o .:? "i2p"
                 <*> o .:? "freenet"
@@ -125,13 +181,14 @@ instance FromJSON NmcDom where
                 <*> o .:? "email"
                 <*> o .:? "loc"
                 <*> o .:? "info"
-                <*> o .:? "ns"
+                <*> o .:/ "ns"
                 <*> o .:? "delegate"
                 <*> o .:? "import"
                 <*> o .:? "map"
-                <*> o .:? "fingerprint"
+                <*> o .:/ "fingerprint"
                 <*> o .:? "tls"
                 <*> o .:? "ds"
+                <*> return Nothing -- domMx not parsed
         parseJSON _ = empty
 
 instance Mergeable NmcDom where
@@ -153,6 +210,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 +225,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 +301,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 ::