src/DNS.hs

   1 module DNS (
   2   MxSetMap,
   3   mx_set_map,
   4   normalize_string_domain )
   5 where
   6
   7 import qualified Data.ByteString.Char8 as BS ( pack, unpack )
   8 import Data.List ( nub )
   9 import Data.Map ( Map )
  10 import qualified Data.Map as Map ( fromList )
  11 import Data.Set ( Set )
  12 import qualified Data.Set as Set ( fromList )
  13 import Network.DNS (
  14   Domain,
  15   defaultResolvConf,
  16   lookupMX,
  17   makeResolvSeed,
  18   normalize,
  19   withResolver )
  20
  21 -- | A map from domain names (represented as 'String's) to sets of
  22 --   mail exchanger names (also represented as 'String's).
  23 --
  24 type MxSetMap = Map String MxSet
  25
  26 -- | A set of mail exchanger names, represented as 'String's.
  27 type MxSet = Set String
  28
  29
  30 -- | Normalize a domain name string by converting to a 'Domain',
  31 --   calling 'normalize', and then converting back.
  32 --
  33 --   ==== __Examples__
  34 --
  35 --   >>> normalize_string_domain "ExAMplE.com"
  36 --   "example.com."
  37 --
  38 normalize_string_domain :: String -> String
  39 normalize_string_domain = BS.unpack . normalize . BS.pack
  40
  41
  42 -- | Retrieve all MX records for the given domain. This is somewhat
  43 --   inefficient, since we create the resolver every time.
  44 --
  45 lookup_mxs :: Domain -> IO [Domain]
  46 lookup_mxs domain = do
  47   default_rs <- makeResolvSeed defaultResolvConf
  48   withResolver default_rs $ \resolver -> do
  49     mxs <- lookupMX resolver domain
  50     return $ case mxs of
  51                Left  _     -> []
  52                Right pairs -> map fst pairs
  53
  54
  55 -- | Takes a list of domain names represented as 'String's and
  56 --   constructs a map from domain names to sets of mail exchangers
  57 --   (for those domain names) also represented as 'String's.
  58 --
  59 --   During construction, we have to switch to the DNS internal
  60 --   representation of a 'Domain' which uses ByteStrings, but before
  61 --   we return the map to the client, we want everything to be in
  62 --   terms of standard 'String's for comparison purposes.
  63 --
  64 --   The list of domains is normalized and de-duped before lookups are
  65 --   performed to avoid doing lookups twice for identical domains.
  66 --
  67 mx_set_map :: [String] -> IO MxSetMap
  68 mx_set_map domains = do
  69   -- Construct a list of pairs.
  70   pairs <- mapM make_pair unique_domains
  71
  72   -- And make a map from the pairs.
  73   return $ Map.fromList pairs
  74
  75   where
  76     -- Convert, normalize, and de-dupe the @domains@.
  77     unique_domains :: [Domain]
  78     unique_domains = nub $ map (normalize . BS.pack) domains
  79
  80     -- | Convert a string domain name into a pair containing the
  81     --   domain name in the first component and a set of its mail
  82     --   exchangers (as strings) in the second component.
  83     --
  84     make_pair :: Domain -> IO (String, Set String)
  85     make_pair domain = do
  86       -- Lookup the @domain@'s MX records.
  87       mx_list <- lookup_mxs domain
  88
  89       -- Now convert the MX records *back* to strings.
  90       let string_mx_list = map BS.unpack mx_list
  91
  92       -- Convert the list into a set
  93       let string_mx_set = Set.fromList string_mx_list
  94
  95       -- Finally, construct the pair and return it.
  96       return (BS.unpack domain, string_mx_set)