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/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/Admin.hs b/src/Handler/Admin.hs
index cadc13683..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
@@ -147,9 +148,24 @@ 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
+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/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/Mail.hs b/src/Handler/Utils/Mail.hs
index 154d7e219..f90ffd604 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
@@ -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
@@ -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
mailT ctx $ do
- _mailTo .= pure (userAddress user)
- mAct
+ failedSubject <- lookupMailHeader "Subject"
+ unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
+ _mailTo .= pure mailtoAddr
+ 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
+-}
+
addFileDB :: ( MonadMail m
diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs
index 23e355232..22f7a8098 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
@@ -79,14 +80,27 @@ 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.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
-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/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() {
diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet
index 39f593166..87dae8ebb 100644
--- a/templates/profileData.hamlet
+++ b/templates/profileData.hamlet
@@ -56,12 +56,16 @@ $# 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}
-
_{MsgAdminUserPinPassword}
-
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index 87f3e38ae..af1cec970 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"
@@ -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] []