incorporate resursive merges
[pdns-pipe-nmc.git] / NmcDom.hs
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module NmcDom   ( NmcDom(..)
4                 , emptyNmcDom
5                 , seedNmcDom
6                 , descendNmcDom
7                 ) where
8
9 import Data.ByteString.Lazy (ByteString)
10 import qualified Data.Text as T (unpack)
11 import Data.List.Split
12 import Data.Char
13 import Data.Map as M (Map, lookup, delete, size)
14 import Control.Applicative ((<$>), (<*>), empty)
15 import Data.Aeson
16
17 data NmcRRService = NmcRRService -- unused
18                         { srvName       :: String
19                         , srvProto      :: String
20                         , srvW1         :: Int
21                         , srvW2         :: Int
22                         , srvPort       :: Int
23                         , srvHost       :: [String]
24                         } deriving (Show, Eq)
25
26 instance FromJSON NmcRRService where
27         parseJSON (Object o) = NmcRRService
28                 <$> o .: "name"
29                 <*> o .: "proto"
30                 <*> o .: "w1"
31                 <*> o .: "w2"
32                 <*> o .: "port"
33                 <*> o .: "host"
34         parseJSON _ = empty
35
36 data NmcRRI2p = NmcRRI2p
37                         { i2pDestination :: String
38                         , i2pName        :: String
39                         , i2pB32         :: String
40                         } deriving (Show, Eq)
41
42 instance FromJSON NmcRRI2p where
43         parseJSON (Object o) = NmcRRI2p
44                 <$> o .: "destination"
45                 <*> o .: "name"
46                 <*> o .: "b32"
47         parseJSON _ = empty
48
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]]
68                         } deriving (Show, Eq)
69
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) =
75                  return $ if isIPv4 s'
76                             then emptyNmcDom { domIp = Just [s'] }
77                             else emptyNmcDom
78                           where
79                             s' = T.unpack s
80                             isIPv4 x = all isNibble $ splitOn "." x
81                             isNibble x =
82                               if all isDigit x then (read x :: Int) < 256
83                               else False
84         parseJSON (Object o) = NmcDom
85                 <$> o .:? "service"
86                 <*> o .:? "ip"
87                 <*> o .:? "ip6"
88                 <*> o .:? "tor"
89                 <*> o .:? "i2p"
90                 <*> o .:? "freenet"
91                 <*> o .:? "alias"
92                 <*> o .:? "translate"
93                 <*> o .:? "email"
94                 <*> o .:? "loc"
95                 <*> o .:? "info"
96                 <*> o .:? "ns"
97                 <*> o .:? "delegate"
98                 <*> o .:? "import"
99                 <*> o .:? "map"
100                 <*> o .:? "fingerprint"
101                 <*> o .:? "tls"
102                 <*> o .:? "ds"
103         parseJSON _ = empty
104
105 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
106                      Nothing Nothing Nothing Nothing Nothing Nothing
107                      Nothing Nothing Nothing Nothing Nothing Nothing
108
109 -- FIXME -- I hope there exists a better way to merge records!
110 mergeNmcDom :: NmcDom -> NmcDom -> NmcDom
111 mergeNmcDom sub dom = dom  { domService = choose domService
112                         , domIp =          choose domIp
113                         , domIp6 =         choose domIp6
114                         , domTor =         choose domTor
115                         , domI2p =         choose domI2p
116                         , domFreenet =     choose domFreenet
117                         , domAlias =       choose domAlias
118                         , domTranslate =   choose domTranslate
119                         , domEmail =       choose domEmail
120                         , domLoc =         choose domLoc
121                         , domInfo =        choose domInfo
122                         , domNs =          choose domNs
123                         , domDelegate =    choose domDelegate
124                         , domImport =      choose domImport
125                         , domMap =         choose domMap
126                         , domFingerprint = choose domFingerprint
127                         , domTls =         choose domTls
128                         , domDs =          choose domDs
129                         }
130   where
131     choose :: (NmcDom -> Maybe a) -> Maybe a
132     choose field = case field dom of
133       Nothing -> field sub
134       Just x  -> Just x
135
136 -- | Perform query and return error string or parsed domain object
137 queryNmcDom ::
138   (String -> IO (Either String ByteString)) -- ^ query operation action
139   -> String                                 -- ^ key
140   -> IO (Either String NmcDom)              -- ^ error string or domain
141 queryNmcDom queryOp key = do
142   l <- queryOp key
143   case l of
144     Left estr -> return $ Left estr
145     Right str -> case decode str :: Maybe NmcDom of
146       Nothing  -> return $ Left $ "Unparseable value: " ++ (show str)
147       Just dom -> return $ Right dom
148
149 -- | Try to fetch "import" object and merge it into the base domain
150 --   Original "import" element is removed, but new imports from the
151 --   imported objects are processed recursively until there are none.
152 mergeImport ::
153   (String -> IO (Either String ByteString)) -- ^ query operation action
154   -> NmcDom                                 -- ^ base domain
155   -> IO (Either String NmcDom)              -- ^ result with merged import
156 mergeImport queryOp base = do
157   let
158     mbase = mergeSelf base
159     base' = mbase {domImport = Nothing}
160   -- print base
161   case domImport mbase of
162     Nothing  -> return $ Right base'
163     Just key -> do
164       sub <- queryNmcDom queryOp key
165       case sub of
166         Left  e    -> return $ Left e
167         Right sub' -> mergeImport queryOp $ sub' `mergeNmcDom` base'
168
169 -- | If there is an element in the map with key "", merge the contents
170 --   and remove this element. Do this recursively.
171 mergeSelf :: NmcDom -> NmcDom
172 mergeSelf base =
173   let
174     nbase = normalizeDom base
175     map   = domMap nbase
176     base' = nbase {domMap = removeSelf map}
177     removeSelf (Nothing)  = Nothing
178     removeSelf (Just map) = if size map' == 0 then Nothing else Just map'
179       where map' = M.delete "" map
180   in
181     case map of
182       Nothing   -> base'
183       Just map' ->
184         case M.lookup "" map' of
185           Nothing  -> base'
186           Just sub -> (mergeSelf sub) `mergeNmcDom` base'
187
188 -- | Presence of some elements require removal of some others
189 normalizeDom :: NmcDom -> NmcDom
190 normalizeDom dom
191   | domNs        dom /= Nothing = emptyNmcDom { domNs    = domNs dom
192                                               , domEmail = domEmail dom
193                                               }
194   | domDelegate  dom /= Nothing = emptyNmcDom -- FIXME
195   | domTranslate dom /= Nothing = dom { domMap = Nothing }
196   | otherwise                   = dom
197
198 -- | Merge imports and Selfs and follow the maps tree to get dom
199 descendNmcDom ::
200   (String -> IO (Either String ByteString)) -- ^ query operation action
201   -> [String]                               -- ^ subdomain chain
202   -> NmcDom                                 -- ^ base domain
203   -> IO (Either String NmcDom)              -- ^ fully processed result
204 descendNmcDom queryOp subdom base = do
205   base' <- mergeImport queryOp base
206   case subdom of
207     []   -> return base'
208     d:ds ->
209       case base' of
210         Left err     -> return base'
211         Right base'' ->
212           case domMap base'' of
213             Nothing  -> return $ Right emptyNmcDom
214             Just map ->
215               case M.lookup d map of
216                 Nothing  -> return $ Right emptyNmcDom
217                 Just sub -> descendNmcDom queryOp ds sub
218
219 -- | Initial NmcDom populated with "import" only, suitable for "descend"
220 seedNmcDom ::
221   String        -- ^ domain key (without namespace prefix)
222   -> NmcDom     -- ^ resulting seed domain
223 seedNmcDom dn = emptyNmcDom { domImport = Just ("d/" ++ dn)}