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