reimplement SRV handling
[pdns-pipe-nmc.git] / NmcDom.hs
index 03eeb98582275db94d2554b48fb4d4a80bb15cf6..8153a1dd7dad2d0b3128b455cf465bf0a93aa381 100644 (file)
--- a/NmcDom.hs
+++ b/NmcDom.hs
@@ -1,38 +1,84 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 module NmcDom   ( NmcDom(..)
+                , NmcRRService(..)
+                , NmcRRI2p(..)
+                , NmcRRTls(..)
                 , emptyNmcDom
-                , seedNmcDom
-                , descendNmcDom
+                , mergeNmcDom
                 ) where
 
-import Data.ByteString.Lazy (ByteString)
-import qualified Data.Text as T (unpack)
-import Data.List.Split
+import Prelude hiding (length)
+import Control.Applicative ((<$>), (<*>), empty, pure)
 import Data.Char
-import Data.Map as M (Map, lookup, delete, size)
-import Control.Applicative ((<$>), (<*>), empty)
+import Data.Text (Text, unpack)
+import Data.List (union)
+import Data.List.Split
+import Data.Vector ((!), length, singleton)
+import Data.Map (Map, unionWith)
+import qualified Data.HashMap.Strict as H (lookup)
 import Data.Aeson
-
-data NmcRRService = NmcRRService -- unused
+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 a) => Mergeable (Map k a) where
+        merge mx my = unionWith merge my mx
+
+-- Alas, the following is not possible in Haskell :-(
+-- instance Mergeable String where
+--         merge _ b = b
+
+instance Mergeable Value where
+        merge _ b = b
+
+instance Mergeable a => Mergeable (Maybe a) where
+        merge (Just x) (Just y) = Just (merge x y)
+        merge Nothing  (Just y) = Just y
+        merge (Just x) Nothing  = Just x
+        merge Nothing  Nothing  = Nothing
+
+instance Eq a => Mergeable [a] where
+        merge xs ys = union xs ys
+
+data NmcRRService = NmcRRService
                         { srvName       :: String
                         , srvProto      :: String
-                        , srvW1         :: Int
-                        , srvW2         :: Int
+                        , srvPrio       :: Int
+                        , srvWeight     :: Int
                         , srvPort       :: Int
-                        , srvHost       :: [String]
+                        , srvHost       :: String
                         } deriving (Show, Eq)
 
 instance FromJSON NmcRRService where
-        parseJSON (Object o) = NmcRRService
-                <$> o .: "name"
-                <*> o .: "proto"
-                <*> o .: "w1"
-                <*> o .: "w2"
-                <*> o .: "port"
-                <*> o .: "host"
+        parseJSON (Array a) =
+                if length a == 6 then NmcRRService
+                        <$> parseJSON (a ! 0)
+                        <*> parseJSON (a ! 1)
+                        <*> parseJSON (a ! 2)
+                        <*> parseJSON (a ! 3)
+                        <*> parseJSON (a ! 4)
+                        <*> parseJSON (a ! 5)
+                else empty
         parseJSON _ = empty
 
+instance Mergeable NmcRRService where
+        merge _ b = b
+
 data NmcRRI2p = NmcRRI2p
                         { i2pDestination :: String
                         , i2pName        :: String
@@ -46,7 +92,48 @@ instance FromJSON NmcRRI2p where
                 <*> o .: "b32"
         parseJSON _ = empty
 
-data NmcDom = NmcDom    { domService     :: Maybe [[String]] -- [NmcRRService]
+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]
                         , domTor         :: Maybe String
@@ -58,13 +145,15 @@ data NmcDom = NmcDom    { domService     :: Maybe [[String]] -- [NmcRRService]
                         , domLoc         :: Maybe String
                         , domInfo        :: Maybe Value
                         , domNs          :: Maybe [String]
-                        , domDelegate    :: Maybe [String]
-                        , domImport      :: 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
+                        , domSrv         :: Maybe [String] -- Synthetic
                         } deriving (Show, Eq)
 
 instance FromJSON NmcDom where
@@ -76,15 +165,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"
@@ -93,131 +182,52 @@ instance FromJSON NmcDom where
                 <*> o .:? "email"
                 <*> o .:? "loc"
                 <*> o .:? "info"
-                <*> o .:? "ns"
+                <*> o .:/ "ns"
                 <*> o .:? "delegate"
-                <*> o .:? "import"
+                <*> o .:/ "import"
                 <*> o .:? "map"
-                <*> o .:? "fingerprint"
+                <*> o .:/ "fingerprint"
                 <*> o .:? "tls"
                 <*> o .:? "ds"
+                <*> return Nothing -- domMx not parsed
+                <*> return Nothing -- domSrv not parsed
         parseJSON _ = empty
 
+instance Mergeable NmcDom where
+        merge sub dom = dom     { domService =     mergelm domService
+                                , domIp =          mergelm domIp
+                                , domIp6 =         mergelm domIp6
+                                , domTor =         choose  domTor
+                                , domI2p =         mergelm domI2p
+                                , domFreenet =     choose  domFreenet
+                                , domAlias =       choose  domAlias
+                                , domTranslate =   choose  domTranslate
+                                , domEmail =       choose  domEmail
+                                , domLoc =         choose  domLoc
+                                , domInfo =        mergelm domInfo
+                                , domNs =          mergelm domNs
+                                , domDelegate =    mergelm domDelegate
+                                , domImport =      mergelm domImport
+                                , domMap =         mergelm domMap
+                                , domFingerprint = mergelm domFingerprint
+                                , domTls =         mergelm domTls
+                                , domDs =          mergelm domDs
+                                , domMx =          mergelm domMx
+                                , domSrv =         mergelm domSrv
+                                }
+          where
+                mergelm x = merge (x sub) (x dom)
+-- Because it is not possible to define instance of merge for Strings,
+-- we have to treat string elements separately, otherwise strings are
+-- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
+                choose field = case field dom of
+                        Nothing -> field sub
+                        Just x  -> Just x
+
+mergeNmcDom :: NmcDom -> NmcDom -> NmcDom
+mergeNmcDom = merge
+
 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
                      Nothing Nothing Nothing Nothing Nothing Nothing
                      Nothing Nothing Nothing Nothing Nothing Nothing
-
--- FIXME -- I hope there exists a better way to merge records!
-mergeNmcDom :: NmcDom -> NmcDom -> NmcDom
-mergeNmcDom sub dom = dom  { domService = choose domService
-                        , domIp =          choose domIp
-                        , domIp6 =         choose domIp6
-                        , domTor =         choose domTor
-                        , domI2p =         choose domI2p
-                        , domFreenet =     choose domFreenet
-                        , domAlias =       choose domAlias
-                        , domTranslate =   choose domTranslate
-                        , domEmail =       choose domEmail
-                        , domLoc =         choose domLoc
-                        , domInfo =        choose domInfo
-                        , domNs =          choose domNs
-                        , domDelegate =    choose domDelegate
-                        , domImport =      choose domImport
-                        , domMap =         choose domMap
-                        , domFingerprint = choose domFingerprint
-                        , domTls =         choose domTls
-                        , domDs =          choose domDs
-                        }
-  where
-    choose :: (NmcDom -> Maybe a) -> Maybe a
-    choose field = case field dom of
-      Nothing -> field sub
-      Just x  -> Just x
-
--- | Perform query and return error string or parsed domain object
-queryNmcDom ::
-  (String -> IO (Either String ByteString)) -- ^ query operation action
-  -> String                                 -- ^ key
-  -> IO (Either String NmcDom)              -- ^ error string or domain
-queryNmcDom queryOp key = do
-  l <- queryOp key
-  case l of
-    Left estr -> return $ Left estr
-    Right str -> case decode str :: Maybe NmcDom of
-      Nothing  -> return $ Left $ "Unparseable value: " ++ (show str)
-      Just dom -> return $ Right dom
-
--- | Try to fetch "import" object and merge it into the base domain
---   Original "import" element is removed, but new imports from the
---   imported objects are processed recursively until there are none.
-mergeImport ::
-  (String -> IO (Either String ByteString)) -- ^ query operation action
-  -> NmcDom                                 -- ^ base domain
-  -> IO (Either String NmcDom)              -- ^ result with merged import
-mergeImport queryOp base = do
-  let
-    mbase = mergeSelf base
-    base' = mbase {domImport = Nothing}
-  -- print base
-  case domImport mbase of
-    Nothing  -> return $ Right base'
-    Just key -> do
-      sub <- queryNmcDom queryOp key
-      case sub of
-        Left  e    -> return $ Left e
-        Right sub' -> mergeImport queryOp $ sub' `mergeNmcDom` base'
-
--- | If there is an element in the map with key "", merge the contents
---   and remove this element. Do this recursively.
-mergeSelf :: NmcDom -> NmcDom
-mergeSelf base =
-  let
-    nbase = normalizeDom base
-    map   = domMap nbase
-    base' = nbase {domMap = removeSelf map}
-    removeSelf (Nothing)  = Nothing
-    removeSelf (Just map) = if size map' == 0 then Nothing else Just map'
-      where map' = M.delete "" map
-  in
-    case map of
-      Nothing   -> base'
-      Just map' ->
-        case M.lookup "" map' of
-          Nothing  -> base'
-          Just sub -> (mergeSelf sub) `mergeNmcDom` base'
-
--- | Presence of some elements require removal of some others
-normalizeDom :: NmcDom -> NmcDom
-normalizeDom dom
-  | domNs        dom /= Nothing = emptyNmcDom { domNs    = domNs dom
-                                              , domEmail = domEmail dom
-                                              }
-  | domDelegate  dom /= Nothing = emptyNmcDom -- FIXME
-  | domTranslate dom /= Nothing = dom { domMap = Nothing }
-  | otherwise                   = dom
-
--- | Merge imports and Selfs and follow the maps tree to get dom
-descendNmcDom ::
-  (String -> IO (Either String ByteString)) -- ^ query operation action
-  -> [String]                               -- ^ subdomain chain
-  -> NmcDom                                 -- ^ base domain
-  -> IO (Either String NmcDom)              -- ^ fully processed result
-descendNmcDom queryOp subdom base = do
-  base' <- mergeImport queryOp base
-  case subdom of
-    []   -> return base'
-    d:ds ->
-      case base' of
-        Left err     -> return base'
-        Right base'' ->
-          case domMap base'' of
-            Nothing  -> return $ Right emptyNmcDom
-            Just map ->
-              case M.lookup d map of
-                Nothing  -> return $ Right emptyNmcDom
-                Just sub -> descendNmcDom queryOp ds sub
-
--- | Initial NmcDom populated with "import" only, suitable for "descend"
-seedNmcDom ::
-  String        -- ^ domain key (without namespace prefix)
-  -> NmcDom     -- ^ resulting seed domain
-seedNmcDom dn = emptyNmcDom { domImport = Just ("d/" ++ dn)}
+                     Nothing Nothing