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 on
  45 --   these. This is a very limited list; I don't want to be in the
  46 --   business of monitoring a million domains for MX record updates.
  47 common_domains :: [Domain]
  48 common_domains = map BS.pack [ "aol.com",
  49                                "comcast.net",
  50                                "cox.net",
  51                                "gmail.com",
  52                                "gmx.de",
  53                                "googlemail.com",
  54                                "hotmail.com",
  55                                "icloud.com",
  56                                "live.com",
  57                                "me.com",
  58                                "msn.com",
  59                                "outlook.com",
  60                                "proton.me",
  61                                "protonmail.ch",
  62                                "protonmail.com",
  63                                "yahoo.com",
  64                                "verizon.net" ]
  65
  66
  67 -- | Check whether the given domain has a valid MX record.
  68 validate_mx :: Resolver -> Domain -> IO Bool
  69 validate_mx resolver domain
  70   | domain `elem` common_domains = return True
  71   | otherwise = do
  72       result <- lookupMX resolver domain
  73       case result of
  74         -- A list of one or more elements?
  75         Right (_:_) -> return True
  76         _           -> return False
  77
  78
  79 -- | Check whether the given domain has a valid A record.
  80 validate_a :: Resolver -> Domain -> IO Bool
  81 validate_a resolver domain
  82   | domain `elem` common_domains = return True
  83   | otherwise = do
  84       result <- lookupA resolver domain
  85       case result of
  86         Right (_:_) -> return True
  87         _           -> return False
  88
  89
  90 -- | Validate an email address by doing some simple syntax checks and
  91 --   (if those fail) an MX lookup. We don't count an A record as a mail
  92 --   exchanger.
  93 validate :: Resolver -> Bool -> Bool -> Address -> IO (Address, Bool)
  94 validate resolver accept_a rfc5322 address = do
  95   let valid_syntax = validate_syntax rfc5322 address
  96   if valid_syntax then do
  97     let (_,domain) = parts address
  98     mx_result <- validate_mx resolver domain
  99     if mx_result
 100     then return (address, True)
 101     else
 102       if accept_a
 103       then do
 104         a_result <- validate_a resolver domain
 105         return (address, a_result)
 106       else
 107         return (address, False)
 108   else
 109     return (address, False)
 110
 111
 112
 113 main :: IO ()
 114 main = do
 115   Args{..} <- get_args
 116
 117   -- Split stdin into lines, which should result in a list of addresses.
 118   input <- BS.hGetContents stdin
 119   let addresses = BS.lines input
 120
 121   -- And remove the empty ones.
 122   let nonempty_addresses = filter (not . BS.null) addresses
 123
 124   rs <- makeResolvSeed resolv_conf
 125   let validate' addr = withResolver rs $ \resolver ->
 126                          validate resolver accept_a rfc5322 addr
 127
 128   -- Construct a list of [IO (Address, Bool)]. The withResolver calls
 129   -- are the ones that should be run in parallel.
 130   let actions = map validate' nonempty_addresses
 131
 132   -- Run the lookup actions in parallel.
 133   results <- parallelInterleaved actions
 134
 135   -- Filter the bad ones.
 136   let valid_results = filter snd results
 137
 138   -- Output the results.
 139   let valid_addresses = map fst valid_results
 140   mapM_ (BS.hPutStrLn stdout) valid_addresses
 141
 142   stopGlobalPool
 143   hFlush stdout