From 05832681d398d4d3614ceba4df97c790bea8a517 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 9 Mar 2023 14:32:35 +0000 Subject: [PATCH 1/4] chore(email): dont allow numeric fraport accounts --- messages/uniworx/utils/utils/de-de-formal.msg | 1 + messages/uniworx/utils/utils/en-eu.msg | 1 + src/Handler/Profile.hs | 7 ++++++- src/Handler/Utils/Profile.hs | 10 ++++++++-- templates/profileData.hamlet | 4 ++++ test/Database/Fill.hs | 2 +- 6 files changed, 21 insertions(+), 4 deletions(-) diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index a36ce9848..31cccdcbd 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -77,6 +77,7 @@ MultiUserFieldExplanationAnyUser: Dieses Eingabefeld sucht in den Adressen aller MultiUserFieldInvitationExplanation: An Adressen, die so keinem Uni2work-Benutzer/keiner Uni2work-Benutzerin zugeordnet werden können, wird eine Einladung per E-Mail versandt. MultiUserFieldInvitationExplanationAlways: Es wird an alle Adressen, die Sie hier angeben, eine Einladung per E-Mail versandt. AmbiguousEmail: E-Mail-Adresse nicht eindeutig +InvalidEmailAddress: E-Mail-Adresse ist ungültig UtilExamResultGrade: Note UtilExamResultPass: Bestanden/Nicht Bestanden UtilExamResultNoShow: Nicht erschienen diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index f2af64e05..9dfe75299 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -77,6 +77,7 @@ MultiUserFieldExplanationAnyUser: This input searches through the addresses of a MultiUserFieldInvitationExplanation: For addresses, which are not found in this way, an invitation will be sent via email. MultiUserFieldInvitationExplanationAlways: An invitation will be sent via email to all addresses you enter here. AmbiguousEmail: Email address is ambiguous +InvalidEmailAddress: Email address is invalid UtilExamResultGrade: Grade UtilExamResultPass: Passed/Failed UtilExamResultNoShow: Not present diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 93c2b9ff8..9bc7efeb7 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -357,6 +357,10 @@ validateSettings User{..} = do userDisplayName == userDisplayName' || -- unchanged or valid (invalid displayNames delivered by LDAP are preserved) validDisplayName userTitle userFirstName userSurname userDisplayName' + userDisplayEmail' <- use _stgDisplayEmail + guardValidation MsgInvalidEmailAddress $ + not (validEmail' userDisplayEmail') + userPostAddress' <- use _stgPostAddress let postalNotSet = isNothing userPostAddress' postalIsValid = validPostAddress userPostAddress' @@ -445,7 +449,7 @@ serveProfileR (uid, user@User{..}) = do now <- liftIO getCurrentTime runDBJobs $ do update uid $ - [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] ++ -- SJ asks: what does this line achieve? + [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] ++ -- Note that DisplayEmail changes must be confirmed, see 472 [ UserPostLastUpdate =. Just now | userPostAddress /= stgPostAddress ] ++ [ UserDisplayName =. stgDisplayName , UserMaxFavourites =. stgMaxFavourites @@ -617,6 +621,7 @@ makeProfileData (Entity uid User{..}) = do mCRoute <- getCurrentRoute showAdminInfo <- pure (mCRoute == Just (AdminUserR cID)) `or2M` hasReadAccessTo (AdminUserR cID) tooltipAvsPersNo <- messageI Info MsgAvsPersonNoNotId + tooltipInvalidEmail <- messageI Error MsgInvalidEmailAddress let profileRemarks = $(i18nWidgetFile "profile-remarks") return $(widgetFile "profileData") diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 23e355232..a018cd7e8 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -80,10 +80,16 @@ validPostAddress (Just StoredMarkup {markupInput = addr}) validPostAddress _ = False validEmail :: Email -> Bool -- Email = Text -validEmail = Email.isValid . encodeUtf8 +validEmail email = validRFC5322 && not invalidFraport + where + validRFC5322 = Email.isValid $ encodeUtf8 email + invalidFraport = case Text.stripSuffix "@fraport.de" email of + Just fralogin -> all isDigit $ drop 1 fralogin + Nothing -> False + validEmail' :: UserEmail -> Bool -- UserEmail = CI Text -validEmail' = Email.isValid . encodeUtf8 . CI.original +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 diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet index 39f593166..82069d56d 100644 --- a/templates/profileData.hamlet +++ b/templates/profileData.hamlet @@ -57,11 +57,15 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later _{MsgUserDisplayEmail}
#{userDisplayEmail} + $if not (validEmail' userDisplayEmail) + \ ^{messageTooltip tooltipInvalidEmail} $if userEmail /= userDisplayEmail
_{MsgUserSystemEmail}
#{mailtoHtml userEmail} + $if not (validEmail' userEmail) + \ ^{messageTooltip tooltipInvalidEmail}
_{MsgAdminUserPinPassword}
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 87f3e38ae..2781dcff3 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -164,7 +164,7 @@ fillDb = do , userLastAuthentication = Nothing , userTokensIssuedAfter = Nothing , userMatrikelnummer = Nothing - , userEmail = "jost@tcs.ifi.lmu.de" + , userEmail = "e12345@fraport.de" , userDisplayEmail = "jost@tcs.ifi.lmu.de" , userDisplayName = "Steffen Jost" , userSurname = "Jost" From f6bed7d0faddd3ad835ea3704fd92b1e48d262f6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 10 Mar 2023 10:30:07 +0000 Subject: [PATCH 2/4] chore(email): automatic mail reroute for dev environment --- config/settings.yml | 6 +++--- src/Settings.hs | 2 +- start.sh | 2 ++ 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 5d0702621..1f547b1dc 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -24,9 +24,9 @@ mail-from: email: "_env:MAILFROM_EMAIL:uniworx@localhost" mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost" mail-use-replyto-instead-sender: "_env:MAIL_USES_REPLYTO:true" -#mail-reroute-to: -# name: "_env:MAIL_REROUTE_TO_NAME:Steffen Jost" -# email: "_env:MAIL_REROUTE_TO_EMAL:jost@tcs.ifi.lmu.de" +mail-reroute-to: + name: "_env:MAIL_REROUTE_TO_NAME:" + email: "_env:MAIL_REROUTE_TO_EMAIL:" #mail-verp: # separator: "_env:VERP_SEPARATOR:+" # prefix: "_env:VERP_PREFIX:bounce" diff --git a/src/Settings.hs b/src/Settings.hs index d32833521..2d5ab05de 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -657,7 +657,7 @@ instance FromJSON AppSettings where appMailVerp <- fromMaybe VerpNone . join <$> (o .:? "mail-verp" <|> pure Nothing) appMailRetainSent <- o .: "mail-retain-sent" appMailSupport <- o .: "mail-support" - appMailRerouteTo <- o .:? "mail-reroute-to" + appMailRerouteTo <- join <$> (o .:? "mail-reroute-to" <|> pure Nothing) appJobWorkers <- o .: "job-workers" appJobFlushInterval <- o .:? "job-flush-interval" diff --git a/start.sh b/start.sh index 47701a357..f5c21989f 100755 --- a/start.sh +++ b/start.sh @@ -29,6 +29,8 @@ export RIBBON=${RIBBON:-${__HOST:-localhost}} export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))} export AVSPASS=${AVSPASS:-nopasswordset} export PATH=${PATH:/home/jost/projects/fradrive} +export MAIL_REROUTE_TO_NAME='Steffen Jost' +export MAIL_REROUTE_TO_EMAIL=jost@tcs.ifi.lmu.de unset HOST move-back() { From 3865afbceb69f8941c25c814abf855b4b035201a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 10 Mar 2023 17:56:02 +0000 Subject: [PATCH 3/4] 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}
From 8cc04c8e1158eb98f520e5ef8685d92f8246e5fb Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 13 Mar 2023 16:31:08 +0000 Subject: [PATCH 4/4] 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
    $forall usr <- unreachables
  • - ^{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] []