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