NmcDom.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2
   3 module NmcDom   ( NmcDom(..)
   4                 , NmcRRService(..)
   5                 , emptyNmcDom
   6                 , seedNmcDom
   7                 , descendNmcDom
   8                 ) where
   9
  10 import Prelude hiding (length)
  11 import Data.ByteString.Lazy (ByteString)
  12 import Data.Text (Text, unpack)
  13 import Data.List as L (union)
  14 import Data.List.Split
  15 import Data.Char
  16 import Data.Map as M (Map, lookup, delete, size, unionWith)
  17 import Data.Vector (toList,(!),length, singleton)
  18 import Control.Monad (foldM)
  19 import Control.Applicative ((<$>), (<*>), empty, pure)
  20 import Data.Aeson
  21
  22 import qualified Data.HashMap.Strict as H
  23 import Data.Aeson.Types
  24
  25 -- Variant of Aeson's `.:?` that interprets a String as a
  26 -- single-element list, so it is possible to have either
  27 --      "ip":["1.2.3.4"]
  28 -- or
  29 --      "ip":"1.2.3.4"
  30 -- with the same result.
  31 (.:/) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
  32 obj .:/ key = case H.lookup key obj of
  33                Nothing -> pure Nothing
  34                Just v  -> case v of
  35                         String s -> parseJSON $ Array (singleton v)
  36                         _        -> parseJSON v
  37
  38 class Mergeable a where
  39         merge :: a -> a -> a -- bias towads second arg
  40
  41 instance (Ord k, Mergeable a) => Mergeable (Map k a) where
  42         merge mx my = M.unionWith merge my mx
  43
  44 -- Alas, the following is not possible in Haskell :-(
  45 -- instance Mergeable String where
  46 --         merge _ b = b
  47
  48 instance Mergeable Value where
  49         merge _ b = b
  50
  51 instance Mergeable a => Mergeable (Maybe a) where
  52         merge (Just x) (Just y) = Just (merge x y)
  53         merge Nothing  (Just y) = Just y
  54         merge (Just x) Nothing  = Just x
  55         merge Nothing  Nothing  = Nothing
  56
  57 instance Eq a => Mergeable [a] where
  58         merge xs ys = L.union xs ys
  59
  60 data NmcRRService = NmcRRService
  61                         { srvName       :: String
  62                         , srvProto      :: String
  63                         , srvPrio       :: Int
  64                         , srvWeight     :: Int
  65                         , srvPort       :: Int
  66                         , srvHost       :: String
  67                         } deriving (Show, Eq)
  68
  69 instance FromJSON NmcRRService where
  70         parseJSON (Array a) =
  71                 if length a == 6 then NmcRRService
  72                         <$> parseJSON (a ! 0)
  73                         <*> parseJSON (a ! 1)
  74                         <*> parseJSON (a ! 2)
  75                         <*> parseJSON (a ! 3)
  76                         <*> parseJSON (a ! 4)
  77                         <*> parseJSON (a ! 5)
  78                 else empty
  79         parseJSON _ = empty
  80
  81 instance Mergeable NmcRRService where
  82         merge _ b = b
  83
  84 data NmcRRI2p = NmcRRI2p
  85                         { i2pDestination :: String
  86                         , i2pName        :: String
  87                         , i2pB32         :: String
  88                         } deriving (Show, Eq)
  89
  90 instance FromJSON NmcRRI2p where
  91         parseJSON (Object o) = NmcRRI2p
  92                 <$> o .: "destination"
  93                 <*> o .: "name"
  94                 <*> o .: "b32"
  95         parseJSON _ = empty
  96
  97 instance Mergeable NmcRRI2p where
  98         merge _ b = b
  99
 100 data NmcRRTls = NmcRRTls
 101                         { tlsMatchType  :: Int -- 0:exact 1:sha256 2:sha512
 102                         , tlsMatchValue :: String
 103                         , tlsIncSubdoms :: Int -- 1:enforce on subdoms 0:no
 104                         } deriving (Show, Eq)
 105
 106 instance FromJSON NmcRRTls where
 107         parseJSON (Array a) =
 108                 if length a == 3 then NmcRRTls
 109                         <$> parseJSON (a ! 0)
 110                         <*> parseJSON (a ! 1)
 111                         <*> parseJSON (a ! 2)
 112                 else empty
 113         parseJSON _ = empty
 114
 115 instance Mergeable NmcRRTls where
 116         merge _ b = b
 117
 118 data NmcRRDs = NmcRRDs
 119                         { dsKeyTag      :: Int
 120                         , dsAlgo        :: Int
 121                         , dsHashType    :: Int
 122                         , dsHashValue   :: String
 123                         } deriving (Show, Eq)
 124
 125 instance FromJSON NmcRRDs where
 126         parseJSON (Array a) =
 127                 if length a == 4 then NmcRRDs
 128                         <$> parseJSON (a ! 0)
 129                         <*> parseJSON (a ! 1)
 130                         <*> parseJSON (a ! 2)
 131                         <*> parseJSON (a ! 3)
 132                 else empty
 133         parseJSON _ = empty
 134
 135 instance Mergeable NmcRRDs where
 136         merge _ b = b
 137
 138 data NmcDom = NmcDom    { domService     :: Maybe [NmcRRService]
 139                         , domIp          :: Maybe [String]
 140                         , domIp6         :: Maybe [String]
 141                         , domTor         :: Maybe String
 142                         , domI2p         :: Maybe NmcRRI2p
 143                         , domFreenet     :: Maybe String
 144                         , domAlias       :: Maybe String
 145                         , domTranslate   :: Maybe String
 146                         , domEmail       :: Maybe String
 147                         , domLoc         :: Maybe String
 148                         , domInfo        :: Maybe Value
 149                         , domNs          :: Maybe [String]
 150                         , domDelegate    :: Maybe String
 151                         , domImport      :: Maybe [String]
 152                         , domMap         :: Maybe (Map String NmcDom)
 153                         , domFingerprint :: Maybe [String]
 154                         , domTls         :: Maybe (Map String
 155                                                     (Map String [NmcRRTls]))
 156                         , domDs          :: Maybe [NmcRRDs]
 157                         , domMx          :: Maybe [String] -- Synthetic
 158                         } deriving (Show, Eq)
 159
 160 instance FromJSON NmcDom where
 161         -- Wherever we expect a domain object, there may be a string
 162         -- containing IPv4 address. Interpret it as such.
 163         -- Question: shall we try to recognize IPv6 addresses too?
 164         parseJSON (String s) =
 165                  return $ if isIPv4 s'
 166                             then emptyNmcDom { domIp = Just [s'] }
 167                             else emptyNmcDom
 168                           where
 169                             s' = unpack s
 170                             isIPv4 x = all isNibble $ splitOn "." x
 171                             isNibble x =
 172                               if all isDigit x then (read x :: Int) < 256
 173                               else False
 174         parseJSON (Object o) = NmcDom
 175                 <$> o .:? "service"
 176                 <*> o .:/ "ip"
 177                 <*> o .:/ "ip6"
 178                 <*> o .:? "tor"
 179                 <*> o .:? "i2p"
 180                 <*> o .:? "freenet"
 181                 <*> o .:? "alias"
 182                 <*> o .:? "translate"
 183                 <*> o .:? "email"
 184                 <*> o .:? "loc"
 185                 <*> o .:? "info"
 186                 <*> o .:/ "ns"
 187                 <*> o .:? "delegate"
 188                 <*> o .:/ "import"
 189                 <*> o .:? "map"
 190                 <*> o .:/ "fingerprint"
 191                 <*> o .:? "tls"
 192                 <*> o .:? "ds"
 193                 <*> return Nothing -- domMx not parsed
 194         parseJSON _ = empty
 195
 196 instance Mergeable NmcDom where
 197         merge sub dom = dom     { domService =     mergelm domService
 198                                 , domIp =          mergelm domIp
 199                                 , domIp6 =         mergelm domIp6
 200                                 , domTor =         choose  domTor
 201                                 , domI2p =         mergelm domI2p
 202                                 , domFreenet =     choose  domFreenet
 203                                 , domAlias =       choose  domAlias
 204                                 , domTranslate =   choose  domTranslate
 205                                 , domEmail =       choose  domEmail
 206                                 , domLoc =         choose  domLoc
 207                                 , domInfo =        mergelm domInfo
 208                                 , domNs =          mergelm domNs
 209                                 , domDelegate =    mergelm domDelegate
 210                                 , domImport =      mergelm domImport
 211                                 , domMap =         mergelm domMap
 212                                 , domFingerprint = mergelm domFingerprint
 213                                 , domTls =         mergelm domTls
 214                                 , domDs =          mergelm domDs
 215                                 , domMx =          mergelm domMx
 216                                 }
 217           where
 218                 mergelm x = merge (x sub) (x dom)
 219 -- Because it is not possible to define instance of merge for Strings,
 220 -- we have to treat string elements separately, otherwise strings are
 221 -- 'unioned' along with the rest of lists. Ugly, but alternatives are worse.
 222                 choose field = case field dom of
 223                         Nothing -> field sub
 224                         Just x  -> Just x
 225
 226
 227 emptyNmcDom = NmcDom Nothing Nothing Nothing Nothing Nothing Nothing
 228                      Nothing Nothing Nothing Nothing Nothing Nothing
 229                      Nothing Nothing Nothing Nothing Nothing Nothing
 230                      Nothing
 231
 232 -- | Perform query and return error string or parsed domain object
 233 queryNmcDom ::
 234   (String -> IO (Either String ByteString)) -- ^ query operation action
 235   -> String                                 -- ^ key
 236   -> IO (Either String NmcDom)              -- ^ error string or domain
 237 queryNmcDom queryOp key = do
 238   l <- queryOp key
 239   case l of
 240     Left estr -> return $ Left estr
 241     Right str -> case decode str :: Maybe NmcDom of
 242       Nothing  -> return $ Left $ "Unparseable value: " ++ (show str)
 243       Just dom -> return $ Right dom
 244
 245 -- | Try to fetch "import" object and merge it into the base domain
 246 --   Original "import" element is removed, but new imports from the
 247 --   imported objects are processed recursively until there are none.
 248 mergeImport ::
 249   (String -> IO (Either String ByteString)) -- ^ query operation action
 250   -> Int                                    -- ^ recursion counter
 251   -> NmcDom                                 -- ^ base domain
 252   -> IO (Either String NmcDom)              -- ^ result with merged import
 253 mergeImport queryOp depth base = do
 254   let
 255     mbase = mergeSelf base
 256     base' = mbase {domImport = Nothing}
 257   -- print base
 258   if depth <= 0 then return $ Left "Nesting of imports is too deep"
 259   else case domImport mbase of
 260     Nothing  -> return $ Right base'
 261     Just keys -> foldM mergeImport1 (Right base') keys
 262       where
 263         mergeImport1 (Left  err) _   = return $ Left err
 264         mergeImport1 (Right acc) key = do
 265           sub <- queryNmcDom queryOp key
 266           case sub of
 267             Left  err  -> return $ Left err
 268             Right sub' -> mergeImport queryOp (depth - 1) $ sub' `merge` acc
 269
 270 -- | If there is an element in the map with key "", merge the contents
 271 --   and remove this element. Do this recursively.
 272 mergeSelf :: NmcDom -> NmcDom
 273 mergeSelf base =
 274   let
 275     map   = domMap base
 276     base' = base {domMap = removeSelf map}
 277     removeSelf Nothing    = Nothing
 278     removeSelf (Just map) = if size map' == 0 then Nothing else Just map'
 279       where map' = M.delete "" map
 280   in
 281     case map of
 282       Nothing   -> base'
 283       Just map' ->
 284         case M.lookup "" map' of
 285           Nothing  -> base'
 286           Just sub -> (mergeSelf sub) `merge` base'
 287         -- recursion depth limited by the size of the record
 288
 289 -- | SRV case - remove everyting and filter SRV records
 290 normalizeSrv :: String -> String -> NmcDom -> NmcDom
 291 normalizeSrv serv proto dom =
 292   emptyNmcDom {domService = fmap (filter needed) (domService dom)}
 293     where
 294       needed r = srvName r == serv && srvProto r == proto
 295
 296 -- | Presence of some elements require removal of some others
 297 normalizeDom :: NmcDom -> NmcDom
 298 normalizeDom dom = foldr id dom [ srvNormalizer
 299                                 , translateNormalizer
 300                                 , nsNormalizer
 301                                 ]
 302   where
 303     nsNormalizer dom = case domNs dom of
 304       Nothing  -> dom
 305       Just ns  -> emptyNmcDom { domNs = domNs dom, domEmail = domEmail dom }
 306     translateNormalizer dom = case domTranslate dom of
 307       Nothing  -> dom
 308       Just tr  -> dom { domMap = Nothing }
 309     srvNormalizer dom = dom { domService = Nothing, domMx = makemx }
 310       where
 311         makemx = case domService dom of
 312           Nothing  -> Nothing
 313           Just svl -> Just $ map makerec (filter needed svl)
 314             where
 315               needed sr = srvName sr == "smtp"
 316                         && srvProto sr == "tcp"
 317                         && srvPort sr == 25
 318               makerec sr = (show (srvPrio sr)) ++ " " ++ (srvHost sr)
 319
 320 -- | Merge imports and Selfs and follow the maps tree to get dom
 321 descendNmcDom ::
 322   (String -> IO (Either String ByteString)) -- ^ query operation action
 323   -> [String]                               -- ^ subdomain chain
 324   -> NmcDom                                 -- ^ base domain
 325   -> IO (Either String NmcDom)              -- ^ fully processed result
 326 descendNmcDom queryOp subdom base = do
 327   base' <- mergeImport queryOp 10 base
 328   case subdom of
 329     []   -> return $ fmap normalizeDom base'
 330     -- A hack to handle SRV records: don't descend if ["_prot","_serv"]
 331     [('_':p),('_':s)] -> return $ fmap (normalizeSrv s p) base'
 332     d:ds ->
 333       case base' of
 334         Left err     -> return base'
 335         Right base'' ->
 336           case domMap base'' of
 337             Nothing  -> return $ Right emptyNmcDom
 338             Just map ->
 339               case M.lookup d map of
 340                 Nothing  -> return $ Right emptyNmcDom
 341                 Just sub -> descendNmcDom queryOp ds sub
 342
 343 -- | Initial NmcDom populated with "import" only, suitable for "descend"
 344 seedNmcDom ::
 345   String        -- ^ domain key (without namespace prefix)
 346   -> NmcDom     -- ^ resulting seed domain
 347 seedNmcDom dn = emptyNmcDom { domImport = Just (["d/" ++ dn])}