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, singleton)
18 import Data.Map (Map, unionWith)
19 import qualified Data.HashMap.Strict as H (lookup)
21 import Data.Aeson.Types
23 -- Variant of Aeson's `.:?` that interprets a String as a
24 -- single-element list, so it is possible to have either
28 -- with the same result.
29 (.:/) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
30 obj .:/ key = case H.lookup key obj of
31 Nothing -> pure Nothing
33 String s -> parseJSON $ Array (singleton v)
36 class Mergeable a where
37 merge :: a -> a -> a -- bias towads second arg
39 instance (Ord k, Mergeable a) => Mergeable (Map k a) where
40 merge mx my = unionWith merge my mx
42 -- Alas, the following is not possible in Haskell :-(
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 = 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 NmcRRTls = NmcRRTls
99 { tlsMatchType :: Int -- 0:exact 1:sha256 2:sha512
100 , tlsMatchValue :: String
101 , tlsIncSubdoms :: Int -- 1:enforce on subdoms 0:no
102 } deriving (Show, Eq)
104 instance FromJSON NmcRRTls where
105 parseJSON (Array a) =
106 if length a == 3 then NmcRRTls
107 <$> parseJSON (a ! 0)
108 <*> parseJSON (a ! 1)
109 <*> parseJSON (a ! 2)
113 instance Mergeable NmcRRTls where
116 data NmcRRDs = NmcRRDs
120 , dsHashValue :: String
121 } deriving (Show, Eq)
123 instance FromJSON NmcRRDs where
124 parseJSON (Array a) =
125 if length a == 4 then NmcRRDs
126 <$> parseJSON (a ! 0)
127 <*> parseJSON (a ! 1)
128 <*> parseJSON (a ! 2)
129 <*> parseJSON (a ! 3)
133 instance Mergeable NmcRRDs where
136 data NmcDom = NmcDom { domService :: Maybe [NmcRRService]
137 , domIp :: Maybe [String]
138 , domIp6 :: Maybe [String]
139 , domTor :: Maybe String
140 , domI2p :: Maybe NmcRRI2p
141 , domFreenet :: Maybe String
142 , domAlias :: Maybe String
143 , domTranslate :: Maybe String
144 , domEmail :: Maybe String
145 , domLoc :: Maybe String
146 , domInfo :: Maybe Value
147 , domNs :: Maybe [String]
148 , domDelegate :: Maybe String
149 , domImport :: Maybe [String]
150 , domMap :: Maybe (Map String NmcDom)
151 , domFingerprint :: Maybe [String]
152 , domTls :: Maybe (Map String
153 (Map String [NmcRRTls]))
154 , domDs :: Maybe [NmcRRDs]
155 , domMx :: Maybe [String] -- Synthetic
156 , domSrv :: Maybe [String] -- Synthetic
157 } deriving (Show, Eq)
159 instance FromJSON NmcDom where
160 -- Wherever we expect a domain object, there may be a string
161 -- containing IPv4 address. Interpret it as such.
162 -- Question: shall we try to recognize IPv6 addresses too?
163 parseJSON (String s) =
164 return $ if isIPv4 s'
165 then emptyNmcDom { domIp = Just [s'] }
169 isIPv4 x = all isNibble $ splitOn "." x
171 if all isDigit x then (read x :: Int) < 256
173 parseJSON (Object o) = NmcDom
181 <*> o .:? "translate"
189 <*> o .:/ "fingerprint"
192 <*> return Nothing -- domMx not parsed
193 <*> return Nothing -- domSrv not parsed
196 instance Mergeable NmcDom where
197 merge sub dom = dom { domService = mergelm domService
198 , domIp = mergelm domIp
199 , domIp6 = mergelm domIp6
200 , domTor = choose domTor
201 , domI2p = mergelm domI2p
202 , domFreenet = choose domFreenet
203 , domAlias = choose domAlias
204 , domTranslate = choose domTranslate
205 , domEmail = choose domEmail
206 , domLoc = choose domLoc
207 , domInfo = mergelm domInfo
208 , domNs = mergelm domNs
209 , domDelegate = mergelm domDelegate
210 , domImport = mergelm domImport
211 , domMap = mergelm domMap
212 , domFingerprint = mergelm domFingerprint
213 , domTls = mergelm domTls
214 , domDs = mergelm domDs
215 , domMx = mergelm domMx
216 , domSrv = mergelm domSrv
219 mergelm x = merge (x sub) (x dom)
220 -- Because it is not possible to define instance of merge for Strings,
221 -- we have to treat string elements separately, otherwise strings are
222 -- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
223 choose field = case field dom of
227 mergeNmcDom :: NmcDom -> NmcDom -> NmcDom
230 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
231 Nothing Nothing Nothing Nothing Nothing Nothing
232 Nothing Nothing Nothing Nothing Nothing Nothing