src/Main.hs

   1 {-# LANGUAGE DoAndIfThenElse #-}
   2 {-# LANGUAGE RecordWildCards #-}
   3
   4 module Main
   5 where
   6
   7 import Control.Concurrent.ParallelIO.Global (
   8    parallelInterleaved,
   9    stopGlobalPool)
  10 import Control.Monad (unless)
  11 import qualified Data.ByteString.Char8 as BS (
  12   hGetContents,
  13   hPutStrLn,
  14   lines,
  15   null,
  16   pack,
  17   readFile)
  18 import Network.DNS (
  19   Domain,
  20   Resolver,
  21   ResolvConf(..),
  22   defaultResolvConf,
  23   makeResolvSeed,
  24   withResolver)
  25 import Network.DNS.Lookup (lookupA, lookupMX)
  26 import System.Directory (doesFileExist)
  27 import System.Exit (exitWith, ExitCode(..))
  28 import System.IO (
  29   IOMode( WriteMode ),
  30   hClose,
  31   hFlush,
  32   openFile,
  33   stdin,
  34   stdout)
  35
  36
  37 import CommandLine (Args(..), apply_args)
  38 import EmailAddress
  39 import ExitCodes (exit_input_file_doesnt_exist)
  40
  41
  42 -- | Resolver parameters. We increase the default timeout from 3 to 10
  43 --   seconds.
  44 resolv_conf ::  ResolvConf
  45 resolv_conf = defaultResolvConf { resolvTimeout = 10 * 1000 * 1000 }
  46
  47 -- | A list of common domains, there's no need to waste MX lookups
  48 --   on these.
  49 common_domains :: [Domain]
  50 common_domains = map BS.pack [ "aol.com",
  51                                "comcast.net",
  52                                "gmail.com",
  53                                "msn.com",
  54                                "yahoo.com",
  55                                "verizon.net" ]
  56
  57
  58 -- | Check whether the given domain has a valid MX record.
  59 validate_mx :: Resolver -> Domain -> IO Bool
  60 validate_mx resolver domain
  61   | domain `elem` common_domains = return True
  62   | otherwise = do
  63       result <- lookupMX resolver domain
  64       case result of
  65         -- A list of one or more elements?
  66         Right (_:_) -> return True
  67         _           -> return False
  68
  69
  70 -- | Check whether the given domain has a valid A record.
  71 validate_a :: Resolver -> Domain -> IO Bool
  72 validate_a resolver domain
  73   | domain `elem` common_domains = return True
  74   | otherwise = do
  75       result <- lookupA resolver domain
  76       case result of
  77         Right (_:_) -> return True
  78         _           -> return False
  79
  80
  81 -- | Validate an email address by doing some simple syntax checks and
  82 --   (if those fail) an MX lookup. We don't count an A record as a mail
  83 --   exchanger.
  84 validate :: Resolver -> Bool -> Bool -> Address -> IO (Address, Bool)
  85 validate resolver accept_a rfc5322 address = do
  86   let valid_syntax = validate_syntax rfc5322 address
  87   if valid_syntax then do
  88     let (_,domain) = parts address
  89     mx_result <- validate_mx resolver domain
  90     if mx_result
  91     then return (address, True)
  92     else
  93       if accept_a
  94       then do
  95         a_result <- validate_a resolver domain
  96         return (address, a_result)
  97       else
  98         return (address, False)
  99   else
 100     return (address, False)
 101
 102
 103
 104 main :: IO ()
 105 main = do
 106   Args{..} <- apply_args
 107
 108   -- Get the input from either stdin, or the file given on the command
 109   -- line.
 110   input <- case input_file of
 111              Nothing   -> BS.hGetContents stdin
 112              Just path -> do
 113                is_file <- doesFileExist path
 114                unless is_file $
 115                  exitWith (ExitFailure exit_input_file_doesnt_exist)
 116                BS.readFile path
 117
 118   -- Do the same for the output handle and stdout.
 119   output_handle <- case output_file of
 120                      Nothing -> return stdout
 121                      Just path -> openFile path WriteMode
 122
 123   -- Split the input into lines.
 124   let addresses = BS.lines input
 125
 126   -- And remove the empty ones.
 127   let nonempty_addresses = filter (not . BS.null) addresses
 128
 129   rs <- makeResolvSeed resolv_conf
 130   let validate' addr = withResolver rs $ \resolver ->
 131                          validate resolver accept_a rfc5322 addr
 132
 133   -- Construct a list of [IO (Address, Bool)]. The withResolver calls
 134   -- are the ones that should be run in parallel.
 135   let actions = map validate' nonempty_addresses
 136
 137   -- Run the lookup actions in parallel.
 138   results <- parallelInterleaved actions
 139
 140   -- Filter the bad ones.
 141   let valid_results = filter snd results
 142
 143   -- Output the results.
 144   let valid_addresses = map fst valid_results
 145   _ <- mapM (BS.hPutStrLn output_handle) valid_addresses
 146
 147   stopGlobalPool
 148
 149   -- Clean up. It's safe to try to close stdout.
 150   hFlush output_handle
 151   hClose output_handle