X-Git-Url: https://gitweb.michael.orlitzky.com/?a=blobdiff_plain;f=src%2FMain.hs;h=ab5f93ac4cdf8a40125ac34ba6b014e91bc60df1;hb=03eb76c0dc4238bc8c579beddb0e65fbed64d28d;hp=bd3cc45f5ff741e936243c9de0cf5baa84f0e1ce;hpb=c9c873eead8a45dd7df8e8ef1f5861a5aa741d9e;p=email-validator.git diff --git a/src/Main.hs b/src/Main.hs index bd3cc45..ab5f93a 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,114 +1,173 @@ {-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE RecordWildCards #-} -module Main +module Main (main) where -import Control.Concurrent.ParallelIO.Global (parallel, stopGlobalPool) -import qualified Data.ByteString as BS -import qualified Data.ByteString.UTF8 as BSU +import Control.Concurrent.ParallelIO.Global ( + parallelInterleaved, + stopGlobalPool ) +import qualified Data.ByteString.Char8 as BS ( + hGetContents, + hPutStrLn, + lines, + null, + pack ) import Network.DNS ( Domain, Resolver, - ResolvConf(..), + ResolvConf( resolvTimeout ), defaultResolvConf, makeResolvSeed, - withResolver) -import Network.DNS.Lookup (lookupMX) -import System.IO (hGetContents, hFlush, hPutStrLn, stdin, stdout) -import Text.Regex.PCRE.Light (compile, match, utf8) + withResolver ) +import Network.DNS.Lookup ( lookupA, lookupMX ) +import System.IO ( + hFlush, + stdin, + stdout ) -type Address = BSU.ByteString --- | Resolver parameters. We increase the default timeout from 3 to 5 +import CommandLine ( + Args( Args, accept_a, rfc5322 ), + get_args ) +import EmailAddress( + Address, + parts, + validate_syntax ) + + +-- | Resolver parameters. We increase the default timeout from 3 to 10 -- seconds. resolv_conf :: ResolvConf -resolv_conf = defaultResolvConf { resolvTimeout = 5 * 1000 * 1000 } +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 BSU.fromString [ "aol.com", - "comcast.net", - "gmail.com", - "msn.com", - "yahoo.com", - "verizon.net" ] - -validate_mx :: Resolver -> Domain -> IO Bool +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. +-- +-- 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 - Nothing -> return False - _ -> return True + 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 "." --- | Split an address into local/domain parts. -parts :: Address -> (BSU.ByteString, BSU.ByteString) -parts address = bytestring_split address '@' + is_null :: (Domain,Int) -> Bool + is_null (mx,prio) = mx == nullmx && prio == 0 --- | Check that the lengths of the local/domain parts are within spec. -validate_length :: Address -> Bool -validate_length address = - (BSU.length localpart <= 64) && (BSU.length domain <= 255) - where - (localpart, domain) = parts address - --- | Validate an email address against a simple regex. This should --- catch common addresses but disallows a lot of (legal) weird stuff. -validate_regex :: Address -> Bool -validate_regex address = - case matches of - Nothing -> False - _ -> True - where - regex_str = "(\\w+)([\\w\\-\\.]*)@(([0-9a-zA-Z\\-]+\\.)+)[a-zA-Z]{2,4}" - regex_bs = BSU.fromString regex_str - regex = compile regex_bs [utf8] - matches = match regex address [] - --- | Validate the syntax of an email address by checking its length --- and validating it against a simple regex. -validate_syntax :: Address -> Bool -validate_syntax address = - (validate_length address) && (validate_regex address) - --- | Split a 'ByteString' @s@ at the first occurrence of @character@. -bytestring_split :: BSU.ByteString -> Char -> (BSU.ByteString, BSU.ByteString) -bytestring_split s character = - (before, after) - where - break_func = (== character) - (before, rest) = BSU.break break_func s - after = BS.tail rest +-- | Check whether the given domain has a valid A record. +validate_a :: Resolver -> Domain -> IO Bool +validate_a resolver domain + | domain `elem` common_domains = return True + | otherwise = do + result <- lookupA resolver domain + case result of + Right (_:_) -> return True + _ -> return False -- | 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. -validate :: Resolver -> Address -> IO (Address, Bool) -validate resolver address = do - let valid_syntax = validate_syntax address +-- (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 - return (address, mx_result) - else do - 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 - input <- hGetContents stdin + Args{..} <- get_args + + -- Split stdin into lines, which should result in a list of addresses. + input <- BS.hGetContents stdin + let addresses = BS.lines input - let addresses = BSU.lines $ BSU.fromString input + -- And remove the empty ones. let nonempty_addresses = filter (not . BS.null) addresses rs <- makeResolvSeed resolv_conf - withResolver rs $ \resolver -> do - let actions = map (validate resolver) nonempty_addresses - results <- parallel actions - let good_pairs = filter snd results - mapM_ ((hPutStrLn stdout) . BSU.toString . fst) good_pairs + let validate' addr = withResolver rs $ \resolver -> + validate resolver accept_a rfc5322 addr + + -- Construct a list of [IO (Address, Bool)]. The withResolver calls + -- are the ones that should be run in parallel. + let actions = map validate' nonempty_addresses + + -- Run the lookup actions in parallel. + results <- parallelInterleaved actions + + -- Filter the bad ones. + let valid_results = filter snd results + + -- Output the results. + let valid_addresses = map fst valid_results + mapM_ (BS.hPutStrLn stdout) valid_addresses stopGlobalPool hFlush stdout