1 {-# LANGUAGE DoAndIfThenElse #-}
2 {-# LANGUAGE RecordWildCards #-}
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
18 import Network.DNS.Lookup (lookupA, lookupMX)
19 import System.Directory (doesFileExist)
20 import System.Exit (exitWith, ExitCode(..))
31 import CommandLine (Args(..), apply_args)
33 import ExitCodes (exit_input_file_doesnt_exist)
36 -- | Resolver parameters. We increase the default timeout from 3 to 5
38 resolv_conf :: ResolvConf
39 resolv_conf = defaultResolvConf { resolvTimeout = 5 * 1000 * 1000 }
41 -- | A list of common domains, there's no need to waste MX lookups
43 common_domains :: [Domain]
44 common_domains = map BSU.fromString [ "aol.com",
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
57 result <- lookupMX resolver domain
59 Nothing -> return False
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
68 result <- lookupA resolver domain
70 Nothing -> return False
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
77 validate :: Resolver -> Bool -> Address -> IO (Address, Bool)
78 validate resolver accept_a address = do
79 let valid_syntax = validate_syntax address
80 if valid_syntax then do
81 let (_,domain) = parts address
82 mx_result <- validate_mx resolver domain
84 then return (address, True)
88 a_result <- validate_a resolver domain
89 return (address, a_result)
91 return (address, False)
93 return (address, False)
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
102 newline = BSU.fromString "\n"
107 Args{..} <- apply_args
109 -- Get the input from either stdin, or the file given on the command
111 input <- case input_file of
112 Nothing -> BS.hGetContents stdin
114 is_file <- doesFileExist path
116 exitWith (ExitFailure exit_input_file_doesnt_exist)
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
124 -- Split the input into lines.
125 let addresses = BSU.lines input
127 -- And remove the empty ones.
128 let nonempty_addresses = filter (not . BS.null) addresses
130 rs <- makeResolvSeed resolv_conf
131 withResolver rs $ \resolver -> do
132 -- Construst a list of [IO (Address, Bool)]
133 let actions = map (validate resolver accept_a) nonempty_addresses
134 -- And compute them in parallel.
135 results <- parallel actions
137 -- Find the pairs with a True in the second position.
138 let good_pairs = filter snd results
139 -- And output the results.
140 mapM_ ((append_handle_with_newline output_handle) . fst) good_pairs
142 -- Clean up. It's safe to try to close stdout.