1 {-# LANGUAGE OverloadedStrings #-}
3 module NmcJson ( NmcRes(..)
9 import Data.ByteString.Lazy (ByteString)
10 import Data.Text as T (unpack)
11 import Data.Map as M (Map, lookup)
12 import Control.Applicative ((<$>), (<*>), empty)
15 data NmcRRService = NmcRRService -- unused
24 instance FromJSON NmcRRService where
25 parseJSON (Object o) = NmcRRService
34 data NmcRRI2p = NmcRRI2p
35 { i2pDestination :: String
40 instance FromJSON NmcRRI2p where
41 parseJSON (Object o) = NmcRRI2p
42 <$> o .: "destination"
47 data NmcDom = NmcDom { domService :: Maybe [[String]] -- [NmcRRService]
48 , domIp :: Maybe [String]
49 , domIp6 :: Maybe [String]
50 , domTor :: Maybe String
51 , domI2p :: Maybe NmcRRI2p
52 , domFreenet :: Maybe String
53 , domAlias :: Maybe String
54 , domTranslate :: Maybe String
55 , domEmail :: Maybe String
56 , domLoc :: Maybe String
57 , domInfo :: Maybe Value
58 , domNs :: Maybe [String]
59 , domDelegate :: Maybe [String]
60 , domImport :: Maybe [[String]]
61 , domMap :: Maybe (Map String NmcDom)
62 , domFingerprint :: Maybe [String]
63 , domTls :: Maybe (Map String
64 (Map String [[String]]))
65 , domDs :: Maybe [[String]]
68 instance FromJSON NmcDom where
69 -- Some just put the IP address in the value, especially in the map.
70 -- As an ugly hack, try to interpret string as IP (v4) address.
71 parseJSON (String s) = return emptyNmcDom { domIp = Just [T.unpack s] }
72 parseJSON (Object o) = NmcDom
88 <*> o .:? "fingerprint"
93 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
94 Nothing Nothing Nothing Nothing Nothing Nothing
95 Nothing Nothing Nothing Nothing Nothing Nothing
97 data NmcRes = NmcRes { resName :: String
98 , resValue :: ByteString -- string with NmcDom
100 , resAddress :: String
101 , resExpires_in :: Int
103 instance FromJSON NmcRes where
104 parseJSON (Object o) = NmcRes
109 <*> o .: "expires_in"
112 normalizeDom :: NmcDom -> NmcDom
114 | domNs dom /= Nothing = emptyNmcDom { domNs = domNs dom
115 , domEmail = domEmail dom
117 | domDelegate dom /= Nothing = emptyNmcDom -- FIXME
118 | domTranslate dom /= Nothing = dom { domMap = Nothing }
121 descendNmc :: [String] -> NmcDom -> NmcDom
122 descendNmc subdom rawdom =
123 let dom = normalizeDom rawdom
129 case M.lookup "" map of -- Stupid, but there are "" in the map
130 Nothing -> dom -- Try to merge it with the root data
131 Just sub -> mergeNmc sub dom -- Or maybe drop it altogether...
134 Nothing -> emptyNmcDom
136 case M.lookup d map of
137 Nothing -> emptyNmcDom
138 Just sub -> descendNmc ds sub
140 -- FIXME -- I hope there exists a better way to merge records!
141 mergeNmc :: NmcDom -> NmcDom -> NmcDom
142 mergeNmc sub dom = dom { domService = choose domService
143 , domIp = choose domIp
144 , domIp6 = choose domIp6
145 , domTor = choose domTor
146 , domI2p = choose domI2p
147 , domFreenet = choose domFreenet
148 , domAlias = choose domAlias
149 , domTranslate = choose domTranslate
150 , domEmail = choose domEmail
151 , domLoc = choose domLoc
152 , domInfo = choose domInfo
153 , domNs = choose domNs
154 , domDelegate = choose domDelegate
155 , domImport = choose domImport
156 , domFingerprint = choose domFingerprint
157 , domTls = choose domTls
158 , domDs = choose domDs
161 choose :: (NmcDom -> Maybe a) -> Maybe a
162 choose field = case field dom of