From 3865afbceb69f8941c25c814abf855b4b035201a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 10 Mar 2023 17:56:02 +0000 Subject: [PATCH] fix(email): ensure sending to valid emails only --- src/Handler/Admin.hs | 3 +- src/Handler/Utils/Mail.hs | 41 ++++++++++++++++++++------- src/Handler/Utils/Profile.hs | 17 +++++++---- src/Handler/Utils/Users.hs | 14 +++++---- src/Jobs/Handler/QueueNotification.hs | 6 ++-- templates/profileData.hamlet | 4 +-- 6 files changed, 58 insertions(+), 27 deletions(-) diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index cadc13683..efa9f37dc 100644 --- a/src/Handler/Admin.hs +++ b/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 diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index 154d7e219..36c6112a1 100644 --- a/src/Handler/Utils/Mail.hs +++ b/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 - _mailTo .= pure (userAddress supervisor) - mAct - if uid==svr - then when (2 <= length receivers) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors - else do - mapSubject ("[SUPERVISOR] " <>) - addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email - + mailtoAddr = userAddress supervisor + if validEmail $ addressEmail mailtoAddr + then + mailT ctx $ do + -- TODO: ensure that the Email is VALID HERE! + _mailTo .= pure mailtoAddr + mAct + 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 diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index a018cd7e8..6c8caa9a1 100644 --- a/src/Handler/Utils/Profile.hs +++ b/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,12 +88,18 @@ validEmail email = validRFC5322 && not invalidFraport Just fralogin -> all isDigit $ drop 1 fralogin Nothing -> False - validEmail' :: UserEmail -> Bool -- UserEmail = CI Text validEmail' = validEmail . CI.original -- | returns first argument, if it is a valid email address; returns second argument untested otherwise; convenience function pickValidEmail :: UserEmail -> UserEmail -> UserEmail -pickValidEmail x y - | validEmail' x = x - | otherwise = y \ No newline at end of file +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 \ No newline at end of file diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index b211bc34c..512291970 100644 --- a/src/Handler/Utils/Users.hs +++ b/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 + where 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) diff --git a/src/Jobs/Handler/QueueNotification.hs b/src/Jobs/Handler/QueueNotification.hs index fc12a3921..db91f4640 100644 --- a/src/Jobs/Handler/QueueNotification.hs +++ b/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}) -> - and2M (return $ validEmail' userEmail) $ + .| C.filterM (\(notification', override, Entity _ User{userNotificationSettings,userDisplayEmail,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 diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 82069d56d..87dae8ebb 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -56,14 +56,14 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
_{MsgUserDisplayEmail}
- #{userDisplayEmail} + #{mailtoHtml userDisplayEmail} $if not (validEmail' userDisplayEmail) \ ^{messageTooltip tooltipInvalidEmail} $if userEmail /= userDisplayEmail
_{MsgUserSystemEmail}
- #{mailtoHtml userEmail} + #{userEmail} $if not (validEmail' userEmail) \ ^{messageTooltip tooltipInvalidEmail}