From 006ab632a394ed8d566f7930e8f6fd5a6ba86814 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 7 Feb 2023 18:31:13 +0100 Subject: [PATCH] fix(ldap): allow ldap update for mangled user entries --- src/Foundation/Yesod/Auth.hs | 21 +++++++++++++++------ src/Handler/Utils/Profile.hs | 12 ++++++++++++ src/Handler/Utils/Users.hs | 4 +++- src/Jobs/Handler/SynchroniseLdap.hs | 7 ++++--- 4 files changed, 34 insertions(+), 10 deletions(-) diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index d231fd94d..70a8abfb9 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -174,7 +174,7 @@ upsertCampusUserByCn persNo = upsertCampusUser UpsertCampusUserGuessUser [(ldapP -- | Upsert User DB according to given LDAP data (does not query LDAP itself) upsertCampusUser :: forall m. ( MonadHandler m, HandlerSite m ~ UniWorX - , MonadThrow m + , MonadCatch m ) => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) upsertCampusUser upsertMode ldapData = do @@ -193,7 +193,14 @@ upsertCampusUser upsertMode ldapData = do (newUser ^. _userFirstName) (newUser ^. _userSurname) (userRec ^. _userDisplayName)) $ - update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ] + update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ] + when (validEmail' (userRec ^. _userEmail)) $ do + let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ] + ++ [ UserAuthentication =. AuthLDAP | is _AuthNoLogin (userRec ^. _userAuthentication) ] + unless (null emUps) $ update userId emUps + -- Attempt to update ident, too: + unless (validEmail' (userRec ^. _userIdent)) $ + void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ())) let userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions' @@ -253,9 +260,11 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do | otherwise -> throwM CampusUserInvalidIdent - userEmail <- if - | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) - -> return $ CI.mk userEmail + 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) + -> return $ CI.mk userEmail | otherwise -> throwM CampusUserInvalidEmail @@ -309,7 +318,7 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do , UserCompanyPersonalNumber =. userCompanyPersonalNumber , UserCompanyDepartment =. userCompanyDepartment ] ++ - [ UserLastAuthentication =. Just now | isLogin ] + [ UserLastAuthentication =. Just now | isLogin ] return (newUser, userUpdate) where diff --git a/src/Handler/Utils/Profile.hs b/src/Handler/Utils/Profile.hs index 027c90425..703b618b5 100644 --- a/src/Handler/Utils/Profile.hs +++ b/src/Handler/Utils/Profile.hs @@ -2,11 +2,14 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +-- TODO: why is this Handler.Utils.Profile instead of Utils.Profile? +-- TODO: consider merging with Handler.Utils.Users? module Handler.Utils.Profile ( checkDisplayName , validDisplayName , fixDisplayName , validPostAddress + , validEmail, validEmail' ) where import Import.NoFoundation @@ -14,10 +17,13 @@ import Import.NoFoundation import Data.Char import qualified Data.Text as Text import qualified Data.Text.Lazy as LT +import qualified Data.CaseInsensitive as CI import qualified Data.MultiSet as MultiSet import qualified Data.Set as Set +import qualified Text.Email.Validate as Email + -- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc. stripFold :: Text -> Text stripFold = Text.toCaseFold . Text.strip @@ -72,3 +78,9 @@ validPostAddress (Just StoredMarkup {markupInput = addr}) , 1 < length (LT.lines addr) = True validPostAddress _ = False + +validEmail :: Email -> Bool -- Email = Text +validEmail = Email.isValid . encodeUtf8 + +validEmail' :: UserEmail -> Bool -- UserEmail = CI Text +validEmail' = Email.isValid . encodeUtf8 . CI.original \ No newline at end of file diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index d2707ff66..9db8c737d 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -2,6 +2,7 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later +-- NOTE: Also see Handler.Utils.Profile for similar utilities module Handler.Utils.Users ( computeUserAuthenticationDigest , Digest, SHA3_256 @@ -44,6 +45,7 @@ import qualified Data.Conduit.Combinators as C import qualified Data.MultiSet as MultiSet import qualified Data.Map as Map import qualified Data.Text as Text +import Handler.Utils.Profile import Jobs.Types(Job, JobChildren) @@ -73,7 +75,7 @@ getPostalPreferenceAndAddress usr@User{..} = (((userPrefersPostal || isNothing userPinPassword) && postPossible) || emailImpossible, pa) where orgEmail = CI.original userEmail - emailImpossible = not ('@' `textElem` orgEmail && '.' `textElem` orgEmail) + emailImpossible = validEmail orgEmail postPossible = isJust pa pa = getPostalAddress usr diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs index 4f3b846a7..9e72713b2 100644 --- a/src/Jobs/Handler/SynchroniseLdap.hs +++ b/src/Jobs/Handler/SynchroniseLdap.hs @@ -9,6 +9,7 @@ module Jobs.Handler.SynchroniseLdap import Import +import qualified Data.CaseInsensitive as CI import qualified Data.Conduit.List as C import Auth.LDAP @@ -47,13 +48,13 @@ dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do case appLdapPool of Just ldapPool -> runDB . void . runMaybeT . handleExc $ do - user@User{userIdent} <- MaybeT $ get jUser - + user@User{userIdent,userLdapPrimaryKey} <- MaybeT $ get jUser + let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey $logInfoS "SynchroniseLdap" [st|Synchronising #{userIdent}|] reTestAfter <- getsYesod $ view _appLdapReTestFailover ldapAttrs <- MaybeT $ campusUserReTest' ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited user - void . lift $ upsertCampusUser (UpsertCampusUserLdapSync userIdent) ldapAttrs + void . lift $ upsertCampusUser (UpsertCampusUserLdapSync upsertIdent) ldapAttrs Nothing -> throwM SynchroniseLdapNoLdap where