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