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)
20 import qualified Data.Map as M (singleton, empty)
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))
77 takeMap o = o .:? "map"
79 takeSrv :: Object -> Parser (Maybe (Map String NmcDom))
81 case H.lookup "service" o of
82 Nothing -> pure Nothing
84 isvl <- parseJSON (Array a)
85 return $ foldr addSrv (Just M.empty) isvl
87 addSrv isv acc = subm `merge` acc
89 subm = Just (M.singleton ("_" ++ isvProto isv) sub2)
90 sub2 = def { domSubmap =
91 Just (M.singleton ("_" ++ isvName isv) sub3) }
92 sub3 = def { domSrv = Just [ NmcRRSrv (isvPrio isv)
98 -- takeTls is almost, but not quite, entirely unlike takeSrv
99 takeTls :: Object -> Parser (Maybe (Map String NmcDom))
100 takeTls o = o .:? "map" -- FIXME
102 class Mergeable a where
103 merge :: a -> a -> a -- bias towads second arg
105 instance (Ord k, Mergeable a) => Mergeable (Map k a) where
106 merge mx my = unionWith merge my mx
108 -- Alas, the following is not possible in Haskell :-(
109 -- instance Mergeable String where
112 instance Mergeable Value where
115 instance Mergeable a => Mergeable (Maybe a) where
116 merge (Just x) (Just y) = Just (merge x y)
117 merge Nothing (Just y) = Just y
118 merge (Just x) Nothing = Just x
119 merge Nothing Nothing = Nothing
121 instance Eq a => Mergeable [a] where
122 merge xs ys = union xs ys
124 data NmcRRSrv = NmcRRSrv
129 } deriving (Show, Eq)
131 instance Mergeable NmcRRSrv where
134 data NmcRRI2p = NmcRRI2p
135 { i2pDestination :: Maybe String
136 , i2pName :: Maybe String
137 , i2pB32 :: Maybe String
138 } deriving (Show, Eq)
140 instance FromJSON NmcRRI2p where
141 parseJSON (Object o) = NmcRRI2p
142 <$> o .:? "destination"
147 instance Mergeable NmcRRI2p where
150 data NmcRRTlsa = NmcRRTlsa
151 { tlsMatchType :: Int -- 0:exact 1:sha256 2:sha512
152 , tlsMatchValue :: String
153 , tlsIncSubdoms :: Int -- 1:enforce on subdoms 0:no
154 } deriving (Show, Eq)
156 instance Mergeable NmcRRTlsa where
159 data NmcRRDs = NmcRRDs
163 , dsHashValue :: String
164 } deriving (Show, Eq)
166 instance FromJSON NmcRRDs where
167 parseJSON (Array a) =
168 if length a == 4 then NmcRRDs
169 <$> parseJSON (a ! 0)
170 <*> parseJSON (a ! 1)
171 <*> parseJSON (a ! 2)
172 <*> parseJSON (a ! 3)
176 instance Mergeable NmcRRDs where
179 data NmcDom = NmcDom { domIp :: Maybe [String]
180 , domIp6 :: Maybe [String]
181 , domTor :: Maybe String
182 , domI2p :: Maybe NmcRRI2p
183 , domFreenet :: Maybe String
184 , domAlias :: Maybe String
185 , domTranslate :: Maybe String
186 , domEmail :: Maybe String
187 , domLoc :: Maybe String
188 , domInfo :: Maybe Value
189 , domNs :: Maybe [String]
190 , domDelegate :: Maybe String
191 , domImport :: Maybe [String]
192 , domSubmap :: Maybe (Map String NmcDom)
193 , domFingerprint :: Maybe [String]
194 , domDs :: Maybe [NmcRRDs]
195 , domMx :: Maybe [String] -- Synthetic
196 , domSrv :: Maybe [NmcRRSrv] -- Synthetic
197 , domTlsa :: Maybe [NmcRRTlsa] -- Synthetic
198 } deriving (Show, Eq)
200 instance Default NmcDom where
201 def = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing
202 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
203 Nothing Nothing Nothing Nothing Nothing
205 instance FromJSON NmcDom where
206 -- Wherever we expect a domain object, there may be a string
207 -- containing IPv4 address. Interpret it as such.
208 -- Question: shall we try to recognize IPv6 addresses too?
209 parseJSON (String s) =
210 return $ if isIPv4 s'
211 then def { domIp = Just [s'] }
215 isIPv4 x = all isNibble $ splitOn "." x
217 if all isDigit x then (read x :: Int) < 256
219 parseJSON (Object o) = NmcDom
226 <*> o .:? "translate"
234 <*> o .:/ "fingerprint"
237 <*> return Nothing -- domSrv created in subdomains
238 <*> return Nothing -- domTlsa created in subdomains
241 instance Mergeable NmcDom where
242 merge sub dom = dom { domIp = mergelm domIp
243 , domIp6 = mergelm domIp6
244 , domTor = choose domTor
245 , domI2p = mergelm domI2p
246 , domFreenet = choose domFreenet
247 , domAlias = choose domAlias
248 , domTranslate = choose domTranslate
249 , domEmail = choose domEmail
250 , domLoc = choose domLoc
251 , domInfo = mergelm domInfo
252 , domNs = mergelm domNs
253 , domDelegate = mergelm domDelegate
254 , domImport = mergelm domImport
255 , domSubmap = mergelm domSubmap
256 , domFingerprint = mergelm domFingerprint
257 , domDs = mergelm domDs
258 , domMx = mergelm domMx
259 , domSrv = mergelm domSrv
260 , domTlsa = mergelm domTlsa
263 mergelm x = merge (x sub) (x dom)
264 -- Because it is not possible to define instance of merge for Strings,
265 -- we have to treat string elements separately, otherwise strings are
266 -- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
267 choose field = case field dom of