-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

module Handler.Utils.Users
  ( computeUserAuthenticationDigest
  , Digest, SHA3_256
  , constEq
  , NameMatchQuality(..)
  , matchesName
  , GuessUserInfo(..)
  , guessUser
  , UserAssimilateException(..), UserAssimilateExceptionReason(..)
  , assimilateUser
  , userPrefersEmail, userPrefersLetter
  , getPostalAddress, getPostalPreferenceAndAddress
  , abbrvName
  , getReceivers
  ) where

import Import
import Auth.LDAP (campusUserMatr')
import Foundation.Yesod.Auth (upsertCampusUser)

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.List as List
import qualified Data.CaseInsensitive as CI

import qualified Database.Esqueleto.Legacy as E
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 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 getPostalAddressIfPreferred
userPrefersLetter :: User -> Bool
userPrefersLetter = fst . getPostalPreferenceAndAddress

-- deprecated, used getPostalAddressIfPreferred
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 || isNothing userPinPassword) && postPossible) || emailImpossible, pa)
  where
    orgEmail        = CI.original userEmail
    emailImpossible = not ('@' `textElem` orgEmail  &&  '.' `textElem` orgEmail)
    postPossible    = isJust pa
    pa = getPostalAddress usr

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

-- | DEPRECATED, use 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
  if null superIds
    then return (underling, [underling], True)
    else do
      supers <- selectList [UserId <-. superIds] []
      if null supers then return (underling, [underling], True)
      else
        return (underling, supers, uid `elem` (entityKey <$> supers))


computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
computeUserAuthenticationDigest = hashlazy . JSON.encode


data GuessUserInfo
  = GuessUserMatrikelnummer
    { guessUserMatrikelnummer         :: UserMatriculation          }
  | GuessUserEduPersonPrincipalName
    { guessUserEduPersonPrincipalName :: UserEduPersonPrincipalName }
  | 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')
      GuessUserEduPersonPrincipalName userEPPN'          -> user E.^. UserLdapPrimaryKey  E.==.          E.val (Just userEPPN')
      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 . E.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]

          doLdap userMatr = do
            ldapPool' <- getsYesod $ view _appLdapPool
            fmap join . for ldapPool' $ \ldapPool -> do
              ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
              for ldapData $ upsertCampusUser UpsertCampusUserGuessUser

      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
  E.insertSelectWithConflict
    UniqueCourseFavourite
    (E.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
    (E.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
    (E.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
    (E.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
    (E.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 . E.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 . E.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
    (E.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
    (E.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 . E.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do
      E.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
      E.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
       E.&&. submissionGroupUserA E.^. SubmissionGroupUserUser E.==. E.val oldUserId
       E.&&. submissionGroupUserB E.^. SubmissionGroupUserUser E.==. E.val newUserId
      E.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
    (E.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
    (E.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
    (E.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
    (E.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
    (E.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
    (E.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
    (E.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
    (E.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
    (E.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 . E.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do
      E.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
    (E.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 . E.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do
      E.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
    (E.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 . E.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do
      E.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
    (E.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
          (E.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do
              E.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 . E.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do
      E.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
    (E.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
    (E.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 . E.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do
      E.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId
      E.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse
       E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId
       E.&&. tutorialParticipantA E.^. TutorialParticipantUser E.==. E.val oldUserId
      E.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
    (E.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
    (E.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
              (E.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 ]
  E.insertSelectWithConflict
    UniqueQualificationUser
    (E.from $ \qualificationUser -> do
        E.where_ $ qualificationUser E.^. QualificationUserUser E.==. E.val oldUserId
        return $ QualificationUser
          E.<#  E.val newUserId
          E.<&> (qualificationUser E.^. QualificationUserQualification)
          E.<&> (qualificationUser E.^. QualificationUserValidUntil)
          E.<&> (qualificationUser E.^. QualificationUserLastRefresh)
          E.<&> (qualificationUser E.^. QualificationUserFirstHeld)
          E.<&> (qualificationUser E.^. QualificationUserBlockedDue)
          E.<&> (qualificationUser E.^. QualificationUserScheduleRenewal)
    )
    (\current excluded ->
      [ QualificationUserValidUntil       E.=. combineWith current excluded E.greatest QualificationUserValidUntil
      , QualificationUserLastRefresh      E.=. combineWith current excluded E.greatest QualificationUserLastRefresh
      , QualificationUserFirstHeld        E.=. combineWith current excluded E.least    QualificationUserFirstHeld
      , QualificationUserBlockedDue       E.=. combineWith current excluded E.greatest QualificationUserBlockedDue  -- Tested: PostgreSQL GREATEST/LEAST ignores NULL values
      , QualificationUserScheduleRenewal  E.=. combineWith current excluded E.greatest QualificationUserScheduleRenewal
      ]
    )
  deleteWhere [ QualificationUserUser ==. oldUserId ]

  -- Supervision is fully merged
  E.insertSelectWithConflict
    UniqueUserSupervisor
    (E.from $ \userSupervisor -> do
      E.where_ $ userSupervisor E.^. UserSupervisorSupervisor E.==. E.val oldUserId
      return $ UserSupervisor
        E.<#  E.val newUserId
        E.<&> (userSupervisor E.^. UserSupervisorUser)
        E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
    )
    (\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)  ] )
  deleteWhere [ UserSupervisorSupervisor ==. oldUserId]

  E.insertSelectWithConflict
    UniqueUserSupervisor
    (E.from $ \userSupervisor -> do
      E.where_ $ userSupervisor E.^. UserSupervisorUser E.==. E.val oldUserId
      return $ UserSupervisor
        E.<#  (userSupervisor E.^. UserSupervisorSupervisor)
        E.<&> E.val newUserId
        E.<&> (userSupervisor E.^. UserSupervisorRerouteNotifications)
    )
    (\current excluded -> [ UserSupervisorRerouteNotifications E.=. (current E.^. UserSupervisorRerouteNotifications E.||. excluded E.^. UserSupervisorRerouteNotifications)  ] )
  deleteWhere [ UserSupervisorUser ==. oldUserId]

  -- Companies, in conflict, keep the newUser-Company as is
  E.insertSelectWithConflict
    UniqueUserCompany
    (E.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)
    )
    (\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] )
  deleteWhere [ UserCompanyUser ==. oldUserId]

  userIdents <- E.select . E.from $ \user -> do
    E.where_ $ user E.^. UserId `E.in_` E.valList [newUserId, oldUserId]
    return ( user E.^. UserId
           , user E.^. UserIdent
           )
  case (,) <$> List.lookup (E.Value oldUserId) userIdents <*> List.lookup (E.Value newUserId) userIdents of
    Just (E.Value oldIdent, E.Value newIdent')
      | oldIdent /= newIdent' -> audit $ TransactionUserIdentChanged oldIdent newIdent'
      | otherwise -> return ()
    _other -> tellError UserAssimilateCouldNotDetermineUserIdents

  delete oldUserId
  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)