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

chore(user): assimilateUsers respects LmsUser and CompanyUser now

Browse Source
This commit is contained in:
Steffen Jost 2022-11-16 13:47:32 +01:00
parent c04704a549
commit a5010eb61d
2 changed files with 60 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/Database/Esqueleto/Utils.hs
View File

@ -430,6 +430,7 @@ bool onFalse onTrue val = E.case_
(E.else_ onFalse) (E.else_ onFalse)
-- called see greatest and least within postgresql -- called see greatest and least within postgresql
-- TODO: this is buggy! Both return always the first argument if any argument is NULL!
max, min :: PersistField a max, min :: PersistField a
=> E.SqlExpr (E.Value a) => E.SqlExpr (E.Value a)
-> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
@ -437,7 +438,7 @@ max, min :: PersistField a
max a b = bool a b $ b E.>. a max a b = bool a b $ b E.>. a
min a b = bool a b $ b E.<. a min a b = bool a b $ b E.<. a
-- these alternatives for max/min ought to be more efficient -- these alternatives for max/min ought to be more efficient; note that NULL is avoided by greatest/least
greatest :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) greatest :: PersistField a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
greatest a b = E.unsafeSqlFunction "GREATEST" $ E.toArgList (a,b) greatest a b = E.unsafeSqlFunction "GREATEST" $ E.toArgList (a,b)

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

@ -273,6 +273,7 @@ data UserAssimilateExceptionReason
| UserAssimilatePersonalisedSheetFileDifferentContent (Entity PersonalisedSheetFile) (Entity PersonalisedSheetFile) | UserAssimilatePersonalisedSheetFileDifferentContent (Entity PersonalisedSheetFile) (Entity PersonalisedSheetFile)
| UserAssimilateTutorialParticipantCollidingRegGroups (Entity TutorialParticipant) (Entity TutorialParticipant) | UserAssimilateTutorialParticipantCollidingRegGroups (Entity TutorialParticipant) (Entity TutorialParticipant)
| UserAssimilateCouldNotDetermineUserIdents | UserAssimilateCouldNotDetermineUserIdents
| UserAssimilateConflictingLmsQualifications (Set.Set QualificationId)
deriving (Eq, Ord, Show, Generic, Typeable) deriving (Eq, Ord, Show, Generic, Typeable)
assimilateUser :: UserId -- ^ @newUserId@ assimilateUser :: UserId -- ^ @newUserId@
@ -846,7 +847,21 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
delete oldSFId delete oldSFId
in runConduit $ getStudyFeatures .| C.mapM_ upsertStudyFeatures in runConduit $ getStudyFeatures .| C.mapM_ upsertStudyFeatures
-- lms -- Qualifications and ongoing LMS
-- LmsUser: insertSelectWithConflict impossible due to 2 simultaneous uniqueness constraints; UniqueLmsIdent requires proper update, prohibits insert and then delete
-- updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] -- might fail due to UniqueLmsQualficationUuser
oldLms <- selectList [ LmsUserUser ==. oldUserId ] [ Asc LmsUserQualification ]
newLms <- selectList [ LmsUserUser ==. newUserId ] [ Asc LmsUserQualification ]
let projQ = lmsUserQualification . entityVal
oldQs = Set.fromList (projQ <$> oldLms)
newQs = Set.fromList (projQ <$> newLms)
qConflicts = oldQs `Set.intersection` newQs
qResolvable = Set.fromList [ lmsUserQualification | Entity _ LmsUser{..} <- oldLms, isJust lmsUserEnded, lmsUserQualification `Set.member` qConflicts ]
qProblems = qConflicts `Set.difference` qResolvable
unless (Set.null qProblems) $ tellError $ UserAssimilateConflictingLmsQualifications qProblems
unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration
updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ]
updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ]
E.insertSelectWithConflict E.insertSelectWithConflict
UniqueQualificationUser UniqueQualificationUser
(E.from $ \qualificationUser -> do (E.from $ \qualificationUser -> do
@ -860,15 +875,52 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
E.<&> (qualificationUser E.^. QualificationUserBlockedDue) E.<&> (qualificationUser E.^. QualificationUserBlockedDue)
) )
(\current excluded -> (\current excluded ->
[ QualificationUserValidUntil E.=. combineWith current excluded E.max QualificationUserValidUntil [ QualificationUserValidUntil E.=. combineWith current excluded E.greatest QualificationUserValidUntil
, QualificationUserLastRefresh E.=. combineWith current excluded E.max QualificationUserLastRefresh , QualificationUserLastRefresh E.=. combineWith current excluded E.greatest QualificationUserLastRefresh
, QualificationUserFirstHeld E.=. combineWith current excluded E.min QualificationUserFirstHeld , QualificationUserFirstHeld E.=. combineWith current excluded E.least QualificationUserFirstHeld
, QualificationUserBlockedDue E.=. combineWith current excluded E.max QualificationUserBlockedDue , QualificationUserBlockedDue E.=. combineWith current excluded E.greatest QualificationUserBlockedDue -- Tested: PostgreSQL GREATEST/LEAST ignores NULL values
] ]
) )
-- TODO: LmsUser!
deleteWhere [ QualificationUserUser ==. oldUserId ] deleteWhere [ QualificationUserUser ==. oldUserId ]
-- Supervision is fully merged
E.insertSelectWithConflict
UniqueUserSupervisor
(E.from $ \userSupervisor -> do
E.where_ $ userSupervisor E.^. UserSupervisorSupervisor E.==. E.val oldUserId
return $ UserSupervisor
E.<# E.val newUserId
E.<&> (userSupervisor E.^. UserSupervisorUser)
E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
)
(\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] )
deleteWhere [ UserSupervisorSupervisor ==. oldUserId]
E.insertSelectWithConflict
UniqueUserSupervisor
(E.from $ \userSupervisor -> do
E.where_ $ userSupervisor E.^. UserSupervisorUser E.==. E.val oldUserId
return $ UserSupervisor
E.<# (userSupervisor E.^. UserSupervisorSupervisor)
E.<&> E.val newUserId
E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
)
(\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) ] )
deleteWhere [ UserSupervisorUser ==. oldUserId]
-- Companies, in conflict, keep the newUser-Company as is
E.insertSelectWithConflict
UniqueCompanyUser
(E.from $ \userCompany -> do
E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId
return $ UserCompany
E.<# (userCompany E.^. UserCompanyCompany)
E.<&> E.val newUserId
E.<&> (userCompany E.^. UserCompanySupervisor)
)
(\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] )
deleteWhere [ UserCompanyUser ==. oldUserId]
userIdents <- E.select . E.from $ \user -> do userIdents <- E.select . E.from $ \user -> do
E.where_ $ user E.^. UserId `E.in_` E.valList [newUserId, oldUserId] E.where_ $ user E.^. UserId `E.in_` E.valList [newUserId, oldUserId]
return ( user E.^. UserId return ( user E.^. UserId