-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# LANGUAGE TypeApplications #-} -- NOTE: Also see Handler.Utils.Profile for similar utilities module Handler.Utils.Users ( -- computeUserAuthenticationDigest -- , Digest, SHA3_256 constEq , NameMatchQuality(..) , matchesName , GuessUserInfo(..) , guessUser , UserAssimilateException(..), UserAssimilateExceptionReason(..) , assimilateUser , userPrefersEmail, userPrefersLetter , getEmailAddress , getPostalAddress, getPostalPreferenceAndAddress , abbrvName , getReceivers, getReceiversFor , getSupervisees ) where import Import import Auth.LDAP (ldapUserMatr') import Foundation.Yesod.Auth (upsertUser) -- 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.Aeson.Types as JSON import qualified Data.Set as Set import qualified Data.CaseInsensitive as CI import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Legacy as EL (on,from) import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Utils as E import qualified Data.Conduit.Combinators as C import qualified Data.MultiSet as MultiSet import qualified Data.Map as Map import qualified Data.Text as Text import Handler.Utils.Profile import Jobs.Types(Job, JobChildren) abbrvName :: User -> Text abbrvName User{userDisplayName, userFirstName, userSurname} = if | (lastDisplayName : tsrif) <- reverse nameParts -> assemble $ reverse $ lastDisplayName : abbreviate tsrif | otherwise -> assemble $ abbreviate (Text.words userFirstName) <> [userSurname] where nameParts = Text.words userDisplayName abbreviate = fmap (Text.take 1) assemble = Text.intercalate "." -- deprecated, used getPostalPreferenceAndAddress userPrefersLetter :: User -> Bool userPrefersLetter = fst . getPostalPreferenceAndAddress -- deprecated, used getPostalPreferenceAndAddress userPrefersEmail :: User -> Bool userPrefersEmail = not . userPrefersLetter -- | result (True, Nothing) indicates that neither userEmail nor userPostAddress is known getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text]) getPostalPreferenceAndAddress usr@User{userPrefersPostal} = ((userPrefersPostal && postPossible) || not emailPossible, pa) -- (((userPrefersPostal || isNothing userPinPassword) && postPossible) || not emailPossible, pa) -- ignore email/post preference if no pinPassword is set where pa = getPostalAddress usr postPossible = isJust pa emailPossible = isJust $ getEmailAddress usr getEmailAddress :: User -> Maybe UserEmail getEmailAddress User{userDisplayEmail, userEmail} = pickValidEmail' userDisplayEmail userEmail getPostalAddress :: User -> Maybe [Text] getPostalAddress User{..} | Just pa <- userPostAddress = Just $ userDisplayName : html2textlines pa | Just abt <- userCompanyDepartment = Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"] | otherwise -> [userDisplayName, abt, "Hausbriefkasten" ] | otherwise = Nothing -- | Consider using Handler.Utils.Avs.updateReceivers instead -- Return Entity User and all Supervisors with rerouteNotifications as well as -- a boolean indicating if the user is own supervisor with rerouteNotifications getReceivers :: UserId -> DB (Entity User, [Entity User], Bool) getReceivers uid = do underling <- getJustEntity uid superVs <- selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] [] let superIds = userSupervisorSupervisor . entityVal <$> superVs directResult = return (underling, [underling], True) if null superIds then directResult else do receivers <- selectList [UserId <-. superIds] [] if null receivers then directResult else return (underling, receivers, uid `elem` (entityKey <$> receivers)) -- | For user with mailTdirect, since this query will also return supervisors that have reroute supervisors themselves, who would then receive multiple duplicates getReceiversFor :: (MonoFoldable mono, UserId ~ Element mono) => mono -> DB [UserId] getReceiversFor uids = (E.unValue <<$>>) $ E.select $ E.distinct $ do usr :& spr <- E.from $ E.table @User `E.leftJoin` E.table @UserSupervisor `E.on` (\(usr :& spr) -> usr E.^. UserId E.=?. spr E.?. UserSupervisorUser E.&&. E.isTrue (spr E.?. UserSupervisorRerouteNotifications)) E.where_ $ usr E.^. UserId `E.in_` E.vals uids return $ E.coalesceDefault [spr E.?. UserSupervisorSupervisor] $ usr E.^. UserId -- | return underlings for currently logged in user getSupervisees :: DB (Set UserId) getSupervisees = do uid <- requireAuthId svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser] return $ Set.insert uid $ Set.fromAscList svs -- 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) instance Binary GuessUserInfo makeLenses_ ''GuessUserInfo data NameMatchQuality = NameMatchSuffix | NameMatchPrefix | NameMatchPermutation | NameMatchEqual deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) 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 . EL.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] ] -- Assuming the input list is sorted in descending order by closeness: takeClosest [] = [] takeClosest [x] = [x] takeClosest (x:x':xs) | EQ <- x `closeness` x' = x : takeClosest (x':xs) | otherwise = [x] -- TODO: Generalize doLdap userMatr = do ldapPool' <- getsYesod $ view _appLdapPool fmap join . for ldapPool' $ \ldapPool@(upsertUserLdapConf,_) -> do ldapData <- ldapUserMatr' ldapPool userMatr for ldapData $ \upsertUserLdapData -> upsertUser UpsertUserGuessUser UpsertUserDataLdap{..} 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 data UserAssimilateException = UserAssimilateException { userAssimilateOldUser, userAssimilateNewUser :: UserId , userAssimilateException :: UserAssimilateExceptionReason } deriving (Eq, Ord, Show, Generic) deriving anyclass (Exception) data UserAssimilateExceptionReason = UserAssimilateExternalExamResultDifferentResult (Entity ExternalExamResult) (Entity ExternalExamResult) | UserAssimilateSubmissionGroupUserMultiple (Entity SubmissionGroupUser) (Entity SubmissionGroupUser) | UserAssimilateExamRegistrationDifferentOccurrence (Entity ExamRegistration) (Entity ExamRegistration) | UserAssimilateExamPartResultDifferentResult (Entity ExamPartResult) (Entity ExamPartResult) | UserAssimilateExamBonusDifferentBonus (Entity ExamBonus) (Entity ExamBonus) | UserAssimilateExamResultDifferentResult (Entity ExamResult) (Entity ExamResult) | UserAssimilatePersonalisedSheetFileDifferentContent (Entity PersonalisedSheetFile) (Entity PersonalisedSheetFile) | UserAssimilateTutorialParticipantCollidingRegGroups (Entity TutorialParticipant) (Entity TutorialParticipant) | UserAssimilateCouldNotDetermineUserIdents | UserAssimilateConflictingLmsQualifications (Set.Set QualificationId) deriving (Eq, Ord, Show, Generic) assimilateUser :: UserId -- ^ @newUserId@ -> UserId -- ^ @oldUserId@ -> DB (Set UserAssimilateException) -- ^ Warnings -- ^ Move all relevant properties (submissions, corrections, grades, ...) from @oldUserId@ to @newUserId@ -- -- Fatal errors are thrown, non-fatal warnings are returned assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do -- retrieve user entities first, to ensure they both exist (oldUserEnt, newUserEnt) <- do oldUser <- getEntity oldUserId newUser <- getEntity newUserId case (oldUser, newUser) of (Just old, Just new) -> return (old,new) _ -> tellError UserAssimilateCouldNotDetermineUserIdents let oldUser = oldUserEnt ^. _entityVal newUser = newUserEnt ^. _entityVal E.insertSelectWithConflict UniqueCourseFavourite (EL.from $ \courseFavourite -> do E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId return $ CourseFavourite E.<# E.val newUserId E.<&> (courseFavourite E.^. CourseFavouriteCourse) E.<&> (courseFavourite E.^. CourseFavouriteReason) E.<&> (courseFavourite E.^. CourseFavouriteLastVisit) ) (\current excluded -> [ CourseFavouriteLastVisit E.=. E.max (current E.^. CourseFavouriteLastVisit) (excluded E.^. CourseFavouriteLastVisit) ]) deleteWhere [ CourseFavouriteUser ==. oldUserId ] E.insertSelectWithConflict UniqueCourseNoFavourite (EL.from $ \courseNoFavourite -> do E.where_ $ courseNoFavourite E.^. CourseNoFavouriteUser E.==. E.val oldUserId return $ CourseNoFavourite E.<# E.val newUserId E.<&> (courseNoFavourite E.^. CourseNoFavouriteCourse) ) (\_current _excluded -> []) deleteWhere [ CourseNoFavouriteUser ==. oldUserId ] E.insertSelectWithConflict UniqueExamOfficeField (EL.from $ \examOfficeField -> do E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val oldUserId return $ ExamOfficeField E.<# E.val newUserId E.<&> (examOfficeField E.^. ExamOfficeFieldField) E.<&> (examOfficeField E.^. ExamOfficeFieldForced) ) (\current excluded -> [ ExamOfficeFieldForced E.=. (current E.^. ExamOfficeFieldForced E.||. excluded E.^. ExamOfficeFieldForced) ]) deleteWhere [ ExamOfficeFieldOffice ==. oldUserId ] E.insertSelectWithConflict UniqueExamOfficeUser (EL.from $ \examOfficeUser -> do E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val oldUserId return $ ExamOfficeUser E.<# E.val newUserId E.<&> (examOfficeUser E.^. ExamOfficeUserUser) ) (\_current _excluded -> []) deleteWhere [ ExamOfficeUserOffice ==. oldUserId ] E.insertSelectWithConflict UniqueExamOfficeUser (EL.from $ \examOfficeUser -> do E.where_ $ examOfficeUser E.^. ExamOfficeUserUser E.==. E.val oldUserId return $ ExamOfficeUser E.<# (examOfficeUser E.^. ExamOfficeUserOffice) E.<&> E.val newUserId ) (\_current _excluded -> []) deleteWhere [ ExamOfficeUserUser ==. oldUserId ] E.insertSelect . EL.from $ \examOfficeResultSynced -> do E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. E.val oldUserId return $ ExamOfficeResultSynced E.<# (examOfficeResultSynced E.^. ExamOfficeResultSyncedSchool) E.<&> E.val newUserId E.<&> (examOfficeResultSynced E.^. ExamOfficeResultSyncedResult) E.<&> (examOfficeResultSynced E.^. ExamOfficeResultSyncedTime) deleteWhere [ ExamOfficeResultSyncedOffice ==. oldUserId ] E.insertSelect . EL.from $ \examOfficeExternalResultSynced -> do E.where_ $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice E.==. E.val oldUserId return $ ExamOfficeExternalResultSynced E.<# (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedSchool) E.<&> E.val newUserId E.<&> (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedResult) E.<&> (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedTime) deleteWhere [ ExamOfficeExternalResultSyncedOffice ==. oldUserId ] let getExternalExamResults = selectSource [ ExternalExamResultUser ==. oldUserId ] [] upsertExternalExamResult oldEEREnt@(Entity oldEERId oldEER) = do newEER' <- getBy $ UniqueExternalExamResult (externalExamResultExam oldEER) newUserId newEERId <- case newEER' of Just newEEREnt@(Entity _ newEER) | ((/=) `on` externalExamResultResult) newEER oldEER || ((/=) `on` externalExamResultTime) newEER oldEER -> tellError $ UserAssimilateExternalExamResultDifferentResult oldEEREnt newEEREnt Just (Entity newEERId newEER) -> newEERId <$ update newEERId [ ExternalExamResultLastChanged =. (max `on` externalExamResultLastChanged) oldEER newEER ] Nothing -> insert oldEER { externalExamResultUser = newUserId } updateWhere [ ExamOfficeExternalResultSyncedResult ==. oldEERId ] [ ExamOfficeExternalResultSyncedResult =. newEERId ] delete oldEERId in runConduit $ getExternalExamResults .| C.mapM_ upsertExternalExamResult E.insertSelectWithConflict UniqueExternalExamStaff (EL.from $ \externalExamStaff -> do E.where_ $ externalExamStaff E.^. ExternalExamStaffUser E.==. E.val oldUserId return $ ExternalExamStaff E.<# E.val newUserId E.<&> (externalExamStaff E.^. ExternalExamStaffExam) ) (\_current _excluded -> []) deleteWhere [ ExternalExamStaffUser ==. oldUserId ] updateWhere [ SubmissionRatingBy ==. Just oldUserId ] [ SubmissionRatingBy =. Just newUserId ] updateWhere [ SubmissionEditUser ==. Just oldUserId ] [ SubmissionEditUser =. Just newUserId ] E.insertSelectWithConflict UniqueSubmissionUser (EL.from $ \submissionUser -> do E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val oldUserId return $ SubmissionUser E.<# E.val newUserId E.<&> (submissionUser E.^. SubmissionUserSubmission) ) (\_current _excluded -> []) deleteWhere [ SubmissionUserUser ==. oldUserId ] do collisions <- E.select . EL.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do EL.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup EL.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup E.&&. submissionGroupUserA E.^. SubmissionGroupUserUser E.==. E.val oldUserId E.&&. submissionGroupUserB E.^. SubmissionGroupUserUser E.==. E.val newUserId EL.on $ submissionGroupA E.^. SubmissionGroupId E.==. submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.where_ $ submissionGroupA E.^. SubmissionGroupCourse E.==. submissionGroupB E.^. SubmissionGroupCourse return (submissionGroupUserA, submissionGroupUserB) forM_ collisions $ \(submissionGroupUserA, submissionGroupUserB) -> tellWarning $ UserAssimilateSubmissionGroupUserMultiple submissionGroupUserA submissionGroupUserB E.insertSelectWithConflict UniqueSubmissionGroupUser (EL.from $ \submissionGroupUser -> do E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val oldUserId return $ SubmissionGroupUser E.<# (submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup) E.<&> E.val newUserId ) (\_current _excluded -> []) deleteWhere [ SubmissionGroupUserUser ==. oldUserId ] updateWhere [ TransactionLogInitiator ==. Just oldUserId ] [ TransactionLogInitiator =. Just newUserId ] -- We're not updating info; doing that would probably be too slow -- Just check for `TransactionUserAssimilated` entries and correct manually updateWhere [ CourseEditUser ==. oldUserId ] [ CourseEditUser =. newUserId ] E.insertSelectWithConflict UniqueLecturer (EL.from $ \lecturer -> do E.where_ $ lecturer E.^. LecturerUser E.==. E.val oldUserId return $ Lecturer E.<# E.val newUserId E.<&> (lecturer E.^. LecturerCourse) E.<&> (lecturer E.^. LecturerType) ) (\_current excluded -> [ LecturerType E.=. excluded E.^. LecturerType ]) deleteWhere [ LecturerUser ==. oldUserId ] E.insertSelectWithConflict UniqueParticipant (EL.from $ \courseParticipant -> do E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val oldUserId return $ CourseParticipant E.<# (courseParticipant E.^. CourseParticipantCourse) E.<&> E.val newUserId E.<&> (courseParticipant E.^. CourseParticipantRegistration) E.<&> (courseParticipant E.^. CourseParticipantState) ) (\current excluded -> [ CourseParticipantState E.=. E.exprLift min (current E.^. CourseParticipantState) (excluded E.^. CourseParticipantState) , CourseParticipantRegistration E.=. E.max (current E.^. CourseParticipantRegistration) (excluded E.^. CourseParticipantRegistration) ] ) deleteWhere [ CourseParticipantUser ==. oldUserId ] let getCourseUserNotes = selectSource [ CourseUserNoteUser ==. oldUserId ] [] upsertCourseUserNote (Entity oldCUNId oldCUN) = do collision <- getBy $ UniqueCourseUserNote newUserId (courseUserNoteCourse oldCUN) newCUNId <- case collision of Nothing -> oldCUNId <$ update oldCUNId [ CourseUserNoteUser =. newUserId ] Just (Entity newCUNId newCUN) -> newCUNId <$ update newCUNId [ CourseUserNoteNote =. ((<>) `on` courseUserNoteNote) oldCUN newCUN ] when (newCUNId /= oldCUNId) $ updateWhere [CourseUserNoteEditNote ==. oldCUNId] [CourseUserNoteEditNote =. newCUNId] delete oldCUNId in runConduit $ getCourseUserNotes .| C.mapM_ upsertCourseUserNote updateWhere [ CourseUserNoteEditUser ==. oldUserId ] [ CourseUserNoteEditUser =. newUserId ] E.insertSelectWithConflict UniqueCourseUserExamOfficeOptOut (EL.from $ \examOfficeOptOut -> do E.where_ $ examOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. E.val oldUserId return $ CourseUserExamOfficeOptOut E.<# (examOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse) E.<&> E.val newUserId E.<&> (examOfficeOptOut E.^. CourseUserExamOfficeOptOutSchool) ) (\_current _excluded -> []) deleteWhere [ CourseUserExamOfficeOptOutUser ==. oldUserId ] E.insertSelectWithConflict UniqueUserFunction (EL.from $ \userFunction -> do E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val oldUserId return $ UserFunction E.<# E.val newUserId E.<&> (userFunction E.^. UserFunctionSchool) E.<&> (userFunction E.^. UserFunctionFunction) ) (\_current _excluded -> []) deleteWhere [ UserFunctionUser ==. oldUserId ] E.insertSelectWithConflict UniqueUserSystemFunction (EL.from $ \userSystemFunction -> do E.where_ $ userSystemFunction E.^. UserSystemFunctionUser E.==. E.val oldUserId return $ UserSystemFunction E.<# E.val newUserId E.<&> (userSystemFunction E.^. UserSystemFunctionFunction) E.<&> (userSystemFunction E.^. UserSystemFunctionManual) E.<&> (userSystemFunction E.^. UserSystemFunctionIsOptOut) ) (\current excluded -> [ UserSystemFunctionManual E.=. (current E.^. UserSystemFunctionManual E.||. excluded E.^. UserSystemFunctionManual), UserSystemFunctionIsOptOut E.=. (current E.^. UserSystemFunctionIsOptOut E.&&. excluded E.^. UserSystemFunctionIsOptOut) ]) deleteWhere [ UserSystemFunctionUser ==. oldUserId ] E.insertSelectWithConflict UniqueUserExamOffice (EL.from $ \userExamOffice -> do E.where_ $ userExamOffice E.^. UserExamOfficeUser E.==. E.val oldUserId return $ UserExamOffice E.<# E.val newUserId E.<&> (userExamOffice E.^. UserExamOfficeField) ) (\_current _excluded -> []) deleteWhere [ UserExamOfficeUser ==. oldUserId ] E.insertSelectWithConflict UniqueUserSchool (EL.from $ \userSchool -> do E.where_ $ userSchool E.^. UserSchoolUser E.==. E.val oldUserId return $ UserSchool E.<# E.val newUserId E.<&> (userSchool E.^. UserSchoolSchool) E.<&> (userSchool E.^. UserSchoolIsOptOut) ) (\current excluded -> [ UserSchoolIsOptOut E.=. (current E.^. UserSchoolIsOptOut E.&&. excluded E.^. UserSchoolIsOptOut) ]) deleteWhere [ UserSchoolUser ==. oldUserId ] updateWhere [ UserGroupMemberUser ==. oldUserId, UserGroupMemberPrimary ==. Active ] [ UserGroupMemberUser =. newUserId ] E.insertSelectWithConflict UniqueUserGroupMember (EL.from $ \userGroupMember -> do E.where_ $ userGroupMember E.^. UserGroupMemberUser E.==. E.val oldUserId return $ UserGroupMember E.<# (userGroupMember E.^. UserGroupMemberGroup) E.<&> E.val newUserId E.<&> (userGroupMember E.^. UserGroupMemberPrimary) ) (\_current _excluded -> []) deleteWhere [ UserGroupMemberUser ==. oldUserId ] do collisions <- E.select . EL.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do EL.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam E.&&. examRegistrationA E.^. ExamRegistrationUser E.==. E.val oldUserId E.&&. examRegistrationB E.^. ExamRegistrationUser E.==. E.val newUserId E.where_ $ examRegistrationA E.^. ExamRegistrationOccurrence E.!=. examRegistrationB E.^. ExamRegistrationOccurrence E.&&. E.isJust (examRegistrationA E.^. ExamRegistrationOccurrence) E.&&. E.isJust (examRegistrationB E.^. ExamRegistrationOccurrence) return (examRegistrationA, examRegistrationB) forM_ collisions $ \(oldExamRegistration, newExamRegistration) -> tellWarning $ UserAssimilateExamRegistrationDifferentOccurrence oldExamRegistration newExamRegistration E.insertSelectWithConflict UniqueExamRegistration (EL.from $ \examRegistration -> do E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val oldUserId return $ ExamRegistration E.<# (examRegistration E.^. ExamRegistrationExam) E.<&> E.val newUserId E.<&> (examRegistration E.^. ExamRegistrationOccurrence) E.<&> (examRegistration E.^. ExamRegistrationTime) ) (\current excluded -> [ ExamRegistrationOccurrence E.=. E.alt (current E.^. ExamRegistrationOccurrence) (excluded E.^. ExamRegistrationOccurrence), ExamRegistrationTime E.=. E.min (current E.^. ExamRegistrationTime) (excluded E.^. ExamRegistrationTime) ]) deleteWhere [ ExamRegistrationUser ==. oldUserId ] do collision <- E.selectMaybe . EL.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do EL.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart E.&&. examPartResultA E.^. ExamPartResultUser E.==. E.val oldUserId E.&&. examPartResultB E.^. ExamPartResultUser E.==. E.val newUserId E.where_ $ examPartResultA E.^. ExamPartResultResult E.!=. examPartResultB E.^. ExamPartResultResult return (examPartResultA, examPartResultB) whenIsJust collision $ \(oldExamPartResult, newExamPartResult) -> tellError $ UserAssimilateExamPartResultDifferentResult oldExamPartResult newExamPartResult E.insertSelectWithConflict UniqueExamPartResult (EL.from $ \examPartResult -> do E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val oldUserId return $ ExamPartResult E.<# (examPartResult E.^. ExamPartResultExamPart) E.<&> E.val newUserId E.<&> (examPartResult E.^. ExamPartResultResult) E.<&> (examPartResult E.^. ExamPartResultLastChanged) ) (\current excluded -> [ ExamPartResultLastChanged E.=. E.max (current E.^. ExamPartResultLastChanged) (excluded E.^. ExamPartResultLastChanged) ]) deleteWhere [ ExamPartResultUser ==. oldUserId ] do collision <- E.selectMaybe . EL.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do EL.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam E.&&. examBonusA E.^. ExamBonusUser E.==. E.val oldUserId E.&&. examBonusB E.^. ExamBonusUser E.==. E.val newUserId E.where_ $ examBonusA E.^. ExamBonusBonus E.!=. examBonusB E.^. ExamBonusBonus return (examBonusA, examBonusB) whenIsJust collision $ \(oldExamBonus, newExamBonus) -> tellError $ UserAssimilateExamBonusDifferentBonus oldExamBonus newExamBonus E.insertSelectWithConflict UniqueExamBonus (EL.from $ \examBonus -> do E.where_ $ examBonus E.^. ExamBonusUser E.==. E.val oldUserId return $ ExamBonus E.<# (examBonus E.^. ExamBonusExam) E.<&> E.val newUserId E.<&> (examBonus E.^. ExamBonusBonus) E.<&> (examBonus E.^. ExamBonusLastChanged) ) (\current excluded -> [ ExamBonusLastChanged E.=. E.max (current E.^. ExamBonusLastChanged) (excluded E.^. ExamBonusLastChanged) ]) deleteWhere [ ExamBonusUser ==. oldUserId ] let getExamResults = selectSource [ ExamResultUser ==. oldUserId ] [] upsertExamResult oldEREnt@(Entity oldERId oldER) = do newER' <- getBy $ UniqueExamResult (examResultExam oldER) newUserId newERId <- case newER' of Just newEREnt@(Entity _ newER) | ((/=) `on` examResultResult) newER oldER -> tellError $ UserAssimilateExamResultDifferentResult oldEREnt newEREnt Just (Entity newERId newER) -> newERId <$ update newERId [ ExamResultLastChanged =. (max `on` examResultLastChanged) oldER newER ] Nothing -> insert oldER { examResultUser = newUserId } updateWhere [ ExamOfficeResultSyncedResult ==. oldERId ] [ ExamOfficeResultSyncedResult =. newERId ] delete oldERId in runConduit $ getExamResults .| C.mapM_ upsertExamResult let getExamCorrectors = selectSource [ ExamCorrectorUser ==. oldUserId ] [] upsertExamCorrector (Entity oldECId examCorrector) = do Entity newECId _ <- upsert examCorrector{ examCorrectorUser = newUserId } [] E.insertSelectWithConflict UniqueExamPartCorrector (EL.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do EL.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector E.where_ $ examCorrector' E.^. ExamCorrectorUser E.==. E.val oldUserId E.&&. examCorrector' E.^. ExamCorrectorExam E.==. E.val (examCorrectorExam examCorrector) return $ ExamPartCorrector E.<# (examPartCorrector E.^. ExamPartCorrectorPart) E.<&> E.val newECId ) (\_current _excluded -> []) deleteWhere [ ExamPartCorrectorCorrector ==. oldECId ] delete oldECId in runConduit $ getExamCorrectors .| C.mapM_ upsertExamCorrector let getQueuedJobs = selectSource [] [] updateQueuedJob (Entity jId QueuedJob{..}) = maybeT_ $ do (content' :: Job) <- hoistMaybe $ JSON.parseMaybe parseJSON queuedJobContent let uContent' = set (typesUsing @JobChildren . filtered (== oldUserId)) newUserId content' guard $ uContent' /= content' lift $ update jId [ QueuedJobContent =. toJSON uContent' ] in runConduit $ getQueuedJobs .| C.mapM_ updateQueuedJob updateWhere [ SentMailRecipient ==. Just oldUserId ] [ SentMailRecipient =. Just newUserId ] updateWhere [ SheetEditUser ==. oldUserId] [ SheetEditUser =. newUserId ] let getSheetPseudonyms = selectSource [ SheetPseudonymUser ==. oldUserId ] [] upsertSheetPseudonym (Entity oldSPId oldSP) = do collision <- existsBy $ UniqueSheetPseudonymUser (sheetPseudonymSheet oldSP) newUserId if | collision -> delete oldSPId | otherwise -> update oldSPId [ SheetPseudonymUser =. newUserId ] in runConduit $ getSheetPseudonyms .| C.mapM_ upsertSheetPseudonym let getSheetCorrectors = selectSource [ SheetCorrectorUser ==. oldUserId ] [] upsertSheetCorrector (Entity oldSCId oldSheetCorrector) = do collision <- getBy $ UniqueSheetCorrector newUserId (sheetCorrectorSheet oldSheetCorrector) case collision of Nothing -> update oldSCId [ SheetCorrectorUser =. newUserId ] Just (Entity newSCId newSheetCorrector) -> do update newSCId [ SheetCorrectorLoad =. (sheetCorrectorLoad oldSheetCorrector <> sheetCorrectorLoad newSheetCorrector) , SheetCorrectorState =. (min `on` sheetCorrectorState) oldSheetCorrector newSheetCorrector ] delete oldSCId in runConduit $ getSheetCorrectors .| C.mapM_ upsertSheetCorrector do collision <- E.selectMaybe . EL.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do EL.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileType E.==. personalisedSheetFileB E.^. PersonalisedSheetFileType E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileTitle E.==. personalisedSheetFileB E.^. PersonalisedSheetFileTitle E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileUser E.==. E.val oldUserId E.&&. personalisedSheetFileB E.^. PersonalisedSheetFileUser E.==. E.val newUserId E.where_ . E.not_ $ personalisedSheetFileA E.^. PersonalisedSheetFileContent `E.maybeEq` personalisedSheetFileB E.^. PersonalisedSheetFileContent return (personalisedSheetFileA, personalisedSheetFileB) whenIsJust collision $ \(oldPersonalisedSheetFile, newPersonalisedSheetFile) -> tellError $ UserAssimilatePersonalisedSheetFileDifferentContent oldPersonalisedSheetFile newPersonalisedSheetFile E.insertSelectWithConflict UniquePersonalisedSheetFile (EL.from $ \personalisedSheetFile -> do E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileUser E.==. E.val oldUserId return $ PersonalisedSheetFile E.<# (personalisedSheetFile E.^. PersonalisedSheetFileSheet) E.<&> E.val newUserId E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileType) E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileTitle) E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileContent) E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileModified) ) (\current excluded -> [ PersonalisedSheetFileModified E.=. E.max (current E.^. PersonalisedSheetFileModified) (excluded E.^. PersonalisedSheetFileModified) ]) deleteWhere [ PersonalisedSheetFileUser ==. oldUserId ] E.insertSelectWithConflict UniqueTutor (EL.from $ \tutor -> do E.where_ $ tutor E.^. TutorUser E.==. E.val oldUserId return $ Tutor E.<# (tutor E.^. TutorTutorial) E.<&> E.val newUserId ) (\_current _excluded -> []) do collision <- E.selectMaybe . EL.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do EL.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId EL.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId E.&&. tutorialParticipantA E.^. TutorialParticipantUser E.==. E.val oldUserId EL.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId E.where_ $ tutorialA E.^. TutorialId E.!=. tutorialB E.^. TutorialId E.&&. tutorialA E.^. TutorialRegGroup E.==. tutorialB E.^. TutorialRegGroup return (tutorialParticipantA, tutorialParticipantB) whenIsJust collision $ \(tutorialUserA, tutorialUserB) -> tellError $ UserAssimilateTutorialParticipantCollidingRegGroups tutorialUserA tutorialUserB E.insertSelectWithConflict UniqueTutorialParticipant (EL.from $ \tutorialParticipant -> do E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val oldUserId return $ TutorialParticipant E.<# (tutorialParticipant E.^. TutorialParticipantTutorial) E.<&> E.val newUserId ) (\_current _excluded -> []) deleteWhere [ TutorialParticipantUser ==. oldUserId ] E.insertSelectWithConflict UniqueSystemMessageHidden (EL.from $ \systemMessageHidden -> do E.where_ $ systemMessageHidden E.^. SystemMessageHiddenUser E.==. E.val oldUserId return $ SystemMessageHidden E.<# (systemMessageHidden E.^. SystemMessageHiddenMessage) E.<&> E.val newUserId E.<&> (systemMessageHidden E.^. SystemMessageHiddenTime) ) (\current excluded -> [ SystemMessageHiddenTime E.=. combineWith current excluded E.max SystemMessageHiddenTime]) deleteWhere [ SystemMessageHiddenUser ==. oldUserId ] let getStudyFeatures = selectSource [ StudyFeaturesUser ==. oldUserId ] [] upsertStudyFeatures (Entity oldSFId oldStudyFeatures) = do collision <- getBy $ UniqueStudyFeatures newUserId (studyFeaturesDegree oldStudyFeatures) (studyFeaturesField oldStudyFeatures) (studyFeaturesType oldStudyFeatures) (studyFeaturesSemester oldStudyFeatures) case collision of Nothing -> update oldSFId [ StudyFeaturesUser =. newUserId ] Just (Entity newSFId newStudyFeatures) -> do update newSFId [ StudyFeaturesSuperField =. ((<|>) `on` studyFeaturesSuperField) newStudyFeatures oldStudyFeatures , StudyFeaturesFirstObserved =. (min `on` studyFeaturesFirstObserved) oldStudyFeatures newStudyFeatures , StudyFeaturesLastObserved =. (max `on` studyFeaturesLastObserved) oldStudyFeatures newStudyFeatures , StudyFeaturesValid =. ((||) `on` studyFeaturesValid) oldStudyFeatures newStudyFeatures , StudyFeaturesRelevanceCached =. ((<|>) `on` studyFeaturesRelevanceCached) oldStudyFeatures newStudyFeatures ] E.insertSelectWithConflict UniqueRelevantStudyFeatures (EL.from $ \relevantStudyFeatures -> do E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. E.val oldSFId return $ RelevantStudyFeatures E.<# (relevantStudyFeatures E.^. RelevantStudyFeaturesTerm) E.<&> E.val newSFId ) (\_current _excluded -> []) deleteWhere [ RelevantStudyFeaturesStudyFeatures ==. oldSFId ] delete oldSFId in runConduit $ getStudyFeatures .| C.mapM_ upsertStudyFeatures -- 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 ] usrQualis <- E.select $ EL.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do EL.on ( newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification E.&&. newQual E.?. QualificationUserUser E.?=. E.val newUserId ) E.where_ $ oldQual E.^. QualificationUserUser E.==. E.val oldUserId return (oldQual, newQual) forM_ usrQualis $ \case (Entity oldQKey _, Nothing) -> update oldQKey [ QualificationUserUser =. newUserId ] -- update must succeed if there is not RHS in the join (Entity oldQKey oldQUsr, Just (Entity newQKey newQUsr)) -> do updateWhere [ QualificationUserBlockQualificationUser ==. oldQKey ] [ QualificationUserBlockQualificationUser =. newQKey ] update newQKey [ QualificationUserValidUntil =. (max `on` view _qualificationUserValidUntil ) oldQUsr newQUsr , QualificationUserLastRefresh =. (max `on` view _qualificationUserLastRefresh ) oldQUsr newQUsr , QualificationUserFirstHeld =. (min `on` view _qualificationUserFirstHeld ) oldQUsr newQUsr , QualificationUserScheduleRenewal =. (max `on` view _qualificationUserScheduleRenewal) oldQUsr newQUsr , QualificationUserLastNotified =. (max `on` view _qualificationUserLastNotified ) oldQUsr newQUsr ] delete oldQKey -- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed -- PrintJobs updateWhere [ PrintJobRecipient ==. Just oldUserId ] [ PrintJobRecipient =. Just newUserId ] updateWhere [ PrintJobSender ==. Just oldUserId ] [ PrintJobSender =. Just newUserId ] -- Supervision is fully merged E.insertSelectWithConflict UniqueUserSupervisor (EL.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 (EL.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 UniqueUserCompany (EL.from $ \userCompany -> do E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId return $ UserCompany E.<# E.val newUserId E.<&> (userCompany E.^. UserCompanyCompany) E.<&> (userCompany E.^. UserCompanySupervisor) E.<&> (userCompany E.^. UserCompanySupervisorReroute) ) (\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] ) deleteWhere [ UserCompanyUser ==. oldUserId] mbOldAvsId <- getBy $ UniqueUserAvsUser oldUserId mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId case (mbOldAvsId,mbNewAvsId) of (Nothing, _) -> return () (Just Entity{entityVal=UserAvs{userAvsPersonId=oldAvsId}}, Just _) -> deleteWhere [UserAvsCardPersonId ==. oldAvsId] >> deleteBy (UniqueUserAvsUser oldUserId) (Just Entity{entityVal=oldUserAvs}, Nothing) -> -- deleteBy $ UniqueUserAvsUser oldUserId -- maybe we need this due to double uniqueness?! void $ upsertBy (UniqueUserAvsId (oldUserAvs ^. _userAvsPersonId)) oldUserAvs{userAvsUser=newUserId} [UserAvsUser =. newUserId] -- merge some optional / incomplete user fields let mergeBy :: forall a . PersistField a => (a -> a -> Bool) -> EntityField User a -> Maybe (Update User) mergeBy cmp uf = let ufl = fieldLens uf oldV = oldUserEnt ^. ufl newV = newUserEnt ^. ufl in toMaybe (cmp oldV newV) (uf =. oldV) mergeMaybe :: forall b . PersistField b => EntityField User (Maybe b) -> Maybe (Update User) mergeMaybe = mergeBy (\oldV newV -> isNothing newV && isJust oldV) update newUserId $ catMaybes -- NOTE: persist does shortcircuit null updates as expected [ mergeMaybe UserPasswordHash , mergeBy (>) UserLastAuthentication , mergeBy (<) UserCreated , toMaybe (not (validEmail' (newUser ^. _userEmail )) && validEmail' (oldUser ^. _userEmail)) (UserEmail =. oldUser ^. _userEmail) , toMaybe (not (validEmail' (newUser ^. _userDisplayEmail)) && validEmail' (oldUser ^. _userDisplayEmail)) (UserDisplayEmail =. oldUser ^. _userDisplayEmail) , mergeMaybe UserMatrikelnummer , toMaybe (isNothing (newUser ^. _userPostAddress) && isJust (oldUser ^. _userPostAddress)) (UserPostAddress =. oldUser ^. _userPostAddress) , toMaybe (isNothing (newUser ^. _userPostAddress) && isJust (oldUser ^. _userPostAddress)) (UserPostLastUpdate =. oldUser ^. _userPostLastUpdate) , toMaybe ((isJust (newUser ^. _userPostAddress) || isJust (oldUser ^. _userPostAddress)) && (newUser ^. _userPrefersPostal || oldUser ^. _userPrefersPostal)) (UserPrefersPostal =. True) , mergeMaybe UserPinPassword , mergeMaybe UserLanguages , mergeMaybe UserSex , mergeMaybe UserBirthday , mergeMaybe UserTelephone , mergeMaybe UserMobile ] delete oldUserId let oldUsrIdent = oldUser ^. _userIdent newUsrIdent = newUser ^. _userIdent when (oldUsrIdent /= newUsrIdent) $ audit $ TransactionUserIdentChanged oldUsrIdent newUsrIdent audit $ TransactionUserAssimilated newUserId oldUserId where tellWarning :: UserAssimilateExceptionReason -> ReaderT SqlBackend (WriterT (Set UserAssimilateException) Handler) () tellWarning = lift . tellPoint . UserAssimilateException oldUserId newUserId tellError :: forall a. UserAssimilateExceptionReason -> ReaderT SqlBackend (WriterT (Set UserAssimilateException) Handler) a tellError = throwM . UserAssimilateException oldUserId newUserId combineWith :: (PersistEntity val, PersistField typ1) => E.SqlExpr (Entity val) -> E.SqlExpr (Entity val) -> (E.SqlExpr (E.Value typ1) -> E.SqlExpr (E.Value typ1) -> E.SqlExpr (E.Value typ2)) -> EntityField val typ1 -> E.SqlExpr (E.Value typ2) combineWith x y f pj = f (x E.^. pj) (y E.^. pj)