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
22 import Data.Default.Class
24 -- Variant of Aeson's `.:?` that interprets a String as a
25 -- single-element list, so it is possible to have either
29 -- with the same result.
30 (.:/) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
31 obj .:/ key = case H.lookup key obj of
32 Nothing -> pure Nothing
34 String s -> parseJSON $ Array (singleton v)
37 makeMx :: Object -> Parser (Maybe [String])
38 makeMx o = return Nothing -- FIXME
40 case H.lookup "service" o of
41 Nothing -> pure Nothing
42 Just (Array saa) -> return $ Just $ fmap mxStr $ filter mxMatch saa
44 mxMatch sa = (sa ! 0) == "smtp" && (sa ! 1) == "tcp" && (sa ! 4) == 25
45 mxStr sa = (sa ! 2) ++ "\t" ++ (sa ! 5)
48 makeSubmap :: Object -> Parser (Maybe (Map String NmcDom))
49 makeSubmap o = o .:? "map" -- FIXME
51 class Mergeable a where
52 merge :: a -> a -> a -- bias towads second arg
54 instance (Ord k, Mergeable a) => Mergeable (Map k a) where
55 merge mx my = unionWith merge my mx
57 -- Alas, the following is not possible in Haskell :-(
58 -- instance Mergeable String where
61 instance Mergeable Value where
64 instance Mergeable a => Mergeable (Maybe a) where
65 merge (Just x) (Just y) = Just (merge x y)
66 merge Nothing (Just y) = Just y
67 merge (Just x) Nothing = Just x
68 merge Nothing Nothing = Nothing
70 instance Eq a => Mergeable [a] where
71 merge xs ys = union xs ys
73 data NmcRRSrv = NmcRRSrv
80 instance Mergeable NmcRRSrv where
83 data NmcRRI2p = NmcRRI2p
84 { i2pDestination :: Maybe String
85 , i2pName :: Maybe String
86 , i2pB32 :: Maybe String
89 instance FromJSON NmcRRI2p where
90 parseJSON (Object o) = NmcRRI2p
91 <$> o .:? "destination"
96 instance Mergeable NmcRRI2p where
99 data NmcRRTlsa = NmcRRTlsa
100 { tlsMatchType :: Int -- 0:exact 1:sha256 2:sha512
101 , tlsMatchValue :: String
102 , tlsIncSubdoms :: Int -- 1:enforce on subdoms 0:no
103 } deriving (Show, Eq)
105 instance Mergeable NmcRRTlsa where
108 data NmcRRDs = NmcRRDs
112 , dsHashValue :: String
113 } deriving (Show, Eq)
115 instance FromJSON NmcRRDs where
116 parseJSON (Array a) =
117 if length a == 4 then NmcRRDs
118 <$> parseJSON (a ! 0)
119 <*> parseJSON (a ! 1)
120 <*> parseJSON (a ! 2)
121 <*> parseJSON (a ! 3)
125 instance Mergeable NmcRRDs where
128 data NmcDom = NmcDom { domIp :: Maybe [String]
129 , domIp6 :: Maybe [String]
130 , domTor :: Maybe String
131 , domI2p :: Maybe NmcRRI2p
132 , domFreenet :: Maybe String
133 , domAlias :: Maybe String
134 , domTranslate :: Maybe String
135 , domEmail :: Maybe String
136 , domLoc :: Maybe String
137 , domInfo :: Maybe Value
138 , domNs :: Maybe [String]
139 , domDelegate :: Maybe String
140 , domImport :: Maybe [String]
141 , domSubmap :: Maybe (Map String NmcDom)
142 , domFingerprint :: Maybe [String]
143 , domDs :: Maybe [NmcRRDs]
144 , domMx :: Maybe [String] -- Synthetic
145 , domSrv :: Maybe [NmcRRSrv] -- Synthetic
146 , domTlsa :: Maybe [NmcRRTlsa] -- Synthetic
147 } deriving (Show, Eq)
149 instance Default NmcDom where
150 def = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing
151 Nothing Nothing Nothing Nothing Nothing Nothing Nothing
152 Nothing Nothing Nothing Nothing Nothing
154 instance FromJSON NmcDom where
155 -- Wherever we expect a domain object, there may be a string
156 -- containing IPv4 address. Interpret it as such.
157 -- Question: shall we try to recognize IPv6 addresses too?
158 parseJSON (String s) =
159 return $ if isIPv4 s'
160 then def { domIp = Just [s'] }
164 isIPv4 x = all isNibble $ splitOn "." x
166 if all isDigit x then (read x :: Int) < 256
168 parseJSON (Object o) = NmcDom
175 <*> o .:? "translate"
183 <*> o .:/ "fingerprint"
186 <*> return Nothing -- domSrv created in subdomains
187 <*> return Nothing -- domTlsa created in subdomains
190 instance Mergeable NmcDom where
191 merge sub dom = dom { domIp = mergelm domIp
192 , domIp6 = mergelm domIp6
193 , domTor = choose domTor
194 , domI2p = mergelm domI2p
195 , domFreenet = choose domFreenet
196 , domAlias = choose domAlias
197 , domTranslate = choose domTranslate
198 , domEmail = choose domEmail
199 , domLoc = choose domLoc
200 , domInfo = mergelm domInfo
201 , domNs = mergelm domNs
202 , domDelegate = mergelm domDelegate
203 , domImport = mergelm domImport
204 , domSubmap = mergelm domSubmap
205 , domFingerprint = mergelm domFingerprint
206 , domDs = mergelm domDs
207 , domMx = mergelm domMx
208 , domSrv = mergelm domSrv
209 , domTlsa = mergelm domTlsa
212 mergelm x = merge (x sub) (x dom)
213 -- Because it is not possible to define instance of merge for Strings,
214 -- we have to treat string elements separately, otherwise strings are
215 -- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
216 choose field = case field dom of