fradrive/src/Handler/Utils/Users.hs

-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, 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>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE TypeApplications #-}

-- NOTE: Also see Handler.Utils.Profile for similar utilities
module Handler.Utils.Users
  ( -- computeUserAuthenticationDigest
    -- , Digest, SHA3_256
    constEq
  , NameMatchQuality(..)
  , matchesName
  , GuessUserInfo(..)
  , guessUser
  , UserAssimilateException(..), UserAssimilateExceptionReason(..)
  , assimilateUser
  , userPrefersEmail, userPrefersLetter
  , getEmailAddress
  , getPostalAddress, getPostalPreferenceAndAddress
  , abbrvName
  , getReceivers, getReceiversFor
  , getSupervisees
  ) where

import Import
import Auth.LDAP (ldapUserMatr')
import Foundation.Yesod.Auth (upsertUser)

-- import Crypto.Hash (hashlazy)

import Data.ByteArray (constEq)
import Data.Maybe (fromJust)
import qualified Data.List.NonEmpty as NonEmpty (fromList)

-- import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON

import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI

import           Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
import qualified Database.Esqueleto.Legacy as EL (on,from)
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E

import qualified Data.Conduit.Combinators as C

import qualified Data.MultiSet as MultiSet
import qualified Data.Map as Map
import qualified Data.Text as Text
import Handler.Utils.Profile

import Jobs.Types(Job, JobChildren)

abbrvName :: User -> Text
abbrvName User{userDisplayName, userFirstName, userSurname} =
    if  | (lastDisplayName : tsrif) <- reverse nameParts
          -> assemble $ reverse $ lastDisplayName : abbreviate tsrif
        | otherwise
          -> assemble $ abbreviate (Text.words userFirstName) <> [userSurname]
  where
    nameParts = Text.words userDisplayName
    abbreviate = fmap (Text.take 1)
    assemble = Text.intercalate "."


-- deprecated, used getPostalPreferenceAndAddress
userPrefersLetter :: User -> Bool
userPrefersLetter = fst . getPostalPreferenceAndAddress

-- deprecated, used getPostalPreferenceAndAddress
userPrefersEmail :: User -> Bool
userPrefersEmail = not . userPrefersLetter

-- | result (True, Nothing) indicates that neither userEmail nor userPostAddress is known
getPostalPreferenceAndAddress :: User -> (Bool, Maybe [Text])
getPostalPreferenceAndAddress usr@User{userPrefersPostal} =
    ((userPrefersPostal && postPossible) || not emailPossible, pa)
    -- (((userPrefersPostal || isNothing userPinPassword) && postPossible) || not emailPossible, pa) -- ignore email/post preference if no pinPassword is set
  where        
    pa = getPostalAddress usr
    postPossible  = isJust pa
    emailPossible = isJust $ getEmailAddress usr
    
getEmailAddress :: User -> Maybe UserEmail
getEmailAddress User{userDisplayEmail, userEmail} = pickValidEmail' userDisplayEmail userEmail

getPostalAddress :: User -> Maybe [Text]
getPostalAddress User{..}
  | Just pa <- userPostAddress
    = Just $ userDisplayName : html2textlines pa
  | Just abt <- userCompanyDepartment
    = Just $ if | "BVD" `isPrefixOf` abt -> [userDisplayName, abt, "Bodenverkehrsdienste"]
                | otherwise              -> [userDisplayName, abt, "Hausbriefkasten"     ]
  | otherwise
    = Nothing

-- | Consider using Handler.Utils.Avs.updateReceivers instead
--   Return Entity User and all Supervisors with rerouteNotifications as well as
--   a boolean indicating if the user is own supervisor with rerouteNotifications
getReceivers :: UserId -> DB (Entity User, [Entity User], Bool)
getReceivers uid = do
  underling <- getJustEntity uid
  superVs <- selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] []
  let superIds = userSupervisorSupervisor . entityVal <$> superVs
      directResult = return (underling, [underling], True)
  if null superIds
    then directResult
    else do
      receivers <- selectList [UserId <-. superIds] []
      if null receivers
        then directResult
        else return (underling, receivers, uid `elem` (entityKey <$> receivers))

-- | For user with mailTdirect, since this query will also return supervisors that have reroute supervisors themselves, who would then receive multiple duplicates
getReceiversFor :: (MonoFoldable mono, UserId ~ Element mono) => mono -> DB [UserId]
getReceiversFor uids = (E.unValue <<$>>) $ E.select $ E.distinct $ do
  usr :& spr <- E.from $ E.table @User `E.leftJoin` E.table @UserSupervisor
    `E.on` (\(usr :& spr) -> usr E.^. UserId E.=?. spr E.?. UserSupervisorUser E.&&. E.isTrue (spr E.?. UserSupervisorRerouteNotifications))
  E.where_ $ usr E.^. UserId `E.in_` E.vals uids
  return $ E.coalesceDefault [spr E.?. UserSupervisorSupervisor] $ usr E.^. UserId

-- | return underlings for currently logged in user
getSupervisees :: DB (Set UserId)
getSupervisees = do 
  uid <- requireAuthId
  svs <- userSupervisorUser . entityVal <<$>> selectList [UserSupervisorSupervisor ==. uid] [Asc UserSupervisorUser]
  return $ Set.insert uid $ Set.fromAscList svs 


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


data GuessUserInfo
  = GuessUserMatrikelnummer
    { guessUserMatrikelnummer         :: UserMatriculation          }
  | GuessUserDisplayName
    { guessUserDisplayName            :: UserDisplayName            }
  | GuessUserSurname
    { guessUserSurname                :: UserSurname                }
  | GuessUserFirstName
    { guessUserFirstName              :: UserFirstName              }
  deriving (Eq, Ord, Read, Show, Generic)
instance Binary GuessUserInfo

makeLenses_ ''GuessUserInfo

data NameMatchQuality
  = NameMatchSuffix
  | NameMatchPrefix
  | NameMatchPermutation
  | NameMatchEqual
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)

matchesName :: Textual t
            => t -- ^ haystack
            -> t -- ^ needle
            -> Maybe NameMatchQuality
matchesName (repack -> haystack) (repack -> needle)
  = fmap (view _1) . Map.lookupMax $ Map.filter id tests
  where
    asWords :: Text -> [CI Text]
    asWords = map CI.mk . filter (not . Text.null) . Text.words . Text.strip

    tests :: Map NameMatchQuality Bool
    tests = mconcat
      [ singletonMap NameMatchEqual       $ asWords needle == asWords haystack
      , singletonMap NameMatchPrefix      $ asWords needle `isPrefixOf` asWords haystack
      , singletonMap NameMatchSuffix      $ asWords needle `isSuffixOf` asWords haystack
      , singletonMap NameMatchPermutation $ ((==) `on` MultiSet.fromList) (asWords needle) (asWords haystack)
      ]


