handle (and test) imports
[pdns-pipe-nmc.git] / NmcDom.hs
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module NmcDom   ( NmcDom(..)
4                 , emptyNmcDom
5                 , descendNmcDom
6                 , queryNmcDom
7                 , mergeImport
8                 ) where
9
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
14 import Data.Char
15 import Data.Map as M (Map, lookup)
16 import Control.Applicative ((<$>), (<*>), empty)
17 import Data.Aeson
18
19 data NmcRRService = NmcRRService -- unused
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 (Object o) = NmcRRService
30                 <$> o .: "name"
31                 <*> o .: "proto"
32                 <*> o .: "w1"
33                 <*> o .: "w2"
34                 <*> o .: "port"
35                 <*> o .: "host"
36         parseJSON _ = empty
37
38 data NmcRRI2p = NmcRRI2p
39                         { i2pDestination :: String
40                         , i2pName        :: String
41                         , i2pB32         :: String
42                         } deriving (Show, Eq)
43
44 instance FromJSON NmcRRI2p where
45         parseJSON (Object o) = NmcRRI2p
46                 <$> o .: "destination"
47                 <*> o .: "name"
48                 <*> o .: "b32"
49         parseJSON _ = empty
50
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]]
70                         } deriving (Show, Eq)
71
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) =
77                  return $ if isIPv4 s'
78                             then emptyNmcDom { domIp = Just [s'] }
79                             else emptyNmcDom
80                           where
81                             s' = T.unpack s
82                             isIPv4 x = all isNibble $ splitOn "." x
83                             isNibble x =
84                               if all isDigit x then (read x :: Int) < 256
85                               else False
86         parseJSON (Object o) = NmcDom
87                 <$> o .:? "service"
88                 <*> o .:? "ip"
89                 <*> o .:? "ip6"
90                 <*> o .:? "tor"
91                 <*> o .:? "i2p"
92                 <*> o .:? "freenet"
93                 <*> o .:? "alias"
94                 <*> o .:? "translate"
95                 <*> o .:? "email"
96                 <*> o .:? "loc"
97                 <*> o .:? "info"
98                 <*> o .:? "ns"
99                 <*> o .:? "delegate"
100                 <*> o .:? "import"
101                 <*> o .:? "map"
102                 <*> o .:? "fingerprint"
103                 <*> o .:? "tls"
104                 <*> o .:? "ds"
105         parseJSON _ = empty
106
107 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
108                      Nothing Nothing Nothing Nothing Nothing Nothing
109                      Nothing Nothing Nothing Nothing Nothing Nothing
110
111 normalizeDom :: NmcDom -> NmcDom
112 normalizeDom dom
113   | domNs        dom /= Nothing = emptyNmcDom { domNs    = domNs dom
114                                               , domEmail = domEmail dom
115                                               }
116   | domDelegate  dom /= Nothing = emptyNmcDom -- FIXME
117   | domTranslate dom /= Nothing = dom { domMap = Nothing }
118   | otherwise                   = dom
119
120 descendNmcDom :: [String] -> NmcDom -> NmcDom
121 descendNmcDom subdom rawdom =
122   let dom = normalizeDom rawdom
123   in case subdom of
124     []   ->
125       case domMap dom of
126         Nothing  -> dom
127         Just map ->
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...
131     d:ds ->
132       case domMap dom of
133         Nothing  -> emptyNmcDom
134         Just map ->
135           case M.lookup d map of
136             Nothing  -> emptyNmcDom
137             Just sub -> descendNmcDom ds sub
138
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
158                         }
159   where
160     choose :: (NmcDom -> Maybe a) -> Maybe a
161     choose field = case field dom of
162       Nothing -> field sub
163       Just x  -> Just x
164
165 -- | Perform query and return error string or parsed domain object
166 queryNmcDom ::
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
171   l <- queryOp key
172   case l of
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
177
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.
182 mergeImport ::
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}
188   -- print base'
189   case domImport base of
190     Nothing  -> return base'
191     Just key -> do
192       sub <- queryNmcDom queryOp (L.pack key)
193       case sub of
194         Left  e    -> return base'
195         Right sub' -> mergeImport queryOp $ sub' `mergeNmcDom` base'