1 {-# LANGUAGE OverloadedStrings #-}
3 module NmcDom ( NmcDom(..)
9 import Prelude hiding (length)
10 import Data.ByteString.Lazy (ByteString)
11 import qualified Data.Text as T (unpack)
12 import Data.List as L (union)
13 import Data.List.Split
15 import Data.Map as M (Map, lookup, delete, size, union)
16 import Data.Vector (toList,(!),length)
17 import Control.Applicative ((<$>), (<*>), empty)
20 class Mergeable a where
21 merge :: a -> a -> a -- bias towads second arg
23 instance Ord k => Mergeable (Map k a) where
24 merge mx my = M.union my mx
26 -- instance Mergeable String where
29 instance Mergeable Value where
32 instance Mergeable a => Mergeable (Maybe a) where
33 merge (Just x) (Just y) = Just (merge x y)
34 merge Nothing (Just y) = Just y
35 merge (Just x) Nothing = Just x
36 merge Nothing Nothing = Nothing
38 instance Eq a => Mergeable [a] where
39 merge xs ys = L.union xs ys
41 data NmcRRService = NmcRRService
50 instance FromJSON NmcRRService where
52 if length a == 6 then NmcRRService
62 instance Mergeable NmcRRService where
65 data NmcRRI2p = NmcRRI2p
66 { i2pDestination :: String
71 instance FromJSON NmcRRI2p where
72 parseJSON (Object o) = NmcRRI2p
73 <$> o .: "destination"
78 instance Mergeable NmcRRI2p where
81 data NmcDom = NmcDom { domService :: Maybe [NmcRRService]
82 , domIp :: Maybe [String]
83 , domIp6 :: Maybe [String]
84 , domTor :: Maybe String
85 , domI2p :: Maybe NmcRRI2p
86 , domFreenet :: Maybe String
87 , domAlias :: Maybe String
88 , domTranslate :: Maybe String
89 , domEmail :: Maybe String
90 , domLoc :: Maybe String
91 , domInfo :: Maybe Value
92 , domNs :: Maybe [String]
93 , domDelegate :: Maybe [String]
94 , domImport :: Maybe String
95 , domMap :: Maybe (Map String NmcDom)
96 , domFingerprint :: Maybe [String]
97 , domTls :: Maybe (Map String
98 (Map String [[String]]))
99 , domDs :: Maybe [[String]]
100 } deriving (Show, Eq)
102 instance FromJSON NmcDom where
103 -- Wherever we expect a domain object, there may be a string
104 -- containing IPv4 address. Interpret it as such.
105 -- Question: shall we try to recognize IPv6 addresses too?
106 parseJSON (String s) =
107 return $ if isIPv4 s'
108 then emptyNmcDom { domIp = Just [s'] }
112 isIPv4 x = all isNibble $ splitOn "." x
114 if all isDigit x then (read x :: Int) < 256
116 parseJSON (Object o) = NmcDom
124 <*> o .:? "translate"
132 <*> o .:? "fingerprint"
137 instance Mergeable NmcDom where
138 merge sub dom = dom { domService = mergelm domService
139 , domIp = mergelm domIp
140 , domIp6 = mergelm domIp6
141 , domTor = choose domTor
142 , domI2p = mergelm domI2p
143 , domFreenet = choose domFreenet
144 , domAlias = choose domAlias
145 , domTranslate = choose domTranslate
146 , domEmail = choose domEmail
147 , domLoc = choose domLoc
148 , domInfo = mergelm domInfo
149 , domNs = mergelm domNs
150 , domDelegate = mergelm domDelegate
151 , domImport = choose domImport
152 , domMap = mergelm domMap
153 , domFingerprint = mergelm domFingerprint
154 , domTls = mergelm domTls
155 , domDs = mergelm domDs
158 mergelm x = merge (x sub) (x dom)
159 -- Because it is not possible to define instance of merge for Strings,
160 -- we have to treat string elements separately, otherwise strings are
161 -- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
162 choose field = case field dom of
167 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
168 Nothing Nothing Nothing Nothing Nothing Nothing
169 Nothing Nothing Nothing Nothing Nothing Nothing
171 -- | Perform query and return error string or parsed domain object
173 (String -> IO (Either String ByteString)) -- ^ query operation action
175 -> IO (Either String NmcDom) -- ^ error string or domain
176 queryNmcDom queryOp key = do
179 Left estr -> return $ Left estr
180 Right str -> case decode str :: Maybe NmcDom of
181 Nothing -> return $ Left $ "Unparseable value: " ++ (show str)
182 Just dom -> return $ Right dom
184 -- | Try to fetch "import" object and merge it into the base domain
185 -- Original "import" element is removed, but new imports from the
186 -- imported objects are processed recursively until there are none.
188 (String -> IO (Either String ByteString)) -- ^ query operation action
189 -> Int -- ^ recursion counter
190 -> NmcDom -- ^ base domain
191 -> IO (Either String NmcDom) -- ^ result with merged import
192 mergeImport queryOp depth base = do
194 mbase = mergeSelf base
195 base' = mbase {domImport = Nothing}
197 if depth <= 0 then return $ Left "Nesting of imports is too deep"
198 else case domImport mbase of
199 Nothing -> return $ Right base'
201 sub <- queryNmcDom queryOp key
203 Left e -> return $ Left e
204 Right sub' -> mergeImport queryOp (depth - 1) $ sub' `merge` base'
206 -- | If there is an element in the map with key "", merge the contents
207 -- and remove this element. Do this recursively.
208 mergeSelf :: NmcDom -> NmcDom
212 base' = base {domMap = removeSelf map}
213 removeSelf Nothing = Nothing
214 removeSelf (Just map) = if size map' == 0 then Nothing else Just map'
215 where map' = M.delete "" map
220 case M.lookup "" map' of
222 Just sub -> (mergeSelf sub) `merge` base'
223 -- recursion depth limited by the size of the record
225 -- | Presence of some elements require removal of some others
226 normalizeDom :: NmcDom -> NmcDom
227 normalizeDom dom = foldr id dom [ translateNormalizer
228 -- , nsNormalizer -- FIXME retrun this
231 nsNormalizer dom = case domNs dom of
233 Just ns -> emptyNmcDom { domNs = domNs dom, domEmail = domEmail dom }
234 translateNormalizer dom = case domTranslate dom of
236 Just tr -> dom { domMap = Nothing }
238 -- | Merge imports and Selfs and follow the maps tree to get dom
240 (String -> IO (Either String ByteString)) -- ^ query operation action
241 -> [String] -- ^ subdomain chain
242 -> NmcDom -- ^ base domain
243 -> IO (Either String NmcDom) -- ^ fully processed result
244 descendNmcDom queryOp subdom base = do
245 base' <- mergeImport queryOp 10 base
247 [] -> return $ fmap normalizeDom base'
248 -- A hack to handle SRV records: don't descend if ["_prot","_serv"]
249 [('_':_),('-':_)] -> return $ fmap normalizeDom base'
252 Left err -> return base'
254 case domMap base'' of
255 Nothing -> return $ Right emptyNmcDom
257 case M.lookup d map of
258 Nothing -> return $ Right emptyNmcDom
259 Just sub -> descendNmcDom queryOp ds sub
261 -- | Initial NmcDom populated with "import" only, suitable for "descend"
263 String -- ^ domain key (without namespace prefix)
264 -> NmcDom -- ^ resulting seed domain
265 seedNmcDom dn = emptyNmcDom { domImport = Just ("d/" ++ dn)}