1 {-# LANGUAGE OverloadedStrings #-}
3 module NmcDom ( NmcDom(..)
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
16 import Data.Map as M (Map, lookup, delete, size, union)
17 import Data.Vector (toList,(!),length)
18 import Control.Applicative ((<$>), (<*>), empty)
21 class Mergeable a where
22 merge :: a -> a -> a -- bias towads second arg
24 instance Ord k => Mergeable (Map k a) where
25 merge mx my = M.union my mx
27 -- instance Mergeable String where
30 instance Mergeable Value where
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
39 instance Eq a => Mergeable [a] where
40 merge xs ys = L.union xs ys
42 data NmcRRService = NmcRRService
51 instance FromJSON NmcRRService where
53 if length a == 6 then NmcRRService
63 instance Mergeable NmcRRService where
66 data NmcRRI2p = NmcRRI2p
67 { i2pDestination :: String
72 instance FromJSON NmcRRI2p where
73 parseJSON (Object o) = NmcRRI2p
74 <$> o .: "destination"
79 instance Mergeable NmcRRI2p where
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)
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'] }
114 isIPv4 x = all isNibble $ splitOn "." x
116 if all isDigit x then (read x :: Int) < 256
118 parseJSON (Object o) = NmcDom
126 <*> o .:? "translate"
134 <*> o .:? "fingerprint"
137 <*> return Nothing -- domMx not parsed
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
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
171 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
172 Nothing Nothing Nothing Nothing Nothing Nothing
173 Nothing Nothing Nothing Nothing Nothing Nothing
176 -- | Perform query and return error string or parsed domain object
178 (String -> IO (Either String ByteString)) -- ^ query operation action
180 -> IO (Either String NmcDom) -- ^ error string or domain
181 queryNmcDom queryOp key = do
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
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.
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
199 mbase = mergeSelf base
200 base' = mbase {domImport = Nothing}
202 if depth <= 0 then return $ Left "Nesting of imports is too deep"
203 else case domImport mbase of
204 Nothing -> return $ Right base'
206 sub <- queryNmcDom queryOp key
208 Left e -> return $ Left e
209 Right sub' -> mergeImport queryOp (depth - 1) $ sub' `merge` base'
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
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
225 case M.lookup "" map' of
227 Just sub -> (mergeSelf sub) `merge` base'
228 -- recursion depth limited by the size of the record
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)}
235 needed r = srvName r == serv && srvProto r == proto
237 -- | Presence of some elements require removal of some others
238 normalizeDom :: NmcDom -> NmcDom
239 normalizeDom dom = foldr id dom [ srvNormalizer
240 , translateNormalizer
244 nsNormalizer dom = case domNs dom of
246 Just ns -> emptyNmcDom { domNs = domNs dom, domEmail = domEmail dom }
247 translateNormalizer dom = case domTranslate dom of
249 Just tr -> dom { domMap = Nothing }
250 srvNormalizer dom = dom { domService = Nothing, domMx = makemx }
252 makemx = case domService dom of
254 Just svl -> Just $ map makerec (filter needed svl)
256 needed sr = srvName sr == "smtp"
257 && srvProto sr == "tcp"
259 makerec sr = (show (srvPrio sr)) ++ " " ++ (srvHost sr)
261 -- | Merge imports and Selfs and follow the maps tree to get dom
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
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'
275 Left err -> return base'
277 case domMap base'' of
278 Nothing -> return $ Right emptyNmcDom
280 case M.lookup d map of
281 Nothing -> return $ Right emptyNmcDom
282 Just sub -> descendNmcDom queryOp ds sub
284 -- | Initial NmcDom populated with "import" only, suitable for "descend"
286 String -- ^ domain key (without namespace prefix)
287 -> NmcDom -- ^ resulting seed domain
288 seedNmcDom dn = emptyNmcDom { domImport = Just ("d/" ++ dn)}