From 687a9c76b8b04eb3e5813746dffcbf832d27162d Mon Sep 17 00:00:00 2001
From: Orion Kindel <orionkindel@gmail.com>
Date: Wed, 6 Dec 2023 20:17:26 -0600
Subject: [PATCH] feat: check wildcard addresses, retry several times to make
 sure that it really doesn't exist

---
 spago.yaml            |  2 ++
 src/Effect.Email.purs | 46 ++++++++++++++++++++++++++++++++++++-------
 2 files changed, 41 insertions(+), 7 deletions(-)

diff --git a/spago.yaml b/spago.yaml
index a6ce4a7..ee6829c 100644
--- a/spago.yaml
+++ b/spago.yaml
@@ -3,6 +3,7 @@ package:
     - aff
     - aff-promise
     - arrays
+    - bifunctors
     - effect
     - either
     - foldable-traversable
@@ -11,6 +12,7 @@ package:
     - nullable
     - prelude
     - strings
+    - tailrec
     - transformers
     - typelevel-prelude
   name: email-address
diff --git a/src/Effect.Email.purs b/src/Effect.Email.purs
index be425ea..2d10b89 100644
--- a/src/Effect.Email.purs
+++ b/src/Effect.Email.purs
@@ -1,13 +1,16 @@
-module Effect.Email (EmailError(..), emailErrorToString, deliverable) where
+module Effect.Email (EmailError(..), emailErrorCode, emailErrorToString, deliverable) where
 
 import Prelude
 
 import Control.Monad.Cont (lift)
-import Control.Monad.Error.Class (throwError)
-import Control.Monad.Except (ExceptT)
+import Control.Monad.Error.Class (liftEither, throwError)
+import Control.Monad.Except (ExceptT(..), runExceptT)
+import Control.Monad.Rec.Class (Step(..), tailRecM)
 import Control.Promise (Promise)
 import Control.Promise as Promise
 import Data.Array as Array
+import Data.Bifunctor (lmap)
+import Data.Either (Either(..))
 import Data.Email (Email)
 import Data.Email as Email
 import Data.Eq.Generic (genericEq)
@@ -25,14 +28,25 @@ foreign import checkEmailImpl :: String -> Effect $ Promise $ QEDResult
 
 data EmailError
   = EmailUnreachable Email
+  | EmailWildcardExists Email
   | EmailSyntaxInvalid Email
   | EmailMXInvalid Email
   | EmailMXNoRecords Email
   | EmailSMTPInvalid Email
   | EmailSMTPError Email String
 
+emailErrorCode :: EmailError -> String
+emailErrorCode (EmailUnreachable _) = "email_unreachable"
+emailErrorCode (EmailWildcardExists _) = "email_wildcard"
+emailErrorCode (EmailSyntaxInvalid _) = "email_invalid"
+emailErrorCode (EmailMXInvalid _) = "email_mx_bad"
+emailErrorCode (EmailMXNoRecords _) = "email_mx_missing"
+emailErrorCode (EmailSMTPInvalid _) = "email_smtp_bad"
+emailErrorCode (EmailSMTPError _ _) = "email_smtp_error"
+
 emailErrorToString :: EmailError -> String
 emailErrorToString (EmailUnreachable e) = "Email <" <> Email.toString e <> "> is unreachable"
+emailErrorToString (EmailWildcardExists e) = "Wildcard address <*." <> Email.domain e <> "> is registered; cannot definitively say if <" <> Email.toString e <> "> exists."
 emailErrorToString (EmailSyntaxInvalid e) = "Email <" <> Email.toString e <> "> is invalid"
 emailErrorToString (EmailMXInvalid e) = "Email <" <> Email.toString e <> "> domain has invalid MX record"
 emailErrorToString (EmailMXNoRecords e) = "Email <" <> Email.toString e <> "> domain has no MX records"
@@ -64,10 +78,9 @@ type QEDResult =
       }
   }
 
-deliverable :: Email -> ExceptT EmailError Aff Email
-deliverable email' = do
+deliverableOnce :: Email -> ExceptT EmailError Aff Email
+deliverableOnce email' = do
   let email = Email.toString email'
-
   { reachable, syntax, mx, smtp } <- lift $ Promise.toAffE $ checkEmailImpl email
   when (not reachable) $ throwError $ EmailUnreachable email'
   when (not syntax.valid) $ throwError $ EmailSyntaxInvalid email'
@@ -75,5 +88,24 @@ deliverable email' = do
   when (not smtp.valid) $ throwError $ EmailSMTPInvalid email'
   when (maybe true Array.null $ Nullable.toMaybe $ mx.mxRecords) $ throwError $ EmailMXNoRecords email'
   for_ (Nullable.toMaybe $ smtp.error) $ throwError <<< EmailSMTPError email'
-
   pure email'
+
+deliverable :: Email -> ExceptT EmailError Aff Email
+deliverable email' =
+  let
+    attempt n
+      | n < 10 =
+          do
+            res <- runExceptT $ deliverableOnce email'
+            case res of
+              Left (EmailUnreachable _) -> pure $ Loop $ n + 1
+              Left e -> pure $ Done $ Left e
+              Right ok -> pure $ Done $ Right ok
+      | otherwise = pure $ Done $ Left $ EmailUnreachable email'
+  in
+    do
+      wildcard <- liftEither $ lmap (const $ EmailSyntaxInvalid email') $ Email.parse $ "*@" <> Email.domain email'
+      res <- lift $ runExceptT $ deliverableOnce wildcard
+      case res of
+        Right _ -> throwError $ EmailWildcardExists email'
+        _ -> ExceptT $ tailRecM attempt 0