fix(email): reenable ldap logins with invalid email addresses (missing mail field problem)
This commit is contained in:
parent
3b0f27d4f2
commit
88a85bb5b6
@ -260,11 +260,11 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidIdent
|
||||
|
||||
userEmail <- if -- TODO: refactor
|
||||
-- | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
|
||||
-- -> return $ CI.mk userEmail
|
||||
| userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
|
||||
userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E<number@fraport.de` here, too strong! Make Email-Field optional!
|
||||
| userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
|
||||
-> return $ CI.mk userEmail
|
||||
-- | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above!
|
||||
-- -> return $ CI.mk userEmail
|
||||
| otherwise
|
||||
-> throwM CampusUserInvalidEmail
|
||||
|
||||
@ -306,19 +306,20 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
|
||||
, userPrefersPostal = userDefaultPrefersPostal
|
||||
, ..
|
||||
}
|
||||
userUpdate = [
|
||||
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
|
||||
UserFirstName =. userFirstName
|
||||
, UserSurname =. userSurname
|
||||
, UserEmail =. userEmail
|
||||
, UserLastLdapSynchronisation =. Just now
|
||||
, UserLdapPrimaryKey =. userLdapPrimaryKey
|
||||
, UserMobile =. userMobile
|
||||
, UserTelephone =. userTelephone
|
||||
, UserCompanyPersonalNumber =. userCompanyPersonalNumber
|
||||
, UserCompanyDepartment =. userCompanyDepartment
|
||||
] ++
|
||||
[ UserLastAuthentication =. Just now | isLogin ]
|
||||
userUpdate =
|
||||
[ UserLastAuthentication =. Just now | isLogin ] ++
|
||||
[ UserEmail =. userEmail | validEmail' userEmail ] ++
|
||||
[
|
||||
-- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
|
||||
UserFirstName =. userFirstName
|
||||
, UserSurname =. userSurname
|
||||
, UserLastLdapSynchronisation =. Just now
|
||||
, UserLdapPrimaryKey =. userLdapPrimaryKey
|
||||
, UserMobile =. userMobile
|
||||
, UserTelephone =. userTelephone
|
||||
, UserCompanyPersonalNumber =. userCompanyPersonalNumber
|
||||
, UserCompanyDepartment =. userCompanyDepartment
|
||||
]
|
||||
return (newUser, userUpdate)
|
||||
|
||||
where
|
||||
|
||||
@ -52,6 +52,13 @@ userAddress :: User -> Address
|
||||
userAddress User{userEmail, userDisplayEmail, userDisplayName}
|
||||
= Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
|
||||
|
||||
userAddressError :: (MonadHandler m, HandlerSite m ~ UniWorX) => User -> m (Bool, Address)
|
||||
userAddressError User{userEmail, userDisplayEmail, userDisplayName}
|
||||
| Just okEmail <- pickValidEmail' userDisplayEmail userEmail = pure (True, Address (Just userDisplayName) $ CI.original okEmail)
|
||||
| otherwise = do
|
||||
$logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow userDisplayEmail <> " Sent to support instead." -- <> " with subject " <> tshow failedSubject
|
||||
(True,) <$> getsYesod (view _appMailSupport)
|
||||
|
||||
-- | Send an email to the given UserId or to all registered Supervisor with rerouteNotifications == True
|
||||
userMailT :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
@ -59,7 +66,7 @@ userMailT :: ( MonadHandler m
|
||||
, MonadUnliftIO m
|
||||
) => UserId -> MailT m () -> m ()
|
||||
userMailT uid mAct = do
|
||||
(underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid
|
||||
(underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid
|
||||
let undername = underling ^. _userDisplayName -- nameHtml' underling
|
||||
undermail = CI.original $ pickValidEmail (underling ^. _userDisplayEmail) (underling ^. _userEmail)
|
||||
infoSupervised :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|
|
||||
@ -98,21 +105,17 @@ userMailT uid mAct = do
|
||||
$else
|
||||
_{MsgMailSupervisorNoCopy}
|
||||
|]
|
||||
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
|
||||
(mailOk, mailtoAddr) <- userAddressError supervisor -- ensures a valid email, logs error and sends to support otherwise
|
||||
|
||||
mailT ctx $ do
|
||||
_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
|
||||
unless mailOk $ mapSubject ("[ERROR]" <>)
|
||||
|
||||
-- | like userMailT, but always sends a single mail to the given UserId, ignoring supervisors
|
||||
userMailTdirect :: ( MonadHandler m
|
||||
@ -137,23 +140,13 @@ userMailTdirect uid mAct = do
|
||||
SelFormatTime -> userTimeFormat
|
||||
, mcCsvOptions = userCsvOptions
|
||||
}
|
||||
mailtoAddr = userAddress user
|
||||
(mailOk, mailtoAddr) <- userAddressError user -- ensures a valid email, logs error and sends to support otherwise
|
||||
mailT ctx $ do
|
||||
failedSubject <- lookupMailHeader "Subject"
|
||||
unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
|
||||
-- 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
|
||||
-}
|
||||
|
||||
|
||||
unless mailOk $ mapSubject ("[ERROR]" <>)
|
||||
mAct
|
||||
|
||||
addFileDB :: ( MonadMail m
|
||||
, HandlerSite m ~ UniWorX
|
||||
|
||||
Loading…
Reference in New Issue
Block a user