123 lines
4.8 KiB
Haskell
123 lines
4.8 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 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 :: Set GuessUserInfo -> DB (Maybe UserId)
|
|
guessUser (Set.toList -> criteria) = $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 = \case
|
|
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.and $ map (toSql user) criteria
|
|
return user
|
|
users <- retrieveUsers
|
|
let users' = sortBy (flip closeness) users
|
|
|
|
matchesMatriculation :: Entity User -> Maybe Bool
|
|
matchesMatriculation = preview $ _entityVal . _userMatrikelnummer . to (\userMatr -> all ((== userMatr) . Just) $ criteria ^.. folded . _guessUserMatrikelnummer)
|
|
|
|
closeness :: Entity User -> Entity User -> Ordering
|
|
closeness = mconcat $ concat
|
|
[ pure $ comparing (fmap Down . matchesMatriculation)
|
|
, (criteria ^.. folded . _guessUserSurname) <&> \surn -> comparing (view $ _entityVal . _userSurname . to (`matchesName` surn))
|
|
, (criteria ^.. folded . _guessUserFirstName) <&> \firstn -> comparing (view $ _entityVal . _userFirstName . to (`matchesName` firstn))
|
|
, (criteria ^.. folded . _guessUserDisplayName) <&> \dispn -> comparing (view $ _entityVal . _userDisplayName . to (`matchesName` dispn))
|
|
]
|
|
|
|
doLdap userMatr = do
|
|
ldapPool' <- getsYesod $ view _appLdapPool
|
|
fmap (fmap entityKey . join) . for ldapPool' $ \ldapPool -> do
|
|
ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
|
|
for ldapData $ upsertCampusUser UpsertCampusUser
|
|
|
|
if
|
|
| [x@(Entity pid _)] <- users'
|
|
, Just True == matchesMatriculation x || didLdap
|
|
-> return $ Just pid
|
|
| x@(Entity pid _) : x' : _ <- users'
|
|
, Just True == matchesMatriculation x || didLdap
|
|
, GT <- x `closeness` x'
|
|
-> return $ Just pid
|
|
| not didLdap
|
|
, userMatr : userMatrs' <- criteria ^.. folded . _guessUserMatrikelnummer
|
|
, all (== userMatr) userMatrs'
|
|
-> doLdap userMatr >>= maybe (go True) (return . Just)
|
|
| otherwise
|
|
-> return Nothing
|