wip move 'synthetic' parsing into NmcDom
[pdns-pipe-nmc.git] / NmcDom.hs
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module NmcDom   ( NmcDom(..)
4                 , NmcRRSrv(..)
5                 , NmcRRI2p(..)
6                 , NmcRRTlsa(..)
7                 , NmcRRDs(..)
8                 , merge
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 makeMx :: Object -> Parser (Maybe [String])
38 makeMx o = return Nothing -- FIXME
39 {-
40   case H.lookup "service" o of
41     Nothing          -> pure Nothing
42     Just (Array saa) -> return $ Just $ fmap mxStr $ filter mxMatch saa
43       where
44         mxMatch sa = (sa ! 0) == "smtp" && (sa ! 1) == "tcp" && (sa ! 4) == 25
45         mxStr sa = (sa ! 2) ++ "\t" ++ (sa ! 5)
46     _                -> empty
47 -}
48 makeSubmap :: Object -> Parser (Maybe (Map String NmcDom))
49 makeSubmap o = o .:? "map" -- FIXME
50
51 class Mergeable a where
52         merge :: a -> a -> a -- bias towads second arg
53
54 instance (Ord k, Mergeable a) => Mergeable (Map k a) where
55         merge mx my = unionWith merge my mx
56
57 -- Alas, the following is not possible in Haskell :-(
58 -- instance Mergeable String where
59 --         merge _ b = b
60
61 instance Mergeable Value where
62         merge _ b = b
63
64 instance Mergeable a => Mergeable (Maybe a) where
65         merge (Just x) (Just y) = Just (merge x y)
66         merge Nothing  (Just y) = Just y
67         merge (Just x) Nothing  = Just x
68         merge Nothing  Nothing  = Nothing
69
70 instance Eq a => Mergeable [a] where
71         merge xs ys = union xs ys
72
73 data NmcRRSrv = NmcRRSrv
74                         { srvPrio       :: Int
75                         , srvWeight     :: Int
76                         , srvPort       :: Int
77                         , srvHost       :: String
78                         } deriving (Show, Eq)
79
80 instance Mergeable NmcRRSrv 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 NmcRRTlsa = NmcRRTlsa
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 Mergeable NmcRRTlsa where
106         merge _ b = b
107
108 data NmcRRDs = NmcRRDs
109                         { dsKeyTag      :: Int
110                         , dsAlgo        :: Int
111                         , dsHashType    :: Int
112                         , dsHashValue   :: String
113                         } deriving (Show, Eq)
114
115 instance FromJSON NmcRRDs where
116         parseJSON (Array a) =
117                 if length a == 4 then NmcRRDs
118                         <$> parseJSON (a ! 0)
119                         <*> parseJSON (a ! 1)
120                         <*> parseJSON (a ! 2)
121                         <*> parseJSON (a ! 3)
122                 else empty
123         parseJSON _ = empty
124
125 instance Mergeable NmcRRDs where
126         merge _ b = b
127
128 data NmcDom = NmcDom    { domIp          :: Maybe [String]
129                         , domIp6         :: Maybe [String]
130                         , domTor         :: Maybe String
131                         , domI2p         :: Maybe NmcRRI2p
132                         , domFreenet     :: Maybe String
133                         , domAlias       :: Maybe String
134                         , domTranslate   :: Maybe String
135                         , domEmail       :: Maybe String
136                         , domLoc         :: Maybe String
137                         , domInfo        :: Maybe Value
138                         , domNs          :: Maybe [String]
139                         , domDelegate    :: Maybe String
140                         , domImport      :: Maybe [String]
141                         , domSubmap      :: Maybe (Map String NmcDom)
142                         , domFingerprint :: Maybe [String]
143                         , domDs          :: Maybe [NmcRRDs]
144                         , domMx          :: Maybe [String]    -- Synthetic
145                         , domSrv         :: Maybe [NmcRRSrv]  -- Synthetic
146                         , domTlsa        :: Maybe [NmcRRTlsa] -- Synthetic
147                         } deriving (Show, Eq)
148
149 instance Default NmcDom where
150   def = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing
151                Nothing Nothing Nothing Nothing Nothing Nothing Nothing
152                Nothing Nothing Nothing Nothing Nothing
153
154 instance FromJSON NmcDom where
155         -- Wherever we expect a domain object, there may be a string
156         -- containing IPv4 address. Interpret it as such.
157         -- Question: shall we try to recognize IPv6 addresses too?
158         parseJSON (String s) =
159                  return $ if isIPv4 s'
160                             then def { domIp = Just [s'] }
161                             else def
162                           where
163                             s' = unpack s
164                             isIPv4 x = all isNibble $ splitOn "." x
165                             isNibble x =
166                               if all isDigit x then (read x :: Int) < 256
167                               else False
168         parseJSON (Object o) = NmcDom
169                 <$> o .:/ "ip"
170                 <*> o .:/ "ip6"
171                 <*> o .:? "tor"
172                 <*> o .:? "i2p"
173                 <*> o .:? "freenet"
174                 <*> o .:? "alias"
175                 <*> o .:? "translate"
176                 <*> o .:? "email"
177                 <*> o .:? "loc"
178                 <*> o .:? "info"
179                 <*> o .:/ "ns"
180                 <*> o .:? "delegate"
181                 <*> o .:/ "import"
182                 <*> makeSubmap o
183                 <*> o .:/ "fingerprint"
184                 <*> o .:? "ds"
185                 <*> makeMx o
186                 <*> return Nothing -- domSrv created in subdomains
187                 <*> return Nothing -- domTlsa created in subdomains
188         parseJSON _ = empty
189
190 instance Mergeable NmcDom where
191         merge sub dom = dom     { domIp =          mergelm domIp
192                                 , domIp6 =         mergelm domIp6
193                                 , domTor =         choose  domTor
194                                 , domI2p =         mergelm domI2p
195                                 , domFreenet =     choose  domFreenet
196                                 , domAlias =       choose  domAlias
197                                 , domTranslate =   choose  domTranslate
198                                 , domEmail =       choose  domEmail
199                                 , domLoc =         choose  domLoc
200                                 , domInfo =        mergelm domInfo
201                                 , domNs =          mergelm domNs
202                                 , domDelegate =    mergelm domDelegate
203                                 , domImport =      mergelm domImport
204                                 , domSubmap =      mergelm domSubmap
205                                 , domFingerprint = mergelm domFingerprint
206                                 , domDs =          mergelm domDs
207                                 , domMx =          mergelm domMx
208                                 , domSrv =         mergelm domSrv
209                                 , domTlsa =        mergelm domTlsa
210                                 }
211           where
212                 mergelm x = merge (x sub) (x dom)
213 -- Because it is not possible to define instance of merge for Strings,
214 -- we have to treat string elements separately, otherwise strings are
215 -- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
216                 choose field = case field dom of
217                         Nothing -> field sub
218                         Just x  -> Just x