src/Main.hs

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