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 ((<$>), (<*>), liftA2, 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, insert, insertWith)
  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 = takeTls o `fmerge` takeSrv o `fmerge` takeMap o
  75   where fmerge = liftA2 merge
  76
  77 takeMap :: Object -> Parser (Maybe (Map String NmcDom))
  78 takeMap o =
  79   case H.lookup "map" o of
  80     Nothing          -> pure Nothing
  81     Just (Object mo) -> do
  82       raw <- (parseJSON (Object mo) :: Parser (Maybe (Map String NmcDom)))
  83       let result = fmap splitup raw
  84       return result
  85         where
  86           splitup :: Map String NmcDom -> Map String NmcDom
  87           splitup x = foldrWithKey stow M.empty x
  88           stow fqdn sdom acc = M.insertWith merge fqdn' sdom' acc
  89             where
  90               (fqdn', sdom') = nest (filter (/= "") (splitOnDots fqdn), sdom)
  91               splitOnDots s  = splitOn "." s
  92               nest ([], v)   = (fqdn, v) -- preserve "self" map entry
  93               nest ([k], v)  = (k, v)
  94               nest (k:ks, v) =
  95                 nest (ks, def { domSubmap = Just (M.singleton k v) })
  96     _ -> empty
  97
  98 takeSrv :: Object -> Parser (Maybe (Map String NmcDom))
  99 takeSrv o =
 100   case H.lookup "service" o of
 101     Nothing          -> pure Nothing
 102     Just (Array a) -> do
 103       isvl <- parseJSON (Array a)
 104       return $ foldr addSrv (Just M.empty) isvl
 105         where
 106           addSrv isv acc = subm `merge` acc
 107             where
 108               subm = Just (M.singleton ("_" ++ isvProto isv) sub2)
 109               sub2 = def { domSubmap =
 110                              Just (M.singleton ("_" ++ isvName isv) sub3) }
 111               sub3 = def { domSrv = Just [ NmcRRSrv (isvPrio isv)
 112                                                     (isvWeight isv)
 113                                                     (isvPort isv)
 114                                                     (isvHost isv) ] }
 115     Just _ -> empty
 116
 117 -- takeTls is almost, but not quite, entirely unlike takeSrv
 118 takeTls :: Object -> Parser (Maybe (Map String NmcDom))
 119 takeTls o =
 120   case H.lookup "tls" o of
 121     Nothing         -> pure Nothing
 122     Just (Object t) ->
 123       (parseJSON (Object t) :: Parser (Map String (Map String [NmcRRTlsa])))
 124         >>= tmap2dmap
 125           where
 126             tmap2dmap :: Map String (Map String [NmcRRTlsa])
 127                       -> Parser (Maybe (Map String NmcDom))
 128                 -- FIXME return parse error on invalid proto or port
 129             tmap2dmap m1 = return $ foldrWithKey addprotoelem (Just M.empty) m1
 130             addprotoelem k1 m2 acc = protoelem k1 m2 `merge` acc
 131             protoelem k1 m2 = Just (M.singleton ("_" ++ k1) (pmap2dmap m2))
 132             pmap2dmap m2 = foldrWithKey addportelem def m2
 133             addportelem k2 v acc = portelem k2 v `merge` acc
 134             portelem k2 v =
 135               def { domSubmap = Just (M.singleton ("_" ++ k2)
 136                                       def { domTlsa = Just v }) }
 137     Just _ -> empty
 138
 139 class Mergeable a where
 140         merge :: a -> a -> a -- bias towads second arg
 141
 142 instance (Ord k, Mergeable a) => Mergeable (Map k a) where
 143         merge mx my = unionWith merge my mx
 144
 145 -- Alas, the following is not possible in Haskell :-(
 146 -- instance Mergeable String where
 147 --         merge _ b = b
 148
 149 instance Mergeable Value where
 150         merge _ b = b
 151
 152 instance Mergeable a => Mergeable (Maybe a) where
 153         merge (Just x) (Just y) = Just (merge x y)
 154         merge Nothing  (Just y) = Just y
 155         merge (Just x) Nothing  = Just x
 156         merge Nothing  Nothing  = Nothing
 157
 158 instance Eq a => Mergeable [a] where
 159         merge xs ys = union xs ys
 160
 161 data NmcRRSrv = NmcRRSrv
 162                         { srvPrio       :: Int
 163                         , srvWeight     :: Int
 164                         , srvPort       :: Int
 165                         , srvHost       :: String
 166                         } deriving (Show, Eq)
 167
 168 instance Mergeable NmcRRSrv where
 169         merge _ b = b
 170
 171 data NmcRRI2p = NmcRRI2p
 172                         { i2pDestination :: Maybe String
 173                         , i2pName        :: Maybe String
 174                         , i2pB32         :: Maybe String
 175                         } deriving (Show, Eq)
 176
 177 instance FromJSON NmcRRI2p where
 178         parseJSON (Object o) = NmcRRI2p
 179                 <$> o .:? "destination"
 180                 <*> o .:? "name"
 181                 <*> o .:? "b32"
 182         parseJSON _ = empty
 183
 184 instance Mergeable NmcRRI2p where
 185         merge _ b = b
 186
 187 data NmcRRTlsa = NmcRRTlsa
 188                         { tlsMatchType  :: Int -- 0:exact 1:sha256 2:sha512
 189                         , tlsMatchValue :: String
 190                         , tlsIncSubdoms :: Int -- 1:enforce on subdoms 0:no
 191                         } deriving (Show, Eq)
 192
 193 instance FromJSON NmcRRTlsa where
 194         parseJSON (Array a) =
 195                 if length a == 3 then NmcRRTlsa
 196                         <$> parseJSON (a ! 0)
 197                         <*> parseJSON (a ! 1)
 198                         <*> parseJSON (a ! 2)
 199                 else empty
 200         parseJSON _ = empty
 201
 202 instance Mergeable NmcRRTlsa where
 203         merge _ b = b
 204
 205 data NmcRRDs = NmcRRDs
 206                         { dsKeyTag      :: Int
 207                         , dsAlgo        :: Int
 208                         , dsHashType    :: Int
 209                         , dsHashValue   :: String
 210                         } deriving (Show, Eq)
 211
 212 instance FromJSON NmcRRDs where
 213         parseJSON (Array a) =
 214                 if length a == 4 then NmcRRDs
 215                         <$> parseJSON (a ! 0)
 216                         <*> parseJSON (a ! 1)
 217                         <*> parseJSON (a ! 2)
 218                         <*> parseJSON (a ! 3)
 219                 else empty
 220         parseJSON _ = empty
 221
 222 instance Mergeable NmcRRDs where
 223         merge _ b = b
 224
 225 data NmcDom = NmcDom    { domIp          :: Maybe [String]
 226                         , domIp6         :: Maybe [String]
 227                         , domTor         :: Maybe String
 228                         , domI2p         :: Maybe NmcRRI2p
 229                         , domFreenet     :: Maybe String
 230                         , domAlias       :: Maybe String
 231                         , domTranslate   :: Maybe String
 232                         , domEmail       :: Maybe String
 233                         , domLoc         :: Maybe String
 234                         , domInfo        :: Maybe Value
 235                         , domNs          :: Maybe [String]
 236                         , domDelegate    :: Maybe String
 237                         , domImport      :: Maybe [String]
 238                         , domSubmap      :: Maybe (Map String NmcDom)
 239                         , domFingerprint :: Maybe [String]
 240                         , domDs          :: Maybe [NmcRRDs]
 241                         , domMx          :: Maybe [String]    -- Synthetic
 242                         , domSrv         :: Maybe [NmcRRSrv]  -- Synthetic
 243                         , domTlsa        :: Maybe [NmcRRTlsa] -- Synthetic
 244                         } deriving (Show, Eq)
 245
 246 instance Default NmcDom where
 247   def = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 248                Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 249                Nothing Nothing Nothing Nothing Nothing
 250
 251 instance FromJSON NmcDom where
 252         -- Wherever we expect a domain object, there may be a string
 253         -- containing IPv4 address. Interpret it as such.
 254         -- Question: shall we try to recognize IPv6 addresses too?
 255         parseJSON (String s) =
 256                  return $ if isIPv4 s'
 257                             then def { domIp = Just [s'] }
 258                             else def
 259                           where
 260                             s' = unpack s
 261                             isIPv4 x = all isNibble $ splitOn "." x
 262                             isNibble x =
 263                               if all isDigit x then (read x :: Int) < 256
 264                               else False
 265         parseJSON (Object o) = NmcDom
 266                 <$> o .:/ "ip"
 267                 <*> o .:/ "ip6"
 268                 <*> o .:? "tor"
 269                 <*> o .:? "i2p"
 270                 <*> o .:? "freenet"
 271                 <*> o .:? "alias"
 272                 <*> o .:? "translate"
 273                 <*> o .:? "email"
 274                 <*> o .:? "loc"
 275                 <*> o .:? "info"
 276                 <*> o .:/ "ns"
 277                 <*> o .:? "delegate"
 278                 <*> o .:/ "import"
 279                 <*> makeSubmap o
 280                 <*> o .:/ "fingerprint"
 281                 <*> o .:? "ds"
 282                 <*> makeMx o
 283                 <*> return Nothing -- domSrv created in subdomains
 284                 <*> return Nothing -- domTlsa created in subdomains
 285         parseJSON _ = empty
 286
 287 instance Mergeable NmcDom where
 288         merge sub dom = dom     { domIp =          mergelm domIp
 289                                 , domIp6 =         mergelm domIp6
 290                                 , domTor =         choose  domTor
 291                                 , domI2p =         mergelm domI2p
 292                                 , domFreenet =     choose  domFreenet
 293                                 , domAlias =       choose  domAlias
 294                                 , domTranslate =   choose  domTranslate
 295                                 , domEmail =       choose  domEmail
 296                                 , domLoc =         choose  domLoc
 297                                 , domInfo =        mergelm domInfo
 298                                 , domNs =          mergelm domNs
 299                                 , domDelegate =    mergelm domDelegate
 300                                 , domImport =      mergelm domImport
 301                                 , domSubmap =      mergelm domSubmap
 302                                 , domFingerprint = mergelm domFingerprint
 303                                 , domDs =          mergelm domDs
 304                                 , domMx =          mergelm domMx
 305                                 , domSrv =         mergelm domSrv
 306                                 , domTlsa =        mergelm domTlsa
 307                                 }
 308           where
 309                 mergelm x = merge (x sub) (x dom)
 310 -- Because it is not possible to define instance of merge for Strings,
 311 -- we have to treat string elements separately, otherwise strings are
 312 -- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
 313                 choose field = case field dom of
 314                         Nothing -> field sub
 315                         Just x  -> Just x