From 8cc04c8e1158eb98f520e5ef8685d92f8246e5fb Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Mon, 13 Mar 2023 16:31:08 +0000
Subject: [PATCH] chore(email): improve email validity checks

---
 src/Handler/Admin.hs         | 19 +++++++++++++++++--
 src/Handler/Utils/Mail.hs    | 30 +++++++++++++++---------------
 src/Handler/Utils/Profile.hs |  1 +
 test/Database/Fill.hs        | 20 ++++++++++++++++----
 4 files changed, 49 insertions(+), 21 deletions(-)

diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs
index efa9f37dc..9749f3004 100644
--- a/src/Handler/Admin.hs
+++ b/src/Handler/Admin.hs
@@ -23,6 +23,7 @@ import qualified Database.Esqueleto.Utils as E
 import Handler.Utils.DateTime
 import Handler.Utils.Avs
 import Handler.Utils.Widgets
+import Handler.Utils.Users 
 
 import Handler.Admin.Test as Handler.Admin
 import Handler.Admin.ErrorMessage as Handler.Admin
@@ -83,7 +84,7 @@ getAdminProblemsR = do
 
 getProblemUnreachableR :: Handler Html
 getProblemUnreachableR = do
-  unreachables <- runDB $ E.select retrieveUnreachableUsers
+  unreachables <- runDB retrieveUnreachableUsers'
   siteLayoutMsg MsgProblemsUnreachableHeading $ do
     setTitleI   MsgProblemsUnreachableHeading
     [whamlet|
@@ -92,7 +93,7 @@ getProblemUnreachableR = do
         <ul>
           $forall usr <- unreachables
             <li>
-              ^{linkUserWidget ForProfileR usr}
+              ^{linkUserWidget ForProfileR usr} (#{usr ^. _userDisplayEmail} / #{usr ^. _userEmail})
     |]
 
 getProblemFbutNoR :: Handler Html
@@ -151,6 +152,20 @@ retrieveUnreachableUsers = do
           E.&&. E.not_ ((user E.^. UserEmail)         `E.like` E.val "%@%.%")
     return user 
 
+retrieveUnreachableUsers' :: DB [Entity User]
+retrieveUnreachableUsers' = do
+  obviousUnreachable <- E.select retrieveUnreachableUsers
+  emailUsers <- E.select $ do 
+    user <- E.from $ E.table @User
+    E.where_ $  E.isNothing (user E.^. UserPostAddress)
+          E.&&. E.isNothing (user E.^. UserCompanyDepartment)
+          E.&&. ( ((user E.^. UserDisplayEmail) `E.like` E.val "%@%.%")
+            E.||. ((user E.^. UserEmail)        `E.like` E.val "%@%.%"))
+    pure user
+  let hasInvalidEmail = isNothing . getEmailAddress . entityVal
+      invaldEmail = filter hasInvalidEmail emailUsers
+  return $ obviousUnreachable ++ invaldEmail
+
 allDriversHaveAvsId :: Day -> DB Bool
 -- allDriversHaveAvsId = fmap isNothing . E.selectOne . retrieveDriversWithoutAvsId
 allDriversHaveAvsId = E.selectNotExists . retrieveDriversWithoutAvsId
diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs
index 36c6112a1..f90ffd604 100644
--- a/src/Handler/Utils/Mail.hs
+++ b/src/Handler/Utils/Mail.hs
@@ -42,13 +42,13 @@ addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSo
 userAddressFrom :: User -> Address
 -- ^ Format an e-mail address suitable for usage in a @From@-header
 --
--- Uses `userDisplayEmail`
+-- Uses `userDisplayEmail` only
 userAddressFrom User{userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userDisplayEmail
 
 userAddress :: User -> Address
 -- ^ Format an e-mail address suitable for usage as a recipient
 --
--- Like userAddressFrom and no longer uses `userEmail`, since unlike Uni2work, userEmail from LDAP is untrustworthy.
+-- Like userAddressFrom, but prefers `userDisplayEmail` (if valid) and otherwise uses `userEmail`. Unlike Uni2work, userEmail from LDAP is untrustworthy.
 userAddress User{userEmail, userDisplayEmail, userDisplayName}
   = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
 
@@ -111,7 +111,7 @@ userMailT uid mAct = do
               mapSubject ("[SUPERVISOR] " <>)
               addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
       else -- do
-        -- failedSubject <- lookupMailHeader "Subject"        
+        -- failedSubject <- lookupMailHeader "Subject"
         $logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr -- <> " with subject " <> tshow failedSubject
 
 -- | like userMailT, but always sends a single mail to the given UserId, ignoring supervisors
@@ -138,20 +138,20 @@ userMailTdirect uid mAct = do
       , mcCsvOptions = userCsvOptions
       }
     mailtoAddr = userAddress user 
-  unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr)
   mailT ctx $ do
