db600304df2a38a55bef100676ee969712bb26fe
[pdns-pipe-nmc.git] / NmcDom.hs
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module NmcDom   ( NmcDom(..)
4                 , NmcRRSrv(..)
5                 , NmcRRI2p(..)
6                 , NmcRRTlsa(..)
7                 , NmcRRDs(..)
8                 , merge
9                 ) where
10
11 import Prelude hiding (length)
12 import Control.Applicative ((<$>), (<*>), empty, pure)
13 import Data.Char
14 import Data.Text (Text, unpack)
15 import Data.List (union)
16 import Data.List.Split
17 import Data.Vector ((!), length)
18 import qualified Data.Vector as V (singleton)
19 import Data.Map (Map, unionWith)
20 import qualified Data.Map as M (singleton, empty)
21 import qualified Data.HashMap.Strict as H (lookup)
22 import Data.Aeson
23 import Data.Aeson.Types
24 import Data.Default.Class
25
26 -- Variant of Aeson's `.:?` that interprets a String as a
27 -- single-element list, so it is possible to have either
28 --      "ip":["1.2.3.4"]
29 -- or
30 --      "ip":"1.2.3.4"
31 -- with the same result.
32 (.:/) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
33 obj .:/ key = case H.lookup key obj of
34                Nothing -> pure Nothing
35                Just v  -> case v of
36                         String s -> parseJSON $ Array (V.singleton v)
37                         _        -> parseJSON v
38
39 data IntRRService = IntRRService { isvName       :: String
40                                  , isvProto      :: String
41                                  , isvPrio       :: Int
42                                  , isvWeight     :: Int
43                                  , isvPort       :: Int
44                                  , isvHost       :: String
45                                  } deriving (Show, Eq)
46
47 instance FromJSON IntRRService where
48         parseJSON (Array a) =
49                 if length a == 6 then IntRRService
50                         <$> parseJSON (a ! 0)
51                         <*> parseJSON (a ! 1)
52                         <*> parseJSON (a ! 2)
53                         <*> parseJSON (a ! 3)
54                         <*> parseJSON (a ! 4)
55                         <*> parseJSON (a ! 5)
56                 else empty
57         parseJSON _ = empty
58
59 makeMx :: Object -> Parser (Maybe [String])
60 makeMx o =
61   case H.lookup "service" o of
62     Nothing          -> pure Nothing
63     Just (Array a) -> do
64       isvl <- parseJSON (Array a)
65       return $ Just $ map mxStr $ filter mxMatch isvl
66         where
67           mxMatch isv = isvName isv  == "smtp"
68                      && isvProto isv == "tcp"
69                      && isvPort isv  == 25
70           mxStr isv = (show (isvPrio isv)) ++ "\t" ++ (isvHost isv)
71     Just _ -> empty
72
73 makeSubmap :: Object -> Parser (Maybe (Map String NmcDom))
74 makeSubmap o = ((.).(.)) merge merge <$> takeTls o <*> takeSrv o <*> takeMap o
75
76 takeMap :: Object -> Parser (Maybe (Map String NmcDom))
77 takeMap o = o .:? "map"
78
79 takeSrv :: Object -> Parser (Maybe (Map String NmcDom))
80 takeSrv o =
81   case H.lookup "service" o of
82     Nothing          -> pure Nothing
83     Just (Array a) -> do
84       isvl <- parseJSON (Array a)
85       return $ foldr addSrv (Just M.empty) isvl
86         where
87           addSrv isv acc = subm `merge` acc
88             where
89               subm = Just (M.singleton ("_" ++ isvProto isv) sub2)
90               sub2 = def { domSubmap =
91                              Just (M.singleton ("_" ++ isvName isv) sub3) }
92               sub3 = def { domSrv = Just [ NmcRRSrv (isvPrio isv)
93                                                     (isvWeight isv)
94                                                     (isvPort isv)
95                                                     (isvHost isv) ] }
96     Just _ -> empty
97
98 -- takeTls is almost, but not quite, entirely unlike takeSrv
99 takeTls :: Object -> Parser (Maybe (Map String NmcDom))
100 takeTls o = o .:? "map" -- FIXME
101
102 class Mergeable a where
103         merge :: a -> a -> a -- bias towads second arg
104
105 instance (Ord k, Mergeable a) => Mergeable (Map k a) where
106         merge mx my = unionWith merge my mx
107
108 -- Alas, the following is not possible in Haskell :-(
109 -- instance Mergeable String where
110 --         merge _ b = b
111
112 instance Mergeable Value where
113         merge _ b = b
114
115 instance Mergeable a => Mergeable (Maybe a) where
116         merge (Just x) (Just y) = Just (merge x y)
117         merge Nothing  (Just y) = Just y
118         merge (Just x) Nothing  = Just x
119         merge Nothing  Nothing  = Nothing
120
121 instance Eq a => Mergeable [a] where
122         merge xs ys = union xs ys
123
124 data NmcRRSrv = NmcRRSrv
125                         { srvPrio       :: Int
126                         , srvWeight     :: Int
127                         , srvPort       :: Int
128                         , srvHost       :: String
129                         } deriving (Show, Eq)
130
131 instance Mergeable NmcRRSrv where
132         merge _ b = b
133
134 data NmcRRI2p = NmcRRI2p
135                         { i2pDestination :: Maybe String
136                         , i2pName        :: Maybe String
137                         , i2pB32         :: Maybe String
138                         } deriving (Show, Eq)
139
140 instance FromJSON NmcRRI2p where
141         parseJSON (Object o) = NmcRRI2p
142                 <$> o .:? "destination"
143                 <*> o .:? "name"
144                 <*> o .:? "b32"
145         parseJSON _ = empty
146
147 instance Mergeable NmcRRI2p where
148         merge _ b = b
149
150 data NmcRRTlsa = NmcRRTlsa
151                         { tlsMatchType  :: Int -- 0:exact 1:sha256 2:sha512
152                         , tlsMatchValue :: String
153                         , tlsIncSubdoms :: Int -- 1:enforce on subdoms 0:no
154                         } deriving (Show, Eq)
155
156 instance Mergeable NmcRRTlsa where
157         merge _ b = b
158
159 data NmcRRDs = NmcRRDs
160                         { dsKeyTag      :: Int
161                         , dsAlgo        :: Int
162                         , dsHashType    :: Int
163                         , dsHashValue   :: String
164                         } deriving (Show, Eq)
165
166 instance FromJSON NmcRRDs where
167         parseJSON (Array a) =
168                 if length a == 4 then NmcRRDs
169                         <$> parseJSON (a ! 0)
170                         <*> parseJSON (a ! 1)
171                         <*> parseJSON (a ! 2)
172                         <*> parseJSON (a ! 3)
173                 else empty
174         parseJSON _ = empty
175
176 instance Mergeable NmcRRDs where
177         merge _ b = b
178
179 data NmcDom = NmcDom    { domIp          :: Maybe [String]
180                         , domIp6         :: Maybe [String]
181                         , domTor         :: Maybe String
182                         , domI2p         :: Maybe NmcRRI2p
183                         , domFreenet     :: Maybe String
184                         , domAlias       :: Maybe String
185                         , domTranslate   :: Maybe String
186                         , domEmail       :: Maybe String
187                         , domLoc         :: Maybe String
188                         , domInfo        :: Maybe Value
189                         , domNs          :: Maybe [String]
190                         , domDelegate    :: Maybe String
191                         , domImport      :: Maybe [String]
192                         , domSubmap      :: Maybe (Map String NmcDom)
193                         , domFingerprint :: Maybe [String]
194                         , domDs          :: Maybe [NmcRRDs]
195                         , domMx          :: Maybe [String]    -- Synthetic
196                         , domSrv         :: Maybe [NmcRRSrv]  -- Synthetic
197                         , domTlsa        :: Maybe [NmcRRTlsa] -- Synthetic
198                         } deriving (Show, Eq)
199
200 instance Default NmcDom where
201   def = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing
202                Nothing Nothing Nothing Nothing Nothing Nothing Nothing
203                Nothing Nothing Nothing Nothing Nothing
204
205 instance FromJSON NmcDom where
206         -- Wherever we expect a domain object, there may be a string
207         -- containing IPv4 address. Interpret it as such.
208         -- Question: shall we try to recognize IPv6 addresses too?
209         parseJSON (String s) =
210                  return $ if isIPv4 s'
211                             then def { domIp = Just [s'] }
212                             else def
213                           where
214                             s' = unpack s
215                             isIPv4 x = all isNibble $ splitOn "." x
216                             isNibble x =
217                               if all isDigit x then (read x :: Int) < 256
218                               else False
219         parseJSON (Object o) = NmcDom
220                 <$> o .:/ "ip"
221                 <*> o .:/ "ip6"
222                 <*> o .:? "tor"
223                 <*> o .:? "i2p"
224                 <*> o .:? "freenet"
225                 <*> o .:? "alias"
226                 <*> o .:? "translate"
227                 <*> o .:? "email"
228                 <*> o .:? "loc"
229                 <*> o .:? "info"
230                 <*> o .:/ "ns"
231                 <*> o .:? "delegate"
232                 <*> o .:/ "import"
233                 <*> makeSubmap o
234                 <*> o .:/ "fingerprint"
235                 <*> o .:? "ds"
236                 <*> makeMx o
237                 <*> return Nothing -- domSrv created in subdomains
238                 <*> return Nothing -- domTlsa created in subdomains
239         parseJSON _ = empty
240
241 instance Mergeable NmcDom where
242         merge sub dom = dom     { domIp =          mergelm domIp
243                                 , domIp6 =         mergelm domIp6
244                                 , domTor =         choose  domTor
245                                 , domI2p =         mergelm domI2p
246                                 , domFreenet =     choose  domFreenet
247                                 , domAlias =       choose  domAlias
248                                 , domTranslate =   choose  domTranslate
249                                 , domEmail =       choose  domEmail
250                                 , domLoc =         choose  domLoc
251                                 , domInfo =        mergelm domInfo
252                                 , domNs =          mergelm domNs
253                                 , domDelegate =    mergelm domDelegate
254                                 , domImport =      mergelm domImport
255                                 , domSubmap =      mergelm domSubmap
256                                 , domFingerprint = mergelm domFingerprint
257                                 , domDs =          mergelm domDs
258                                 , domMx =          mergelm domMx
259                                 , domSrv =         mergelm domSrv
260                                 , domTlsa =        mergelm domTlsa
261                                 }
262           where
263                 mergelm x = merge (x sub) (x dom)
264 -- Because it is not possible to define instance of merge for Strings,
265 -- we have to treat string elements separately, otherwise strings are
266 -- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
267                 choose field = case field dom of
268                         Nothing -> field sub
269                         Just x  -> Just x