1 {-# LANGUAGE OverloadedStrings #-}
3 module NmcDom ( NmcDom(..)
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
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)
22 import qualified Data.HashMap.Strict as H
23 import Data.Aeson.Types
25 -- Variant of Aeson's `.:?` that interprets a String as a
26 -- single-element list, so it is possible to have either
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
35 String s -> parseJSON $ Array (singleton v)
38 class Mergeable a where
39 merge :: a -> a -> a -- bias towads second arg
41 instance (Ord k, Mergeable a) => Mergeable (Map k a) where
42 merge mx my = M.unionWith merge my mx
44 -- Alas, the following is not possible in Haskell :-(
45 -- instance Mergeable String where
48 instance Mergeable Value where
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
57 instance Eq a => Mergeable [a] where
58 merge xs ys = L.union xs ys
60 data NmcRRService = NmcRRService
69 instance FromJSON NmcRRService where
71 if length a == 6 then NmcRRService
81 instance Mergeable NmcRRService where
84 data NmcRRI2p = NmcRRI2p
85 { i2pDestination :: String
90 instance FromJSON NmcRRI2p where
91 parseJSON (Object o) = NmcRRI2p
92 <$> o .: "destination"
97 instance Mergeable NmcRRI2p where
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)
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)
115 instance Mergeable NmcRRTls where
118 data NmcRRDs = NmcRRDs
122 , dsHashValue :: String
123 } deriving (Show, Eq)
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)
135 instance Mergeable NmcRRDs where
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)
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'] }
170 isIPv4 x = all isNibble $ splitOn "." x
172 if all isDigit x then (read x :: Int) < 256
174 parseJSON (Object o) = NmcDom
182 <*> o .:? "translate"
190 <*> o .:/ "fingerprint"
193 <*> return Nothing -- domMx not parsed
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
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
227 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
228 Nothing Nothing Nothing Nothing Nothing Nothing
229 Nothing Nothing Nothing Nothing Nothing Nothing
232 -- | Perform query and return error string or parsed domain object
234 (String -> IO (Either String ByteString)) -- ^ query operation action
236 -> IO (Either String NmcDom) -- ^ error string or domain
237 queryNmcDom queryOp key = do
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
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.
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
255 mbase = mergeSelf base
256 base' = mbase {domImport = Nothing}
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
263 mergeImport1 (Left err) _ = return $ Left err
264 mergeImport1 (Right acc) key = do
265 sub <- queryNmcDom queryOp key
267 Left err -> return $ Left err
268 Right sub' -> mergeImport queryOp (depth - 1) $ sub' `merge` acc
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
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
284 case M.lookup "" map' of
286 Just sub -> (mergeSelf sub) `merge` base'
287 -- recursion depth limited by the size of the record
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)}
294 needed r = srvName r == serv && srvProto r == proto
296 -- | Presence of some elements require removal of some others
297 normalizeDom :: NmcDom -> NmcDom
298 normalizeDom dom = foldr id dom [ srvNormalizer
299 , translateNormalizer
303 nsNormalizer dom = case domNs dom of
305 Just ns -> emptyNmcDom { domNs = domNs dom, domEmail = domEmail dom }
306 translateNormalizer dom = case domTranslate dom of
308 Just tr -> dom { domMap = Nothing }
309 srvNormalizer dom = dom { domService = Nothing, domMx = makemx }
311 makemx = case domService dom of
313 Just svl -> Just $ map makerec (filter needed svl)
315 needed sr = srvName sr == "smtp"
316 && srvProto sr == "tcp"
318 makerec sr = (show (srvPrio sr)) ++ " " ++ (srvHost sr)
320 -- | Merge imports and Selfs and follow the maps tree to get dom
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
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'
334 Left err -> return base'
336 case domMap base'' of
337 Nothing -> return $ Right emptyNmcDom
339 case M.lookup d map of
340 Nothing -> return $ Right emptyNmcDom
341 Just sub -> descendNmcDom queryOp ds sub
343 -- | Initial NmcDom populated with "import" only, suitable for "descend"
345 String -- ^ domain key (without namespace prefix)
346 -> NmcDom -- ^ resulting seed domain
347 seedNmcDom dn = emptyNmcDom { domImport = Just (["d/" ++ dn])}