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