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

feat(guess-user): variant of guessUser

Browse Source
This commit is contained in:
Sarah Vaupel 2020-08-14 15:53:27 +02:00
parent e1a9977772
commit 58ae9dddbc
2 changed files with 33 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -123,8 +123,6 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
-> return Nothing
-- TODO replace guessUser with guessUserTmp when finished
-- TODO PredDNF GuessUserInfo instead of Set GuessUserInfo (work in progress)
guessUserTmp :: PredDNF GuessUserInfo -> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User)))
guessUserTmp (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) = $cachedHereBinary criteria $ go False
where
@ -133,34 +131,50 @@ guessUserTmp (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteri
containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y
toSql user = \case
toSql user pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of
GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation')
GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName'
GuessUserSurname userSurname' -> user E.^. UserSurname `containsAsSet` userSurname'
GuessUserFirstName userFirstName' -> user E.^. UserFirstName `containsAsSet` userFirstName'
mNeg PLVariable{} = id
mNeg PLNegated{} = E.not_
go didLdap = do
let retrieveUsers = E.select . E.from $ \user -> do
E.where_ . E.or $ map (E.and . map (\c -> mNeg c $ toSql user $ plVar c)) criteria
E.where_ . E.or $ map (E.and . map (toSql user)) criteria
return user
users <- retrieveUsers
let users' = sortBy (flip closeness) users
-- TODO account for PLNegated
-- TODO enhance
matchesMatriculation :: Entity User -> Maybe Bool
matchesMatriculation = preview $ _entityVal . _userMatrikelnummer . to (\userMatr -> any ((== userMatr) . Just) $ criteria ^.. folded . folded . _plVar . _guessUserMatrikelnummer)
matchesMatriculation = preview $ _entityVal . _userMatrikelnummer . to (\userMatr ->
any (\p -> all ((== userMatr) . Just) (p ^.. folded . _PLVariable . _guessUserMatrikelnummer)
&& all ((/= userMatr) . Just) (p ^.. folded . _PLNegated . _guessUserMatrikelnummer))
$ criteria ^.. folded)
closeness :: Entity User -> Entity User -> Ordering
closeness = mconcat $ concat
[ pure $ comparing (fmap Down . matchesMatriculation)
-- TODO account for PLNegated below
, (criteria ^.. folded . folded . _plVar . _guessUserSurname) <&> \surn -> comparing (view $ _entityVal . _userSurname . to (`matchesName` surn))
, (criteria ^.. folded . folded . _plVar . _guessUserFirstName) <&> \firstn -> comparing (view $ _entityVal . _userFirstName . to (`matchesName` firstn))
, (criteria ^.. folded . folded . _plVar . _guessUserDisplayName) <&> \dispn -> comparing (view $ _entityVal . _userDisplayName . to (`matchesName` dispn))
]
closeness ul ur = maximum $ impureNonNull $ criteria <&> \term ->
let
comp True userField guess = (term ^.. folded . _PLVariable . guess) <&> \name ->
compare ( ul ^. _entityVal . userField . to (`matchesName` name))
( ur ^. _entityVal . userField . to (`matchesName` 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
[ 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
]
takeClosest [] = []
takeClosest [x] = [x]
takeClosest (x:x':xs)
| EQ <- x `closeness` x' = x : takeClosest (x':xs)
| otherwise = [x]
doLdap userMatr = do
ldapPool' <- getsYesod $ view _appLdapPool
@ -168,13 +182,6 @@ guessUserTmp (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteri
ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
for ldapData $ upsertCampusUser UpsertCampusUser
let
aux [] = []
aux [x] = [x]
aux (x:x':xs)
| EQ <- x `closeness` x' = x : aux (x':xs)
| otherwise = [x]
if
| x : [] <- users'
, fromMaybe False (matchesMatriculation x) || didLdap
@ -183,11 +190,11 @@ guessUserTmp (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteri
, fromMaybe False (matchesMatriculation x) || didLdap
, GT <- x `closeness` x'
-> return $ Just $ Right x
| xs@(x:_:_) <- aux users'
| xs@(x:_:_) <- takeClosest users'
, fromMaybe False (matchesMatriculation x) || didLdap
-> return $ Just $ Left $ NonEmpty.fromList xs
| not didLdap
, userMatr : userMatrs' <- criteria ^.. folded . folded . _plVar . _guessUserMatrikelnummer
, userMatr : userMatrs' <- criteria ^.. folded . folded . _PLVariable . _guessUserMatrikelnummer
, all (== userMatr) userMatrs'
-> doLdap userMatr >>= maybe (go True) (return . Just . Right)
| otherwise

1
src/Model/Types/Security.hs
View File

@ -132,6 +132,7 @@ data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
deriving anyclass (Hashable, Binary)
makeLenses_ ''PredLiteral
makePrisms ''PredLiteral
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1