reimplement SRV handling
[pdns-pipe-nmc.git] / NmcDom.hs
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module NmcDom   ( NmcDom(..)
4                 , NmcRRService(..)
5                 , NmcRRI2p(..)
6                 , NmcRRTls(..)
7                 , emptyNmcDom
8                 , mergeNmcDom
9                 ) where
10
11 import Prelude hiding (length)
12 import Control.Applicative ((<$>), (<*>), empty, pure)
13 import Data.Char
14 import Data.Text (Text, unpack)
15 import Data.List (union)
16 import Data.List.Split
17 import Data.Vector ((!), length, singleton)
18 import Data.Map (Map, unionWith)
19 import qualified Data.HashMap.Strict as H (lookup)
20 import Data.Aeson
21 import Data.Aeson.Types
22
23 -- Variant of Aeson's `.:?` that interprets a String as a
24 -- single-element list, so it is possible to have either
25 --      "ip":["1.2.3.4"]
26 -- or
27 --      "ip":"1.2.3.4"
28 -- with the same result.
29 (.:/) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
30 obj .:/ key = case H.lookup key obj of
31                Nothing -> pure Nothing
32                Just v  -> case v of
33                         String s -> parseJSON $ Array (singleton v)
34                         _        -> parseJSON v
35
36 class Mergeable a where
37         merge :: a -> a -> a -- bias towads second arg
38
39 instance (Ord k, Mergeable a) => Mergeable (Map k a) where
40         merge mx my = unionWith merge my mx
41
42 -- Alas, the following is not possible in Haskell :-(
43 -- instance Mergeable String where
44 --         merge _ b = b
45
46 instance Mergeable Value where
47         merge _ b = b
48
49 instance Mergeable a => Mergeable (Maybe a) where
50         merge (Just x) (Just y) = Just (merge x y)
51         merge Nothing  (Just y) = Just y
52         merge (Just x) Nothing  = Just x
53         merge Nothing  Nothing  = Nothing
54
55 instance Eq a => Mergeable [a] where
56         merge xs ys = union xs ys
57
58 data NmcRRService = NmcRRService
59                         { srvName       :: String
60                         , srvProto      :: String
61                         , srvPrio       :: Int
62                         , srvWeight     :: Int
63                         , srvPort       :: Int
64                         , srvHost       :: String
65                         } deriving (Show, Eq)
66
67 instance FromJSON NmcRRService where
68         parseJSON (Array a) =
69                 if length a == 6 then NmcRRService
70                         <$> parseJSON (a ! 0)
71                         <*> parseJSON (a ! 1)
72                         <*> parseJSON (a ! 2)
73                         <*> parseJSON (a ! 3)
74                         <*> parseJSON (a ! 4)
75                         <*> parseJSON (a ! 5)
76                 else empty
77         parseJSON _ = empty
78
79 instance Mergeable NmcRRService where
80         merge _ b = b
81
82 data NmcRRI2p = NmcRRI2p
83                         { i2pDestination :: String
84                         , i2pName        :: String
85                         , i2pB32         :: String
86                         } deriving (Show, Eq)
87
88 instance FromJSON NmcRRI2p where
89         parseJSON (Object o) = NmcRRI2p
90                 <$> o .: "destination"
91                 <*> o .: "name"
92                 <*> o .: "b32"
93         parseJSON _ = empty
94
95 instance Mergeable NmcRRI2p where
96         merge _ b = b
97
98 data NmcRRTls = NmcRRTls
99                         { tlsMatchType  :: Int -- 0:exact 1:sha256 2:sha512
100                         , tlsMatchValue :: String
101                         , tlsIncSubdoms :: Int -- 1:enforce on subdoms 0:no
102                         } deriving (Show, Eq)
103
104 instance FromJSON NmcRRTls where
105         parseJSON (Array a) =
106                 if length a == 3 then NmcRRTls
107                         <$> parseJSON (a ! 0)
108                         <*> parseJSON (a ! 1)
109                         <*> parseJSON (a ! 2)
110                 else empty
111         parseJSON _ = empty
112
113 instance Mergeable NmcRRTls where
114         merge _ b = b
115
116 data NmcRRDs = NmcRRDs
117                         { dsKeyTag      :: Int
118                         , dsAlgo        :: Int
119                         , dsHashType    :: Int
120                         , dsHashValue   :: String
121                         } deriving (Show, Eq)
122
123 instance FromJSON NmcRRDs where
124         parseJSON (Array a) =
125                 if length a == 4 then NmcRRDs
126                         <$> parseJSON (a ! 0)
127                         <*> parseJSON (a ! 1)
128                         <*> parseJSON (a ! 2)
129                         <*> parseJSON (a ! 3)
130                 else empty
131         parseJSON _ = empty
132
133 instance Mergeable NmcRRDs where
134         merge _ b = b
135
136 data NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]
137                         , domIp          :: Maybe [String]
138                         , domIp6         :: Maybe [String]
139                         , domTor         :: Maybe String
140                         , domI2p         :: Maybe NmcRRI2p
141                         , domFreenet     :: Maybe String
142                         , domAlias       :: Maybe String
143                         , domTranslate   :: Maybe String
144                         , domEmail       :: Maybe String
145                         , domLoc         :: Maybe String
146                         , domInfo        :: Maybe Value
147                         , domNs          :: Maybe [String]
148                         , domDelegate    :: Maybe String
149                         , domImport      :: Maybe [String]
150                         , domMap         :: Maybe (Map String NmcDom)
151                         , domFingerprint :: Maybe [String]
152                         , domTls         :: Maybe (Map String
153                                                     (Map String [NmcRRTls]))
154                         , domDs          :: Maybe [NmcRRDs]
155                         , domMx          :: Maybe [String] -- Synthetic
156                         , domSrv         :: Maybe [String] -- Synthetic
157                         } deriving (Show, Eq)
158
159 instance FromJSON NmcDom where
160         -- Wherever we expect a domain object, there may be a string
161         -- containing IPv4 address. Interpret it as such.
162         -- Question: shall we try to recognize IPv6 addresses too?
163         parseJSON (String s) =
164                  return $ if isIPv4 s'
165                             then emptyNmcDom { domIp = Just [s'] }
166                             else emptyNmcDom
167                           where
168                             s' = unpack s
169                             isIPv4 x = all isNibble $ splitOn "." x
170                             isNibble x =
171                               if all isDigit x then (read x :: Int) < 256
172                               else False
173         parseJSON (Object o) = NmcDom
174                 <$> o .:? "service"
175                 <*> o .:/ "ip"
176                 <*> o .:/ "ip6"
177                 <*> o .:? "tor"
178                 <*> o .:? "i2p"
179                 <*> o .:? "freenet"
180                 <*> o .:? "alias"
181                 <*> o .:? "translate"
182                 <*> o .:? "email"
183                 <*> o .:? "loc"
184                 <*> o .:? "info"
185                 <*> o .:/ "ns"
186                 <*> o .:? "delegate"
187                 <*> o .:/ "import"
188                 <*> o .:? "map"
189                 <*> o .:/ "fingerprint"
190                 <*> o .:? "tls"
191                 <*> o .:? "ds"
192                 <*> return Nothing -- domMx not parsed
193                 <*> return Nothing -- domSrv not parsed
194         parseJSON _ = empty
195
196 instance Mergeable NmcDom where
197         merge sub dom = dom     { domService =     mergelm domService
198                                 , domIp =          mergelm domIp
199                                 , domIp6 =         mergelm domIp6
200                                 , domTor =         choose  domTor
201                                 , domI2p =         mergelm domI2p
202                                 , domFreenet =     choose  domFreenet
203                                 , domAlias =       choose  domAlias
204                                 , domTranslate =   choose  domTranslate
205                                 , domEmail =       choose  domEmail
206                                 , domLoc =         choose  domLoc
207                                 , domInfo =        mergelm domInfo
208                                 , domNs =          mergelm domNs
209                                 , domDelegate =    mergelm domDelegate
210                                 , domImport =      mergelm domImport
211                                 , domMap =         mergelm domMap
212                                 , domFingerprint = mergelm domFingerprint
213                                 , domTls =         mergelm domTls
214                                 , domDs =          mergelm domDs
215                                 , domMx =          mergelm domMx
216                                 , domSrv =         mergelm domSrv
217                                 }
218           where
219                 mergelm x = merge (x sub) (x dom)
220 -- Because it is not possible to define instance of merge for Strings,
221 -- we have to treat string elements separately, otherwise strings are
222 -- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
223                 choose field = case field dom of
224                         Nothing -> field sub
225                         Just x  -> Just x
226
227 mergeNmcDom :: NmcDom -> NmcDom -> NmcDom
228 mergeNmcDom = merge
229
230 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
231                      Nothing Nothing Nothing Nothing Nothing Nothing
232                      Nothing Nothing Nothing Nothing Nothing Nothing
233                      Nothing Nothing