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 -> NmcDom -- ^ base domain
190 -> IO (Either String NmcDom) -- ^ result with merged import
191 mergeImport queryOp base = do
193 mbase = mergeSelf base
194 base' = mbase {domImport = Nothing}
196 case domImport mbase of
197 Nothing -> return $ Right base'
199 sub <- queryNmcDom queryOp key
201 Left e -> return $ Left e
202 Right sub' -> mergeImport queryOp $ sub' `merge` base'
204 -- | If there is an element in the map with key "", merge the contents
205 -- and remove this element. Do this recursively.
206 mergeSelf :: NmcDom -> NmcDom
210 base' = base {domMap = removeSelf map}
211 removeSelf Nothing = Nothing
212 removeSelf (Just map) = if size map' == 0 then Nothing else Just map'
213 where map' = M.delete "" map
218 case M.lookup "" map' of
220 Just sub -> (mergeSelf sub) `merge` base'
222 -- | Presence of some elements require removal of some others
223 normalizeDom :: NmcDom -> NmcDom
224 normalizeDom dom = foldr id dom [ translateNormalizer
225 -- , nsNormalizer -- FIXME retrun this
228 nsNormalizer dom = case domNs dom of
230 Just ns -> emptyNmcDom { domNs = domNs dom, domEmail = domEmail dom }
231 translateNormalizer dom = case domTranslate dom of
233 Just tr -> dom { domMap = Nothing }
235 -- | Merge imports and Selfs and follow the maps tree to get dom
237 (String -> IO (Either String ByteString)) -- ^ query operation action
238 -> [String] -- ^ subdomain chain
239 -> NmcDom -- ^ base domain
240 -> IO (Either String NmcDom) -- ^ fully processed result
241 descendNmcDom queryOp subdom base = do
242 base' <- mergeImport queryOp base
244 [] -> return $ fmap normalizeDom base'
247 Left err -> return base'
249 case domMap base'' of
250 Nothing -> return $ Right emptyNmcDom
252 case M.lookup d map of
253 Nothing -> return $ Right emptyNmcDom
254 Just sub -> descendNmcDom queryOp ds sub
256 -- | Initial NmcDom populated with "import" only, suitable for "descend"
258 String -- ^ domain key (without namespace prefix)
259 -> NmcDom -- ^ resulting seed domain
260 seedNmcDom dn = emptyNmcDom { domImport = Just ("d/" ++ dn)}