src/Main.hs

   1 {-# LANGUAGE DoAndIfThenElse #-}
   2 {-# LANGUAGE RecordWildCards #-}
   3
   4 module Main (main)
   5 where
   6
   7 import Control.Concurrent.ParallelIO.Global (
   8    parallelInterleaved,
   9    stopGlobalPool )
  10 import qualified Data.ByteString.Char8 as BS (
  11   hGetContents,
  12   hPutStrLn,
  13   lines,
  14   null,
  15   pack )
  16 import Network.DNS (
  17   Domain,
  18   Resolver,
  19   ResolvConf( resolvTimeout ),
  20   defaultResolvConf,
  21   makeResolvSeed,
  22   withResolver )
  23 import Network.DNS.Lookup ( lookupA, lookupMX )
  24 import System.IO (
  25   hFlush,
  26   stdin,
  27   stdout )
  28
  29
  30 import CommandLine (
  31   Args( Args, accept_a, rfc5322 ),
  32   get_args )
  33 import EmailAddress(
  34   Address,
  35   parts,
  36   validate_syntax )
  37
  38
  39 -- | Resolver parameters. We increase the default timeout from 3 to 10
  40 --   seconds.
  41 resolv_conf ::  ResolvConf
  42 resolv_conf = defaultResolvConf { resolvTimeout = 10 * 1000 * 1000 }
  43
  44 -- | A list of common domains, there's no need to waste MX lookups on
  45 --   these. This is a very limited list; I don't want to be in the
  46 --   business of monitoring a million domains for MX record updates.
  47 common_domains :: [Domain]
  48 common_domains = map BS.pack [ "aol.com",
  49                                "comcast.net",
  50                                "cox.net",
  51                                "gmail.com",
  52                                "gmx.de",
  53                                "googlemail.com",
  54                                "hotmail.com",
  55                                "icloud.com",
  56                                "live.com",
  57                                "me.com",
  58                                "msn.com",
  59                                "outlook.com",
  60                                "proton.me",
  61                                "protonmail.ch",
  62                                "protonmail.com",
  63                                "yahoo.com",
  64                                "verizon.net" ]
  65
  66
  67 -- | Check whether the given domain has a valid MX record. NULLMX
  68 --   (RFC7505) records consisting of a single period must not be
  69 --   accepted.
  70 --
  71 --   Two points about NULLMX:
  72 --
  73 --   * RFC7505 states that a domain MUST NOT have any other MX records
  74 --   if it has a NULLMX record. We don't enforce this. If you have a
  75 --   NULLMX record and some other MX record, we will reluctantly
  76 --   consider the second one valid.
  77 --
  78 --   * RFC7505 also states that a NULLMX record must have a priority
  79 --   of 0. We do not enforce this either. We ignore any records
  80 --   containing an empty label (i.e. a single dot). Such a record will
  81 --   not be deliverable anyway, and in light of the first item, means
  82 --   that we will not \"incorrectly\" reject batshit-crazy domains
  83 --   that have a NULLMX record (but with a non-zero priority) in
  84 --   addition to other, valid MX records.
  85 --
  86
  87 validate_mx :: Resolver -> Domain -> IO Bool
  88 validate_mx resolver domain
  89   | domain `elem` common_domains = return True
  90   | otherwise = do
  91       result <- lookupMX resolver domain
  92       let nullmx = BS.pack "." :: Domain
  93       let non_null = (\(mx,_) -> mx /= nullmx) :: (Domain,Int) -> Bool
  94       let non_null_mxs = fmap (filter non_null) result
  95       case non_null_mxs of
  96         Right (_:_) -> return True
  97         _           -> return False
  98
  99
 100 -- | Check whether the given domain has a valid A record.
 101 validate_a :: Resolver -> Domain -> IO Bool
 102 validate_a resolver domain
 103   | domain `elem` common_domains = return True
 104   | otherwise = do
 105       result <- lookupA resolver domain
 106       case result of
 107         Right (_:_) -> return True
 108         _           -> return False
 109
 110
 111 -- | Validate an email address by doing some simple syntax checks and
 112 --   (if those fail) an MX lookup. We don't count an A record as a mail
 113 --   exchanger.
 114 validate :: Resolver -> Bool -> Bool -> Address -> IO (Address, Bool)
 115 validate resolver accept_a rfc5322 address = do
 116   let valid_syntax = validate_syntax rfc5322 address
 117   if valid_syntax then do
 118     let (_,domain) = parts address
 119     mx_result <- validate_mx resolver domain
 120     if mx_result
 121     then return (address, True)
 122     else
 123       if accept_a
 124       then do
 125         a_result <- validate_a resolver domain
 126         return (address, a_result)
 127       else
 128         return (address, False)
 129   else
 130     return (address, False)
 131
 132
 133
 134 main :: IO ()
 135 main = do
 136   Args{..} <- get_args
 137
 138   -- Split stdin into lines, which should result in a list of addresses.
 139   input <- BS.hGetContents stdin
 140   let addresses = BS.lines input
 141
 142   -- And remove the empty ones.
 143   let nonempty_addresses = filter (not . BS.null) addresses
 144
 145   rs <- makeResolvSeed resolv_conf
 146   let validate' addr = withResolver rs $ \resolver ->
 147                          validate resolver accept_a rfc5322 addr
 148
 149   -- Construct a list of [IO (Address, Bool)]. The withResolver calls
 150   -- are the ones that should be run in parallel.
 151   let actions = map validate' nonempty_addresses
 152
 153   -- Run the lookup actions in parallel.
 154   results <- parallelInterleaved actions
 155
 156   -- Filter the bad ones.
 157   let valid_results = filter snd results
 158
 159   -- Output the results.
 160   let valid_addresses = map fst valid_results
 161   mapM_ (BS.hPutStrLn stdout) valid_addresses
 162
 163   stopGlobalPool
 164   hFlush stdout