guessUser :: PredDNF GuessUserInfo  -- ^ guessing criteria
          -> Maybe Int64  -- ^ Should the query be limited to a maximum number of results?
          -> DB (Maybe (Either (NonEmpty (Entity User)) (Entity User)))  -- ^ Just (Left _) in case of multiple results,
                                                                         --   Just (Right _) in case of single result, and
                                                                         --   Nothing in case of no result
guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria) mQueryLimit = $cachedHereBinary criteria $ go False
  where
    asWords :: Text -> [Text]
    asWords = filter (not . Text.null) . Text.words . Text.strip

    containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y

    toSql user pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of
      GuessUserMatrikelnummer         userMatriculation' -> user E.^. UserMatrikelnummer  E.==.          E.val (Just userMatriculation')
      GuessUserDisplayName            userDisplayName'   -> user E.^. UserDisplayName    `containsAsSet` userDisplayName'
      GuessUserSurname                userSurname'       -> user E.^. UserSurname        `containsAsSet` userSurname'
      GuessUserFirstName              userFirstName'     -> user E.^. UserFirstName      `containsAsSet` userFirstName'

    go didLdap = do
      let retrieveUsers = E.select . EL.from $ \user -> do
            E.where_ . E.or $ map (E.and . map (toSql user)) criteria
            when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit
            return user
      users <- retrieveUsers
      let users' = sortBy (flip closeness) users

          matchesMatriculation :: Entity User -> Maybe Bool
          matchesMatriculation = preview $ _entityVal . _userMatrikelnummer . to (\userMatr ->
            any (\p -> all ((== userMatr) . Just) (p ^.. folded . _PLVariable . _guessUserMatrikelnummer)
                    && all ((/= userMatr) . Just) (p ^.. folded . _PLNegated  . _guessUserMatrikelnummer))
            $ criteria ^.. folded)

          closeness :: Entity User -> Entity User -> Ordering
          closeness ul ur = maximum $ impureNonNull $ criteria <&> \term ->
            let
              matches userField name = _entityVal . userField . to (`matchesName` name)
              comp True  userField guess = (term ^.. folded . _PLVariable . guess) <&> \name ->
                compare (       ul ^. userField `matches` name)
                        (       ur ^. userField `matches` name)
              comp False userField guess = (term ^.. folded . _PLNegated  . guess) <&> \name ->
                compare (Down $ ul ^. userField `matches` name)
                        (Down $ ur ^. userField `matches` name)
            in mconcat $ concat $
                 [ pure $ compare (Down $ matchesMatriculation ul) (Down $ matchesMatriculation ur)
                 ] <>
                 [ comp b userField guess
                 | (userField,guess) <- [(_userSurname    , _guessUserSurname)
                                        ,(_userFirstName  , _guessUserFirstName)
                                        ,(_userDisplayName, _guessUserDisplayName)
                                        ]
                  , b <- [True,False]
                  ]

          -- Assuming the input list is sorted in descending order by closeness:
          takeClosest []  = []
          takeClosest [x] = [x]
          takeClosest (x:x':xs)
            | EQ <- x `closeness` x' = x : takeClosest (x':xs)
            | otherwise = [x]

          -- TODO: Generalize
          doLdap userMatr = do
            ldapPool' <- getsYesod $ view _appLdapPool
            fmap join . for ldapPool' $ \ldapPool@(upsertUserLdapConf,_) -> do
              ldapData <- ldapUserMatr' ldapPool userMatr
              for ldapData $ \upsertUserLdapData -> upsertUser UpsertUserGuessUser UpsertUserDataLdap{..}

      let
        getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation
        getTermMatr = getTermMatrAux Nothing where
          getTermMatrAux acc [] = acc
          getTermMatrAux acc (PLVariable (GuessUserMatrikelnummer matr):xs)
            | Just matr' <- acc, matr == matr' = getTermMatrAux acc xs
            | Nothing    <- acc                = getTermMatrAux (Just matr) xs
            | otherwise                        = Nothing
          getTermMatrAux acc (PLNegated  (GuessUserMatrikelnummer matr):xs)
            | Just matr' <- acc, matr /= matr' = getTermMatrAux acc xs
            | Nothing    <- acc                = getTermMatrAux acc xs
            | otherwise                        = Nothing
          getTermMatrAux acc (_:xs) = getTermMatrAux acc xs

        convertLdapResults :: [Entity User] -> Maybe (Either (NonEmpty (Entity User)) (Entity User))
        convertLdapResults []  = Nothing
        convertLdapResults [x] = Just $ Right x
        convertLdapResults xs  = Just $ Left $ NonEmpty.fromList xs

      if
        | [x] <- users'
        , Just True == matchesMatriculation x || didLdap
          -> return $ Just $ Right x
        | x : x' : _ <- users'
        , Just True == matchesMatriculation x || didLdap
        , GT <- x `closeness` x'
          -> return $ Just $ Right x
        | xs@(x:_:_) <- takeClosest users'
        , Just True == matchesMatriculation x || didLdap
          -> return $ Just $ Left $ NonEmpty.fromList xs
        | not didLdap
        , userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria
          -> mapM doLdap userMatrs >>= maybe (go True) (return . Just) . convertLdapResults . catMaybes
        | otherwise
          -> return Nothing


data UserAssimilateException = UserAssimilateException
  { userAssimilateOldUser, userAssimilateNewUser :: UserId
  , userAssimilateException :: UserAssimilateExceptionReason
  } deriving (Eq, Ord, Show, Generic)
    deriving anyclass (Exception)

data UserAssimilateExceptionReason
  = UserAssimilateExternalExamResultDifferentResult (Entity ExternalExamResult) (Entity ExternalExamResult)
  | UserAssimilateSubmissionGroupUserMultiple (Entity SubmissionGroupUser) (Entity SubmissionGroupUser)
  | UserAssimilateExamRegistrationDifferentOccurrence (Entity ExamRegistration) (Entity ExamRegistration)
  | UserAssimilateExamPartResultDifferentResult (Entity ExamPartResult) (Entity ExamPartResult)
  | UserAssimilateExamBonusDifferentBonus (Entity ExamBonus) (Entity ExamBonus)
  | UserAssimilateExamResultDifferentResult (Entity ExamResult) (Entity ExamResult)
  | UserAssimilatePersonalisedSheetFileDifferentContent (Entity PersonalisedSheetFile) (Entity PersonalisedSheetFile)
  | UserAssimilateTutorialParticipantCollidingRegGroups (Entity TutorialParticipant) (Entity TutorialParticipant)
  | UserAssimilateCouldNotDetermineUserIdents
  | UserAssimilateConflictingLmsQualifications (Set.Set QualificationId)
  deriving (Eq, Ord, Show, Generic)

