1 {-# LANGUAGE OverloadedStrings #-}
3 module NmcDom ( NmcDom(..)
9 import Data.ByteString.Lazy (ByteString)
10 import qualified Data.Text as T (unpack)
11 import Data.List.Split
13 import Data.Map as M (Map, lookup)
14 import Control.Applicative ((<$>), (<*>), empty)
17 data NmcRRService = NmcRRService -- unused
26 instance FromJSON NmcRRService where
27 parseJSON (Object o) = NmcRRService
36 data NmcRRI2p = NmcRRI2p
37 { i2pDestination :: String
42 instance FromJSON NmcRRI2p where
43 parseJSON (Object o) = NmcRRI2p
44 <$> o .: "destination"
49 data NmcDom = NmcDom { domService :: Maybe [[String]] -- [NmcRRService]
50 , domIp :: Maybe [String]
51 , domIp6 :: Maybe [String]
52 , domTor :: Maybe String
53 , domI2p :: Maybe NmcRRI2p
54 , domFreenet :: Maybe String
55 , domAlias :: Maybe String
56 , domTranslate :: Maybe String
57 , domEmail :: Maybe String
58 , domLoc :: Maybe String
59 , domInfo :: Maybe Value
60 , domNs :: Maybe [String]
61 , domDelegate :: Maybe [String]
62 , domImport :: Maybe String
63 , domMap :: Maybe (Map String NmcDom)
64 , domFingerprint :: Maybe [String]
65 , domTls :: Maybe (Map String
66 (Map String [[String]]))
67 , domDs :: Maybe [[String]]
70 instance FromJSON NmcDom where
71 -- Wherever we expect a domain object, there may be a string
72 -- containing IPv4 address. Interpret it as such.
73 -- Question: shall we try to recognize IPv6 addresses too?
74 parseJSON (String s) =
76 then emptyNmcDom { domIp = Just [s'] }
80 isIPv4 x = all isNibble $ splitOn "." x
82 if all isDigit x then (read x :: Int) < 256
84 parseJSON (Object o) = NmcDom
100 <*> o .:? "fingerprint"
105 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
106 Nothing Nothing Nothing Nothing Nothing Nothing
107 Nothing Nothing Nothing Nothing Nothing Nothing
109 normalizeDom :: NmcDom -> NmcDom
111 | domNs dom /= Nothing = emptyNmcDom { domNs = domNs dom
112 , domEmail = domEmail dom
114 | domDelegate dom /= Nothing = emptyNmcDom -- FIXME
115 | domTranslate dom /= Nothing = dom { domMap = Nothing }
118 descendNmcDom :: [String] -> NmcDom -> NmcDom
119 descendNmcDom subdom rawdom =
120 let dom = normalizeDom rawdom
126 case M.lookup "" map of -- Stupid, but there are "" in the map
127 Nothing -> dom -- Try to merge it with the root data
128 Just sub -> mergeNmcDom sub dom -- Or maybe drop it altogether...
131 Nothing -> emptyNmcDom
133 case M.lookup d map of
134 Nothing -> emptyNmcDom
135 Just sub -> descendNmcDom ds sub
137 -- FIXME -- I hope there exists a better way to merge records!
138 mergeNmcDom :: NmcDom -> NmcDom -> NmcDom
139 mergeNmcDom sub dom = dom { domService = choose domService
140 , domIp = choose domIp
141 , domIp6 = choose domIp6
142 , domTor = choose domTor
143 , domI2p = choose domI2p
144 , domFreenet = choose domFreenet
145 , domAlias = choose domAlias
146 , domTranslate = choose domTranslate
147 , domEmail = choose domEmail
148 , domLoc = choose domLoc
149 , domInfo = choose domInfo
150 , domNs = choose domNs
151 , domDelegate = choose domDelegate
152 , domImport = choose domImport
153 , domFingerprint = choose domFingerprint
154 , domTls = choose domTls
155 , domDs = choose domDs
158 choose :: (NmcDom -> Maybe a) -> Maybe a
159 choose field = case field dom of
163 -- | Perform query and return error string or parsed domain object
165 (String -> IO (Either String ByteString)) -- ^ query operation action
167 -> IO (Either String NmcDom) -- ^ error string or domain
168 queryNmcDom queryOp key = do
171 Left estr -> return $ Left estr
172 Right str -> case decode str :: Maybe NmcDom of
173 Nothing -> return $ Left $ "Unparseable value: " ++ (show str)
174 Just dom -> return $ Right dom
176 -- | Try to fetch "import" object and merge it into the base domain
177 -- In case of errors they are ignored, and nothing is merged.
178 -- Original "import" element is removed, but new imports from the
179 -- imported objects are processed recursively until there are none.
181 (String -> IO (Either String ByteString)) -- ^ query operation action
182 -> NmcDom -- ^ base domain
183 -> IO NmcDom -- ^ result with merged import
184 mergeImport queryOp base = do
185 let base' = base {domImport = Nothing}
187 case domImport base of
188 Nothing -> return base'
190 sub <- queryNmcDom queryOp key
192 Left e -> return base'
193 Right sub' -> mergeImport queryOp $ sub' `mergeNmcDom` base'