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