1 {-# LANGUAGE OverloadedStrings #-}
3 module NmcDom ( NmcDom(..)
11 import Prelude hiding (length)
12 import Control.Applicative ((<$>), (<*>), liftA2, 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, foldrWithKey)
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 = takeTls o `fmerge` takeSrv o `fmerge` takeMap o
75 where fmerge = liftA2 merge
77 takeMap :: Object -> Parser (Maybe (Map String NmcDom))
79 case H.lookup "map" o of
80 Nothing -> pure Nothing
81 Just (Object mo) -> H.foldrWithKey addmapentry (pure (Just M.empty)) mo
83 addmapentry "" v acc = parseJSON v >>= inject acc ""
84 addmapentry k v acc = nest (splitOn "." (unpack k)) v acc
85 nest [] v acc = empty -- does not happen as a result of splitOn
86 nest [""] v acc = empty -- empty element of fqdn forbidden
87 nest [d] v acc = parseJSON v >>= inject acc d
89 nest ds v acc >>= (inject acc d) . (\r -> def { domSubmap = r })
90 inject acc d r = (fmap.fmap) (M.insertWith merge d r) acc
93 takeSrv :: Object -> Parser (Maybe (Map String NmcDom))
95 case H.lookup "service" o of
96 Nothing -> pure Nothing
98 isvl <- parseJSON (Array a)
99 return $ foldr addSrv (Just M.empty) isvl
101 addSrv isv acc = subm `merge` acc
103 subm = Just (M.singleton ("_" ++ isvProto isv) sub2)
104 sub2 = def { domSubmap =
105 Just (M.singleton ("_" ++ isvName isv) sub3) }
106 sub3 = def { domSrv = Just [ NmcRRSrv (isvPrio isv)
112 -- takeTls is almost, but not quite, entirely unlike takeSrv
113 takeTls :: Object -> Parser (Maybe (Map String NmcDom))
115 case H.lookup "tls" o of
116 Nothing -> pure Nothing
118 (parseJSON (Object t) :: Parser (Map String (Map String [NmcRRTlsa])))
121 tmap2dmap :: Map String (Map String [NmcRRTlsa])
122 -> Parser (Maybe (Map String NmcDom))
123 -- FIXME return parse error on invalid proto or port
124 tmap2dmap m1 = return $ foldrWithKey addprotoelem (Just M.empty) m1
125 addprotoelem k1 m2 acc = protoelem k1 m2 `merge` acc
126 protoelem k1 m2 = Just (M.singleton ("_" ++ k1) (pmap2dmap m2))
127 pmap2dmap m2 = foldrWithKey addportelem def m2
128 addportelem k2 v acc = portelem k2 v `merge` acc
130 def { domSubmap = Just (M.singleton ("_" ++ k2)
131 def { domTlsa = Just v }) }
134 class Mergeable a where
135 merge :: a -> a -> a -- bias towads second arg
137 instance (Ord k, Mergeable a) => Mergeable (Map k a) where
138 merge mx my = unionWith merge my mx
140 -- Alas, the following is not possible in Haskell :-(
141 -- instance Mergeable String where
144 instance Mergeable Value where
147 instance Mergeable a => Mergeable (Maybe a) where
148 merge (Just x) (Just y) = Just (merge x y)
149 merge Nothing (Just y) = Just y
150 merge (Just x) Nothing = Just x
151 merge Nothing Nothing = Nothing
153 instance Eq a => Mergeable [a] where
154 merge xs ys = union xs ys
156 data NmcRRSrv = NmcRRSrv
161 } deriving (Show, Eq)
163 instance Mergeable NmcRRSrv where
166 data NmcRRI2p = NmcRRI2p
167 { i2pDestination :: Maybe String
168 , i2pName :: Maybe String
169 , i2pB32 :: Maybe String
170 } deriving (Show, Eq)
172 instance FromJSON NmcRRI2p where
173 parseJSON (Object o) = NmcRRI2p
174 <$> o .:? "destination"
179 instance Mergeable NmcRRI2p where
182 data NmcRRTlsa = NmcRRTlsa
183 { tlsMatchType :: Int -- 0:exact 1:sha256 2:sha512
184 , tlsMatchValue :: String
185 , tlsIncSubdoms :: Bool -- enforce on subdoms?
186 } deriving (Show, Eq)
188 instance FromJSON NmcRRTlsa where
189 parseJSON (Array a) =
190 if length a == 3 then NmcRRTlsa
191 <$> parseJSON (a ! 0)
192 <*> parseJSON (a ! 1)
194 Number 0 -> return False
195 Number 1 -> return True
200 instance Mergeable NmcRRTlsa where
203 data NmcRRDs = NmcRRDs
207 , dsHashValue :: String
208 } deriving (Show, Eq)
210 instance FromJSON NmcRRDs where
211 parseJSON (Array a) =
212 if length a == 4 then NmcRRDs
213 <$> parseJSON (a ! 0)
214 <*> parseJSON (a ! 1)
215 <*> parseJSON (a ! 2)
216 <*> parseJSON (a ! 3)
220 instance Mergeable NmcRRDs where
223 data NmcDom = NmcDom { domIp :: Maybe [String]
224 , domIp6 :: Maybe [String]
225 , domTor :: Maybe String
226 , domI2p :: Maybe NmcRRI2p
227 , domFreenet :: Maybe String
228 , domAlias :: Maybe String
229 , domTranslate :: Maybe String
230 , domEmail :: Maybe String
231 , domLoc :: Maybe String
232 , domInfo :: Maybe Value
233 , domNs :: Maybe [String]
234 , domDelegate :: Maybe String
235 , domImport :: Maybe [String]
236 , domSubmap :: Maybe (Map String NmcDom)
237 , domFingerprint :: Maybe [String]
238 , domDs :: Maybe [NmcRRDs]
239 , domMx :: Maybe [String] -- Synthetic
240 , domSrv :: Maybe [NmcRRSrv] -- Synthetic
241 , domTlsa :: Maybe [NmcRRTlsa] -- Synthetic
242 } deriving (Show, Eq)
244 instance Default NmcDom where
245 def = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing
246 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
247 Nothing Nothing Nothing Nothing Nothing
249 instance FromJSON NmcDom where
250 -- Wherever we expect a domain object, there may be a string
251 -- containing IPv4 address. Interpret it as such.
252 -- Question: shall we try to recognize IPv6 addresses too?
253 parseJSON (String s) =
254 return $ if isIPv4 s'
255 then def { domIp = Just [s'] }
259 isIPv4 x = all isNibble $ splitOn "." x
261 if all isDigit x then (read x :: Int) < 256
263 parseJSON (Object o) = NmcDom
270 <*> o .:? "translate"
278 <*> o .:/ "fingerprint"
281 <*> return Nothing -- domSrv created in subdomains
282 <*> return Nothing -- domTlsa created in subdomains
285 instance Mergeable NmcDom where
286 merge sub dom = dom { domIp = mergelm domIp
287 , domIp6 = mergelm domIp6
288 , domTor = choose domTor
289 , domI2p = mergelm domI2p
290 , domFreenet = choose domFreenet
291 , domAlias = choose domAlias
292 , domTranslate = choose domTranslate
293 , domEmail = choose domEmail
294 , domLoc = choose domLoc
295 , domInfo = mergelm domInfo
296 , domNs = mergelm domNs
297 , domDelegate = mergelm domDelegate
298 , domImport = mergelm domImport
299 , domSubmap = mergelm domSubmap
300 , domFingerprint = mergelm domFingerprint
301 , domDs = mergelm domDs
302 , domMx = mergelm domMx
303 , domSrv = mergelm domSrv
304 , domTlsa = mergelm domTlsa
307 mergelm x = merge (x sub) (x dom)
308 -- Because it is not possible to define instance of merge for Strings,
309 -- we have to treat string elements separately, otherwise strings are
310 -- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
311 choose field = case field dom of