module Handler.Utils.Users
  ( computeUserAuthenticationDigest
  , Digest, SHA3_256
  , constEq
  , NameMatchQuality(..)
  , matchesName
  , GuessUserInfo(..)
  , guessUser
  , UserAssimilateException(..), UserAssimilateExceptionReason(..)
  , assimilateUser
  ) where

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

import Crypto.Hash (hashlazy)

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

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

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

import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E

import qualified Data.Conduit.Combinators as C

import qualified Data.MultiSet as MultiSet
import qualified Data.Map as Map
import qualified Data.Text as Text

import Jobs.Types(Job, JobChildren)


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, Typeable)
instance Binary GuessUserInfo

makeLenses_ ''GuessUserInfo

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

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 . E.from $ \user -> do
            E.where_ . E.or $ map (E.and . map (toSql user)) criteria
            when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit
            return user
      users <- retrieveUsers
      let users' = sortBy (flip closeness) users

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

          closeness :: Entity User -> Entity User -> Ordering
          closeness ul ur = maximum $ impureNonNull $ criteria <&> \term -> 
            let
              matches userField name = _entityVal . userField . to (`matchesName` name)
              comp True  userField guess = (term ^.. folded . _PLVariable . guess) <&> \name ->
                compare (       ul ^. userField `matches` name)
                        (       ur ^. userField `matches` name)
              comp False userField guess = (term ^.. folded . _PLNegated  . guess) <&> \name ->
                compare (Down $ ul ^. userField `matches` name)
                        (Down $ ur ^. userField `matches` name)
            in mconcat $ concat $
                 [ pure $ compare (Down $ matchesMatriculation ul) (Down $ matchesMatriculation ur)
                 ] <>
                 [ comp b userField guess
                 | (userField,guess) <- [(_userSurname    , _guessUserSurname)
                                        ,(_userFirstName  , _guessUserFirstName)
                                        ,(_userDisplayName, _guessUserDisplayName)
                                        ]
                  , b <- [True,False]
                  ]
          
          -- Assuming the input list is sorted in descending order by closeness:
          takeClosest []  = []
          takeClosest [x] = [x]
          takeClosest (x:x':xs)
            | EQ <- x `closeness` x' = x : takeClosest (x':xs)
            | otherwise = [x]

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

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

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


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

data UserAssimilateExceptionReason
  = UserAssimilateExternalExamResultDifferentResult (Entity ExternalExamResult) (Entity ExternalExamResult)
  | UserAssimilateCourseParticipantDifferentAllocation (Entity CourseParticipant) (Entity CourseParticipant)
  | UserAssimilateSubmissionGroupUserMultiple (Entity SubmissionGroupUser) (Entity SubmissionGroupUser)
  | UserAssimilateAllocationUserDifferentPriority (Entity AllocationUser) (Entity AllocationUser)
  | UserAssimilateAllocationDeregisterDuplicateCourse (Entity AllocationDeregister) (Entity AllocationDeregister)
  | 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
  deriving (Eq, Ord, Show, Generic, Typeable)

assimilateUser :: UserId -- ^ @newUserId@
               -> UserId -- ^ @oldUserId@
               -> DB (Set UserAssimilateException) -- ^ Warnings
