X-Git-Url: http://gitweb.michael.orlitzky.com/?p=email-validator.git;a=blobdiff_plain;f=src%2FMain.hs;h=1cc4c73aa47d963e56f30a7188f05781f010b76c;hp=4a0208b05372564cdd6fa6e5d8e9bca116380078;hb=HEAD;hpb=d6756c15921c8ab1828be2acf165f3907c23f6a6 diff --git a/src/Main.hs b/src/Main.hs index 4a0208b..ab5f93a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,39 +7,33 @@ where import Control.Concurrent.ParallelIO.Global ( parallelInterleaved, stopGlobalPool ) -import Control.Monad ( unless ) import qualified Data.ByteString.Char8 as BS ( hGetContents, hPutStrLn, lines, null, - pack, - readFile ) + pack ) import Network.DNS ( Domain, Resolver, - ResolvConf(..), + ResolvConf( resolvTimeout ), defaultResolvConf, makeResolvSeed, withResolver ) import Network.DNS.Lookup ( lookupA, lookupMX ) -import System.Directory ( doesFileExist ) -import System.Exit ( exitWith, ExitCode(..) ) import System.IO ( - IOMode( WriteMode ), - hClose, hFlush, - openFile, stdin, stdout ) -import CommandLine ( Args(..), get_args ) +import CommandLine ( + Args( Args, accept_a, rfc5322 ), + get_args ) import EmailAddress( Address, parts, validate_syntax ) -import ExitCodes ( exit_input_file_doesnt_exist ) -- | Resolver parameters. We increase the default timeout from 3 to 10 @@ -47,28 +41,63 @@ import ExitCodes ( exit_input_file_doesnt_exist ) resolv_conf :: ResolvConf resolv_conf = defaultResolvConf { resolvTimeout = 10 * 1000 * 1000 } --- | A list of common domains, there's no need to waste MX lookups --- on these. +-- | A list of common domains, there's no need to waste MX lookups on +-- these. This is a very limited list; I don't want to be in the +-- business of monitoring a million domains for MX record updates. common_domains :: [Domain] common_domains = map BS.pack [ "aol.com", "comcast.net", + "cox.net", "gmail.com", + "gmx.de", + "googlemail.com", + "hotmail.com", + "icloud.com", + "live.com", + "me.com", "msn.com", + "outlook.com", + "proton.me", + "protonmail.ch", + "protonmail.com", "yahoo.com", "verizon.net" ] -- | Check whether the given domain has a valid MX record. -validate_mx :: Resolver -> Domain -> IO Bool +-- +-- NULLMX (RFC7505) records consisting of a single period must not +-- be accepted. Moreover, the existence of a NULLMX must be reported +-- back to the caller because the whole point of a NULLMX is that +-- its existence should preempt an @A@ record check. We abuse the +-- return type for this, and return @Nothing@ in the event of a +-- NULLMX. Otherwise we return @Just True@ or @Just False@ to +-- indicate the existence (or not) of MX records. +-- +-- RFC7505 states that a domain MUST NOT have any other MX records +-- if it has a NULLMX record. We enforce this. If you have a NULLMX +-- record and some other MX record, we consider the set invalid. +-- +validate_mx :: Resolver -> Domain -> IO (Maybe Bool) validate_mx resolver domain - | domain `elem` common_domains = return True + | domain `elem` common_domains = return $ Just True | otherwise = do result <- lookupMX resolver domain case result of - -- A list of one or more elements? - Right (_:_) -> return True - _ -> return False - + Left _ -> + return $ Just False + Right mxs -> + case mxs of + [] -> return $ Just False + _ -> if any (is_null) mxs + then return Nothing + else return $ Just True + where + nullmx :: Domain + nullmx = BS.pack "." + + is_null :: (Domain,Int) -> Bool + is_null (mx,prio) = mx == nullmx && prio == 0 -- | Check whether the given domain has a valid A record. validate_a :: Resolver -> Domain -> IO Bool @@ -82,48 +111,41 @@ validate_a resolver domain -- | Validate an email address by doing some simple syntax checks and --- (if those fail) an MX lookup. We don't count an A record as a mail --- exchanger. +-- (if those fail) an MX lookup. We don't count an @A@ record as a mail +-- exchanger unless @accept_a@ is True. And even then, the existence +-- of a NULLMX record will preclude the acceptance of an @A@ record. +-- The domain @example.com@ is a great test case for this behavior. validate :: Resolver -> Bool -> Bool -> Address -> IO (Address, Bool) validate resolver accept_a rfc5322 address = do let valid_syntax = validate_syntax rfc5322 address if valid_syntax then do let (_,domain) = parts address mx_result <- validate_mx resolver domain - if mx_result - then return (address, True) - else - if accept_a - then do - a_result <- validate_a resolver domain - return (address, a_result) - else - return (address, False) - else - return (address, False) - + case mx_result of + Nothing -> + -- NULLMX, don't fall back to 'A' records under any + -- circumstances. + return (address, False) + Just mxr -> + if mxr + then return (address, True) + else + if accept_a + then do + a_result <- validate_a resolver domain + return (address, a_result) + else + return (address, False) + else + return (address, False) main :: IO () main = do Args{..} <- get_args - -- Get the input from either stdin, or the file given on the command - -- line. - input <- case input_file of - Nothing -> BS.hGetContents stdin - Just path -> do - is_file <- doesFileExist path - unless is_file $ - exitWith (ExitFailure exit_input_file_doesnt_exist) - BS.readFile path - - -- Do the same for the output handle and stdout. - output_handle <- case output_file of - Nothing -> return stdout - Just path -> openFile path WriteMode - - -- Split the input into lines. + -- Split stdin into lines, which should result in a list of addresses. + input <- BS.hGetContents stdin let addresses = BS.lines input -- And remove the empty ones. @@ -145,10 +167,7 @@ main = do -- Output the results. let valid_addresses = map fst valid_results - mapM_ (BS.hPutStrLn output_handle) valid_addresses + mapM_ (BS.hPutStrLn stdout) valid_addresses stopGlobalPool - - -- Clean up. It's safe to try to close stdout. - hFlush output_handle - hClose output_handle + hFlush stdout