1 {-# LANGUAGE DoAndIfThenElse #-}
2 {-# LANGUAGE RecordWildCards #-}
7 import Control.Concurrent.ParallelIO.Global (
10 import Control.Monad (unless)
11 import qualified Data.ByteString.Char8 as BS (
25 import Network.DNS.Lookup (lookupA, lookupMX)
26 import System.Directory (doesFileExist)
27 import System.Exit (exitWith, ExitCode(..))
37 import CommandLine (Args(..), get_args)
39 import ExitCodes (exit_input_file_doesnt_exist)
42 -- | Resolver parameters. We increase the default timeout from 3 to 10
44 resolv_conf :: ResolvConf
45 resolv_conf = defaultResolvConf { resolvTimeout = 10 * 1000 * 1000 }
47 -- | A list of common domains, there's no need to waste MX lookups
49 common_domains :: [Domain]
50 common_domains = map BS.pack [ "aol.com",
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
63 result <- lookupMX resolver domain
65 -- A list of one or more elements?
66 Right (_:_) -> return True
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
75 result <- lookupA resolver domain
77 Right (_:_) -> return True
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
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
91 then return (address, True)
95 a_result <- validate_a resolver domain
96 return (address, a_result)
98 return (address, False)
100 return (address, False)
108 -- Get the input from either stdin, or the file given on the command
110 input <- case input_file of
111 Nothing -> BS.hGetContents stdin
113 is_file <- doesFileExist path
115 exitWith (ExitFailure exit_input_file_doesnt_exist)
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
123 -- Split the input into lines.
124 let addresses = BS.lines input
126 -- And remove the empty ones.
127 let nonempty_addresses = filter (not . BS.null) addresses
129 rs <- makeResolvSeed resolv_conf
130 let validate' addr = withResolver rs $ \resolver ->
131 validate resolver accept_a rfc5322 addr
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
137 -- Run the lookup actions in parallel.
138 results <- parallelInterleaved actions
140 -- Filter the bad ones.
141 let valid_results = filter snd results
143 -- Output the results.
144 let valid_addresses = map fst valid_results
145 _ <- mapM (BS.hPutStrLn output_handle) valid_addresses
149 -- Clean up. It's safe to try to close stdout.