From 58ae9dddbc994f17cc52cc0940d996dedf583ba5 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Fri, 14 Aug 2020 15:53:27 +0200 Subject: [PATCH] feat(guess-user): variant of guessUser --- src/Handler/Utils/Users.hs | 57 +++++++++++++++++++++---------------- src/Model/Types/Security.hs | 1 + 2 files changed, 33 insertions(+), 25 deletions(-) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index a79e3b4fe..251bce187 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -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 diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 00723ec41..202eff51b 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -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