e03f683bf2107166fe4bdca7ebfde45449f07888
[pdns-pipe-nmc.git] / NmcDom.hs
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module NmcDom   ( NmcDom(..)
4                 , NmcRRService(..)
5                 , emptyNmcDom
6                 , seedNmcDom
7                 , descendNmcDom
8                 ) where
9
10 import Prelude hiding (length)
11 import Data.ByteString.Lazy (ByteString)
12 import Data.Text (Text, unpack)
13 import Data.List as L (union)
14 import Data.List.Split
15 import Data.Char
16 import Data.Map as M (Map, lookup, delete, size, unionWith)
17 import Data.Vector (toList,(!),length, singleton)
18 import Control.Monad (foldM)
19 import Control.Applicative ((<$>), (<*>), empty, pure)
20 import Data.Aeson
21
22 import qualified Data.HashMap.Strict as H
23 import Data.Aeson.Types
24
25 -- Variant of Aeson's `.:?` that interprets a String as a
26 -- single-element list, so it is possible to have either
27 --      "ip":["1.2.3.4"]
28 -- or
29 --      "ip":"1.2.3.4"
30 -- with the same result.
31 (.:/) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
32 obj .:/ key = case H.lookup key obj of
33                Nothing -> pure Nothing
34                Just v  -> case v of
35                         String s -> parseJSON $ Array (singleton v)
36                         _        -> parseJSON v
37
38 class Mergeable a where
39         merge :: a -> a -> a -- bias towads second arg
40
41 instance (Ord k, Mergeable a) => Mergeable (Map k a) where
42         merge mx my = M.unionWith merge my mx
43
44 -- Alas, the following is not possible in Haskell :-(
45 -- instance Mergeable String where
46 --         merge _ b = b
47
48 instance Mergeable Value where
49         merge _ b = b
50
51 instance Mergeable a => Mergeable (Maybe a) where
52         merge (Just x) (Just y) = Just (merge x y)
53         merge Nothing  (Just y) = Just y
54         merge (Just x) Nothing  = Just x
55         merge Nothing  Nothing  = Nothing
56
57 instance Eq a => Mergeable [a] where
58         merge xs ys = L.union xs ys
59
60 data NmcRRService = NmcRRService
61                         { srvName       :: String
62                         , srvProto      :: String
63                         , srvPrio       :: Int
64                         , srvWeight     :: Int
65                         , srvPort       :: Int
66                         , srvHost       :: String
67                         } deriving (Show, Eq)
68
69 instance FromJSON NmcRRService where
70         parseJSON (Array a) =
71                 if length a == 6 then NmcRRService
72                         <$> parseJSON (a ! 0)
73                         <*> parseJSON (a ! 1)
74                         <*> parseJSON (a ! 2)
75                         <*> parseJSON (a ! 3)
76                         <*> parseJSON (a ! 4)
77                         <*> parseJSON (a ! 5)
78                 else empty
79         parseJSON _ = empty
80
81 instance Mergeable NmcRRService where
82         merge _ b = b
83
84 data NmcRRI2p = NmcRRI2p
85                         { i2pDestination :: String
86                         , i2pName        :: String
87                         , i2pB32         :: String
88                         } deriving (Show, Eq)
89
90 instance FromJSON NmcRRI2p where
91         parseJSON (Object o) = NmcRRI2p
92                 <$> o .: "destination"
93                 <*> o .: "name"
94                 <*> o .: "b32"
95         parseJSON _ = empty
96
97 instance Mergeable NmcRRI2p where
98         merge _ b = b
99
100 data NmcRRTls = NmcRRTls
101                         { tlsMatchType  :: Int -- 0:exact 1:sha256 2:sha512
102                         , tlsMatchValue :: String
103                         , tlsIncSubdoms :: Int -- 1:enforce on subdoms 0:no
104                         } deriving (Show, Eq)
105
106 instance FromJSON NmcRRTls where
107         parseJSON (Array a) =
108                 if length a == 3 then NmcRRTls
109                         <$> parseJSON (a ! 0)
110                         <*> parseJSON (a ! 1)
111                         <*> parseJSON (a ! 2)
112                 else empty
113         parseJSON _ = empty
114
115 instance Mergeable NmcRRTls where
116         merge _ b = b
117
118 data NmcRRDs = NmcRRDs
119                         { dsKeyTag      :: Int
120                         , dsAlgo        :: Int
121                         , dsHashType    :: Int
122                         , dsHashValue   :: String
123                         } deriving (Show, Eq)
124
125 instance FromJSON NmcRRDs where
126         parseJSON (Array a) =
127                 if length a == 4 then NmcRRDs
128                         <$> parseJSON (a ! 0)
129                         <*> parseJSON (a ! 1)
130                         <*> parseJSON (a ! 2)
131                         <*> parseJSON (a ! 3)
132                 else empty
133         parseJSON _ = empty
134
135 instance Mergeable NmcRRDs where
136         merge _ b = b
137
138 data NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]
139                         , domIp          :: Maybe [String]
140                         , domIp6         :: Maybe [String]
141                         , domTor         :: Maybe String
142                         , domI2p         :: Maybe NmcRRI2p
143                         , domFreenet     :: Maybe String
144                         , domAlias       :: Maybe String
145                         , domTranslate   :: Maybe String
146                         , domEmail       :: Maybe String
147                         , domLoc         :: Maybe String
148                         , domInfo        :: Maybe Value
149                         , domNs          :: Maybe [String]
150                         , domDelegate    :: Maybe String
151                         , domImport      :: Maybe [String]
152                         , domMap         :: Maybe (Map String NmcDom)
153                         , domFingerprint :: Maybe [String]
154                         , domTls         :: Maybe (Map String
155                                                     (Map String [NmcRRTls]))
156                         , domDs          :: Maybe [NmcRRDs]
157                         , domMx          :: Maybe [String] -- Synthetic
158                         } deriving (Show, Eq)
159
160 instance FromJSON NmcDom where
161         -- Wherever we expect a domain object, there may be a string
162         -- containing IPv4 address. Interpret it as such.
163         -- Question: shall we try to recognize IPv6 addresses too?
164         parseJSON (String s) =
165                  return $ if isIPv4 s'
166                             then emptyNmcDom { domIp = Just [s'] }
167                             else emptyNmcDom
168                           where
169                             s' = unpack s
170                             isIPv4 x = all isNibble $ splitOn "." x
171                             isNibble x =
172                               if all isDigit x then (read x :: Int) < 256
173                               else False
174         parseJSON (Object o) = NmcDom
175                 <$> o .:? "service"
176                 <*> o .:/ "ip"
177                 <*> o .:/ "ip6"
178                 <*> o .:? "tor"
179                 <*> o .:? "i2p"
180                 <*> o .:? "freenet"
181                 <*> o .:? "alias"
182                 <*> o .:? "translate"
183                 <*> o .:? "email"
184                 <*> o .:? "loc"
185                 <*> o .:? "info"
186                 <*> o .:/ "ns"
187                 <*> o .:? "delegate"
188                 <*> o .:/ "import"
189                 <*> o .:? "map"
190                 <*> o .:/ "fingerprint"
191                 <*> o .:? "tls"
192                 <*> o .:? "ds"
193                 <*> return Nothing -- domMx not parsed
194         parseJSON _ = empty
195
196 instance Mergeable NmcDom where
197         merge sub dom = dom     { domService =     mergelm domService
198                                 , domIp =          mergelm domIp
199                                 , domIp6 =         mergelm domIp6
200                                 , domTor =         choose  domTor
201                                 , domI2p =         mergelm domI2p
202                                 , domFreenet =     choose  domFreenet
203                                 , domAlias =       choose  domAlias
204                                 , domTranslate =   choose  domTranslate
205                                 , domEmail =       choose  domEmail
206                                 , domLoc =         choose  domLoc
207                                 , domInfo =        mergelm domInfo
208                                 , domNs =          mergelm domNs
209                                 , domDelegate =    mergelm domDelegate
210                                 , domImport =      mergelm domImport
211                                 , domMap =         mergelm domMap
212                                 , domFingerprint = mergelm domFingerprint
213                                 , domTls =         mergelm domTls
214                                 , domDs =          mergelm domDs
215                                 , domMx =          mergelm domMx
216                                 }
217           where
218                 mergelm x = merge (x sub) (x dom)
219 -- Because it is not possible to define instance of merge for Strings,
220 -- we have to treat string elements separately, otherwise strings are
221 -- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
222                 choose field = case field dom of
223                         Nothing -> field sub
224                         Just x  -> Just x
225
226
227 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
228                      Nothing Nothing Nothing Nothing Nothing Nothing
229                      Nothing Nothing Nothing Nothing Nothing Nothing
230                      Nothing
231
232 -- | Perform query and return error string or parsed domain object
233 queryNmcDom ::
234   (String -> IO (Either String ByteString)) -- ^ query operation action
235   -> String                                 -- ^ key
236   -> IO (Either String NmcDom)              -- ^ error string or domain
237 queryNmcDom queryOp key = do
238   l <- queryOp key
239   case l of
240     Left estr -> return $ Left estr
241     Right str -> case decode str :: Maybe NmcDom of
242       Nothing  -> return $ Left $ "Unparseable value: " ++ (show str)
243       Just dom -> return $ Right dom
244
245 -- | Try to fetch "import" object and merge it into the base domain
246 --   Original "import" element is removed, but new imports from the
247 --   imported objects are processed recursively until there are none.
248 mergeImport ::
249   (String -> IO (Either String ByteString)) -- ^ query operation action
250   -> Int                                    -- ^ recursion counter
251   -> NmcDom                                 -- ^ base domain
252   -> IO (Either String NmcDom)              -- ^ result with merged import
253 mergeImport queryOp depth base = do
254   let
255     mbase = mergeSelf base
256     base' = mbase {domImport = Nothing}
257   -- print base
258   if depth <= 0 then return $ Left "Nesting of imports is too deep"
259   else case domImport mbase of
260     Nothing  -> return $ Right base'
261     Just keys -> foldM mergeImport1 (Right base') keys
262       where
263         mergeImport1 (Left  err) _   = return $ Left err
264         mergeImport1 (Right acc) key = do
265           sub <- queryNmcDom queryOp key
266           case sub of
267             Left  err  -> return $ Left err
268             Right sub' -> mergeImport queryOp (depth - 1) $ sub' `merge` acc
269
270 -- | If there is an element in the map with key "", merge the contents
271 --   and remove this element. Do this recursively.
272 mergeSelf :: NmcDom -> NmcDom
273 mergeSelf base =
274   let
275     map   = domMap base
276     base' = base {domMap = removeSelf map}
277     removeSelf Nothing    = Nothing
278     removeSelf (Just map) = if size map' == 0 then Nothing else Just map'
279       where map' = M.delete "" map
280   in
281     case map of
282       Nothing   -> base'
283       Just map' ->
284         case M.lookup "" map' of
285           Nothing  -> base'
286           Just sub -> (mergeSelf sub) `merge` base'
287         -- recursion depth limited by the size of the record
288
289 -- | SRV case - remove everyting and filter SRV records
290 normalizeSrv :: String -> String -> NmcDom -> NmcDom
291 normalizeSrv serv proto dom =
292   emptyNmcDom {domService = fmap (filter needed) (domService dom)}
293     where
294       needed r = srvName r == serv && srvProto r == proto
295
296 -- | Presence of some elements require removal of some others
297 normalizeDom :: NmcDom -> NmcDom
298 normalizeDom dom = foldr id dom [ srvNormalizer
299                                 , translateNormalizer
300                                 , nsNormalizer
301                                 ]
302   where
303     nsNormalizer dom = case domNs dom of
304       Nothing  -> dom
305       Just ns  -> emptyNmcDom { domNs = domNs dom, domEmail = domEmail dom }
306     translateNormalizer dom = case domTranslate dom of
307       Nothing  -> dom
308       Just tr  -> dom { domMap = Nothing }
309     srvNormalizer dom = dom { domService = Nothing, domMx = makemx }
310       where
311         makemx = case domService dom of
312           Nothing  -> Nothing
313           Just svl -> Just $ map makerec (filter needed svl)
314             where
315               needed sr = srvName sr == "smtp"
316                         && srvProto sr == "tcp"
317                         && srvPort sr == 25
318               makerec sr = (show (srvPrio sr)) ++ " " ++ (srvHost sr)
319
320 -- | Merge imports and Selfs and follow the maps tree to get dom
321 descendNmcDom ::
322   (String -> IO (Either String ByteString)) -- ^ query operation action
323   -> [String]                               -- ^ subdomain chain
324   -> NmcDom                                 -- ^ base domain
325   -> IO (Either String NmcDom)              -- ^ fully processed result
326 descendNmcDom queryOp subdom base = do
327   base' <- mergeImport queryOp 10 base
328   case subdom of
329     []   -> return $ fmap normalizeDom base'
330     -- A hack to handle SRV records: don't descend if ["_prot","_serv"]
331     [('_':p),('_':s)] -> return $ fmap (normalizeSrv s p) base'
332     d:ds ->
333       case base' of
334         Left err     -> return base'
335         Right base'' ->
336           case domMap base'' of
337             Nothing  -> return $ Right emptyNmcDom
338             Just map ->
339               case M.lookup d map of
340                 Nothing  -> return $ Right emptyNmcDom
341                 Just sub -> descendNmcDom queryOp ds sub
342
343 -- | Initial NmcDom populated with "import" only, suitable for "descend"
344 seedNmcDom ::
345   String        -- ^ domain key (without namespace prefix)
346   -> NmcDom     -- ^ resulting seed domain
347 seedNmcDom dn = emptyNmcDom { domImport = Just (["d/" ++ dn])}