src/DNS.hs

   1 module DNS (
   2   MxSetMap,
   3   NormalDomain,
   4   mx_set_map,
   5   normalize_string )
   6 where
   7
   8 import qualified Data.ByteString.Char8 as BS ( pack, unpack )
   9 import Data.List ( nub )
  10 import Data.Map ( Map )
  11 import qualified Data.Map as Map ( fromList )
  12 import Data.Set ( Set )
  13 import qualified Data.Set as Set ( fromList )
  14 import Network.DNS (
  15   Domain,
  16   defaultResolvConf,
  17   lookupMX,
  18   makeResolvSeed,
  19   normalize,
  20   withResolver )
  21
  22 -- | A type-safe wrapper around a domain name (represented as a
  23 --   string) that ensures we've created it by calling
  24 --   'normalize_string'. This prevents us from making
  25 --   comparisons on un-normalized 'Domain's or 'String's.
  26 --
  27 newtype NormalDomain =
  28   NormalDomain String
  29   deriving ( Eq, Ord, Show )
  30
  31
  32 -- | A set of mail exchanger names, represented as 'String's. The use
  33 --   of 'NormalDomain' prevents us from constructing a set of names
  34 --   that aren't normalized first.
  35 --
  36 type MxSet = Set NormalDomain
  37
  38
  39 -- | A map from domain names (represented as 'String's) to sets of
  40 --   mail exchanger names (also represented as 'String's). The use of
  41 --   'NormalDomain' in the key prevents us from using keys that aren't
  42 --   normalized; this is important because we'll be using them for
  43 --   lookups and want e.g. \"foo.com\" and \"FOO.com\" to look up the
  44 --   same MX records.
  45 --
  46 type MxSetMap = Map NormalDomain MxSet
  47
  48
  49 -- | Normalize a domain name string by converting to a 'Domain',
  50 --   calling 'normalize', and then converting back.
  51 --
  52 --   ==== __Examples__
  53 --
  54 --   >>> normalize_string "ExAMplE.com"
  55 --   NormalDomain "example.com."
  56 --
  57 normalize_string :: String -> NormalDomain
  58 normalize_string = NormalDomain . BS.unpack . normalize . BS.pack
  59
  60
  61 -- | Retrieve all MX records for the given domain. This is somewhat
  62 --   inefficient, since we create the resolver every time.
  63 --
  64 lookup_mxs :: Domain -> IO [Domain]
  65 lookup_mxs domain = do
  66   default_rs <- makeResolvSeed defaultResolvConf
  67   withResolver default_rs $ \resolver -> do
  68     mxs <- lookupMX resolver domain
  69     return $ case mxs of
  70                Left  _     -> []
  71                Right pairs -> map fst pairs
  72
  73
  74 -- | Takes a list of domain names represented as 'String's and
  75 --   constructs a map from domain names to sets of mail exchangers
  76 --   (for those domain names) also represented as 'String's.
  77 --
  78 --   During construction, we have to switch to the DNS internal
  79 --   representation of a 'Domain' which uses ByteStrings, but before
  80 --   we return the map to the client, we want everything to be in
  81 --   terms of standard 'String's for comparison purposes.
  82 --
  83 --   The list of domains is normalized and de-duped before lookups are
  84 --   performed to avoid doing lookups twice for identical domains.
  85 --
  86 mx_set_map :: [String] -> IO MxSetMap
  87 mx_set_map domains = do
  88   -- Construct a list of pairs.
  89   pairs <- mapM make_pair unique_domains
  90
  91   -- And make a map from the pairs.
  92   return $ Map.fromList pairs
  93
  94   where
  95     -- Convert, normalize, and de-dupe the @domains@.
  96     unique_domains :: [Domain]
  97     unique_domains = nub $ map (normalize . BS.pack) domains
  98
  99     -- | Convert a string domain name into a pair containing the
 100     --   domain name in the first component and a set of its mail
 101     --   exchangers (as strings) in the second component.
 102     --
 103     make_pair :: Domain -> IO (NormalDomain, Set NormalDomain)
 104     make_pair domain = do
 105       -- Lookup the @domain@'s MX records.
 106       mx_list <- lookup_mxs domain
 107
 108       -- Now convert the MX records *back* to strings, and then to
 109       -- NormalDomains
 110       let normal_mx_list = map (normalize_string . BS.unpack) mx_list
 111
 112       -- Convert the list into a set...
 113       let normal_mx_set = Set.fromList normal_mx_list
 114
 115       -- The lookup key.
 116       let normal_domain = normalize_string $ BS.unpack domain
 117
 118       -- Finally, construct the pair and return it.
 119       return (normal_domain, normal_mx_set)