wip merging imports
[pdns-pipe-nmc.git] / NmcDom.hs
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module NmcDom   ( NmcDom(..)
4                 , emptyNmcDom
5                 , descendNmcDom
6                 , mergeImport
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)
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 normalizeDom :: NmcDom -> NmcDom
110 normalizeDom dom
111   | domNs        dom /= Nothing = emptyNmcDom { domNs    = domNs dom
112                                               , domEmail = domEmail dom
113                                               }
114   | domDelegate  dom /= Nothing = emptyNmcDom -- FIXME
115   | domTranslate dom /= Nothing = dom { domMap = Nothing }
116   | otherwise                   = dom
117
118 descendNmcDom :: [String] -> NmcDom -> NmcDom
119 descendNmcDom subdom rawdom =
120   let dom = normalizeDom rawdom
121   in case subdom of
122     []   ->
123       case domMap dom of
124         Nothing  -> dom
125         Just map ->
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...
129     d:ds ->
130       case domMap dom of
131         Nothing  -> emptyNmcDom
132         Just map ->
133           case M.lookup d map of
134             Nothing  -> emptyNmcDom
135             Just sub -> descendNmcDom ds sub
136
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
156                         }
157   where
158     choose :: (NmcDom -> Maybe a) -> Maybe a
159     choose field = case field dom of
160       Nothing -> field sub
161       Just x  -> Just x
162
163 -- | Perform query and return error string or parsed domain object
164 queryNmcDom ::
165   (String -> IO (Either String ByteString)) -- ^ query operation action
166   -> String                                 -- ^ key
167   -> IO (Either String NmcDom)              -- ^ error string or domain
168 queryNmcDom queryOp key = do
169   l <- queryOp key
170   case l of
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
175
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.
180 mergeImport ::
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}
186   -- print base'
187   case domImport base of
188     Nothing  -> return base'
189     Just key -> do
190       sub <- queryNmcDom queryOp key
191       case sub of
192         Left  e    -> return base'
193         Right sub' -> mergeImport queryOp $ sub' `mergeNmcDom` base'