From: Michael Orlitzky <michael@orlitzky.com>
Date: Thu, 25 Apr 2024 00:33:40 +0000 (-0400)
Subject: src/Main.hs: support NULLMX fully
X-Git-Tag: 1.1.0~3
X-Git-Url: https://gitweb.michael.orlitzky.com/email-validator.git/?p=email-validator.git;a=commitdiff_plain;h=03eb76c0dc4238bc8c579beddb0e65fbed64d28d

src/Main.hs: support NULLMX fully

We now ignore --accept-a for domains that have NULLMX records.
---

diff --git a/src/Main.hs b/src/Main.hs
index 74789e7..ab5f93a 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -64,38 +64,40 @@ common_domains = map BS.pack [ "aol.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.
+-- | Check whether the given domain has a valid MX record.
 --
---   Two points about NULLMX:
+--   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 don't enforce this. If you have a
---   NULLMX record and some other MX record, we will reluctantly
---   consider the second one valid.
+--   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.
 --
---   * RFC7505 also states that a NULLMX record must have a priority
---   of 0. We do not enforce this either. We ignore any records
---   containing an empty label (i.e. a single dot). Such a record will
---   not be deliverable anyway, and in light of the first item, means
---   that we will not \"incorrectly\" reject batshit-crazy domains
---   that have a NULLMX record (but with a non-zero priority) in
---   addition to other, valid MX records.
---
-
-validate_mx :: Resolver -> Domain -> IO Bool
+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
-      let nullmx = BS.pack "." :: Domain
-      let non_null = (\(mx,_) -> mx /= nullmx) :: (Domain,Int) -> Bool
-      let non_null_mxs = fmap (filter non_null) result
-      case non_null_mxs of
-        Right (_:_) -> return True
-        _           -> return False
-
+      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
@@ -109,26 +111,33 @@ 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 ()