-- ^ Move all relevant properties (submissions, corrections, grades, ...) from @oldUserId@ to @newUserId@
--
-- Fatal errors are thrown, non-fatal warnings are returned
assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
  E.insertSelectWithConflict
    UniqueCourseFavourite 
    (E.from $ \courseFavourite -> do
        E.where_ $ courseFavourite E.^. CourseFavouriteUser E.==. E.val oldUserId
        return $ CourseFavourite
          E.<#  E.val newUserId
          E.<&> (courseFavourite E.^. CourseFavouriteCourse)
          E.<&> (courseFavourite E.^. CourseFavouriteReason)
          E.<&> (courseFavourite E.^. CourseFavouriteLastVisit)
    )
    (\current excluded -> [ CourseFavouriteLastVisit E.=. E.max (current E.^. CourseFavouriteLastVisit) (excluded E.^. CourseFavouriteLastVisit) ])
  deleteWhere [ CourseFavouriteUser ==. oldUserId ]

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

  let getCourseApplications = selectSource [ CourseApplicationUser ==. oldUserId ] []
      upsertCourseApplication (Entity oldAppId oldApp) = do
        newApp <- selectList [CourseApplicationUser ==. newUserId, CourseApplicationCourse ==. courseApplicationCourse oldApp, CourseApplicationAllocation ==. courseApplicationAllocation oldApp] [LimitTo 1]
        case newApp of
          (_ : _) -> return ()
          [] -> do
            newAppId <- insert oldApp
              { courseApplicationUser = newUserId
              }
            updateWhere [ CourseApplicationFileApplication ==. oldAppId ] [ CourseApplicationFileApplication =. newAppId ]
        delete oldAppId
   in runConduit $ getCourseApplications .| C.mapM_ upsertCourseApplication

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

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

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

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

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

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

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

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

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

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

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

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

  do
    collision <- E.selectMaybe . E.from $ \(courseParticipantA `E.InnerJoin` courseParticipantB) -> do
      E.on $ courseParticipantA E.^. CourseParticipantCourse E.==. courseParticipantB E.^. CourseParticipantCourse
       E.&&. courseParticipantA E.^. CourseParticipantUser E.==. E.val oldUserId
       E.&&. courseParticipantB E.^. CourseParticipantUser E.==. E.val newUserId
      E.where_ . E.isJust $ courseParticipantA E.^. CourseParticipantAllocated
      E.where_ . E.isJust $ courseParticipantB E.^. CourseParticipantAllocated
      return (courseParticipantA, courseParticipantB)
    whenIsJust collision $ \(oldParticipant, newParticipant)
      -> tellError $ UserAssimilateCourseParticipantDifferentAllocation oldParticipant newParticipant
  E.insertSelectWithConflict
    UniqueParticipant
    (E.from $ \courseParticipant -> do
        E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val oldUserId
        return $ CourseParticipant
          E.<#  (courseParticipant E.^. CourseParticipantCourse)
          E.<&> E.val newUserId
          E.<&> (courseParticipant E.^. CourseParticipantRegistration)
          E.<&> (courseParticipant E.^. CourseParticipantAllocated)
          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)
       , CourseParticipantAllocated E.=. E.alt (current E.^. CourseParticipantAllocated) (excluded E.^. CourseParticipantAllocated)
       ]
    )
  deleteWhere [ CourseParticipantUser ==. oldUserId ]

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

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

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

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

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

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

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

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

  do
    collisions <- E.select . E.from $ \(allocationUserA `E.InnerJoin` allocationUserB) -> do
      E.on $ allocationUserA E.^. AllocationUserAllocation E.==. allocationUserB E.^. AllocationUserAllocation
       E.&&. allocationUserA E.^. AllocationUserUser E.==. E.val oldUserId
       E.&&. allocationUserB E.^. AllocationUserUser E.==. E.val newUserId
      E.where_ $ allocationUserA E.^. AllocationUserPriority E.!=. allocationUserB E.^. AllocationUserPriority
      return (allocationUserA, allocationUserB)
    forM_ collisions $ \(oldAllocUser, newAllocUser)
      -> tellWarning $ UserAssimilateAllocationUserDifferentPriority oldAllocUser newAllocUser
  E.insertSelectWithConflict
    UniqueAllocationUser
    (E.from $ \allocationUser -> do
        E.where_ $ allocationUser E.^. AllocationUserUser E.==. E.val oldUserId
        return $ AllocationUser
          E.<#  (allocationUser E.^. AllocationUserAllocation)
          E.<&> E.val newUserId
          E.<&> (allocationUser E.^. AllocationUserTotalCourses)
          E.<&> (allocationUser E.^. AllocationUserPriority)
    )
    (\current excluded -> [ AllocationUserTotalCourses E.=. E.max (current E.^. AllocationUserTotalCourses) (excluded E.^. AllocationUserTotalCourses) ])
  deleteWhere [ AllocationUserUser ==. oldUserId ]

  do
    collisions <- E.select . E.from $ \(allocationDeregisterA `E.InnerJoin` allocationDeregisterB) -> do
      E.on $ allocationDeregisterA E.^. AllocationDeregisterCourse E.==. allocationDeregisterB E.^. AllocationDeregisterCourse
       E.&&. allocationDeregisterA E.^. AllocationDeregisterUser E.==. E.val oldUserId
       E.&&. allocationDeregisterB E.^. AllocationDeregisterUser E.==. E.val newUserId
      return (allocationDeregisterA, allocationDeregisterB)
    forM_ collisions $ \(oldAllocationDeregister, newAllocationDeregister) ->
      tellWarning $ UserAssimilateAllocationDeregisterDuplicateCourse oldAllocationDeregister newAllocationDeregister
  updateWhere [ AllocationDeregisterUser ==. oldUserId ] [ AllocationDeregisterUser =. newUserId ]

  E.insertSelectWithConflict
    UniqueAllocationNotificationSetting
    (E.from $ \allocNotifySetting -> do
        E.where_ $ allocNotifySetting E.^. AllocationNotificationSettingUser E.==. E.val oldUserId
        return $ AllocationNotificationSetting
          E.<#  E.val newUserId
          E.<&> (allocNotifySetting E.^. AllocationNotificationSettingAllocation)
          E.<&> (allocNotifySetting E.^. AllocationNotificationSettingIsOptOut)
    )
    (\current excluded -> [ AllocationNotificationSettingIsOptOut E.=. (current E.^. AllocationNotificationSettingIsOptOut E.||. excluded E.^. AllocationNotificationSettingIsOptOut) ])
  deleteWhere [ AllocationNotificationSettingUser ==. oldUserId ]

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

  do
    collision <- E.selectMaybe . E.from $ \(examPartResultA `E.InnerJoin` examPartResultB) -> do
      E.on $ examPartResultA E.^. ExamPartResultExamPart E.==. examPartResultB E.^. ExamPartResultExamPart
       E.&&. examPartResultA E.^. ExamPartResultUser E.==. E.val oldUserId
       E.&&. examPartResultB E.^. ExamPartResultUser E.==. E.val newUserId
      E.where_ $ examPartResultA E.^. ExamPartResultResult E.!=. examPartResultB E.^. ExamPartResultResult
      return (examPartResultA, examPartResultB)
    whenIsJust collision $ \(oldExamPartResult, newExamPartResult)
      -> tellError $ UserAssimilateExamPartResultDifferentResult oldExamPartResult newExamPartResult
  E.insertSelectWithConflict
    UniqueExamPartResult
    (E.from $ \examPartResult -> do
        E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val oldUserId
        return $ ExamPartResult
          E.<#  (examPartResult E.^. ExamPartResultExamPart)
          E.<&> E.val newUserId
          E.<&> (examPartResult E.^. ExamPartResultResult)
          E.<&> (examPartResult E.^. ExamPartResultLastChanged)
    )
    (\current excluded -> [ ExamPartResultLastChanged E.=. E.max (current E.^. ExamPartResultLastChanged) (excluded E.^. ExamPartResultLastChanged) ])
  deleteWhere [ ExamPartResultUser ==. oldUserId ]
  
  do
    collision <- E.selectMaybe . E.from $ \(examBonusA `E.InnerJoin` examBonusB) -> do
      E.on $ examBonusA E.^. ExamBonusExam E.==. examBonusB E.^. ExamBonusExam
       E.&&. examBonusA E.^. ExamBonusUser E.==. E.val oldUserId
       E.&&. examBonusB E.^. ExamBonusUser E.==. E.val newUserId
      E.where_ $ examBonusA E.^. ExamBonusBonus E.!=. examBonusB E.^. ExamBonusBonus
      return (examBonusA, examBonusB)
    whenIsJust collision $ \(oldExamBonus, newExamBonus)
      -> tellError $ UserAssimilateExamBonusDifferentBonus oldExamBonus newExamBonus
  E.insertSelectWithConflict
    UniqueExamBonus
    (E.from $ \examBonus -> do
        E.where_ $ examBonus E.^. ExamBonusUser E.==. E.val oldUserId
        return $ ExamBonus
          E.<#  (examBonus E.^. ExamBonusExam)
          E.<&> E.val newUserId
          E.<&> (examBonus E.^. ExamBonusBonus)
          E.<&> (examBonus E.^. ExamBonusLastChanged)
    )
    (\current excluded -> [ ExamBonusLastChanged E.=. E.max (current E.^. ExamBonusLastChanged) (excluded E.^. ExamBonusLastChanged) ])
  deleteWhere [ ExamBonusUser ==. oldUserId ]
  
  let getExamResults = selectSource [ ExamResultUser ==. oldUserId ] []
      upsertExamResult oldEREnt@(Entity oldERId oldER) = do
        newER' <- getBy $ UniqueExamResult (examResultExam oldER) newUserId
        newERId <- case newER' of
          Just newEREnt@(Entity _ newER)
            | ((/=) `on` examResultResult) newER oldER
              -> tellError $ UserAssimilateExamResultDifferentResult oldEREnt newEREnt
          Just (Entity newERId newER) -> newERId <$ update newERId
            [ ExamResultLastChanged =. (max `on` examResultLastChanged) oldER newER
            ]
          Nothing -> insert oldER
            { examResultUser = newUserId
            }
        updateWhere [ ExamOfficeResultSyncedResult ==. oldERId ] [ ExamOfficeResultSyncedResult =. newERId ]
        delete oldERId
   in runConduit $ getExamResults .| C.mapM_ upsertExamResult

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

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

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

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

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

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

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

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

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

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

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

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

  delete oldUserId
  audit $ TransactionUserAssimilated newUserId oldUserId
  where
    tellWarning :: UserAssimilateExceptionReason -> ReaderT SqlBackend (WriterT (Set UserAssimilateException) Handler) ()
    tellWarning = lift . tellPoint . UserAssimilateException oldUserId newUserId

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