174 lines
7.7 KiB
Haskell
174 lines
7.7 KiB
Haskell
module Handler.Utils.Users
|
|
( computeUserAuthenticationDigest
|
|
, Digest, SHA3_256
|
|
, constEq
|
|
, NameMatchQuality(..)
|
|
, matchesName
|
|
, GuessUserInfo(..)
|
|
, guessUser
|
|
) where
|
|
|
|
import Import
|
|
import Auth.LDAP (campusUserMatr')
|
|
import Foundation.Yesod.Auth (upsertCampusUser)
|
|
|
|
import Crypto.Hash (hashlazy)
|
|
|
|
import Data.ByteArray (constEq)
|
|
import Data.Maybe (fromJust)
|
|
import qualified Data.List.NonEmpty as NonEmpty (fromList)
|
|
|
|
import qualified Data.Aeson as JSON
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Data.MultiSet as MultiSet
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Text as Text
|
|
|
|
|
|
computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
|
|
computeUserAuthenticationDigest = hashlazy . JSON.encode
|
|
|
|
|
|
data GuessUserInfo
|
|
= GuessUserMatrikelnummer { guessUserMatrikelnummer :: UserMatriculation }
|
|
| GuessUserDisplayName { guessUserDisplayName :: UserDisplayName }
|
|
| GuessUserSurname { guessUserSurname :: UserSurname }
|
|
| GuessUserFirstName { guessUserFirstName :: UserFirstName }
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
instance Binary GuessUserInfo
|
|
|
|
makeLenses_ ''GuessUserInfo
|
|
|
|
data NameMatchQuality
|
|
= NameMatchSuffix
|
|
| NameMatchPrefix
|
|
| NameMatchPermutation
|
|
| NameMatchEqual
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
matchesName :: Textual t
|
|
=> t -- ^ haystack
|
|
-> t -- ^ needle
|
|
-> Maybe NameMatchQuality
|
|
matchesName (repack -> haystack) (repack -> needle)
|
|
= fmap (view _1) . Map.lookupMax $ Map.filter id tests
|
|
where
|
|
asWords :: Text -> [CI Text]
|
|
asWords = map CI.mk . filter (not . Text.null) . Text.words . Text.strip
|
|
|
|
tests :: Map NameMatchQuality Bool
|
|
tests = mconcat
|
|
[ singletonMap NameMatchEqual $ asWords needle == asWords haystack
|
|
, singletonMap NameMatchPrefix $ asWords needle `isPrefixOf` asWords haystack
|
|
, singletonMap NameMatchSuffix $ asWords needle `isSuffixOf` asWords haystack
|
|
, singletonMap NameMatchPermutation $ ((==) `on` MultiSet.fromList) (asWords needle) (asWords haystack)
|
|
]
|
|
|
|
|
|
guessUser :: PredDNF GuessUserInfo -- ^ guessing criteria
|
|
-> Maybe Int64 -- ^ Should the query be limited to a maximum number of results?
|
|
-> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User))) -- ^ Just (Left _) in case of multiple results,
|
|
-- Just (Right _) in case of single result, and
|
|
-- Nothing in case of no result
|
|
guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) mQueryLimit = $cachedHereBinary criteria $ go False
|
|
where
|
|
asWords :: Text -> [Text]
|
|
asWords = filter (not . Text.null) . Text.words . Text.strip
|
|
|
|
containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y
|
|
|
|
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'
|
|
|
|
go didLdap = do
|
|
let retrieveUsers = E.select . E.from $ \user -> do
|
|
E.where_ . E.or $ map (E.and . map (toSql user)) criteria
|
|
when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit
|
|
return user
|
|
users <- retrieveUsers
|
|
let users' = sortBy (flip closeness) users
|
|
|
|
matchesMatriculation :: Entity User -> Maybe Bool
|
|
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 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 ^. userField `matches` name)
|
|
( ur ^. userField `matches` name)
|
|
comp False userField guess = (term ^.. folded . _PLNegated . guess) <&> \name ->
|
|
compare (Down $ ul ^. userField `matches` name)
|
|
(Down $ ur ^. userField `matches` name)
|
|
in mconcat $ concat $
|
|
[ pure $ compare (Down $ matchesMatriculation ul) (Down $ matchesMatriculation ur)
|
|
] <>
|
|
[ comp b userField guess
|
|
| (userField,guess) <- [(_userSurname , _guessUserSurname)
|
|
,(_userFirstName , _guessUserFirstName)
|
|
,(_userDisplayName, _guessUserDisplayName)
|
|
]
|
|
, b <- [True,False]
|
|
]
|
|
|
|
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
|
|
fmap join . for ldapPool' $ \ldapPool -> do
|
|
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'
|
|
, Just True == matchesMatriculation x || didLdap
|
|
-> return $ Just $ Right x
|
|
| x : x' : _ <- users'
|
|
, Just True == matchesMatriculation x || didLdap
|
|
, GT <- x `closeness` x'
|
|
-> return $ Just $ Right x
|
|
| xs@(x:_:_) <- takeClosest users'
|
|
, Just True == matchesMatriculation x || didLdap
|
|
-> return $ Just $ Left $ NonEmpty.fromList xs
|
|
| not didLdap
|
|
, userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria
|
|
-> mapM doLdap userMatrs >>= maybe (go True) (return . Just) . convertLdapResults . catMaybes
|
|
| otherwise
|
|
-> return Nothing
|