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