-- SPDX-FileCopyrightText: 2022-2025 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -- NOTE: Also see Handler.Utils.Profile for similar utilities module Handler.Utils.Users ( computeUserAuthenticationDigest , Digest, SHA3_256 , constEq , NameMatchQuality(..) , matchesName , GuessUserInfo(..) , guessUser, guessUserByEmail , UserAssimilateException(..), UserAssimilateExceptionReason(..) , assimilateUser , getUserPrimaryCompany, getUserPrimaryCompanyAddress , getUserEmail , getEmailAddress, getJustEmailAddress , getUserEmailAutomatic , getEmailAddressFor, getJustEmailAddressFor , getPostalAddress, getPostalAddress' , getPostalPreferenceAndAddress, getPostalPreferenceAndAddress' , abbrvName , getReceivers, getReceiversFor , getSupervisees ) where import Import import Foundation.Yesod.Auth (userLookupAndUpsert) 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) data ExceptionUserHandling = ExceptionUserHasNoEmail deriving (Eq, Ord, Read, Show, Generic) -- Enum, Bounded, instance Exception ExceptionUserHandling 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 "." -- | Retrieve primary company association for user. -- Warning: if there are multiple associations witht the same priority, one with rerouting and supervision are preferred, them alphabetically -- Note that Entity Company can be retrieved, since CompanyShorthand is the DB key. getUserPrimaryCompany :: UserId -> DBRead' (Maybe UserCompany) getUserPrimaryCompany uid = entityVal <<$>> selectFirst [UserCompanyUser ==. uid] [Desc UserCompanyPriority, Desc UserCompanySupervisorReroute, Desc UserCompanySupervisor, Asc UserCompanyCompany] getUserPrimaryCompanyAddress :: UserId -> (Company -> Maybe a) -> DBRead' (Maybe a) getUserPrimaryCompanyAddress uid prj = runMaybeT $ do UserCompany{userCompanyCompany=cid, userCompanyUseCompanyAddress=True} <- MaybeT $ getUserPrimaryCompany uid -- return Nothing if company address is not to be used company <- MaybeT $ get cid -- hoistMaybe $ prj company MaybeT $ pure $ prj company -- | Compute actual address for user; returning True for Postal preference, as well as address (user or company) and primary e-mail -- result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known getPostalPreferenceAndAddress :: Entity User -> DBRead' (Bool, Maybe [Text], Maybe UserEmail) getPostalPreferenceAndAddress usr = do pa <- getPostalAddress usr em <- getUserEmail usr let usrPrefPost = usr ^. _entityVal . _userPrefersPostal finalPref = (usrPrefPost && isJust pa) || isNothing em -- finalPref = isJust pa && (usrPrefPost || isNothing em) return (finalPref, pa, em) -- | result (True, Nothing, Nothing) indicates that neither userEmail nor userPostAddress is known -- primed variant returns storedMarkup without prefixed userDisplayName getPostalPreferenceAndAddress' :: Entity User -> DBReadUq' (Bool, (Maybe StoredMarkup, Bool), (Maybe UserEmail, Bool)) getPostalPreferenceAndAddress' usr = do pa <- getPostalAddress' usr em <- getUserEmailAutomatic usr let usrPrefPost = usr ^. _entityVal . _userPrefersPostal finalPref = (usrPrefPost && isJust (fst pa)) || isNothing (fst em) -- finalPref = isJust (fst pa) && (usrPrefPost || isNothing (fst em)) return (finalPref, pa, em) getEmailAddressFor :: UserId -> DBRead' (Maybe Address) getEmailAddressFor = maybeM (return Nothing) getEmailAddress . getEntity getJustEmailAddressFor :: UserId -> DBRead' Address getJustEmailAddressFor = maybeThrowM ExceptionUserHasNoEmail . getEmailAddressFor getJustEmailAddress :: Entity User -> DBRead' Address getJustEmailAddress = maybeThrowM ExceptionUserHasNoEmail . getEmailAddress getEmailAddress :: Entity User -> DBRead' (Maybe Address) getEmailAddress usr@Entity{entityVal=User{userDisplayName}} = toAddress <<$>> getUserEmail usr where toAddress = Address (Just userDisplayName) . CI.original getUserEmail :: Entity User -> DBRead' (Maybe UserEmail) getUserEmail Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}} | validEmail' userDisplayEmail = return $ Just userDisplayEmail | otherwise = do compEmailMb <- getUserPrimaryCompanyAddress uid companyEmail return $ pickValidEmail' $ mcons compEmailMb [userEmail] -- like `getUserEmail`, but also checks whether the Email will be update automatically getUserEmailAutomatic :: Entity User -> DBReadUq' (Maybe UserEmail, Bool) getUserEmailAutomatic Entity{entityKey=uid, entityVal=User{userDisplayEmail, userEmail}} | validEmail' userDisplayEmail = do muavs <- getBy $ UniqueUserAvsUser uid let auto = userDisplayEmail == muavs ^. _Just . _userAvsLastFirmInfo . _Just . _avsFirmPrimaryEmail . _Just . from _CI -- Recall: _Just on Nothing yields mempty here || userDisplayEmail == muavs ^. _Just . _userAvsLastPersonInfo . _Just . _avsInfoPersonEMail . _Just . from _CI return (Just userDisplayEmail, auto) | otherwise = getUserPrimaryCompanyAddress uid companyEmail >>= \case Just compEmail | validEmail' compEmail -> return (Just compEmail, True ) Nothing | validEmail' userEmail -> return (Just userEmail, False) _ -> return (Nothing , False) -- address is prefixed with userDisplayName getPostalAddress :: Entity User -> DBRead' (Maybe [Text]) getPostalAddress Entity{entityKey=uid, entityVal=User{..}} | (Just upo) <- userPostAddress, validPostAddress userPostAddress = prefixMarkupName upo | otherwise = do getUserPrimaryCompanyAddress uid companyPostAddress >>= \case (Just pa) -> prefixMarkupName pa Nothing | Just abt <- userCompanyDepartment -> return $ Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"] | otherwise -> [userDisplayName, abt, "Hausbriefkasten" ] | otherwise -> return Nothing where prefixMarkupName = return . Just . (userDisplayName :) . html2textlines -- primed variant returns storedMarkup without prefixed userDisplayName and whether updates are automatic getPostalAddress' :: Entity User -> DBReadUq' (Maybe StoredMarkup, Bool) getPostalAddress' Entity{entityKey=uid, entityVal=User{..}} | validPostAddress userPostAddress = do muavs <- getBy $ UniqueUserAvsUser uid let auto = userPostAddress == muavs ^? _Just . _userAvsLastFirmInfo . _Just . _avsFirmPostAddress . _Just -- Recall: using _Just with ^. on Nothing yields mempty return (userPostAddress, auto) | otherwise = do getUserPrimaryCompanyAddress uid companyPostAddress >>= \case res@(Just _) -> return (res, True) Nothing | Just abt <- userCompanyDepartment -> return $ (,True) $ Just $ plaintextToStoredMarkup $ textUnlines $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"] | otherwise -> [userDisplayName, abt, "Hausbriefkasten" ] | otherwise -> return (Nothing, True) -- | 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 uid and underlings for currently logged in user, empty if not logged in getSupervisees :: Bool -> DB (Set UserId) getSupervisees forceLogin = do mbuid <- if forceLogin then Just <$> requireAuthId -- forces login else maybeAuthId flip foldMapM mbuid $ \uid -> do svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser] return $ Set.insert uid $ Set.fromAscList svs computeUserAuthenticationDigest :: Maybe Text -> Digest SHA3_256 computeUserAuthenticationDigest = hashlazy . JSON.encode -- guessUserByCompanyPersonalNumber :: Text -> Text -> DB (Maybe UserId) -- guessUserByCompanyPersonalNumber surname ipn = getKeyByFilter [UserCompanyPersonalNumber ==. Just ipn, UserSurname ==. surname] guessUserByEmail :: UserEmail -> DB (Maybe UserId) guessUserByEmail eml = firstJustM $ [ getKeyBy $ UniqueEmail eml , getKeyBy $ UniqueAuthentication eml -- aka UserIdent , getKeyByFilter [UserDisplayEmail ==. eml] ] <> maybeEmpty (getFraportLogin (CI.original eml)) (\lgi -> [ getKeyBy $ UniqueLdapPrimaryKey $ Just lgi ]) 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 didUpsert = 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] doUpsert = flip userLookupAndUpsert UpsertUserGuessUser 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 convertUpsertResults :: [Entity User] -> Maybe (Either (NonEmpty (Entity User)) (Entity User)) convertUpsertResults [] = Nothing convertUpsertResults [x] = Just $ Right x convertUpsertResults xs = Just $ Left $ NonEmpty.fromList xs if | [x] <- users' , Just True == matchesMatriculation x || didUpsert -> return $ Just $ Right x | x : x' : _ <- users' , Just True == matchesMatriculation x || didUpsert , GT <- x `closeness` x' -> return $ Just $ Right x | xs@(x:_:_) <- takeClosest users' , Just True == matchesMatriculation x || didUpsert -> return $ Just $ Left $ NonEmpty.fromList xs | not didUpsert , userMatrs <- ((Set.toList . Set.fromList) (mapMaybe getTermMatr criteria)) -> mapM doUpsert userMatrs >>= maybe (go True) (return . Just) . convertUpsertResults . 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.selectOne . 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.selectOne . 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.selectOne . 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.selectOne . 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 E.<&> (tutorialParticipant E.^. TutorialParticipantCompany) E.<&> (tutorialParticipant E.^. TutorialParticipantDrivingPermit) E.<&> (tutorialParticipant E.^. TutorialParticipantEyeExam) E.<&> (tutorialParticipant E.^. TutorialParticipantNote) ) (\_current _excluded -> []) E.insertSelectWithConflict UniqueTutorialParticipantDay (EL.from $ \tutorialParticipantDay -> do E.where_ $ tutorialParticipantDay E.^. TutorialParticipantDayUser E.==. E.val oldUserId return $ TutorialParticipantDay E.<# (tutorialParticipantDay E.^. TutorialParticipantDayTutorial) E.<&> E.val newUserId E.<&> (tutorialParticipantDay E.^. TutorialParticipantDayDay) E.<&> (tutorialParticipantDay E.^. TutorialParticipantDayAttendance) E.<&> (tutorialParticipantDay E.^. TutorialParticipantDayNote) ) (\current excluded -> [ TutorialParticipantDayAttendance E.=. (current E.^. TutorialParticipantDayAttendance E.||. excluded E.^. TutorialParticipantDayAttendance) , TutorialParticipantDayNote E.=. E.coalesce [current E.^. TutorialParticipantDayNote, excluded E.^. TutorialParticipantDayNote] ] ) deleteWhere [ TutorialParticipantDayUser ==. oldUserId ] 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 UniqueLmsQualificationUuser 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) E.<&> (userSupervisor E.^. UserSupervisorCompany) E.<&> (userSupervisor E.^. UserSupervisorReason) ) (\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) , UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] , UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason] ] ) 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) E.<&> (userSupervisor E.^. UserSupervisorCompany) E.<&> (userSupervisor E.^. UserSupervisorReason) ) (\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications) , UserSupervisorCompany E.=. E.coalesce [current E.^. UserSupervisorCompany, excluded E.^. UserSupervisorCompany] , UserSupervisorReason E.=. E.coalesce [current E.^. UserSupervisorReason , excluded E.^. UserSupervisorReason] ] ) 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) E.<&> (userCompany E.^. UserCompanyPriority) E.<&> (userCompany E.^. UserCompanyUseCompanyAddress) E.<&> (userCompany E.^. UserCompanyReason) ) (\current excluded -> [ UserCompanySupervisor E.=. E.greatest (current E.^. UserCompanySupervisor) (excluded E.^. UserCompanySupervisor) -- t > f , UserCompanyPriority E.=. E.greatest (current E.^. UserCompanyPriority) (excluded E.^. UserCompanyPriority) , UserCompanyUseCompanyAddress E.=. E.greatest (current E.^. UserCompanyUseCompanyAddress) (excluded E.^. UserCompanyUseCompanyAddress) , UserCompanyReason E.=. E.coalesce [current E.^. UserCompanyReason ,excluded E.^. UserCompanyReason] ] ) deleteWhere [ UserCompanyUser ==. oldUserId] E.insertSelectWithConflict UniqueUserDay (EL.from $ \userDay -> do E.where_ $ userDay E.^. UserDayUser E.==. E.val oldUserId return $ UserDay E.<# E.val newUserId E.<&> (userDay E.^. UserDayDay) E.<&> (userDay E.^. UserDayParkingToken) ) (\current excluded -> [ UserDayParkingToken E.=. (current E.^. UserDayParkingToken E.||. excluded E.^. UserDayParkingToken) ] ) deleteWhere [ UserDayUser ==. oldUserId] mbOldAvsId <- getBy $ UniqueUserAvsUser oldUserId mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId case (mbOldAvsId,mbNewAvsId) of (Nothing, _) -> return () (Just Entity{entityVal=UserAvs{userAvsPersonId=oldAvsId}}, Just _) -> deleteBy (UniqueUserAvsId oldAvsId) (Just Entity{entityVal=oldUserAvs}, Nothing) -> void $ upsertBySafe (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)