src/Main.hs

   1 {-# LANGUAGE DoAndIfThenElse #-}
   2 {-# LANGUAGE RecordWildCards #-}
   3
   4 module Main (main)
   5 where
   6
   7 import Control.Concurrent.ParallelIO.Global (
   8    parallelInterleaved,
   9    stopGlobalPool )
  10 import qualified Data.ByteString.Char8 as BS (
  11   hGetContents,
  12   hPutStrLn,
  13   lines,
  14   null,
  15   pack )
  16 import Network.DNS (
  17   Domain,
  18   Resolver,
  19   ResolvConf( resolvTimeout ),
  20   defaultResolvConf,
  21   makeResolvSeed,
  22   withResolver )
  23 import Network.DNS.Lookup ( lookupA, lookupMX )
  24 import System.IO (
  25   hFlush,
  26   stdin,
  27   stdout )
  28
  29
  30 import CommandLine (
  31   Args( Args, accept_a, rfc5322 ),
  32   get_args )
  33 import EmailAddress(
  34   Address,
  35   parts,
  36   validate_syntax )
  37
  38
  39 -- | Resolver parameters. We increase the default timeout from 3 to 10
  40 --   seconds.
  41 resolv_conf ::  ResolvConf
  42 resolv_conf = defaultResolvConf { resolvTimeout = 10 * 1000 * 1000 }
  43
  44 -- | A list of common domains, there's no need to waste MX lookups
  45 --   on these.
  46 common_domains :: [Domain]
  47 common_domains = map BS.pack [ "aol.com",
  48                                "comcast.net",
  49                                "gmail.com",
  50                                "msn.com",
  51                                "yahoo.com",
  52                                "verizon.net" ]
  53
  54
  55 -- | Check whether the given domain has a valid MX record.
  56 validate_mx :: Resolver -> Domain -> IO Bool
  57 validate_mx resolver domain
  58   | domain `elem` common_domains = return True
  59   | otherwise = do
  60       result <- lookupMX resolver domain
  61       case result of
  62         -- A list of one or more elements?
  63         Right (_:_) -> return True
  64         _           -> return False
  65
  66
  67 -- | Check whether the given domain has a valid A record.
  68 validate_a :: Resolver -> Domain -> IO Bool
  69 validate_a resolver domain
  70   | domain `elem` common_domains = return True
  71   | otherwise = do
  72       result <- lookupA resolver domain
  73       case result of
  74         Right (_:_) -> return True
  75         _           -> return False
  76
  77
  78 -- | Validate an email address by doing some simple syntax checks and
  79 --   (if those fail) an MX lookup. We don't count an A record as a mail
  80 --   exchanger.
  81 validate :: Resolver -> Bool -> Bool -> Address -> IO (Address, Bool)
  82 validate resolver accept_a rfc5322 address = do
  83   let valid_syntax = validate_syntax rfc5322 address
  84   if valid_syntax then do
  85     let (_,domain) = parts address
  86     mx_result <- validate_mx resolver domain
  87     if mx_result
  88     then return (address, True)
  89     else
  90       if accept_a
  91       then do
  92         a_result <- validate_a resolver domain
  93         return (address, a_result)
  94       else
  95         return (address, False)
  96   else
  97     return (address, False)
  98
  99
 100
 101 main :: IO ()
 102 main = do
 103   Args{..} <- get_args
 104
 105   -- Split stdin into lines, which should result in a list of addresses.
 106   input <- BS.hGetContents stdin
 107   let addresses = BS.lines input
 108
 109   -- And remove the empty ones.
 110   let nonempty_addresses = filter (not . BS.null) addresses
 111
 112   rs <- makeResolvSeed resolv_conf
 113   let validate' addr = withResolver rs $ \resolver ->
 114                          validate resolver accept_a rfc5322 addr
 115
 116   -- Construct a list of [IO (Address, Bool)]. The withResolver calls
 117   -- are the ones that should be run in parallel.
 118   let actions = map validate' nonempty_addresses
 119
 120   -- Run the lookup actions in parallel.
 121   results <- parallelInterleaved actions
 122
 123   -- Filter the bad ones.
 124   let valid_results = filter snd results
 125
 126   -- Output the results.
 127   let valid_addresses = map fst valid_results
 128   mapM_ (BS.hPutStrLn stdout) valid_addresses
 129
 130   stopGlobalPool
 131   hFlush stdout