]> www.average.org Git - pdns-pipe-nmc.git/blob - NmcDom.hs
use Data.Default.Class for empty NmcDom
[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                         } deriving (Show, Eq)
159
160 instance Default NmcDom where
161   def = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing
162                Nothing Nothing Nothing Nothing Nothing Nothing Nothing
163                Nothing Nothing Nothing Nothing Nothing Nothing
164
165 instance FromJSON NmcDom where
166         -- Wherever we expect a domain object, there may be a string
167         -- containing IPv4 address. Interpret it as such.
168         -- Question: shall we try to recognize IPv6 addresses too?
169         parseJSON (String s) =
170                  return $ if isIPv4 s'
171                             then def { domIp = Just [s'] }
172                             else def
173                           where
174                             s' = unpack s
175                             isIPv4 x = all isNibble $ splitOn "." x
176                             isNibble x =
177                               if all isDigit x then (read x :: Int) < 256
178                               else False
179         parseJSON (Object o) = NmcDom
180                 <$> o .:? "service"
181                 <*> o .:/ "ip"
182                 <*> o .:/ "ip6"
183                 <*> o .:? "tor"
184                 <*> o .:? "i2p"
185                 <*> o .:? "freenet"
186                 <*> o .:? "alias"
187                 <*> o .:? "translate"
188                 <*> o .:? "email"
189                 <*> o .:? "loc"
190                 <*> o .:? "info"
191                 <*> o .:/ "ns"
192                 <*> o .:? "delegate"
193                 <*> o .:/ "import"
194                 <*> o .:? "map"
195                 <*> o .:/ "fingerprint"
196                 <*> o .:? "tls"
197                 <*> o .:? "ds"
198                 <*> return Nothing -- domMx not parsed
199                 <*> return Nothing -- domSrv not parsed
200         parseJSON _ = empty
201
202 instance Mergeable NmcDom where
203         merge sub dom = dom     { domService =     mergelm domService
204                                 , domIp =          mergelm domIp
205                                 , domIp6 =         mergelm domIp6
206                                 , domTor =         choose  domTor
207                                 , domI2p =         mergelm domI2p
208                                 , domFreenet =     choose  domFreenet
209                                 , domAlias =       choose  domAlias
210                                 , domTranslate =   choose  domTranslate
211                                 , domEmail =       choose  domEmail
212                                 , domLoc =         choose  domLoc
213                                 , domInfo =        mergelm domInfo
214                                 , domNs =          mergelm domNs
215                                 , domDelegate =    mergelm domDelegate
216                                 , domImport =      mergelm domImport
217                                 , domMap =         mergelm domMap
218                                 , domFingerprint = mergelm domFingerprint
219                                 , domTls =         mergelm domTls
220                                 , domDs =          mergelm domDs
221                                 , domMx =          mergelm domMx
222                                 , domSrv =         mergelm domSrv
223                                 }
224           where
225                 mergelm x = merge (x sub) (x dom)
226 -- Because it is not possible to define instance of merge for Strings,
227 -- we have to treat string elements separately, otherwise strings are
228 -- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
229                 choose field = case field dom of
230                         Nothing -> field sub
231                         Just x  -> Just x
232
233 mergeNmcDom :: NmcDom -> NmcDom -> NmcDom
234 mergeNmcDom = merge