1 {-# LANGUAGE OverloadedStrings #-}
3 module NmcDom ( NmcDom(..)
11 import Prelude hiding (length)
12 import Control.Applicative ((<$>), (<*>), empty, pure)
14 import Data.Text (Text, unpack)
15 import Data.List (union)
16 import Data.List.Split
17 import Data.Vector ((!), length)
18 import qualified Data.Vector as V (singleton)
19 import Data.Map (Map, unionWith, foldrWithKey)
20 import qualified Data.Map as M (singleton, empty, insert, insertWith)
21 import qualified Data.HashMap.Strict as H (lookup)
23 import Data.Aeson.Types
24 import Data.Default.Class
26 -- Variant of Aeson's `.:?` that interprets a String as a
27 -- single-element list, so it is possible to have either
31 -- with the same result.
32 (.:/) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
33 obj .:/ key = case H.lookup key obj of
34 Nothing -> pure Nothing
36 String s -> parseJSON $ Array (V.singleton v)
39 data IntRRService = IntRRService { isvName :: String
47 instance FromJSON IntRRService where
49 if length a == 6 then IntRRService
59 makeMx :: Object -> Parser (Maybe [String])
61 case H.lookup "service" o of
62 Nothing -> pure Nothing
64 isvl <- parseJSON (Array a)
65 return $ Just $ map mxStr $ filter mxMatch isvl
67 mxMatch isv = isvName isv == "smtp"
68 && isvProto isv == "tcp"
70 mxStr isv = (show (isvPrio isv)) ++ "\t" ++ (isvHost isv)
73 makeSubmap :: Object -> Parser (Maybe (Map String NmcDom))
74 makeSubmap o = ((.).(.)) merge merge <$> takeTls o <*> takeSrv o <*> takeMap o
76 takeMap :: Object -> Parser (Maybe (Map String NmcDom))
78 case H.lookup "map" o of
79 Nothing -> pure Nothing
80 Just (Object mo) -> do
81 unsplit <- (parseJSON (Object mo) :: Parser (Maybe (Map String NmcDom)))
82 let result = fmap splitup unsplit
85 splitup :: Map String NmcDom -> Map String NmcDom
86 splitup x = foldrWithKey stow M.empty x
87 stow fqdn sdom acc = M.insertWith merge fqdn' sdom' acc
89 (fqdn', sdom') = nest (filter (/= "") (splitOnDots fqdn), sdom)
90 splitOnDots s = splitOn "." s
91 nest ([], v) = (fqdn, v) -- can split result be empty?
92 nest ([k], v) = (k, v)
94 nest (ks, def { domSubmap = Just (M.singleton k v) })
97 takeSrv :: Object -> Parser (Maybe (Map String NmcDom))
99 case H.lookup "service" o of
100 Nothing -> pure Nothing
102 isvl <- parseJSON (Array a)
103 return $ foldr addSrv (Just M.empty) isvl
105 addSrv isv acc = subm `merge` acc
107 subm = Just (M.singleton ("_" ++ isvProto isv) sub2)
108 sub2 = def { domSubmap =
109 Just (M.singleton ("_" ++ isvName isv) sub3) }
110 sub3 = def { domSrv = Just [ NmcRRSrv (isvPrio isv)
116 -- takeTls is almost, but not quite, entirely unlike takeSrv
117 takeTls :: Object -> Parser (Maybe (Map String NmcDom))
119 case H.lookup "tls" o of
120 Nothing -> pure Nothing
122 (parseJSON (Object t) :: Parser (Map String (Map String [NmcRRTlsa])))
125 tmap2dmap :: Map String (Map String [NmcRRTlsa])
126 -> Parser (Maybe (Map String NmcDom))
127 -- FIXME return parse error on invalid proto or port
128 tmap2dmap m1 = return $ foldrWithKey addprotoelem (Just M.empty) m1
129 addprotoelem k1 m2 acc = protoelem k1 m2 `merge` acc
130 protoelem k1 m2 = Just (M.singleton ("_" ++ k1) (pmap2dmap m2))
131 pmap2dmap m2 = foldrWithKey addportelem def m2
132 addportelem k2 v acc = portelem k2 v `merge` acc
134 def { domSubmap = Just (M.singleton ("_" ++ k2)
135 def { domTlsa = Just v }) }
138 class Mergeable a where
139 merge :: a -> a -> a -- bias towads second arg
141 instance (Ord k, Mergeable a) => Mergeable (Map k a) where
142 merge mx my = unionWith merge my mx
144 -- Alas, the following is not possible in Haskell :-(
145 -- instance Mergeable String where
148 instance Mergeable Value where
151 instance Mergeable a => Mergeable (Maybe a) where
152 merge (Just x) (Just y) = Just (merge x y)
153 merge Nothing (Just y) = Just y
154 merge (Just x) Nothing = Just x
155 merge Nothing Nothing = Nothing
157 instance Eq a => Mergeable [a] where
158 merge xs ys = union xs ys
160 data NmcRRSrv = NmcRRSrv
165 } deriving (Show, Eq)
167 instance Mergeable NmcRRSrv where
170 data NmcRRI2p = NmcRRI2p
171 { i2pDestination :: Maybe String
172 , i2pName :: Maybe String
173 , i2pB32 :: Maybe String
174 } deriving (Show, Eq)
176 instance FromJSON NmcRRI2p where
177 parseJSON (Object o) = NmcRRI2p
178 <$> o .:? "destination"
183 instance Mergeable NmcRRI2p where
186 data NmcRRTlsa = NmcRRTlsa
187 { tlsMatchType :: Int -- 0:exact 1:sha256 2:sha512
188 , tlsMatchValue :: String
189 , tlsIncSubdoms :: Int -- 1:enforce on subdoms 0:no
190 } deriving (Show, Eq)
192 instance FromJSON NmcRRTlsa where
193 parseJSON (Array a) =
194 if length a == 3 then NmcRRTlsa
195 <$> parseJSON (a ! 0)
196 <*> parseJSON (a ! 1)
197 <*> parseJSON (a ! 2)
201 instance Mergeable NmcRRTlsa where
204 data NmcRRDs = NmcRRDs
208 , dsHashValue :: String
209 } deriving (Show, Eq)
211 instance FromJSON NmcRRDs where
212 parseJSON (Array a) =
213 if length a == 4 then NmcRRDs
214 <$> parseJSON (a ! 0)
215 <*> parseJSON (a ! 1)
216 <*> parseJSON (a ! 2)
217 <*> parseJSON (a ! 3)
221 instance Mergeable NmcRRDs where
224 data NmcDom = NmcDom { domIp :: Maybe [String]
225 , domIp6 :: Maybe [String]
226 , domTor :: Maybe String
227 , domI2p :: Maybe NmcRRI2p
228 , domFreenet :: Maybe String
229 , domAlias :: Maybe String
230 , domTranslate :: Maybe String
231 , domEmail :: Maybe String
232 , domLoc :: Maybe String
233 , domInfo :: Maybe Value
234 , domNs :: Maybe [String]
235 , domDelegate :: Maybe String
236 , domImport :: Maybe [String]
237 , domSubmap :: Maybe (Map String NmcDom)
238 , domFingerprint :: Maybe [String]
239 , domDs :: Maybe [NmcRRDs]
240 , domMx :: Maybe [String] -- Synthetic
241 , domSrv :: Maybe [NmcRRSrv] -- Synthetic
242 , domTlsa :: Maybe [NmcRRTlsa] -- Synthetic
243 } deriving (Show, Eq)
245 instance Default NmcDom where
246 def = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing
247 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
248 Nothing Nothing Nothing Nothing Nothing
250 instance FromJSON NmcDom where
251 -- Wherever we expect a domain object, there may be a string
252 -- containing IPv4 address. Interpret it as such.
253 -- Question: shall we try to recognize IPv6 addresses too?
254 parseJSON (String s) =
255 return $ if isIPv4 s'
256 then def { domIp = Just [s'] }
260 isIPv4 x = all isNibble $ splitOn "." x
262 if all isDigit x then (read x :: Int) < 256
264 parseJSON (Object o) = NmcDom
271 <*> o .:? "translate"
279 <*> o .:/ "fingerprint"
282 <*> return Nothing -- domSrv created in subdomains
283 <*> return Nothing -- domTlsa created in subdomains
286 instance Mergeable NmcDom where
287 merge sub dom = dom { domIp = mergelm domIp
288 , domIp6 = mergelm domIp6
289 , domTor = choose domTor
290 , domI2p = mergelm domI2p
291 , domFreenet = choose domFreenet
292 , domAlias = choose domAlias
293 , domTranslate = choose domTranslate
294 , domEmail = choose domEmail
295 , domLoc = choose domLoc
296 , domInfo = mergelm domInfo
297 , domNs = mergelm domNs
298 , domDelegate = mergelm domDelegate
299 , domImport = mergelm domImport
300 , domSubmap = mergelm domSubmap
301 , domFingerprint = mergelm domFingerprint
302 , domDs = mergelm domDs
303 , domMx = mergelm domMx
304 , domSrv = mergelm domSrv
305 , domTlsa = mergelm domTlsa
308 mergelm x = merge (x sub) (x dom)
309 -- Because it is not possible to define instance of merge for Strings,
310 -- we have to treat string elements separately, otherwise strings are
311 -- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
312 choose field = case field dom of