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, union)
17 import Data.Vector (toList,(!),length, singleton)
18 import Control.Applicative ((<$>), (<*>), empty, pure)
21 import qualified Data.HashMap.Strict as H
22 import Data.Aeson.Types
24 -- Variant of Aeson's `.:?` that interprets a String as a
25 -- single-element list, so it is possible to have either
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
34 String s -> parseJSON $ Array (singleton v)
37 class Mergeable a where
38 merge :: a -> a -> a -- bias towads second arg
40 instance Ord k => Mergeable (Map k a) where
41 merge mx my = M.union my mx
43 -- instance Mergeable String where
46 instance Mergeable Value where
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
55 instance Eq a => Mergeable [a] where
56 merge xs ys = L.union xs ys
58 data NmcRRService = NmcRRService
67 instance FromJSON NmcRRService where
69 if length a == 6 then NmcRRService
79 instance Mergeable NmcRRService where
82 data NmcRRI2p = NmcRRI2p
83 { i2pDestination :: String
88 instance FromJSON NmcRRI2p where
89 parseJSON (Object o) = NmcRRI2p
90 <$> o .: "destination"
95 instance Mergeable NmcRRI2p where
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)
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'] }
130 isIPv4 x = all isNibble $ splitOn "." x
132 if all isDigit x then (read x :: Int) < 256
134 parseJSON (Object o) = NmcDom
142 <*> o .:? "translate"
150 <*> o .:/ "fingerprint"
153 <*> return Nothing -- domMx not parsed
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
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
187 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
188 Nothing Nothing Nothing Nothing Nothing Nothing
189 Nothing Nothing Nothing Nothing Nothing Nothing
192 -- | Perform query and return error string or parsed domain object
194 (String -> IO (Either String ByteString)) -- ^ query operation action
196 -> IO (Either String NmcDom) -- ^ error string or domain
197 queryNmcDom queryOp key = do
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
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.
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
215 mbase = mergeSelf base
216 base' = mbase {domImport = Nothing}
218 if depth <= 0 then return $ Left "Nesting of imports is too deep"
219 else case domImport mbase of
220 Nothing -> return $ Right base'
222 sub <- queryNmcDom queryOp key
224 Left e -> return $ Left e
225 Right sub' -> mergeImport queryOp (depth - 1) $ sub' `merge` base'
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
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
241 case M.lookup "" map' of
243 Just sub -> (mergeSelf sub) `merge` base'
244 -- recursion depth limited by the size of the record
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)}
251 needed r = srvName r == serv && srvProto r == proto
253 -- | Presence of some elements require removal of some others
254 normalizeDom :: NmcDom -> NmcDom
255 normalizeDom dom = foldr id dom [ srvNormalizer
256 , translateNormalizer
260 nsNormalizer dom = case domNs dom of
262 Just ns -> emptyNmcDom { domNs = domNs dom, domEmail = domEmail dom }
263 translateNormalizer dom = case domTranslate dom of
265 Just tr -> dom { domMap = Nothing }
266 srvNormalizer dom = dom { domService = Nothing, domMx = makemx }
268 makemx = case domService dom of
270 Just svl -> Just $ map makerec (filter needed svl)
272 needed sr = srvName sr == "smtp"
273 && srvProto sr == "tcp"
275 makerec sr = (show (srvPrio sr)) ++ " " ++ (srvHost sr)
277 -- | Merge imports and Selfs and follow the maps tree to get dom
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
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'
291 Left err -> return base'
293 case domMap base'' of
294 Nothing -> return $ Right emptyNmcDom
296 case M.lookup d map of
297 Nothing -> return $ Right emptyNmcDom
298 Just sub -> descendNmcDom queryOp ds sub
300 -- | Initial NmcDom populated with "import" only, suitable for "descend"
302 String -- ^ domain key (without namespace prefix)
303 -> NmcDom -- ^ resulting seed domain
304 seedNmcDom dn = emptyNmcDom { domImport = Just ("d/" ++ dn)}