{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE RecordWildCards #-}

module Main (main)
where

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( resolvTimeout ),
  defaultResolvConf,
  makeResolvSeed,
  withResolver )
import Network.DNS.Lookup ( lookupA, lookupMX )
import System.IO (
  hFlush,
  stdin,
  stdout )


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 = 10 * 1000 * 1000 }

-- | 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.
--
--   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 $ Just True
  | otherwise = do
      result <- lookupMX resolver domain
      case result of
        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
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 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
    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

  -- 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.
  let nonempty_addresses = filter (not . BS.null) addresses

  rs <- makeResolvSeed resolv_conf
  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