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.
  68 --
  69 --   NULLMX (RFC7505) records consisting of a single period must not
  70 --   be accepted. Moreover, the existence of a NULLMX must be reported
  71 --   back to the caller because the whole point of a NULLMX is that
  72 --   its existence should preempt an @A@ record check. We abuse the
  73 --   return type for this, and return @Nothing@ in the event of a
  74 --   NULLMX. Otherwise we return @Just True@ or @Just False@ to
  75 --   indicate the existence (or not) of MX records.
  76 --
  77 --   RFC7505 states that a domain MUST NOT have any other MX records
  78 --   if it has a NULLMX record. We enforce this. If you have a NULLMX
  79 --   record and some other MX record, we consider the set invalid.
  80 --
  81 validate_mx :: Resolver -> Domain -> IO (Maybe Bool)
  82 validate_mx resolver domain
  83   | domain `elem` common_domains = return $ Just True
  84   | otherwise = do
  85       result <- lookupMX resolver domain
  86       case result of
  87         Left _ ->
  88             return $ Just False
  89         Right mxs ->
  90             case mxs of
  91               [] -> return $ Just False
  92               _  -> if any (is_null) mxs
  93                    then return Nothing
  94                    else return $ Just True
  95   where
  96     nullmx :: Domain
  97     nullmx = BS.pack "."
  98
  99     is_null :: (Domain,Int) -> Bool
 100     is_null (mx,prio) = mx == nullmx && prio == 0
 101
 102 -- | Check whether the given domain has a valid A record.
 103 validate_a :: Resolver -> Domain -> IO Bool
 104 validate_a resolver domain
 105   | domain `elem` common_domains = return True
 106   | otherwise = do
 107       result <- lookupA resolver domain
 108       case result of
 109         Right (_:_) -> return True
 110         _           -> return False
 111
 112
 113 -- | Validate an email address by doing some simple syntax checks and
 114 --   (if those fail) an MX lookup. We don't count an @A@ record as a mail
 115 --   exchanger unless @accept_a@ is True. And even then, the existence
 116 --   of a NULLMX record will preclude the acceptance of an @A@ record.
 117 --   The domain @example.com@ is a great test case for this behavior.
 118 validate :: Resolver -> Bool -> Bool -> Address -> IO (Address, Bool)
 119 validate resolver accept_a rfc5322 address = do
 120   let valid_syntax = validate_syntax rfc5322 address
 121   if valid_syntax then do
 122     let (_,domain) = parts address
 123     mx_result <- validate_mx resolver domain
 124     case mx_result of
 125       Nothing  ->
 126           -- NULLMX, don't fall back to 'A' records under any
 127           -- circumstances.
 128           return (address, False)
 129       Just mxr ->
 130           if mxr
 131           then return (address, True)
 132           else
 133             if accept_a
 134             then do
 135               a_result <- validate_a resolver domain
 136               return (address, a_result)
 137             else
 138               return (address, False)
 139           else
 140             return (address, False)
 141
 142
 143 main :: IO ()
 144 main = do
 145   Args{..} <- get_args
 146
 147   -- Split stdin into lines, which should result in a list of addresses.
 148   input <- BS.hGetContents stdin
 149   let addresses = BS.lines input
 150
 151   -- And remove the empty ones.
 152   let nonempty_addresses = filter (not . BS.null) addresses
 153
 154   rs <- makeResolvSeed resolv_conf
 155   let validate' addr = withResolver rs $ \resolver ->
 156                          validate resolver accept_a rfc5322 addr
 157
 158   -- Construct a list of [IO (Address, Bool)]. The withResolver calls
 159   -- are the ones that should be run in parallel.
 160   let actions = map validate' nonempty_addresses
 161
 162   -- Run the lookup actions in parallel.
 163   results <- parallelInterleaved actions
 164
 165   -- Filter the bad ones.
 166   let valid_results = filter snd results
 167
 168   -- Output the results.
 169   let valid_addresses = map fst valid_results
 170   mapM_ (BS.hPutStrLn stdout) valid_addresses
 171
 172   stopGlobalPool
 173   hFlush stdout