fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

chore(users): tweak assimilateUsers for new config

Browse Source
This commit is contained in:
Sarah Vaupel 2024-02-20 00:38:46 +01:00
parent 9bf7033eac
commit 8a353c357f
1 changed files with 7 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -27,17 +27,16 @@ import Import
import Auth.LDAP (ldapUserMatr') import Auth.LDAP (ldapUserMatr')
import Foundation.Yesod.Auth (upsertUser) import Foundation.Yesod.Auth (upsertUser)
import Crypto.Hash (hashlazy) -- import Crypto.Hash (hashlazy)
import Data.ByteArray (constEq) import Data.ByteArray (constEq)
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import qualified Data.List.NonEmpty as NonEmpty (fromList) import qualified Data.List.NonEmpty as NonEmpty (fromList)
import qualified Data.Aeson as JSON -- import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON import qualified Data.Aeson.Types as JSON
import qualified Data.Set as Set import qualified Data.Set as Set
-- import qualified Data.List as List
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Database.Esqueleto.Experimental ((:&)(..)) import Database.Esqueleto.Experimental ((:&)(..))
@ -235,11 +234,12 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
| EQ <- x `closeness` x' = x : takeClosest (x':xs) | EQ <- x `closeness` x' = x : takeClosest (x':xs)
| otherwise = [x] | otherwise = [x]
-- TODO: Generalize
doLdap userMatr = do doLdap userMatr = do
ldapPool' <- getsYesod $ view _appLdapPool ldapPool' <- getsYesod $ view _appLdapPool
fmap join . for ldapPool' $ \ldapPool -> do fmap join . for ldapPool' $ \ldapPool@(upsertUserLdapConf,_) -> do
ldapData <- ldapUserMatr' ldapPool userMatr ldapData <- ldapUserMatr' ldapPool userMatr
for ldapData $ upsertLdapUser UpsertUserGuessUser for ldapData $ \upsertUserLdapData -> upsertUser UpsertUserGuessUser UpsertUserDataLdap{..}
let let
getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation
@ -909,9 +909,8 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
mergeMaybe = mergeBy (\oldV newV -> isNothing newV && isJust oldV) mergeMaybe = mergeBy (\oldV newV -> isNothing newV && isJust oldV)
update newUserId $ catMaybes -- NOTE: persist does shortcircuit null updates as expected update newUserId $ catMaybes -- NOTE: persist does shortcircuit null updates as expected
[ mergeMaybe UserLdapPrimaryKey [ mergeMaybe UserPasswordHash
, mergeBy (<) UserAuthentication , mergeBy (>) UserLastLogin
, mergeBy (>) UserLastAuthentication
, mergeBy (<) UserCreated , mergeBy (<) UserCreated
, toMaybe (not (validEmail' (newUser ^. _userEmail )) && validEmail' (oldUser ^. _userEmail)) , toMaybe (not (validEmail' (newUser ^. _userEmail )) && validEmail' (oldUser ^. _userEmail))
(UserEmail =. oldUser ^. _userEmail) (UserEmail =. oldUser ^. _userEmail)