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] []