From 234dd28f48095a81da6dff8c9a817c477d2c69d6 Mon Sep 17 00:00:00 2001 From: Steffen Date: Thu, 18 Apr 2024 13:32:00 +0200 Subject: [PATCH] refactor(avs): rework fraport email recognition --- models/users.model | 2 +- src/Handler/Utils/Avs.hs | 4 ++-- src/Handler/Utils/Users.hs | 18 +++++++----------- src/Utils.hs | 8 ++++++++ src/Utils/Mail.hs | 19 ++++++++++++++++++- 5 files changed, 36 insertions(+), 15 deletions(-) diff --git a/models/users.model b/models/users.model index 5597a7375..f1e35c47e 100644 --- a/models/users.model +++ b/models/users.model @@ -21,7 +21,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create lastAuthentication UTCTime Maybe -- last login date created UTCTime default=now() lastLdapSynchronisation UTCTime Maybe - ldapPrimaryKey UserEduPersonPrincipalName Maybe + ldapPrimaryKey UserEduPersonPrincipalName Maybe -- Fraport Personnel Number or Email-Prefix for @fraport.de work here tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null) matrikelnummer UserMatriculation Maybe -- usually a number; AVS Personalnummer; nicht Fraport Personalnummer! firstName Text -- For export in tables, pre-split firstName from displayName diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 7816fc2e8..d282b3e77 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -672,7 +672,7 @@ createAvsUserById api = do return $ seq userCompId $ seq userAvsId uid - +-- | upsert superior by eMail through LDAP only (currently no email search available in AVS) repsertSuperiorSupervisor :: Maybe CompanyId -> AvsFirmInfo -> UserId -> DB () repsertSuperiorSupervisor cid afi uid = whenIsJust (afi ^. _avsFirmEMailSuperior) $ \supemail -> forMM_ @@ -762,7 +762,7 @@ guessAvsUser someid = do other -> do -- attempt to recover by trying other ids whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all runDB . runMaybeT $ - let someIdent = stripCI someid + let someIdent = stripCI someid -- also see Handler.Utils.guessUserByEmail for a similar function, this one is more lenient, since a unique email is acceptable, even it would not be unique as DisplayEmail in MaybeT (getKeyBy $ UniqueEmail someIdent) -- recall that monadic actions are only executed until first success here <|> MaybeT (getKeyBy $ UniqueAuthentication someIdent) <|> MaybeT (getKeyByFilter [UserDisplayEmail ==. someIdent]) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 6c1f11dbf..844ad0c20 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -201,17 +201,13 @@ computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256 computeUserAuthenticationDigest = hashlazy . JSON.encode guessUserByEmail :: UserEmail -> DB (Maybe UserId) -guessUserByEmail eml = listToMaybe <$> selectKeysList - (ofoldl1Ex' (||.) - [ [UserDisplayEmail ==. eml] - , [UserEmail ==. eml] - , [UserIdent ==. eml] - -- , [UserLdapPrimaryKey ==. Text.stripSuffix "@fraport.de" $ CI.foldedCase eml] - ] - ) - [ Asc UserEmail -- Unique, to ensure reproducable results - , LimitTo 1 - ] +guessUserByEmail eml = getKeyByFilter $ ofoldl1Ex' (||.) $ + mcons (getFraportLogin (CI.original eml) <&> (\lgi -> + [UserLdapPrimaryKey ==. Just lgi])) -- Note that we must exclude `==. Nothing` here! + [ [UserDisplayEmail ==. eml] + , [UserEmail ==. eml] + , [UserIdent ==. eml] + ] data GuessUserInfo = GuessUserMatrikelnummer diff --git a/src/Utils.hs b/src/Utils.hs index 58ad3ab19..8d42aa073 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1039,6 +1039,14 @@ altM ma mb = ma >>= \case Nothing -> mb res -> return res +-- | Map f and get the first Just +firstJust :: MonoFoldable mono => (Element mono -> Maybe a) -> mono -> Maybe a +firstJust f = foldr go Nothing + where + -- go :: a -> Maybe b -> Maybe b + go x Nothing = f x + go _ res = res + -- Takes computations returnings @Maybe@; tries each one in order. -- The first one to return a @Just@ wins. Returns @Nothing@ if all computations -- return @Nothing@. diff --git a/src/Utils/Mail.hs b/src/Utils/Mail.hs index 6f172a5ac..a59498e39 100644 --- a/src/Utils/Mail.hs +++ b/src/Utils/Mail.hs @@ -13,12 +13,29 @@ import qualified Data.CaseInsensitive as CI import qualified Text.Email.Validate as Email +-- | domains used by LDAP accounts +fraportMailDomains :: [Text] +fraportMailDomains = ["@fraport.de"] -- <&> foldCase only! + +-- | returns the part before the @ symbol of an email address that ends with a fraport domain, preserving case +-- eg. getFraportLogin "E1234@fraport.de" == Just "E1234" +-- getFraportLogin "S.Guy@fraport.de" == Just "S.Guy" +-- getFraportLogin "S.Guy@elsewhere.com" == Nothing +-- Use CI.traverse getFraportLogin :: CI Text -> Maybe (CI Text) +-- CI.traverse getFraportLogin "S.Jost@Fraport.de" == Just "S.Jost" +getFraportLogin :: Text -> Maybe Text +getFraportLogin email = orgCase <$> lowerCaseLogin + where + orgCase = flip Text.take email . Text.length + lowerCaseLogin = firstJust (flip Text.stripSuffix $ foldCase email) fraportMailDomains + +-- | check that an email is valid and that it is not an E-account that nobody reads -- also see `Handler.Utils.Users.getUserEmail` for Tests accepting User Type validEmail :: Text -> Bool -- Email = Text validEmail email = validRFC5322 && not invalidFraport where validRFC5322 = Email.isValid $ encodeUtf8 email - invalidFraport = case Text.stripSuffix "@fraport.de" (foldCase email) of + invalidFraport = case getFraportLogin email of Just fralogin -> Text.all Char.isDigit $ Text.drop 1 fralogin -- Emails like E1234@fraport.de or 012345!fraport.de are not read Nothing -> False