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