1 {-# LANGUAGE OverloadedStrings #-}
3 module NmcDom ( NmcDom(..)
10 import Data.ByteString.Lazy (ByteString)
11 import qualified Data.ByteString.Lazy.Char8 as L (pack)
12 import qualified Data.Text as T (unpack)
13 import Data.List.Split
15 import Data.Map as M (Map, lookup)
16 import Control.Applicative ((<$>), (<*>), empty)
19 data NmcRRService = NmcRRService -- unused
28 instance FromJSON NmcRRService where
29 parseJSON (Object o) = NmcRRService
38 data NmcRRI2p = NmcRRI2p
39 { i2pDestination :: String
44 instance FromJSON NmcRRI2p where
45 parseJSON (Object o) = NmcRRI2p
46 <$> o .: "destination"
51 data NmcDom = NmcDom { domService :: Maybe [[String]] -- [NmcRRService]
52 , domIp :: Maybe [String]
53 , domIp6 :: Maybe [String]
54 , domTor :: Maybe String
55 , domI2p :: Maybe NmcRRI2p
56 , domFreenet :: Maybe String
57 , domAlias :: Maybe String
58 , domTranslate :: Maybe String
59 , domEmail :: Maybe String
60 , domLoc :: Maybe String
61 , domInfo :: Maybe Value
62 , domNs :: Maybe [String]
63 , domDelegate :: Maybe [String]
64 , domImport :: Maybe String
65 , domMap :: Maybe (Map String NmcDom)
66 , domFingerprint :: Maybe [String]
67 , domTls :: Maybe (Map String
68 (Map String [[String]]))
69 , domDs :: Maybe [[String]]
72 instance FromJSON NmcDom where
73 -- Wherever we expect a domain object, there may be a string
74 -- containing IPv4 address. Interpret it as such.
75 -- Question: shall we try to recognize IPv6 addresses too?
76 parseJSON (String s) =
78 then emptyNmcDom { domIp = Just [s'] }
82 isIPv4 x = all isNibble $ splitOn "." x
84 if all isDigit x then (read x :: Int) < 256
86 parseJSON (Object o) = NmcDom
102 <*> o .:? "fingerprint"
107 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
108 Nothing Nothing Nothing Nothing Nothing Nothing
109 Nothing Nothing Nothing Nothing Nothing Nothing
111 normalizeDom :: NmcDom -> NmcDom
113 | domNs dom /= Nothing = emptyNmcDom { domNs = domNs dom
114 , domEmail = domEmail dom
116 | domDelegate dom /= Nothing = emptyNmcDom -- FIXME
117 | domTranslate dom /= Nothing = dom { domMap = Nothing }
120 descendNmcDom :: [String] -> NmcDom -> NmcDom
121 descendNmcDom subdom rawdom =
122 let dom = normalizeDom rawdom
128 case M.lookup "" map of -- Stupid, but there are "" in the map
129 Nothing -> dom -- Try to merge it with the root data
130 Just sub -> mergeNmcDom sub dom -- Or maybe drop it altogether...
133 Nothing -> emptyNmcDom
135 case M.lookup d map of
136 Nothing -> emptyNmcDom
137 Just sub -> descendNmcDom ds sub
139 -- FIXME -- I hope there exists a better way to merge records!
140 mergeNmcDom :: NmcDom -> NmcDom -> NmcDom
141 mergeNmcDom sub dom = dom { domService = choose domService
142 , domIp = choose domIp
143 , domIp6 = choose domIp6
144 , domTor = choose domTor
145 , domI2p = choose domI2p
146 , domFreenet = choose domFreenet
147 , domAlias = choose domAlias
148 , domTranslate = choose domTranslate
149 , domEmail = choose domEmail
150 , domLoc = choose domLoc
151 , domInfo = choose domInfo
152 , domNs = choose domNs
153 , domDelegate = choose domDelegate
154 , domImport = choose domImport
155 , domFingerprint = choose domFingerprint
156 , domTls = choose domTls
157 , domDs = choose domDs
160 choose :: (NmcDom -> Maybe a) -> Maybe a
161 choose field = case field dom of
165 -- | Perform query and return error string or parsed domain object
167 (ByteString -> IO (Either String ByteString)) -- ^ query operation action
168 -> ByteString -- ^ key
169 -> IO (Either String NmcDom) -- ^ error string or domain
170 queryNmcDom queryOp key = do
173 Left estr -> return $ Left estr
174 Right str -> case decode str :: Maybe NmcDom of
175 Nothing -> return $ Left $ "Unparseable value: " ++ (show str)
176 Just dom -> return $ Right dom
178 -- | Try to fetch "import" object and merge it into the base domain
179 -- Any errors are ignored, and nothing is merged.
180 -- Original "import" element is removed, but new imports from the
181 -- imported objects are processed recursively until there are none.
183 (ByteString -> IO (Either String ByteString)) -- ^ query operation action
184 -> NmcDom -- ^ base domain
185 -> IO NmcDom -- ^ result with merged import
186 mergeImport queryOp base = do
187 let base' = base {domImport = Nothing}
189 case domImport base of
190 Nothing -> return base'
192 sub <- queryNmcDom queryOp (L.pack key)
194 Left e -> return base'
195 Right sub' -> mergeImport queryOp $ sub' `mergeNmcDom` base'