diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 70a8abfb9..aaa04294d 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -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 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 diff --git a/src/Handler/Utils/Mail.hs b/src/Handler/Utils/Mail.hs index f90ffd604..bda5fe032 100644 --- a/src/Handler/Utils/Mail.hs +++ b/src/Handler/Utils/Mail.hs @@ -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