assimilateUser :: UserId -- ^ @newUserId@
               -> UserId -- ^ @oldUserId@
               -> DB (Set UserAssimilateException) -- ^ Warnings
-- ^ Move all relevant properties (submissions, corrections, grades, ...) from @oldUserId@ to @newUserId@
--
-- Fatal errors are thrown, non-fatal warnings are returned
assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
  -- retrieve user entities first, to ensure they both exist
  (oldUserEnt, newUserEnt) <- do 
      oldUser <- getEntity oldUserId
      newUser <- getEntity newUserId
      case (oldUser, newUser) of 
        (Just old, Just new) -> return (old,new)
        _ -> tellError UserAssimilateCouldNotDetermineUserIdents
  let oldUser = oldUserEnt ^. _entityVal
      newUser = newUserEnt ^. _entityVal

  E.insertSelectWithConflict
    UniqueCourseFavourite
    (EL.from $ \courseFavourite -> do
        E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId
        return $ CourseFavourite
          E.<#  E.val newUserId
          E.<&> (courseFavourite E.^. CourseFavouriteCourse)
          E.<&> (courseFavourite E.^. CourseFavouriteReason)
          E.<&> (courseFavourite E.^. CourseFavouriteLastVisit)
    )
    (\current excluded -> [ CourseFavouriteLastVisit E.=. E.max (current E.^. CourseFavouriteLastVisit) (excluded E.^. CourseFavouriteLastVisit) ])
  deleteWhere [ CourseFavouriteUser ==. oldUserId ]

  E.insertSelectWithConflict
    UniqueCourseNoFavourite
    (EL.from $ \courseNoFavourite -> do
        E.where_ $ courseNoFavourite E.^. CourseNoFavouriteUser E.==. E.val oldUserId
        return $ CourseNoFavourite
          E.<#  E.val newUserId
          E.<&> (courseNoFavourite E.^. CourseNoFavouriteCourse)
    )
    (\_current _excluded -> [])
  deleteWhere [ CourseNoFavouriteUser ==. oldUserId ]

  E.insertSelectWithConflict
    UniqueExamOfficeField
    (EL.from $ \examOfficeField -> do
        E.where_ $ examOfficeField E.^. ExamOfficeFieldOffice E.==. E.val oldUserId
        return $ ExamOfficeField
          E.<#  E.val newUserId
          E.<&> (examOfficeField E.^. ExamOfficeFieldField)
          E.<&> (examOfficeField E.^. ExamOfficeFieldForced)
    )
    (\current excluded -> [ ExamOfficeFieldForced E.=. (current E.^. ExamOfficeFieldForced E.||. excluded E.^. ExamOfficeFieldForced) ])
  deleteWhere [ ExamOfficeFieldOffice ==. oldUserId ]

  E.insertSelectWithConflict
    UniqueExamOfficeUser
    (EL.from $ \examOfficeUser -> do
        E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. E.val oldUserId
        return $ ExamOfficeUser
          E.<#  E.val newUserId
          E.<&> (examOfficeUser E.^. ExamOfficeUserUser)
    )
    (\_current _excluded -> [])
  deleteWhere [ ExamOfficeUserOffice ==. oldUserId ]
  E.insertSelectWithConflict
    UniqueExamOfficeUser
    (EL.from $ \examOfficeUser -> do
        E.where_ $ examOfficeUser E.^. ExamOfficeUserUser E.==. E.val oldUserId
        return $ ExamOfficeUser
          E.<#  (examOfficeUser E.^. ExamOfficeUserOffice)
          E.<&> E.val newUserId
    )
    (\_current _excluded -> [])
  deleteWhere [ ExamOfficeUserUser ==. oldUserId ]

  E.insertSelect . EL.from $ \examOfficeResultSynced -> do
    E.where_ $ examOfficeResultSynced E.^. ExamOfficeResultSyncedOffice E.==. E.val oldUserId
    return $ ExamOfficeResultSynced
          E.<#  (examOfficeResultSynced E.^. ExamOfficeResultSyncedSchool)
          E.<&> E.val newUserId
          E.<&> (examOfficeResultSynced E.^. ExamOfficeResultSyncedResult)
          E.<&> (examOfficeResultSynced E.^. ExamOfficeResultSyncedTime)
  deleteWhere [ ExamOfficeResultSyncedOffice ==. oldUserId ]

  E.insertSelect . EL.from $ \examOfficeExternalResultSynced -> do
    E.where_ $ examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedOffice E.==. E.val oldUserId
    return $ ExamOfficeExternalResultSynced
          E.<#  (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedSchool)
          E.<&> E.val newUserId
          E.<&> (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedResult)
          E.<&> (examOfficeExternalResultSynced E.^. ExamOfficeExternalResultSyncedTime)
  deleteWhere [ ExamOfficeExternalResultSyncedOffice ==. oldUserId ]

  let getExternalExamResults = selectSource [ ExternalExamResultUser ==. oldUserId ] []
      upsertExternalExamResult oldEEREnt@(Entity oldEERId oldEER) = do
        newEER' <- getBy $ UniqueExternalExamResult (externalExamResultExam oldEER) newUserId
        newEERId <- case newEER' of
          Just newEEREnt@(Entity _ newEER)
            |    ((/=) `on` externalExamResultResult) newEER oldEER
              || ((/=) `on` externalExamResultTime) newEER oldEER
              -> tellError $ UserAssimilateExternalExamResultDifferentResult oldEEREnt newEEREnt
          Just (Entity newEERId newEER) -> newEERId <$ update newEERId
            [ ExternalExamResultLastChanged =. (max `on` externalExamResultLastChanged) oldEER newEER
            ]
          Nothing -> insert oldEER
            { externalExamResultUser = newUserId
            }
        updateWhere [ ExamOfficeExternalResultSyncedResult ==. oldEERId ] [ ExamOfficeExternalResultSyncedResult =. newEERId ]
        delete oldEERId
   in runConduit $ getExternalExamResults .| C.mapM_ upsertExternalExamResult

  E.insertSelectWithConflict
    UniqueExternalExamStaff
    (EL.from $ \externalExamStaff -> do
       E.where_ $ externalExamStaff E.^. ExternalExamStaffUser E.==. E.val oldUserId
       return $ ExternalExamStaff
         E.<#  E.val newUserId
         E.<&> (externalExamStaff E.^. ExternalExamStaffExam)
    )
    (\_current _excluded -> [])
  deleteWhere [ ExternalExamStaffUser ==. oldUserId ]

  updateWhere [ SubmissionRatingBy ==. Just oldUserId ] [ SubmissionRatingBy =. Just newUserId ]

  updateWhere [ SubmissionEditUser ==. Just oldUserId ] [ SubmissionEditUser =. Just newUserId ]

  E.insertSelectWithConflict
    UniqueSubmissionUser
    (EL.from $ \submissionUser -> do
       E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val oldUserId
       return $ SubmissionUser
         E.<#  E.val newUserId
         E.<&> (submissionUser E.^. SubmissionUserSubmission)
    )
    (\_current _excluded -> [])
  deleteWhere [ SubmissionUserUser ==. oldUserId ]

  do
    collisions <- E.select . EL.from $ \((submissionGroupUserA `E.InnerJoin` submissionGroupA) `E.InnerJoin` (submissionGroupUserB `E.InnerJoin` submissionGroupB)) -> do
      EL.on $ submissionGroupB E.^. SubmissionGroupId E.==. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
      EL.on $ submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup E.!=. submissionGroupUserB E.^. SubmissionGroupUserSubmissionGroup
       E.&&. submissionGroupUserA E.^. SubmissionGroupUserUser E.==. E.val oldUserId
       E.&&. submissionGroupUserB E.^. SubmissionGroupUserUser E.==. E.val newUserId
      EL.on $ submissionGroupA E.^. SubmissionGroupId E.==. submissionGroupUserA E.^. SubmissionGroupUserSubmissionGroup
      E.where_ $ submissionGroupA E.^. SubmissionGroupCourse E.==. submissionGroupB E.^. SubmissionGroupCourse
      return (submissionGroupUserA, submissionGroupUserB)
    forM_ collisions $ \(submissionGroupUserA, submissionGroupUserB) ->
      tellWarning $ UserAssimilateSubmissionGroupUserMultiple submissionGroupUserA submissionGroupUserB
  E.insertSelectWithConflict
    UniqueSubmissionGroupUser
    (EL.from $ \submissionGroupUser -> do
       E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val oldUserId
       return $ SubmissionGroupUser
         E.<#  (submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup)
         E.<&> E.val newUserId
    )
    (\_current _excluded -> [])
  deleteWhere [ SubmissionGroupUserUser ==. oldUserId ]

  updateWhere [ TransactionLogInitiator ==. Just oldUserId ] [ TransactionLogInitiator =. Just newUserId ]
  -- We're not updating info; doing that would probably be too slow
  -- Just check for `TransactionUserAssimilated` entries and correct manually

  updateWhere [ CourseEditUser ==. oldUserId ] [ CourseEditUser =. newUserId ]

  E.insertSelectWithConflict
    UniqueLecturer
    (EL.from $ \lecturer -> do
        E.where_ $ lecturer E.^. LecturerUser E.==. E.val oldUserId
        return $ Lecturer
          E.<#  E.val newUserId
          E.<&> (lecturer E.^. LecturerCourse)
          E.<&> (lecturer E.^. LecturerType)
    )
    (\_current excluded -> [ LecturerType E.=. excluded E.^. LecturerType ])
  deleteWhere [ LecturerUser ==. oldUserId ]

  E.insertSelectWithConflict
    UniqueParticipant
    (EL.from $ \courseParticipant -> do
        E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val oldUserId
        return $ CourseParticipant
          E.<#  (courseParticipant E.^. CourseParticipantCourse)
          E.<&> E.val newUserId
          E.<&> (courseParticipant E.^. CourseParticipantRegistration)
          E.<&> (courseParticipant E.^. CourseParticipantState)
    )
    (\current excluded ->
       [ CourseParticipantState E.=. E.exprLift min (current E.^. CourseParticipantState) (excluded E.^. CourseParticipantState)
       , CourseParticipantRegistration E.=. E.max (current E.^. CourseParticipantRegistration) (excluded E.^. CourseParticipantRegistration)
       ]
    )
  deleteWhere [ CourseParticipantUser ==. oldUserId ]

  let getCourseUserNotes = selectSource [ CourseUserNoteUser ==. oldUserId ] []
      upsertCourseUserNote (Entity oldCUNId oldCUN) = do
        collision <- getBy $ UniqueCourseUserNote newUserId (courseUserNoteCourse oldCUN)
        newCUNId <- case collision of
          Nothing -> oldCUNId <$ update oldCUNId [ CourseUserNoteUser =. newUserId ]
          Just (Entity newCUNId newCUN) -> newCUNId <$ update newCUNId [ CourseUserNoteNote =. ((<>) `on` courseUserNoteNote) oldCUN newCUN ]
        when (newCUNId /= oldCUNId) $
          updateWhere [CourseUserNoteEditNote ==. oldCUNId] [CourseUserNoteEditNote =. newCUNId]
        delete oldCUNId
   in runConduit $ getCourseUserNotes .| C.mapM_ upsertCourseUserNote

  updateWhere [ CourseUserNoteEditUser ==. oldUserId ] [ CourseUserNoteEditUser =. newUserId ]

  E.insertSelectWithConflict
    UniqueCourseUserExamOfficeOptOut
    (EL.from $ \examOfficeOptOut -> do
        E.where_ $ examOfficeOptOut E.^. CourseUserExamOfficeOptOutUser E.==. E.val oldUserId
        return $ CourseUserExamOfficeOptOut
          E.<#  (examOfficeOptOut E.^. CourseUserExamOfficeOptOutCourse)
          E.<&> E.val newUserId
          E.<&> (examOfficeOptOut E.^. CourseUserExamOfficeOptOutSchool)
    )
    (\_current _excluded -> [])
  deleteWhere [ CourseUserExamOfficeOptOutUser ==. oldUserId ]

  E.insertSelectWithConflict
    UniqueUserFunction
    (EL.from $ \userFunction -> do
        E.where_ $ userFunction E.^. UserFunctionUser E.==. E.val oldUserId
        return $ UserFunction
          E.<#  E.val newUserId
          E.<&> (userFunction E.^. UserFunctionSchool)
          E.<&> (userFunction E.^. UserFunctionFunction)
    )
    (\_current _excluded -> [])
  deleteWhere [ UserFunctionUser ==. oldUserId ]

  E.insertSelectWithConflict
    UniqueUserSystemFunction
    (EL.from $ \userSystemFunction -> do
        E.where_ $ userSystemFunction E.^. UserSystemFunctionUser E.==. E.val oldUserId
        return $ UserSystemFunction
          E.<#  E.val newUserId
          E.<&> (userSystemFunction E.^. UserSystemFunctionFunction)
          E.<&> (userSystemFunction E.^. UserSystemFunctionManual)
          E.<&> (userSystemFunction E.^. UserSystemFunctionIsOptOut)
    )
    (\current excluded -> [ UserSystemFunctionManual E.=. (current E.^. UserSystemFunctionManual E.||. excluded E.^. UserSystemFunctionManual), UserSystemFunctionIsOptOut E.=. (current E.^. UserSystemFunctionIsOptOut E.&&. excluded E.^. UserSystemFunctionIsOptOut) ])
  deleteWhere [ UserSystemFunctionUser ==. oldUserId ]

  E.insertSelectWithConflict
    UniqueUserExamOffice
    (EL.from $ \userExamOffice -> do
        E.where_ $ userExamOffice E.^. UserExamOfficeUser E.==. E.val oldUserId
        return $ UserExamOffice
          E.<#  E.val newUserId
          E.<&> (userExamOffice E.^. UserExamOfficeField)
    )
    (\_current _excluded -> [])
  deleteWhere [ UserExamOfficeUser ==. oldUserId ]

  E.insertSelectWithConflict
    UniqueUserSchool
    (EL.from $ \userSchool -> do
        E.where_ $ userSchool E.^. UserSchoolUser E.==. E.val oldUserId
        return $ UserSchool
          E.<#  E.val newUserId
          E.<&> (userSchool E.^. UserSchoolSchool)
          E.<&> (userSchool E.^. UserSchoolIsOptOut)
    )
    (\current excluded -> [ UserSchoolIsOptOut E.=. (current E.^. UserSchoolIsOptOut E.&&. excluded E.^. UserSchoolIsOptOut) ])
  deleteWhere [ UserSchoolUser ==. oldUserId ]

  updateWhere [ UserGroupMemberUser ==. oldUserId, UserGroupMemberPrimary ==. Active ] [ UserGroupMemberUser =. newUserId ]
  E.insertSelectWithConflict
    UniqueUserGroupMember
    (EL.from $ \userGroupMember -> do
        E.where_ $ userGroupMember E.^. UserGroupMemberUser E.==. E.val oldUserId
        return $ UserGroupMember
          E.<#  (userGroupMember E.^. UserGroupMemberGroup)
          E.<&> E.val newUserId
          E.<&> (userGroupMember E.^. UserGroupMemberPrimary)
    )
    (\_current _excluded -> [])
  deleteWhere [ UserGroupMemberUser ==. oldUserId ]

  do
    collisions <- E.select . EL.from $ \(examRegistrationA `E.InnerJoin` examRegistrationB) -> do
      EL.on $ examRegistrationA E.^. ExamRegistrationExam E.==. examRegistrationB E.^. ExamRegistrationExam
       E.&&. examRegistrationA E.^. ExamRegistrationUser E.==. E.val oldUserId
       E.&&. examRegistrationB E.^. ExamRegistrationUser E.==. E.val newUserId
      E.where_ $ examRegistrationA E.^. ExamRegistrationOccurrence E.!=. examRegistrationB E.^. ExamRegistrationOccurrence
        E.&&. E.isJust (examRegistrationA E.^. ExamRegistrationOccurrence)
        E.&&. E.isJust (examRegistrationB E.^. ExamRegistrationOccurrence)
      return (examRegistrationA, examRegistrationB)
    forM_ collisions $ \(oldExamRegistration, newExamRegistration)
      -> tellWarning $ UserAssimilateExamRegistrationDifferentOccurrence oldExamRegistration newExamRegistration
  E.insertSelectWithConflict
    UniqueExamRegistration
    (EL.from $ \examRegistration -> do
        E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val oldUserId
        return $ ExamRegistration
          E.<#  (examRegistration E.^. ExamRegistrationExam)
          E.<&> E.val newUserId
          E.<&> (examRegistration E.^. ExamRegistrationOccurrence)
          E.<&> (examRegistration E.^. ExamRegistrationTime)
    )
    (\current excluded -> [ ExamRegistrationOccurrence E.=. E.alt (current E.^. ExamRegistrationOccurrence) (excluded E.^. ExamRegistrationOccurrence), ExamRegistrationTime E.=. E.min (current E.^. ExamRegistrationTime) (excluded E.^. ExamRegistrationTime) ])
  deleteWhere [ ExamRegistrationUser ==. oldUserId ]

  do
    collision <- E.selectMaybe . EL.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do
      EL.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart
       E.&&. examPartResultA E.^. ExamPartResultUser E.==. E.val oldUserId
       E.&&. examPartResultB E.^. ExamPartResultUser E.==. E.val newUserId
      E.where_ $ examPartResultA E.^. ExamPartResultResult E.!=. examPartResultB E.^. ExamPartResultResult
      return (examPartResultA, examPartResultB)
    whenIsJust collision $ \(oldExamPartResult, newExamPartResult)
      -> tellError $ UserAssimilateExamPartResultDifferentResult oldExamPartResult newExamPartResult
  E.insertSelectWithConflict
    UniqueExamPartResult
    (EL.from $ \examPartResult -> do
        E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val oldUserId
        return $ ExamPartResult
          E.<#  (examPartResult E.^. ExamPartResultExamPart)
          E.<&> E.val newUserId
          E.<&> (examPartResult E.^. ExamPartResultResult)
          E.<&> (examPartResult E.^. ExamPartResultLastChanged)
    )
    (\current excluded -> [ ExamPartResultLastChanged E.=. E.max (current E.^. ExamPartResultLastChanged) (excluded E.^. ExamPartResultLastChanged) ])
  deleteWhere [ ExamPartResultUser ==. oldUserId ]

  do
    collision <- E.selectMaybe . EL.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do
      EL.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam
       E.&&. examBonusA E.^. ExamBonusUser E.==. E.val oldUserId
       E.&&. examBonusB E.^. ExamBonusUser E.==. E.val newUserId
      E.where_ $ examBonusA E.^. ExamBonusBonus E.!=. examBonusB E.^. ExamBonusBonus
      return (examBonusA, examBonusB)
    whenIsJust collision $ \(oldExamBonus, newExamBonus)
      -> tellError $ UserAssimilateExamBonusDifferentBonus oldExamBonus newExamBonus
  E.insertSelectWithConflict
    UniqueExamBonus
    (EL.from $ \examBonus -> do
        E.where_ $ examBonus E.^. ExamBonusUser E.==. E.val oldUserId
        return $ ExamBonus
          E.<#  (examBonus E.^. ExamBonusExam)
          E.<&> E.val newUserId
          E.<&> (examBonus E.^. ExamBonusBonus)
          E.<&> (examBonus E.^. ExamBonusLastChanged)
    )
    (\current excluded -> [ ExamBonusLastChanged E.=. E.max (current E.^. ExamBonusLastChanged) (excluded E.^. ExamBonusLastChanged) ])
  deleteWhere [ ExamBonusUser ==. oldUserId ]

  let getExamResults = selectSource [ ExamResultUser ==. oldUserId ] []
      upsertExamResult oldEREnt@(Entity oldERId oldER) = do
        newER' <- getBy $ UniqueExamResult (examResultExam oldER) newUserId
        newERId <- case newER' of
          Just newEREnt@(Entity _ newER)
            | ((/=) `on` examResultResult) newER oldER
              -> tellError $ UserAssimilateExamResultDifferentResult oldEREnt newEREnt
          Just (Entity newERId newER) -> newERId <$ update newERId
            [ ExamResultLastChanged =. (max `on` examResultLastChanged) oldER newER
            ]
          Nothing -> insert oldER
            { examResultUser = newUserId
            }
        updateWhere [ ExamOfficeResultSyncedResult ==. oldERId ] [ ExamOfficeResultSyncedResult =. newERId ]
        delete oldERId
   in runConduit $ getExamResults .| C.mapM_ upsertExamResult

  let getExamCorrectors = selectSource [ ExamCorrectorUser ==. oldUserId ] []
      upsertExamCorrector (Entity oldECId examCorrector) = do
        Entity newECId _ <- upsert examCorrector{ examCorrectorUser = newUserId } []
        E.insertSelectWithConflict
          UniqueExamPartCorrector
          (EL.from $ \(examPartCorrector `E.InnerJoin` examCorrector') -> do
              EL.on $ examCorrector' E.^. ExamCorrectorId E.==. examPartCorrector E.^. ExamPartCorrectorCorrector
              E.where_ $ examCorrector' E.^. ExamCorrectorUser E.==. E.val oldUserId
                   E.&&. examCorrector' E.^. ExamCorrectorExam E.==. E.val (examCorrectorExam examCorrector)
              return $ ExamPartCorrector
                E.<#  (examPartCorrector E.^. ExamPartCorrectorPart)
                E.<&> E.val newECId
          )
          (\_current _excluded -> [])
        deleteWhere [ ExamPartCorrectorCorrector ==. oldECId ]
        delete oldECId
   in runConduit $ getExamCorrectors .| C.mapM_ upsertExamCorrector

  let getQueuedJobs = selectSource [] []
      updateQueuedJob (Entity jId QueuedJob{..}) = maybeT_ $ do
        (content' :: Job) <- hoistMaybe $ JSON.parseMaybe parseJSON queuedJobContent
        let uContent' = set (typesUsing @JobChildren . filtered (== oldUserId)) newUserId content'
        guard $ uContent' /= content'
        lift $ update jId [ QueuedJobContent =. toJSON uContent' ]
   in runConduit $ getQueuedJobs .| C.mapM_ updateQueuedJob

  updateWhere [ SentMailRecipient ==. Just oldUserId ] [ SentMailRecipient =. Just newUserId ]

  updateWhere [ SheetEditUser ==. oldUserId] [ SheetEditUser =. newUserId ]

  let getSheetPseudonyms = selectSource [ SheetPseudonymUser ==. oldUserId ] []
      upsertSheetPseudonym (Entity oldSPId oldSP) = do
        collision <- existsBy $ UniqueSheetPseudonymUser (sheetPseudonymSheet oldSP) newUserId
        if
          | collision -> delete oldSPId
          | otherwise -> update oldSPId [ SheetPseudonymUser =. newUserId ]
   in runConduit $ getSheetPseudonyms .| C.mapM_ upsertSheetPseudonym

  let getSheetCorrectors = selectSource [ SheetCorrectorUser ==. oldUserId ] []
      upsertSheetCorrector (Entity oldSCId oldSheetCorrector) = do
        collision <- getBy $ UniqueSheetCorrector newUserId (sheetCorrectorSheet oldSheetCorrector)
        case collision of
          Nothing -> update oldSCId [ SheetCorrectorUser =. newUserId ]
          Just (Entity newSCId newSheetCorrector) -> do
            update newSCId
              [ SheetCorrectorLoad =. (sheetCorrectorLoad oldSheetCorrector <> sheetCorrectorLoad newSheetCorrector)
              , SheetCorrectorState =. (min `on` sheetCorrectorState) oldSheetCorrector newSheetCorrector
              ]
            delete oldSCId
   in runConduit $ getSheetCorrectors .| C.mapM_ upsertSheetCorrector

  do
    collision <- E.selectMaybe . EL.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do
      EL.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet
       E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileType E.==. personalisedSheetFileB E.^. PersonalisedSheetFileType
       E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileTitle E.==. personalisedSheetFileB E.^. PersonalisedSheetFileTitle
       E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileUser E.==. E.val oldUserId
       E.&&. personalisedSheetFileB E.^. PersonalisedSheetFileUser E.==. E.val newUserId
      E.where_ . E.not_ $ personalisedSheetFileA E.^. PersonalisedSheetFileContent `E.maybeEq` personalisedSheetFileB E.^. PersonalisedSheetFileContent
      return (personalisedSheetFileA, personalisedSheetFileB)
    whenIsJust collision $ \(oldPersonalisedSheetFile, newPersonalisedSheetFile)
      -> tellError $ UserAssimilatePersonalisedSheetFileDifferentContent oldPersonalisedSheetFile newPersonalisedSheetFile
  E.insertSelectWithConflict
    UniquePersonalisedSheetFile
    (EL.from $ \personalisedSheetFile -> do
        E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileUser E.==. E.val oldUserId
        return $ PersonalisedSheetFile
          E.<#  (personalisedSheetFile E.^. PersonalisedSheetFileSheet)
          E.<&> E.val newUserId
          E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileType)
          E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileTitle)
          E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileContent)
          E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileModified)
    )
    (\current excluded -> [ PersonalisedSheetFileModified E.=. E.max (current E.^. PersonalisedSheetFileModified) (excluded E.^. PersonalisedSheetFileModified) ])
  deleteWhere [ PersonalisedSheetFileUser ==. oldUserId ]

  E.insertSelectWithConflict
    UniqueTutor
    (EL.from $ \tutor -> do
        E.where_ $ tutor E.^. TutorUser E.==. E.val oldUserId
        return $ Tutor
          E.<#  (tutor E.^. TutorTutorial)
          E.<&> E.val newUserId
    )
    (\_current _excluded -> [])

  do
    collision <- E.selectMaybe . EL.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do
      EL.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId
      EL.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse
       E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId
       E.&&. tutorialParticipantA E.^. TutorialParticipantUser E.==. E.val oldUserId
      EL.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId
      E.where_ $ tutorialA E.^. TutorialId E.!=. tutorialB E.^. TutorialId
           E.&&. tutorialA E.^. TutorialRegGroup E.==. tutorialB E.^. TutorialRegGroup
      return (tutorialParticipantA, tutorialParticipantB)
    whenIsJust collision $ \(tutorialUserA, tutorialUserB)
      -> tellError $ UserAssimilateTutorialParticipantCollidingRegGroups tutorialUserA tutorialUserB
  E.insertSelectWithConflict
    UniqueTutorialParticipant
    (EL.from $ \tutorialParticipant -> do
        E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val oldUserId
        return $ TutorialParticipant
          E.<#  (tutorialParticipant E.^. TutorialParticipantTutorial)
          E.<&> E.val newUserId
    )
    (\_current _excluded -> [])
  deleteWhere [ TutorialParticipantUser ==. oldUserId ]

  E.insertSelectWithConflict
    UniqueSystemMessageHidden
    (EL.from $ \systemMessageHidden -> do
        E.where_ $ systemMessageHidden E.^. SystemMessageHiddenUser E.==. E.val oldUserId
        return $ SystemMessageHidden
          E.<#  (systemMessageHidden E.^. SystemMessageHiddenMessage)
          E.<&> E.val newUserId
          E.<&> (systemMessageHidden E.^. SystemMessageHiddenTime)
    )
    (\current excluded -> [ SystemMessageHiddenTime E.=. combineWith current excluded E.max SystemMessageHiddenTime])
  deleteWhere [ SystemMessageHiddenUser ==. oldUserId ]

  let getStudyFeatures = selectSource [ StudyFeaturesUser ==. oldUserId ] []
      upsertStudyFeatures (Entity oldSFId oldStudyFeatures) = do
        collision <- getBy $ UniqueStudyFeatures newUserId (studyFeaturesDegree oldStudyFeatures) (studyFeaturesField oldStudyFeatures) (studyFeaturesType oldStudyFeatures) (studyFeaturesSemester oldStudyFeatures)
        case collision of
          Nothing -> update oldSFId [ StudyFeaturesUser =. newUserId ]
          Just (Entity newSFId newStudyFeatures) -> do
            update newSFId
              [ StudyFeaturesSuperField =. ((<|>) `on` studyFeaturesSuperField) newStudyFeatures oldStudyFeatures
              , StudyFeaturesFirstObserved =. (min `on` studyFeaturesFirstObserved) oldStudyFeatures newStudyFeatures
              , StudyFeaturesLastObserved =. (max `on` studyFeaturesLastObserved) oldStudyFeatures newStudyFeatures
              , StudyFeaturesValid =. ((||) `on` studyFeaturesValid) oldStudyFeatures newStudyFeatures
              , StudyFeaturesRelevanceCached =. ((<|>) `on` studyFeaturesRelevanceCached) oldStudyFeatures newStudyFeatures
              ]
            E.insertSelectWithConflict
              UniqueRelevantStudyFeatures
              (EL.from $ \relevantStudyFeatures -> do
                  E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. E.val oldSFId
                  return $ RelevantStudyFeatures
                    E.<#  (relevantStudyFeatures E.^. RelevantStudyFeaturesTerm)
                    E.<&> E.val newSFId
              )
              (\_current _excluded -> [])
            deleteWhere [ RelevantStudyFeaturesStudyFeatures ==. oldSFId ]
            delete oldSFId
   in runConduit $ getStudyFeatures .| C.mapM_ upsertStudyFeatures

  -- Qualifications and ongoing LMS
  -- LmsUser: insertSelectWithConflict impossible due to 2 simultaneous uniqueness constraints; UniqueLmsIdent requires proper update, prohibits insert and then delete
  -- updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ] -- might fail due to UniqueLmsQualficationUuser
  oldLms <- selectList [ LmsUserUser ==. oldUserId ] [ Asc LmsUserQualification ]
  newLms <- selectList [ LmsUserUser ==. newUserId ] [ Asc LmsUserQualification ]
  let projQ = lmsUserQualification . entityVal
      oldQs = Set.fromList (projQ <$> oldLms)
      newQs = Set.fromList (projQ <$> newLms)
      qConflicts  = oldQs `Set.intersection` newQs
      qResolvable = Set.fromList [ lmsUserQualification | Entity _ LmsUser{..} <- oldLms, isJust lmsUserEnded, lmsUserQualification `Set.member` qConflicts ]
      qProblems   = qConflicts `Set.difference` qResolvable
  unless (Set.null qProblems)   $ tellError $ UserAssimilateConflictingLmsQualifications qProblems
  unless (Set.null qResolvable) $ deleteWhere [ LmsUserUser ==. oldUserId, LmsUserQualification <-. Set.toList qResolvable ] -- delete conflicting and finished LMS, which are still within auditDuration
  updateWhere [ LmsUserUser ==. oldUserId ] [ LmsUserUser =. newUserId ]
  updateWhere [ QualificationEditUser ==. oldUserId ] [ QualificationEditUser =. newUserId ]
  usrQualis <- E.select $ EL.from $ \(oldQual `E.LeftOuterJoin` newQual) -> do
      EL.on (      newQual E.?. QualificationUserQualification E.?=. oldQual E.^. QualificationUserQualification
            E.&&. newQual E.?. QualificationUserUser          E.?=. E.val newUserId
            )
      E.where_ $  oldQual E.^. QualificationUserUser          E.==. E.val oldUserId          
      return (oldQual, newQual)
  forM_ usrQualis $ \case 
    (Entity oldQKey _, Nothing) -> update oldQKey [ QualificationUserUser =. newUserId ] -- update must succeed if there is not RHS in the join
    (Entity oldQKey oldQUsr, Just (Entity newQKey newQUsr)) -> do
      updateWhere [ QualificationUserBlockQualificationUser ==. oldQKey ] [ QualificationUserBlockQualificationUser =. newQKey ]
      update newQKey 
        [ QualificationUserValidUntil       =. (max `on` view _qualificationUserValidUntil     ) oldQUsr newQUsr
        , QualificationUserLastRefresh      =. (max `on` view _qualificationUserLastRefresh    ) oldQUsr newQUsr
        , QualificationUserFirstHeld        =. (min `on` view _qualificationUserFirstHeld      ) oldQUsr newQUsr
        , QualificationUserScheduleRenewal  =. (max `on` view _qualificationUserScheduleRenewal) oldQUsr newQUsr
        , QualificationUserLastNotified     =. (max `on` view _qualificationUserLastNotified   ) oldQUsr newQUsr
        ]
      delete oldQKey
  -- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed  

  -- PrintJobs
  updateWhere [ PrintJobRecipient ==. Just oldUserId ] [ PrintJobRecipient =. Just newUserId ]
  updateWhere [ PrintJobSender    ==. Just oldUserId ] [ PrintJobSender    =. Just newUserId ]

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

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

  -- Companies, in conflict, keep the newUser-Company as is
  E.insertSelectWithConflict
    UniqueUserCompany
    (EL.from $ \userCompany -> do
      E.where_ $ userCompany E.^. UserCompanyUser E.==. E.val oldUserId
      return $ UserCompany
        E.<#  E.val newUserId
        E.<&> (userCompany E.^. UserCompanyCompany)
        E.<&> (userCompany E.^. UserCompanySupervisor)
        E.<&> (userCompany E.^. UserCompanySupervisorReroute)
    )
    (\current _excluded -> [ UserCompanySupervisor E.=. (current E.^. UserCompanySupervisor)] )
  deleteWhere [ UserCompanyUser ==. oldUserId]

  mbOldAvsId <- getBy $ UniqueUserAvsUser oldUserId
  mbNewAvsId <- getBy $ UniqueUserAvsUser newUserId  
  case (mbOldAvsId,mbNewAvsId) of 
    (Nothing, _) 
      -> return ()
    (Just Entity{entityVal=UserAvs{userAvsPersonId=oldAvsId}}, Just _) 
      -> deleteWhere [UserAvsCardPersonId ==. oldAvsId] >> deleteBy (UniqueUserAvsUser oldUserId)
    (Just Entity{entityVal=oldUserAvs}, Nothing) 
      -> -- deleteBy $ UniqueUserAvsUser oldUserId -- maybe we need this due to double uniqueness?!
         void $ upsertBy (UniqueUserAvsId (oldUserAvs ^. _userAvsPersonId)) oldUserAvs{userAvsUser=newUserId} [UserAvsUser =. newUserId]

  -- merge some optional / incomplete user fields
  let mergeBy :: forall a . PersistField a => (a -> a -> Bool) -> EntityField User a -> Maybe (Update User)
      mergeBy cmp uf =  let ufl   = fieldLens uf
                            oldV  = oldUserEnt ^. ufl
                            newV  = newUserEnt ^. ufl
                        in toMaybe (cmp oldV newV) (uf =. oldV)
                        
      mergeMaybe :: forall b . PersistField b => EntityField User (Maybe b) -> Maybe (Update User)
      mergeMaybe = mergeBy (\oldV newV -> isNothing newV && isJust oldV)

  update newUserId $ catMaybes          -- NOTE: persist does shortcircuit null updates as expected
      [ mergeMaybe  UserPasswordHash
      , mergeBy (>) UserLastAuthentication
      , mergeBy (<) UserCreated
      , toMaybe (not (validEmail' (newUser ^. _userEmail       )) && validEmail' (oldUser ^. _userEmail))
                (UserEmail =. oldUser ^. _userEmail)
      , toMaybe (not (validEmail' (newUser ^. _userDisplayEmail)) && validEmail' (oldUser ^. _userDisplayEmail))
                (UserDisplayEmail =. oldUser ^. _userDisplayEmail)
      , mergeMaybe UserMatrikelnummer
      , toMaybe (isNothing (newUser ^. _userPostAddress) && isJust (oldUser ^. _userPostAddress))
                (UserPostAddress =. oldUser ^. _userPostAddress)
      , toMaybe (isNothing (newUser ^. _userPostAddress) && isJust (oldUser ^. _userPostAddress))
                (UserPostLastUpdate =. oldUser ^. _userPostLastUpdate)
      , toMaybe ((isJust (newUser ^. _userPostAddress) || isJust (oldUser ^. _userPostAddress))
                  && (newUser ^. _userPrefersPostal || oldUser ^. _userPrefersPostal))
                (UserPrefersPostal =. True)      
      , mergeMaybe UserPinPassword
      , mergeMaybe UserLanguages
      , mergeMaybe UserSex
      , mergeMaybe UserBirthday
      , mergeMaybe UserTelephone
      , mergeMaybe UserMobile
      ]  

  delete oldUserId
  let oldUsrIdent = oldUser ^. _userIdent
      newUsrIdent = newUser ^. _userIdent
  when (oldUsrIdent /= newUsrIdent) $ audit $ TransactionUserIdentChanged oldUsrIdent newUsrIdent
  audit $ TransactionUserAssimilated newUserId oldUserId
  where
    tellWarning :: UserAssimilateExceptionReason -> ReaderT SqlBackend (WriterT (Set UserAssimilateException) Handler) ()
    tellWarning = lift . tellPoint . UserAssimilateException oldUserId newUserId

    tellError :: forall a. UserAssimilateExceptionReason -> ReaderT SqlBackend (WriterT (Set UserAssimilateException) Handler) a
    tellError = throwM . UserAssimilateException oldUserId newUserId



combineWith :: (PersistEntity val, PersistField typ1) =>
                     E.SqlExpr (Entity val)
                     -> E.SqlExpr (Entity val)
                     -> (E.SqlExpr (E.Value typ1) -> E.SqlExpr (E.Value typ1) -> E.SqlExpr (E.Value typ2))
                     -> EntityField val typ1
                     -> E.SqlExpr (E.Value typ2)
combineWith x y f pj = f (x E.^. pj) (y E.^. pj)