+    failedSubject <- lookupMailHeader "Subject"
+    unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
     _mailTo .= pure mailtoAddr
-    mAct
-  -- TODO: ensure that the Email is VALID HERE!
-  -- if validEmail $ addressEmail mailtoAddr
-  --   then 
-  --     mailT ctx $ do
-  --       _mailTo .= pure mailtoAddr
-  --       mAct
-  --   else do
-  --     -- failedSubject <- lookupMailHeader "Subject"        
-  --     $logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr -- <> " with subject " <> tshow failedSubject
-      
+    mAct  
+{- Problematic due to return type a      
+  if validEmail $ addressEmail mailtoAddr
+    then mailT ctx $ do
+      _mailTo .= pure mailtoAddr
+      mAct
+    else 
+      -- failedSubject <- lookupMailHeader "Subject"        
+      $logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAdd -- <> " with subject " <> tshow failedSubject
+-}      
 
 
 
diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs
index 6c8caa9a1..22f7a8098 100644
--- a/src/Handler/Utils/Profile.hs
+++ b/src/Handler/Utils/Profile.hs
@@ -80,6 +80,7 @@ validPostAddress (Just StoredMarkup {markupInput = addr})
     = True
 validPostAddress _ = False
 
+-- also see `Handler.Utils.Users.getEmailAddress` for Tests accepting User Type
 validEmail :: Email -> Bool      -- Email = Text
 validEmail email = validRFC5322 && not invalidFraport
   where 
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index 2781dcff3..af1cec970 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -386,14 +386,14 @@ fillDb = do
       = foldMap tshow cs : toMatrikel rest
       | otherwise
       = []
-    manyUser (firstName, middleName, userSurname) (Just -> userMatrikelnummer) = User
+    manyUser (firstName, middleName, userSurname) userMatrikelnummer' = User
       { userIdent
       , userAuthentication = AuthLDAP
       , userLastAuthentication = Nothing
       , userTokensIssuedAfter = Nothing
-      , userMatrikelnummer
-      , userEmail = userIdent
-      , userDisplayEmail = userIdent
+      , userMatrikelnummer = Just userMatrikelnummer'
+      , userEmail        = userEmail'
+      , userDisplayEmail = userDisplayEmail'
       , userDisplayName = case middleName of
           Just middleName' -> [st|#{firstName} #{middleName'} #{userSurname}|]
           Nothing          -> [st|#{firstName} #{userSurname}|]
@@ -433,6 +433,18 @@ fillDb = do
         userIdent = fromString $ case middleName of
           Just middleName' -> repack [st|#{firstName}.#{middleName'}.#{userSurname}@example.invalid|]
           Nothing          -> repack [st|#{firstName}.#{userSurname}@example.invalid|]
+        userEmail' :: CI Text
+        userEmail' = CI.mk $ case firstName of           
+          "James"     -> userIdent
+          "John"      -> userIdent
+          --"Elizabeth" -> "AVSID:" <> userMatrikelnummer'
+          _           ->      "E" <> userMatrikelnummer' <> "@fraport.de"
+        userDisplayEmail' :: CI Text
+        userDisplayEmail' = CI.mk $ case userSurname of 
+          "Walker"    -> "AVSNO:" <> userMatrikelnummer'
+          "Clark"     ->      "E" <> userMatrikelnummer' <> "@fraport.de"
+          _           -> userIdent
+
   matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
   manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
   matUsers <- selectList [UserMatrikelnummer !=. Nothing] []