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)
  18 import qualified Data.Vector as V (singleton)
  19 import Data.Map (Map, unionWith, foldrWithKey)
  20 import qualified Data.Map as M (singleton, empty)
  21 import qualified Data.HashMap.Strict as H (lookup)
  22 import Data.Aeson
  23 import Data.Aeson.Types
  24 import Data.Default.Class
  25
  26 -- Variant of Aeson's `.:?` that interprets a String as a
  27 -- single-element list, so it is possible to have either
  28 --      "ip":["1.2.3.4"]
  29 -- or
  30 --      "ip":"1.2.3.4"
  31 -- with the same result.
  32 (.:/) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
  33 obj .:/ key = case H.lookup key obj of
  34                Nothing -> pure Nothing
  35                Just v  -> case v of
  36                         String s -> parseJSON $ Array (V.singleton v)
  37                         _        -> parseJSON v
  38
  39 data IntRRService = IntRRService { isvName       :: String
  40                                  , isvProto      :: String
  41                                  , isvPrio       :: Int
  42                                  , isvWeight     :: Int
  43                                  , isvPort       :: Int
  44                                  , isvHost       :: String
  45                                  } deriving (Show, Eq)
  46
  47 instance FromJSON IntRRService where
  48         parseJSON (Array a) =
  49                 if length a == 6 then IntRRService
  50                         <$> parseJSON (a ! 0)
  51                         <*> parseJSON (a ! 1)
  52                         <*> parseJSON (a ! 2)
  53                         <*> parseJSON (a ! 3)
  54                         <*> parseJSON (a ! 4)
  55                         <*> parseJSON (a ! 5)
  56                 else empty
  57         parseJSON _ = empty
  58
  59 makeMx :: Object -> Parser (Maybe [String])
  60 makeMx o =
  61   case H.lookup "service" o of
  62     Nothing          -> pure Nothing
  63     Just (Array a) -> do
  64       isvl <- parseJSON (Array a)
  65       return $ Just $ map mxStr $ filter mxMatch isvl
  66         where
  67           mxMatch isv = isvName isv  == "smtp"
  68                      && isvProto isv == "tcp"
  69                      && isvPort isv  == 25
  70           mxStr isv = (show (isvPrio isv)) ++ "\t" ++ (isvHost isv)
  71     Just _ -> empty
  72
  73 makeSubmap :: Object -> Parser (Maybe (Map String NmcDom))
  74 makeSubmap o = ((.).(.)) merge merge <$> takeTls o <*> takeSrv o <*> takeMap o
  75
  76 takeMap :: Object -> Parser (Maybe (Map String NmcDom))
  77 takeMap o = o .:? "map" -- FIXME split over dots here
  78
  79 takeSrv :: Object -> Parser (Maybe (Map String NmcDom))
  80 takeSrv o =
  81   case H.lookup "service" o of
  82     Nothing          -> pure Nothing
  83     Just (Array a) -> do
  84       isvl <- parseJSON (Array a)
  85       return $ foldr addSrv (Just M.empty) isvl
  86         where
  87           addSrv isv acc = subm `merge` acc
  88             where
  89               subm = Just (M.singleton ("_" ++ isvProto isv) sub2)
  90               sub2 = def { domSubmap =
  91                              Just (M.singleton ("_" ++ isvName isv) sub3) }
  92               sub3 = def { domSrv = Just [ NmcRRSrv (isvPrio isv)
  93                                                     (isvWeight isv)
  94                                                     (isvPort isv)
  95                                                     (isvHost isv) ] }
  96     Just _ -> empty
  97
  98 -- takeTls is almost, but not quite, entirely unlike takeSrv
  99 takeTls :: Object -> Parser (Maybe (Map String NmcDom))
 100 takeTls o =
 101   case H.lookup "tls" o of
 102     Nothing         -> pure Nothing
 103     Just (Object t) ->
 104       (parseJSON (Object t) :: Parser (Map String (Map String [NmcRRTlsa])))
 105         >>= tmap2dmap
 106           where
 107             tmap2dmap :: Map String (Map String [NmcRRTlsa])
 108                       -> Parser (Maybe (Map String NmcDom))
 109                 -- FIXME return parse error on invalid proto or port
 110             tmap2dmap m1 = return $ foldrWithKey addprotoelem (Just M.empty) m1
 111             addprotoelem k1 m2 acc = protoelem k1 m2 `merge` acc
 112             protoelem k1 m2 = Just (M.singleton ("_" ++ k1) (pmap2dmap m2))
 113             pmap2dmap m2 = foldrWithKey addportelem def m2
 114             addportelem k2 v acc = portelem k2 v `merge` acc
 115             portelem k2 v =
 116               def { domSubmap = Just (M.singleton ("_" ++ k2)
 117                                       def { domTlsa = Just v }) }
 118     Just _ -> empty
 119
 120 class Mergeable a where
 121         merge :: a -> a -> a -- bias towads second arg
 122
 123 instance (Ord k, Mergeable a) => Mergeable (Map k a) where
 124         merge mx my = unionWith merge my mx
 125
 126 -- Alas, the following is not possible in Haskell :-(
 127 -- instance Mergeable String where
 128 --         merge _ b = b
 129
 130 instance Mergeable Value where
 131         merge _ b = b
 132
 133 instance Mergeable a => Mergeable (Maybe a) where
 134         merge (Just x) (Just y) = Just (merge x y)
 135         merge Nothing  (Just y) = Just y
 136         merge (Just x) Nothing  = Just x
 137         merge Nothing  Nothing  = Nothing
 138
 139 instance Eq a => Mergeable [a] where
 140         merge xs ys = union xs ys
 141
 142 data NmcRRSrv = NmcRRSrv
 143                         { srvPrio       :: Int
 144                         , srvWeight     :: Int
 145                         , srvPort       :: Int
 146                         , srvHost       :: String
 147                         } deriving (Show, Eq)
 148
 149 instance Mergeable NmcRRSrv where
 150         merge _ b = b
 151
 152 data NmcRRI2p = NmcRRI2p
 153                         { i2pDestination :: Maybe String
 154                         , i2pName        :: Maybe String
 155                         , i2pB32         :: Maybe String
 156                         } deriving (Show, Eq)
 157
 158 instance FromJSON NmcRRI2p where
 159         parseJSON (Object o) = NmcRRI2p
 160                 <$> o .:? "destination"
 161                 <*> o .:? "name"
 162                 <*> o .:? "b32"
 163         parseJSON _ = empty
 164
 165 instance Mergeable NmcRRI2p where
 166         merge _ b = b
 167
 168 data NmcRRTlsa = NmcRRTlsa
 169                         { tlsMatchType  :: Int -- 0:exact 1:sha256 2:sha512
 170                         , tlsMatchValue :: String
 171                         , tlsIncSubdoms :: Int -- 1:enforce on subdoms 0:no
 172                         } deriving (Show, Eq)
 173
 174 instance FromJSON NmcRRTlsa where
 175         parseJSON (Array a) =
 176                 if length a == 3 then NmcRRTlsa
 177                         <$> parseJSON (a ! 0)
 178                         <*> parseJSON (a ! 1)
 179                         <*> parseJSON (a ! 2)
 180                 else empty
 181         parseJSON _ = empty
 182
 183 instance Mergeable NmcRRTlsa where
 184         merge _ b = b
 185
 186 data NmcRRDs = NmcRRDs
 187                         { dsKeyTag      :: Int
 188                         , dsAlgo        :: Int
 189                         , dsHashType    :: Int
 190                         , dsHashValue   :: String
 191                         } deriving (Show, Eq)
 192
 193 instance FromJSON NmcRRDs where
 194         parseJSON (Array a) =
 195                 if length a == 4 then NmcRRDs
 196                         <$> parseJSON (a ! 0)
 197                         <*> parseJSON (a ! 1)
 198                         <*> parseJSON (a ! 2)
 199                         <*> parseJSON (a ! 3)
 200                 else empty
 201         parseJSON _ = empty
 202
 203 instance Mergeable NmcRRDs where
 204         merge _ b = b
 205
 206 data NmcDom = NmcDom    { domIp          :: Maybe [String]
 207                         , domIp6         :: Maybe [String]
 208                         , domTor         :: Maybe String
 209                         , domI2p         :: Maybe NmcRRI2p
 210                         , domFreenet     :: Maybe String
 211                         , domAlias       :: Maybe String
 212                         , domTranslate   :: Maybe String
 213                         , domEmail       :: Maybe String
 214                         , domLoc         :: Maybe String
 215                         , domInfo        :: Maybe Value
 216                         , domNs          :: Maybe [String]
 217                         , domDelegate    :: Maybe String
 218                         , domImport      :: Maybe [String]
 219                         , domSubmap      :: Maybe (Map String NmcDom)
 220                         , domFingerprint :: Maybe [String]
 221                         , domDs          :: Maybe [NmcRRDs]
 222                         , domMx          :: Maybe [String]    -- Synthetic
 223                         , domSrv         :: Maybe [NmcRRSrv]  -- Synthetic
 224                         , domTlsa        :: Maybe [NmcRRTlsa] -- Synthetic
 225                         } deriving (Show, Eq)
 226
 227 instance Default NmcDom where
 228   def = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 229                Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 230                Nothing Nothing Nothing Nothing Nothing
 231
 232 instance FromJSON NmcDom where
 233         -- Wherever we expect a domain object, there may be a string
 234         -- containing IPv4 address. Interpret it as such.
 235         -- Question: shall we try to recognize IPv6 addresses too?
 236         parseJSON (String s) =
 237                  return $ if isIPv4 s'
 238                             then def { domIp = Just [s'] }
 239                             else def
 240                           where
 241                             s' = unpack s
 242                             isIPv4 x = all isNibble $ splitOn "." x
 243                             isNibble x =
 244                               if all isDigit x then (read x :: Int) < 256
 245                               else False
 246         parseJSON (Object o) = NmcDom
 247                 <$> o .:/ "ip"
 248                 <*> o .:/ "ip6"
 249                 <*> o .:? "tor"
 250                 <*> o .:? "i2p"
 251                 <*> o .:? "freenet"
 252                 <*> o .:? "alias"
 253                 <*> o .:? "translate"
 254                 <*> o .:? "email"
 255                 <*> o .:? "loc"
 256                 <*> o .:? "info"
 257                 <*> o .:/ "ns"
 258                 <*> o .:? "delegate"
 259                 <*> o .:/ "import"
 260                 <*> makeSubmap o
 261                 <*> o .:/ "fingerprint"
 262                 <*> o .:? "ds"
 263                 <*> makeMx o
 264                 <*> return Nothing -- domSrv created in subdomains
 265                 <*> return Nothing -- domTlsa created in subdomains
 266         parseJSON _ = empty
 267
 268 instance Mergeable NmcDom where
 269         merge sub dom = dom     { domIp =          mergelm domIp
 270                                 , domIp6 =         mergelm domIp6
 271                                 , domTor =         choose  domTor
 272                                 , domI2p =         mergelm domI2p
 273                                 , domFreenet =     choose  domFreenet
 274                                 , domAlias =       choose  domAlias
 275                                 , domTranslate =   choose  domTranslate
 276                                 , domEmail =       choose  domEmail
 277                                 , domLoc =         choose  domLoc
 278                                 , domInfo =        mergelm domInfo
 279                                 , domNs =          mergelm domNs
 280                                 , domDelegate =    mergelm domDelegate
 281                                 , domImport =      mergelm domImport
 282                                 , domSubmap =      mergelm domSubmap
 283                                 , domFingerprint = mergelm domFingerprint
 284                                 , domDs =          mergelm domDs
 285                                 , domMx =          mergelm domMx
 286                                 , domSrv =         mergelm domSrv
 287                                 , domTlsa =        mergelm domTlsa
 288                                 }
 289           where
 290                 mergelm x = merge (x sub) (x dom)
 291 -- Because it is not possible to define instance of merge for Strings,
 292 -- we have to treat string elements separately, otherwise strings are
 293 -- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
 294                 choose field = case field dom of
 295                         Nothing -> field sub
 296                         Just x  -> Just x