allow string where array of strings is expected

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

diff --git a/NmcDom.hs b/NmcDom.hs
index c32a16e2245b30b64f066bdb5ee71c0b1eb05b6f..adb378999a064e81ce759d9b3d3e7c61a0dd34a0 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


@@ -8,15 +9,31 @@ module NmcDom   ( NmcDom(..)
 
 import Prelude hiding (length)
 import Data.ByteString.Lazy (ByteString)
 
 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.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.Vector (toList,(!),length, singleton)
+import Control.Applicative ((<$>), (<*>), empty, pure)

 import Data.Aeson
 
 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
 
 class Mergeable a where
         merge :: a -> a -> a -- bias towads second arg
 


@@ -41,8 +58,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)


@@ -90,13 +107,14 @@ data NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]
                         , domLoc         :: Maybe String
                         , domInfo        :: Maybe Value
                         , domNs          :: Maybe [String]
                         , 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]]
                         , domImport      :: Maybe String
                         , domMap         :: Maybe (Map String NmcDom)
                         , domFingerprint :: 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


@@ -108,15 +126,15 @@ instance FromJSON NmcDom where
                             then emptyNmcDom { domIp = Just [s'] }
                             else emptyNmcDom
                           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"
                             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"
                 <*> o .:? "tor"
                 <*> o .:? "i2p"
                 <*> o .:? "freenet"


@@ -125,13 +143,14 @@ instance FromJSON NmcDom where
                 <*> o .:? "email"
                 <*> o .:? "loc"
                 <*> o .:? "info"
                 <*> o .:? "email"
                 <*> o .:? "loc"
                 <*> o .:? "info"

-                <*> o .:? "ns"
+                <*> o .:/ "ns"

                 <*> o .:? "delegate"
                 <*> o .:? "import"
                 <*> o .:? "map"
                 <*> o .:? "delegate"
                 <*> o .:? "import"
                 <*> o .:? "map"

-                <*> o .:? "fingerprint"
+                <*> o .:/ "fingerprint"

                 <*> o .:? "tls"
                 <*> o .:? "ds"
                 <*> o .:? "tls"
                 <*> o .:? "ds"

+                <*> return Nothing -- domMx not parsed

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


@@ -153,6 +172,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 +187,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 ::


@@ -222,10 +243,18 @@ mergeSelf base =
           Just sub -> (mergeSelf sub) `merge` base'
         -- recursion depth limited by the size of the record
 
           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


@@ -234,6 +263,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 ::


@@ -246,7 +285,7 @@ descendNmcDom queryOp subdom base = do
   case subdom of
     []   -> return $ fmap normalizeDom base'
     -- A hack to handle SRV records: don't descend if ["_prot","_serv"]
   case subdom of
     []   -> return $ fmap normalizeDom base'
     -- A hack to handle SRV records: don't descend if ["_prot","_serv"]

-    [('_':_),('-':_)] -> return $ fmap normalizeDom base'
+    [('_':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'