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