-- SPDX-FileCopyrightText: 2022-23 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 (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           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          }
  | 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 . 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]

          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
  -- 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 UserLdapPrimaryKey
      , mergeBy (<) UserAuthentication
      , 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)
