fix(email): ensure sending to valid emails only

src/Handler/Admin.hs

@@ -147,7 +147,8 @@ retrieveUnreachableUsers = do
     user <- E.from $ E.table @User
     E.where_ $  E.isNothing (user E.^. UserPostAddress)
           E.&&. E.isNothing (user E.^. UserCompanyDepartment)
-          E.&&. E.not_ ((user E.^. UserEmail) `E.like` E.val "%@%.%") 
+          E.&&. E.not_ ((user E.^. UserDisplayEmail)  `E.like` E.val "%@%.%")
+          E.&&. E.not_ ((user E.^. UserEmail)         `E.like` E.val "%@%.%")
     return user 
 
 allDriversHaveAvsId :: Day -> DB Bool

src/Handler/Utils/Mail.hs

@@ -16,7 +16,7 @@ import Handler.Utils.Pandoc
 import Handler.Utils.Files
 import Handler.Utils.Widgets (nameHtml') -- TODO: how to use name widget here?
 import Handler.Utils.Users (getReceivers)
-import Handler.Utils.Profile (pickValidEmail)
+import Handler.Utils.Profile 
 
 import qualified Data.CaseInsensitive as CI
 
@@ -98,15 +98,21 @@ userMailT uid mAct = do
               $else
                 _{MsgMailSupervisorNoCopy}
           |]
-    mailT ctx $ do
+        mailtoAddr = userAddress supervisor
-      _mailTo .= pure (userAddress supervisor)
+    if validEmail $ addressEmail mailtoAddr
-      mAct
+      then 
-      if uid==svr
+        mailT ctx $ do
-        then when (2 <= length receivers) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
+          -- TODO: ensure that the Email is VALID HERE!
-        else do
+          _mailTo .= pure mailtoAddr 
-          mapSubject ("[SUPERVISOR] " <>)
+          mAct
-          addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
+          if uid==svr
-
+            then when (length receivers > 1) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
+            else do
+              mapSubject ("[SUPERVISOR] " <>)
+              addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
+      else -- do
+        -- 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
 userMailTdirect :: ( MonadHandler m
@@ -131,9 +137,22 @@ userMailTdirect uid mAct = do
           SelFormatTime -> userTimeFormat
       , mcCsvOptions = userCsvOptions
       }
+    mailtoAddr = userAddress user 
+  unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr)
   mailT ctx $ do
-    _mailTo .= pure (userAddress user)
+    _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
+      
+
 
 
 addFileDB :: ( MonadMail m

src/Handler/Utils/Profile.hs

@@ -9,7 +9,8 @@ module Handler.Utils.Profile
   , validDisplayName
   , fixDisplayName
   , validPostAddress  
-  , validEmail, validEmail', pickValidEmail
+  , validEmail, validEmail'
+  , pickValidEmail, pickValidEmail'
   ) where
 
 import Import.NoFoundation
@@ -87,7 +88,6 @@ validEmail email = validRFC5322 && not invalidFraport
       Just fralogin -> all isDigit $ drop 1 fralogin
       Nothing       -> False
 
-
 validEmail' :: UserEmail -> Bool -- UserEmail = CI Text
 validEmail' = validEmail . CI.original
 
@@ -96,3 +96,10 @@ pickValidEmail :: UserEmail -> UserEmail -> UserEmail
 pickValidEmail x y
   | validEmail' x = x
   | otherwise     = y
+
+-- | returns first valid email address or none if none are valid
+pickValidEmail' :: UserEmail -> UserEmail -> Maybe UserEmail
+pickValidEmail' x y 
+  | validEmail' x = Just x
+  | validEmail' y = Just y
+  | otherwise     = Nothing

src/Handler/Utils/Users.hs

@@ -14,6 +14,7 @@ module Handler.Utils.Users
   , UserAssimilateException(..), UserAssimilateExceptionReason(..)
   , assimilateUser
   , userPrefersEmail, userPrefersLetter
+  , getEmailAddress
   , getPostalAddress, getPostalPreferenceAndAddress
   , abbrvName
   , getReceivers
@@ -71,13 +72,16 @@ userPrefersEmail = not . userPrefersLetter
 
 -- | result (True, Nothing) indicates that neither userEmail nor userPostAddress is known
 getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text])
-getPostalPreferenceAndAddress usr@User{..} =
+getPostalPreferenceAndAddress usr@User{userPrefersPostal} =
     ((userPrefersPostal && postPossible) || not emailPossible, pa)
     -- (((userPrefersPostal || isNothing userPinPassword) && postPossible) || not emailPossible, pa) -- ignore email/post preference if no pinPassword is set
   where        
-    emailPossible = validEmail' userEmail
-    postPossible  = isJust pa
     pa = getPostalAddress usr
+    postPossible  = isJust pa
+    emailPossible = isJust $ getEmailAddress usr
+    
+getEmailAddress :: User -> Maybe UserEmail
+getEmailAddress User{userDisplayEmail, userEmail} = pickValidEmail' userDisplayEmail userEmail
 
 getPostalAddress :: User -> Maybe [Text]
 getPostalAddress User{..}
@@ -89,7 +93,7 @@ getPostalAddress User{..}
   | otherwise
     = Nothing
 
--- | DEPRECATED, use Handler.Utils.Avs.updateReceivers instead
+-- | Consider using Handler.Utils.Avs.updateReceivers instead
 --   Return Entity User and all Supervisors with rerouteNotifications as well as
 --   a boolean indicating if the user is own supervisor with rerouteNotifications
 getReceivers :: UserId -> DB (Entity User, [Entity User], Bool)

src/Jobs/Handler/QueueNotification.hs

@@ -15,7 +15,7 @@ import Jobs.Queue
 
 import qualified Data.Set as Set
 
-import Handler.Utils.Profile (validEmail')
+import Handler.Utils.Profile (pickValidEmail')
 import Handler.Utils.ExamOffice.Exam
 import Handler.Utils.ExamOffice.ExternalExam
 
@@ -26,8 +26,8 @@ dispatchJobQueueNotification :: Notification -> JobHandler UniWorX
 dispatchJobQueueNotification jNotification = JobHandlerAtomic $
   runConduit $ yield jNotification
             .| transPipe (hoist lift) determineNotificationCandidates
-            .| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userEmail}) -> 
+            .| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userDisplayEmail,userEmail}) -> 
-                and2M (return $ validEmail' userEmail) $
+                and2M (return $ isJust $ pickValidEmail' userDisplayEmail userEmail) $
                   or2M (return override) $ notificationAllowed userNotificationSettings <$> hoist lift (classifyNotification notification'))
             .| C.map (\(notification', _, Entity uid _) -> JobSendNotification uid notification')
             .| sinkDBJobs

templates/profileData.hamlet

@@ -56,14 +56,14 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
       <dt .deflist__dt>
         _{MsgUserDisplayEmail}
       <dd .deflist__dd .email>
-        #{userDisplayEmail}
+        #{mailtoHtml userDisplayEmail}
           $if not (validEmail' userDisplayEmail)
             \ ^{messageTooltip tooltipInvalidEmail}
       $if userEmail /= userDisplayEmail
         <dt .deflist__dt>
           _{MsgUserSystemEmail}
         <dd .deflist__dd>
-          #{mailtoHtml userEmail}
+          #{userEmail}
             $if not (validEmail' userEmail)
             \ ^{messageTooltip tooltipInvalidEmail}
       <dt .deflist__dt>