89 lines
3.6 KiB
Haskell
89 lines
3.6 KiB
Haskell
module Handler.Utils.Users
|
|
( computeUserAuthenticationDigest
|
|
, Digest, SHA3_256
|
|
, constEq
|
|
, GuessUserInfo(..)
|
|
, guessUser
|
|
) where
|
|
|
|
import Import
|
|
import Auth.LDAP (campusUserMatr')
|
|
|
|
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
|
|
|
|
|
|
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
|
|
|
|
guessUser :: Set GuessUserInfo -> DB (Maybe UserId)
|
|
guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
|
|
where
|
|
toSql user = \case
|
|
GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation')
|
|
GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `E.hasInfix` E.val userDisplayName'
|
|
GuessUserSurname userSurname' -> user E.^. UserSurname `E.hasInfix` E.val userSurname'
|
|
GuessUserFirstName userFirstName' -> user E.^. UserFirstName `E.hasInfix` E.val 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 (preview $ _entityVal . _userSurname . to CI.mk . only (CI.mk surn))
|
|
, (criteria ^.. folded . _guessUserFirstName) <&> \firstn -> comparing (preview $ _entityVal . _userFirstName . to CI.mk . only (CI.mk firstn))
|
|
, (criteria ^.. folded . _guessUserDisplayName) <&> \dispn -> comparing (preview $ _entityVal . _userDisplayName . to CI.mk . only (CI.mk dispn))
|
|
]
|
|
|
|
doLdap userMatr = do
|
|
app <- getYesod
|
|
let ldap = (,) <$> app ^. _appLdapConf <*> app ^. _appLdapPool
|
|
fmap (fmap entityKey . join) . for ldap $ \(ldapConf, ldapPool) -> do
|
|
ldapData <- campusUserMatr' ldapConf ldapPool userMatr
|
|
for ldapData $ upsertCampusUser UpsertCampusUser
|
|
|
|
|
|
case users' of
|
|
x@(Entity pid _) : xs
|
|
| [] <- xs
|
|
, fromMaybe False (matchesMatriculation x) || didLdap
|
|
-> return $ Just pid
|
|
| x' : _ <- xs
|
|
, fromMaybe False (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)
|
|
_other
|
|
-> return Nothing
|