fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(guess-user): fix ldap-lookup condition and refactor

Browse Source
This commit is contained in:
Sarah Vaupel 2020-08-15 16:37:13 +02:00
parent 4154a395f4
commit ad4ae713c8
1 changed files with 35 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
src/Handler/Utils/Users.hs
View File

@ -96,7 +96,6 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
users <- retrieveUsers
let users' = sortBy (flip closeness) users
-- TODO enhance
matchesMatriculation :: Entity User -> Maybe Bool
matchesMatriculation = preview $ _entityVal . _userMatrikelnummer . to (\userMatr ->
any (\p -> all ((== userMatr) . Just) (p ^.. folded . _PLVariable . _guessUserMatrikelnummer)
@ -106,21 +105,23 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
closeness :: Entity User -> Entity User -> Ordering
closeness ul ur = maximum $ impureNonNull $ criteria <&> \term ->
let
matches userField name = _entityVal . userField . to (`matchesName` name)
comp True userField guess = (term ^.. folded . _PLVariable . guess) <&> \name ->
compare ( ul ^. _entityVal . userField . to (`matchesName` name))
( ur ^. _entityVal . userField . to (`matchesName` name))
compare ( ul ^. userField `matches` name)
( ur ^. userField `matches` name)
comp False userField guess = (term ^.. folded . _PLNegated . guess) <&> \name ->
compare (Down $ ul ^. _entityVal . userField . to (`matchesName` name))
(Down $ ur ^. _entityVal . userField . to (`matchesName` name))
in mconcat $ concat
compare (Down $ ul ^. userField `matches` name)
(Down $ ur ^. userField `matches` name)
in mconcat $ concat $
[ pure $ compare (Down $ matchesMatriculation ul) (Down $ matchesMatriculation ur)
, comp True _userSurname _guessUserSurname
, comp False _userSurname _guessUserSurname
, comp True _userFirstName _guessUserFirstName
, comp False _userFirstName _guessUserFirstName
, comp True _userDisplayName _guessUserDisplayName
, comp False _userDisplayName _guessUserDisplayName
]
] <>
[ comp b userField guess
| (userField,guess) <- [(_userSurname , _guessUserSurname)
,(_userFirstName , _guessUserFirstName)
,(_userDisplayName, _guessUserDisplayName)
]
, b <- [True,False]
]
takeClosest [] = []
takeClosest [x] = [x]
@ -134,6 +135,25 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
for ldapData $ upsertCampusUser UpsertCampusUser
let
getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation
getTermMatr = getTermMatrAux Nothing where
getTermMatrAux acc [] = acc
getTermMatrAux acc (PLVariable (GuessUserMatrikelnummer matr):xs)
| Just matr' <- acc, matr == matr' = getTermMatrAux acc xs
| Nothing <- acc = getTermMatrAux (Just matr) xs
| otherwise = Nothing
getTermMatrAux acc (PLNegated (GuessUserMatrikelnummer matr):xs)
| Just matr' <- acc, matr /= matr' = getTermMatrAux acc xs
| Nothing <- acc = getTermMatrAux acc xs
| otherwise = Nothing
getTermMatrAux acc (_:xs) = getTermMatrAux acc xs
convertLdapResults :: [Entity User] -> Maybe (Either (NonEmpty (Entity User)) (Entity User))
convertLdapResults [] = Nothing
convertLdapResults [x] = Just $ Right x
convertLdapResults xs = Just $ Left $ NonEmpty.fromList xs
if
| x : [] <- users'
, fromMaybe False (matchesMatriculation x) || didLdap
@ -146,8 +166,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
, fromMaybe False (matchesMatriculation x) || didLdap
-> return $ Just $ Left $ NonEmpty.fromList xs
| not didLdap
, userMatr : userMatrs' <- criteria ^.. folded . folded . _PLVariable . _guessUserMatrikelnummer
, all (== userMatr) userMatrs'
-> doLdap userMatr >>= maybe (go True) (return . Just . Right)
, userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria
-> mapM doLdap userMatrs >>= maybe (go True) (return . Just) . convertLdapResults . catMaybes
| otherwise
-> return Nothing