]> gitweb.michael.orlitzky.com - email-validator.git/blob - src/Main.hs
551dae752ae3343446716b520f0d13bb5274ed74
[email-validator.git] / src / Main.hs
1 {-# LANGUAGE DoAndIfThenElse #-}
2 {-# LANGUAGE RecordWildCards #-}
3
4 module 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 import ExitCodes (exit_input_file_doesnt_exist)
40
41
42 -- | Resolver parameters. We increase the default timeout from 3 to 10
43 -- seconds.
44 resolv_conf :: ResolvConf
45 resolv_conf = defaultResolvConf { resolvTimeout = 10 * 1000 * 1000 }
46
47 -- | A list of common domains, there's no need to waste MX lookups
48 -- on these.
49 common_domains :: [Domain]
50 common_domains = map BS.pack [ "aol.com",
51 "comcast.net",
52 "gmail.com",
53 "msn.com",
54 "yahoo.com",
55 "verizon.net" ]
56
57
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
62 | otherwise = do
63 result <- lookupMX resolver domain
64 case result of
65 -- A list of one or more elements?
66 Right (_:_) -> return True
67 _ -> return False
68
69
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
74 | otherwise = do
75 result <- lookupA resolver domain
76 case result of
77 Right (_:_) -> return True
78 _ -> return False
79
80
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
83 -- exchanger.
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
90 if mx_result
91 then return (address, True)
92 else
93 if accept_a
94 then do
95 a_result <- validate_a resolver domain
96 return (address, a_result)
97 else
98 return (address, False)
99 else
100 return (address, False)
101
102
103
104 main :: IO ()
105 main = do
106 Args{..} <- get_args
107
108 -- Get the input from either stdin, or the file given on the command
109 -- line.
110 input <- case input_file of
111 Nothing -> BS.hGetContents stdin
112 Just path -> do
113 is_file <- doesFileExist path
114 unless is_file $
115 exitWith (ExitFailure exit_input_file_doesnt_exist)
116 BS.readFile path
117
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
122
123 -- Split the input into lines.
124 let addresses = BS.lines input
125
126 -- And remove the empty ones.
127 let nonempty_addresses = filter (not . BS.null) addresses
128
129 rs <- makeResolvSeed resolv_conf
130 let validate' addr = withResolver rs $ \resolver ->
131 validate resolver accept_a rfc5322 addr
132
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
136
137 -- Run the lookup actions in parallel.
138 results <- parallelInterleaved actions
139
140 -- Filter the bad ones.
141 let valid_results = filter snd results
142
143 -- Output the results.
144 let valid_addresses = map fst valid_results
145 _ <- mapM (BS.hPutStrLn output_handle) valid_addresses
146
147 stopGlobalPool
148
149 -- Clean up. It's safe to try to close stdout.
150 hFlush output_handle
151 hClose output_handle