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