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