add .gitignore
[pdns-pipe-nmc.git] / NmcJson.hs
1 {-# LANGUAGE OverloadedStrings #-}
2
3 module NmcJson  ( NmcRes(..)
4                 , NmcDom(..)
5                 , emptyNmcDom
6                 , descendNmc
7                 ) where
8
9 import Data.ByteString.Lazy (ByteString)
10 import Data.Text as T (unpack)
11 import Data.List.Split
12 import Data.Char
13 import Data.Map as M (Map, lookup)
14 import Control.Applicative ((<$>), (<*>), empty)
15 import Data.Aeson
16
17 data NmcRRService = NmcRRService -- unused
18                         { srvName       :: String
19                         , srvProto      :: String
20                         , srvW1         :: Int
21                         , srvW2         :: Int
22                         , srvPort       :: Int
23                         , srvHost       :: [String]
24                         } deriving (Show, Eq)
25
26 instance FromJSON NmcRRService where
27         parseJSON (Object o) = NmcRRService
28                 <$> o .: "name"
29                 <*> o .: "proto"
30                 <*> o .: "w1"
31                 <*> o .: "w2"
32                 <*> o .: "port"
33                 <*> o .: "host"
34         parseJSON _ = empty
35
36 data NmcRRI2p = NmcRRI2p
37                         { i2pDestination :: String
38                         , i2pName        :: String
39                         , i2pB32         :: String
40                         } deriving (Show, Eq)
41
42 instance FromJSON NmcRRI2p where
43         parseJSON (Object o) = NmcRRI2p
44                 <$> o .: "destination"
45                 <*> o .: "name"
46                 <*> o .: "b32"
47         parseJSON _ = empty
48
49 data NmcDom = NmcDom    { domService     :: Maybe [[String]] -- [NmcRRService]
50                         , domIp          :: Maybe [String]
51                         , domIp6         :: Maybe [String]
52                         , domTor         :: Maybe String
53                         , domI2p         :: Maybe NmcRRI2p
54                         , domFreenet     :: Maybe String
55                         , domAlias       :: Maybe String
56                         , domTranslate   :: Maybe String
57                         , domEmail       :: Maybe String
58                         , domLoc         :: Maybe String
59                         , domInfo        :: Maybe Value
60                         , domNs          :: Maybe [String]
61                         , domDelegate    :: Maybe [String]
62                         , domImport      :: Maybe [[String]]
63                         , domMap         :: Maybe (Map String NmcDom)
64                         , domFingerprint :: Maybe [String]
65                         , domTls         :: Maybe (Map String
66                                                     (Map String [[String]]))
67                         , domDs          :: Maybe [[String]]
68                         } deriving (Show, Eq)
69
70 instance FromJSON NmcDom where
71         -- Wherever we expect a domain object, there may be a string
72         -- containing IPv4 address. Interpret it as such.
73         -- Question: shall we try to recognize IPv6 addresses too?
74         parseJSON (String s) =
75                  return $ if isIPv4 s'
76                             then emptyNmcDom { domIp = Just [s'] }
77                             else emptyNmcDom
78                           where
79                             s' = T.unpack s
80                             isIPv4 x = all isNibble $ splitOn "." x
81                             isNibble x =
82                               if all isDigit x then (read x :: Int) < 256
83                               else False
84         parseJSON (Object o) = NmcDom
85                 <$> o .:? "service"
86                 <*> o .:? "ip"
87                 <*> o .:? "ip6"
88                 <*> o .:? "tor"
89                 <*> o .:? "i2p"
90                 <*> o .:? "freenet"
91                 <*> o .:? "alias"
92                 <*> o .:? "translate"
93                 <*> o .:? "email"
94                 <*> o .:? "loc"
95                 <*> o .:? "info"
96                 <*> o .:? "ns"
97                 <*> o .:? "delegate"
98                 <*> o .:? "import"
99                 <*> o .:? "map"
100                 <*> o .:? "fingerprint"
101                 <*> o .:? "tls"
102                 <*> o .:? "ds"
103         parseJSON _ = empty
104
105 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
106                      Nothing Nothing Nothing Nothing Nothing Nothing
107                      Nothing Nothing Nothing Nothing Nothing Nothing
108
109 data NmcRes = NmcRes    { resName       :: String
110                         , resValue      :: ByteString -- string with NmcDom
111                         , resTxid       :: String
112                         , resAddress    :: String
113                         , resExpires_in :: Int
114                         } deriving (Show)
115 instance FromJSON NmcRes where
116         parseJSON (Object o) = NmcRes
117                 <$> o .: "name"
118                 <*> o .: "value"
119                 <*> o .: "txid"
120                 <*> o .: "address"
121                 <*> o .: "expires_in"
122         parseJSON _ = empty
123
124 normalizeDom :: NmcDom -> NmcDom
125 normalizeDom dom
126   | domNs        dom /= Nothing = emptyNmcDom { domNs    = domNs dom
127                                               , domEmail = domEmail dom
128                                               }
129   | domDelegate  dom /= Nothing = emptyNmcDom -- FIXME
130   | domTranslate dom /= Nothing = dom { domMap = Nothing }
131   | otherwise                   = dom
132
133 descendNmc :: [String] -> NmcDom -> NmcDom
134 descendNmc subdom rawdom =
135   let dom = normalizeDom rawdom
136   in case subdom of
137     []   ->
138       case domMap dom of
139         Nothing  -> dom
140         Just map ->
141           case M.lookup "" map of         -- Stupid, but there are "" in the map
142             Nothing  -> dom               -- Try to merge it with the root data
143             Just sub -> mergeNmc sub dom  -- Or maybe drop it altogether...
144     d:ds ->
145       case domMap dom of
146         Nothing  -> emptyNmcDom
147         Just map ->
148           case M.lookup d map of
149             Nothing  -> emptyNmcDom
150             Just sub -> descendNmc ds sub
151
152 -- FIXME -- I hope there exists a better way to merge records!
153 mergeNmc :: NmcDom -> NmcDom -> NmcDom
154 mergeNmc sub dom = dom  { domService = choose domService
155                         , domIp =          choose domIp
156                         , domIp6 =         choose domIp6
157                         , domTor =         choose domTor
158                         , domI2p =         choose domI2p
159                         , domFreenet =     choose domFreenet
160                         , domAlias =       choose domAlias
161                         , domTranslate =   choose domTranslate
162                         , domEmail =       choose domEmail
163                         , domLoc =         choose domLoc
164                         , domInfo =        choose domInfo
165                         , domNs =          choose domNs
166                         , domDelegate =    choose domDelegate
167                         , domImport =      choose domImport
168                         , domFingerprint = choose domFingerprint
169                         , domTls =         choose domTls
170                         , domDs =          choose domDs
171                         }
172   where
173     choose :: (NmcDom -> Maybe a) -> Maybe a
174     choose field = case field dom of
175       Nothing -> field sub
176       Just x  -> Just x