use liftA2 to merge parsers
[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 ((<$>), (<*>), liftA2, 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, foldrWithKey)
20 import qualified Data.Map as M (singleton, empty, insert, insertWith)
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 = takeTls o `fmerge` takeSrv o `fmerge` takeMap o
75   where fmerge = liftA2 merge
76
77 takeMap :: Object -> Parser (Maybe (Map String NmcDom))
78 takeMap o =
79   case H.lookup "map" o of
80     Nothing          -> pure Nothing
81     Just (Object mo) -> do
82       raw <- (parseJSON (Object mo) :: Parser (Maybe (Map String NmcDom)))
83       let result = fmap splitup raw
84       return result
85         where
86           splitup :: Map String NmcDom -> Map String NmcDom
87           splitup x = foldrWithKey stow M.empty x
88           stow fqdn sdom acc = M.insertWith merge fqdn' sdom' acc
89             where
90               (fqdn', sdom') = nest (filter (/= "") (splitOnDots fqdn), sdom)
91               splitOnDots s  = splitOn "." s
92               nest ([], v)   = (fqdn, v) -- preserve "self" map entry
93               nest ([k], v)  = (k, v)
94               nest (k:ks, v) =
95                 nest (ks, def { domSubmap = Just (M.singleton k v) })
96     _ -> empty
97
98 takeSrv :: Object -> Parser (Maybe (Map String NmcDom))
99 takeSrv o =
100   case H.lookup "service" o of
101     Nothing          -> pure Nothing
102     Just (Array a) -> do
103       isvl <- parseJSON (Array a)
104       return $ foldr addSrv (Just M.empty) isvl
105         where
106           addSrv isv acc = subm `merge` acc
107             where
108               subm = Just (M.singleton ("_" ++ isvProto isv) sub2)
109               sub2 = def { domSubmap =
110                              Just (M.singleton ("_" ++ isvName isv) sub3) }
111               sub3 = def { domSrv = Just [ NmcRRSrv (isvPrio isv)
112                                                     (isvWeight isv)
113                                                     (isvPort isv)
114                                                     (isvHost isv) ] }
115     Just _ -> empty
116
117 -- takeTls is almost, but not quite, entirely unlike takeSrv
118 takeTls :: Object -> Parser (Maybe (Map String NmcDom))
119 takeTls o =
120   case H.lookup "tls" o of
121     Nothing         -> pure Nothing
122     Just (Object t) ->
123       (parseJSON (Object t) :: Parser (Map String (Map String [NmcRRTlsa])))
124         >>= tmap2dmap
125           where
126             tmap2dmap :: Map String (Map String [NmcRRTlsa])
127                       -> Parser (Maybe (Map String NmcDom))
128                 -- FIXME return parse error on invalid proto or port
129             tmap2dmap m1 = return $ foldrWithKey addprotoelem (Just M.empty) m1
130             addprotoelem k1 m2 acc = protoelem k1 m2 `merge` acc
131             protoelem k1 m2 = Just (M.singleton ("_" ++ k1) (pmap2dmap m2))
132             pmap2dmap m2 = foldrWithKey addportelem def m2
133             addportelem k2 v acc = portelem k2 v `merge` acc
134             portelem k2 v =
135               def { domSubmap = Just (M.singleton ("_" ++ k2)
136                                       def { domTlsa = Just v }) }
137     Just _ -> empty
138
139 class Mergeable a where
140         merge :: a -> a -> a -- bias towads second arg
141
142 instance (Ord k, Mergeable a) => Mergeable (Map k a) where
143         merge mx my = unionWith merge my mx
144
145 -- Alas, the following is not possible in Haskell :-(
146 -- instance Mergeable String where
147 --         merge _ b = b
148
149 instance Mergeable Value where
150         merge _ b = b
151
152 instance Mergeable a => Mergeable (Maybe a) where
153         merge (Just x) (Just y) = Just (merge x y)
154         merge Nothing  (Just y) = Just y
155         merge (Just x) Nothing  = Just x
156         merge Nothing  Nothing  = Nothing
157
158 instance Eq a => Mergeable [a] where
159         merge xs ys = union xs ys
160
161 data NmcRRSrv = NmcRRSrv
162                         { srvPrio       :: Int
163                         , srvWeight     :: Int
164                         , srvPort       :: Int
165                         , srvHost       :: String
166                         } deriving (Show, Eq)
167
168 instance Mergeable NmcRRSrv where
169         merge _ b = b
170
171 data NmcRRI2p = NmcRRI2p
172                         { i2pDestination :: Maybe String
173                         , i2pName        :: Maybe String
174                         , i2pB32         :: Maybe String
175                         } deriving (Show, Eq)
176
177 instance FromJSON NmcRRI2p where
178         parseJSON (Object o) = NmcRRI2p
179                 <$> o .:? "destination"
180                 <*> o .:? "name"
181                 <*> o .:? "b32"
182         parseJSON _ = empty
183
184 instance Mergeable NmcRRI2p where
185         merge _ b = b
186
187 data NmcRRTlsa = NmcRRTlsa
188                         { tlsMatchType  :: Int -- 0:exact 1:sha256 2:sha512
189                         , tlsMatchValue :: String
190                         , tlsIncSubdoms :: Int -- 1:enforce on subdoms 0:no
191                         } deriving (Show, Eq)
192
193 instance FromJSON NmcRRTlsa where
194         parseJSON (Array a) =
195                 if length a == 3 then NmcRRTlsa
196                         <$> parseJSON (a ! 0)
197                         <*> parseJSON (a ! 1)
198                         <*> parseJSON (a ! 2)
199                 else empty
200         parseJSON _ = empty
201
202 instance Mergeable NmcRRTlsa where
203         merge _ b = b
204
205 data NmcRRDs = NmcRRDs
206                         { dsKeyTag      :: Int
207                         , dsAlgo        :: Int
208                         , dsHashType    :: Int
209                         , dsHashValue   :: String
210                         } deriving (Show, Eq)
211
212 instance FromJSON NmcRRDs where
213         parseJSON (Array a) =
214                 if length a == 4 then NmcRRDs
215                         <$> parseJSON (a ! 0)
216                         <*> parseJSON (a ! 1)
217                         <*> parseJSON (a ! 2)
218                         <*> parseJSON (a ! 3)
219                 else empty
220         parseJSON _ = empty
221
222 instance Mergeable NmcRRDs where
223         merge _ b = b
224
225 data NmcDom = NmcDom    { domIp          :: Maybe [String]
226                         , domIp6         :: Maybe [String]
227                         , domTor         :: Maybe String
228                         , domI2p         :: Maybe NmcRRI2p
229                         , domFreenet     :: Maybe String
230                         , domAlias       :: Maybe String
231                         , domTranslate   :: Maybe String
232                         , domEmail       :: Maybe String
233                         , domLoc         :: Maybe String
234                         , domInfo        :: Maybe Value
235                         , domNs          :: Maybe [String]
236                         , domDelegate    :: Maybe String
237                         , domImport      :: Maybe [String]
238                         , domSubmap      :: Maybe (Map String NmcDom)
239                         , domFingerprint :: Maybe [String]
240                         , domDs          :: Maybe [NmcRRDs]
241                         , domMx          :: Maybe [String]    -- Synthetic
242                         , domSrv         :: Maybe [NmcRRSrv]  -- Synthetic
243                         , domTlsa        :: Maybe [NmcRRTlsa] -- Synthetic
244                         } deriving (Show, Eq)
245
246 instance Default NmcDom where
247   def = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing
248                Nothing Nothing Nothing Nothing Nothing Nothing Nothing
249                Nothing Nothing Nothing Nothing Nothing
250
251 instance FromJSON NmcDom where
252         -- Wherever we expect a domain object, there may be a string
253         -- containing IPv4 address. Interpret it as such.
254         -- Question: shall we try to recognize IPv6 addresses too?
255         parseJSON (String s) =
256                  return $ if isIPv4 s'
257                             then def { domIp = Just [s'] }
258                             else def
259                           where
260                             s' = unpack s
261                             isIPv4 x = all isNibble $ splitOn "." x
262                             isNibble x =
263                               if all isDigit x then (read x :: Int) < 256
264                               else False
265         parseJSON (Object o) = NmcDom
266                 <$> o .:/ "ip"
267                 <*> o .:/ "ip6"
268                 <*> o .:? "tor"
269                 <*> o .:? "i2p"
270                 <*> o .:? "freenet"
271                 <*> o .:? "alias"
272                 <*> o .:? "translate"
273                 <*> o .:? "email"
274                 <*> o .:? "loc"
275                 <*> o .:? "info"
276                 <*> o .:/ "ns"
277                 <*> o .:? "delegate"
278                 <*> o .:/ "import"
279                 <*> makeSubmap o
280                 <*> o .:/ "fingerprint"
281                 <*> o .:? "ds"
282                 <*> makeMx o
283                 <*> return Nothing -- domSrv created in subdomains
284                 <*> return Nothing -- domTlsa created in subdomains
285         parseJSON _ = empty
286
287 instance Mergeable NmcDom where
288         merge sub dom = dom     { domIp =          mergelm domIp
289                                 , domIp6 =         mergelm domIp6
290                                 , domTor =         choose  domTor
291                                 , domI2p =         mergelm domI2p
292                                 , domFreenet =     choose  domFreenet
293                                 , domAlias =       choose  domAlias
294                                 , domTranslate =   choose  domTranslate
295                                 , domEmail =       choose  domEmail
296                                 , domLoc =         choose  domLoc
297                                 , domInfo =        mergelm domInfo
298                                 , domNs =          mergelm domNs
299                                 , domDelegate =    mergelm domDelegate
300                                 , domImport =      mergelm domImport
301                                 , domSubmap =      mergelm domSubmap
302                                 , domFingerprint = mergelm domFingerprint
303                                 , domDs =          mergelm domDs
304                                 , domMx =          mergelm domMx
305                                 , domSrv =         mergelm domSrv
306                                 , domTlsa =        mergelm domTlsa
307                                 }
308           where
309                 mergelm x = merge (x sub) (x dom)
310 -- Because it is not possible to define instance of merge for Strings,
311 -- we have to treat string elements separately, otherwise strings are
312 -- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
313                 choose field = case field dom of
314                         Nothing -> field sub
315                         Just x  -> Just x