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