feat(users): assimilation

2020-11-02 09:58:01 +01:00 · 2020-11-02 09:58:01 +01:00 · ef51c6e7c3
commit ef51c6e7c3
parent 3ff2cf1fec
32 changed files with 796 additions and 48 deletions
--- a/frontend/src/app.sass
+++ b/frontend/src/app.sass
@ -723,6 +723,10 @@ section
 .uuid, .pseudonym, .ldap-primary-key, .email, .file-path, .metric-value, .metric-label
  font-family: var(--font-monospace)

+.shown
+  font-family: var(--font-monospace)
+  white-space: pre-wrap
+
 .token
  font-family: var(--font-monospace)
  white-space: pre-wrap
--- a/messages/uniworx/de-de-formal.msg
+++ b/messages/uniworx/de-de-formal.msg
@ -775,6 +775,12 @@ AccessRightsNotChanged: Berechtigungen wurden nicht verändert
 UserSystemFunctions: Systemweite Rollen
 UserSystemFunctionsSaved: Systemweite Rollen gespeichert
 UserSystemFunctionsNotChanged: Es wurden keine systemweiten Rollen angepasst
+UserAssimilateUser: Benutzer
+BtnUserAssimilate: Assimilieren
+AssimilateUserNotFound: E-Mail Adresse konnte keinem Benutzer zugeordnet werden
+AssimilateUserHaveError: Beim Assimilieren ist ein Fehler aufgetreten
+AssimilateUserHaveWarnings: Beim Assimilieren wurden Warnungen ausgegeben
+AssimilateUserSuccess: Benutzer erfolgreich assimiliert

 LecturersForN n@Int: #{pluralDE n "Dozent" "Dozenten"}

@ -2300,6 +2306,8 @@ UserDisplayEmail: Angezeigte E-Mail-Adresse
 UserDisplayEmailTip: Diese Adresse wird in öffentlich zugänglichen Teilen des Systems im Zusammenhang mit Ihrem Namen angezeigt. Benachrichtigungen und andere Kommunikation von Uni2work und Nutzern mit erweiterten Rechten erhalten sie stets, unabhängig von dieser Einstellung, an die in Ihren Persönlichen Daten hinterlegte primäre Adresse.
 UserDisplayEmailChangeSent displayEmail@UserEmail: Anweisungen zum Ändern der angezeigten E-Mail-Adresse wurden an „#{displayEmail}” versandt

+UserCreated: Account erstellt
+
 SchoolShort: Kürzel
 SchoolName: Name
 SchoolLdapOrganisations: Assoziierte LDAP-Fragmente
@ -2407,6 +2415,7 @@ AdminUserIdent: Identifikation
 AdminUserAuth: Authentifizierung
 AdminUserMatriculation: Matrikelnummer
 AdminUserSex: Geschlecht
+AdminUserAssimilate: Benutzer assimilieren
 AuthKindLDAP: Campus-Kennung
 AuthKindPWHash: Uni2work-Kennung
 UserAdded: Benutzer erfolgreich angelegt
--- a/messages/uniworx/en-eu.msg
+++ b/messages/uniworx/en-eu.msg
@ -771,6 +771,12 @@ AccessRightsNotChanged: Permissions left unchanged
 UserSystemFunctions: System wide roles
 UserSystemFunctionsSaved: Successfully saved system wide roles
 UserSystemFunctionsNotChanged: No system wide roles were changed
+UserAssimilateUser: User
+BtnUserAssimilate: Assimilate
+AssimilateUserNotFound: Email could not be resolved to an user
+AssimilateUserHaveError: An error occurred during assimilation
+AssimilateUserHaveWarnings: Warnings were ermitted during assimilation
+AssimilateUserSuccess: Successfully assimilated user

 LecturersForN n: #{pluralEN n "Lecturer" "Lecturers"}

@ -2300,6 +2306,8 @@ UserDisplayEmail: Display email
 UserDisplayEmailTip: This email address may be displayed publicly alongside your display name. Notifications and other communication from Uni2work or users with elevated permissions are always sent to your primary email address as specified under "personal information".
 UserDisplayEmailChangeSent displayEmail: Instructions to change your display email have been sent to “#{displayEmail}”.

+UserCreated: Account created
+
 SchoolShort: Shorthand
 SchoolName: Name
 SchoolLdapOrganisations: Associated LDAP fragments
@ -2407,6 +2415,7 @@ AdminUserIdent: Identification
 AdminUserAuth: Authentication
 AdminUserMatriculation: Matriculation
 AdminUserSex: Sex
+AdminUserAssimilate: Assimilate user
 AuthKindLDAP: Campus account
 AuthKindPWHash: Uni2work account
 UserAdded: Successfully added user
--- a/models/allocations.model
+++ b/models/allocations.model
@ -45,12 +45,14 @@ AllocationUser
    totalCourses        Natural          -- number of total allocated courses for this user must be <= than this number
    priority            AllocationPriority Maybe
    UniqueAllocationUser allocation user
+    deriving Eq Ord Show

 AllocationDeregister -- self-inflicted user-deregistrations from an allocated course
    user                UserId
    course              CourseId Maybe
    time                UTCTime
    reason              Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button)
+    deriving Eq Ord Show

 AllocationNotificationSetting
    user                UserId
--- a/models/courses.model
+++ b/models/courses.model
@ -60,6 +60,7 @@ CourseParticipant                      -- course enrolement
    allocated    AllocationId Maybe    -- participant was centrally allocated
    state        CourseParticipantState
    UniqueParticipant user course
+    deriving Eq Ord Show
 -- Replace the last two by the following, once an audit log is available
 -- CourseUserNote                 -- lecturers of a specific course may share a text note on each enrolled student
 --     course       CourseId
--- a/models/exams.model
+++ b/models/exams.model
@ -43,24 +43,28 @@ ExamRegistration
  occurrence ExamOccurrenceId Maybe
  time UTCTime default=now()
  UniqueExamRegistration exam user
+  deriving Eq Ord Show
 ExamPartResult
  examPart ExamPartId
  user UserId
  result ExamResultPoints
  lastChanged UTCTime default=now()
  UniqueExamPartResult examPart user
+  deriving Eq Ord Show
 ExamBonus
  exam ExamId
  user UserId
  bonus Points
  lastChanged UTCTime default=now()
  UniqueExamBonus exam user
+  deriving Eq Ord Show
 ExamResult
  exam ExamId
  user UserId
  result ExamResultPassedGrade
  lastChanged UTCTime default=now()
  UniqueExamResult exam user
+  deriving Eq Ord Show
 ExamCorrector
  exam ExamId
  user UserId
--- a/models/external-exams.model
+++ b/models/external-exams.model
@ -13,6 +13,7 @@ ExternalExamResult
  time UTCTime
  lastChanged UTCTime
  UniqueExternalExamResult exam user
+  deriving Eq Ord Show
 ExternalExamStaff
  user UserId
  exam ExternalExamId
--- a/models/submissions.model
+++ b/models/submissions.model
@ -31,3 +31,4 @@ SubmissionGroupUser              -- Registered submission groups, just for check
    submissionGroup     SubmissionGroupId
    user                UserId
    UniqueSubmissionGroupUser submissionGroup user
+    deriving Eq Ord Show
--- a/models/tutorials.model
+++ b/models/tutorials.model
@ -20,4 +20,5 @@ Tutor
 TutorialParticipant
    tutorial    TutorialId
    user        UserId
-    UniqueTutorialParticipant tutorial user
+    UniqueTutorialParticipant tutorial user
+    deriving Eq Ord Show
--- a/src/Audit/Types.hs
+++ b/src/Audit/Types.hs
@ -170,6 +170,11 @@ data Transaction
    , transactionUser         :: UserId
    }

+  | TransactionUserAssimilated
+    { transactionUser            :: UserId
+    , transactionAssimilatedUser :: UserId
+    }
+  
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

 deriveJSON defaultOptions
--- a/src/Database/Esqueleto/Utils.hs
+++ b/src/Database/Esqueleto/Utils.hs
@ -4,7 +4,7 @@
 module Database.Esqueleto.Utils
  ( true, false
  , justVal, justValList
-  , isJust
+  , isJust, alt
  , isInfixOf, hasInfix
  , strConcat, substring
  , or, and
@ -30,6 +30,7 @@ module Database.Esqueleto.Utils
  , selectCountRows
  , selectMaybe
  , day, diffDays
+  , exprLift
  , module Database.Esqueleto.Utils.TH
  ) where

@ -83,6 +84,9 @@ justValList = E.valList . map Just
 isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
 isJust = E.not_ . E.isNothing

+alt :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value (Maybe typ))
+alt a b = E.case_ [(isJust a, a), (isJust b, b)] b
+
 infix 4 `isInfixOf`, `hasInfix`

 -- | Check if the first string is contained in the text derived from the second argument
@ -388,3 +392,29 @@ infixl 6 `diffDays`
 diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int)
 -- ^ PostgreSQL is weird.
 diffDays a b = E.veryUnsafeCoerceSqlExprValue $ a E.-. b
+
+
+class ExprLift e a | e -> a where
+  exprLift :: a -> e
+
+instance PersistField a => ExprLift (E.SqlExpr (E.Value a)) a where
+  exprLift = E.val
+
+instance (PersistField a, PersistField b, Finite a) => ExprLift (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b)) (a -> b) where
+  exprLift f v = E.case_
+    [ E.when_ (v E.==. E.val v') E.then_ (E.val $ f v')
+    | v' <- universeF
+    ]
+    (E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ()))))
+  
+instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2) => ExprLift (E.SqlExpr (E.Value a1) -> E.SqlExpr (E.Value a2) -> E.SqlExpr (E.Value b)) (a1 -> a2 -> b) where
+  exprLift f v1 v2 = E.case_
+    [ E.when_ (       v1 E.==. E.val v1'
+                E.&&. v2 E.==. E.val v2'
+              )
+      E.then_ (E.val $ f v1' v2')
+    | v1' <- universeF
+    , v2' <- universeF
+    ]
+    (E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ()))))
+ 
--- a/src/Foundation/Authorization.hs
+++ b/src/Foundation/Authorization.hs
@ -40,7 +40,6 @@ import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E

 import Control.Monad.Error.Class (MonadError(..))
-import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Monad.Memo.Class (MonadMemo(..), for4)

 import Data.Aeson.Lens hiding (_Value, key)
--- a/src/Foundation/Instances.hs
+++ b/src/Foundation/Instances.hs
@ -37,7 +37,6 @@ import Foundation.DB

 import Network.Wai.Parse (lbsBackEnd)

-import Control.Monad.Writer.Class (MonadWriter(..))
 import UnliftIO.Pool (withResource)


--- a/src/Foundation/Yesod/Auth.hs
+++ b/src/Foundation/Yesod/Auth.hs
@ -40,7 +40,6 @@ import qualified Data.Binary as Binary
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E

-import Control.Monad.Writer.Class (MonadWriter(..))
 import Crypto.Hash.Conduit (sinkHash)


--- a/src/Foundation/Yesod/Middleware.hs
+++ b/src/Foundation/Yesod/Middleware.hs
@ -15,9 +15,6 @@ import qualified Network.Wai as W
 import qualified Data.Aeson as JSON
 import qualified Data.CaseInsensitive as CI
  
-import Control.Monad.Reader.Class (MonadReader(..))
-import Control.Monad.Writer.Class (MonadWriter(..))
-
 import Yesod.Core.Types (GHState(..), HandlerData(..), RunHandlerEnv(rheSite, rheChild))


--- a/src/Handler/Profile.hs
+++ b/src/Handler/Profile.hs
@ -476,8 +476,6 @@ makeProfileData (Entity uid User{..}) = do
      examTable        = i18n MsgPersonalInfoExamAchievementsWip
      ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
      tutorialTable    = i18n MsgPersonalInfoTutorialsWip
-  lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication
-  lastLdapSync <- traverse (formatTime SelFormatDateTime) userLastLdapSynchronisation

  cID <- encrypt uid
  mCRoute <- getCurrentRoute
--- a/src/Handler/Users.hs
+++ b/src/Handler/Users.hs
@ -53,18 +53,16 @@ hijackUserForm csrf = do

 data UserAction = UserLdapSync | UserHijack
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+  deriving anyclass (Universe, Finite)

-instance Universe UserAction
-instance Finite UserAction
 nullaryPathPiece ''UserAction $ camelToPathPiece' 1
 embedRenderMessage ''UniWorX ''UserAction id


 data AllUsersAction = AllUsersLdapSync
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+  deriving anyclass (Universe, Finite)

-instance Universe AllUsersAction
-instance Finite AllUsersAction
 nullaryPathPiece ''AllUsersAction $ camelToPathPiece' 1
 embedRenderMessage ''UniWorX ''AllUsersAction id

@ -277,6 +275,19 @@ instance Button UniWorX ButtonAuthMode where
  btnClasses _ = [BCIsButton]


+data UserAssimilateButton = BtnUserAssimilate
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
+  deriving anyclass (Universe, Finite)
+
+instance Button UniWorX UserAssimilateButton where
+  btnClasses _ = [BCIsButton, BCPrimary]
+
+nullaryPathPiece ''UserAssimilateButton $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''UserAssimilateButton id
+
+
+  
+
 getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html
 getAdminUserR = postAdminUserR
 postAdminUserR uuid = do
@ -393,9 +404,33 @@ postAdminUserR uuid = do
            | otherwise
              -> addMessageI Info MsgUserSystemFunctionsNotChanged
          redirect $ AdminUserR uuid
-    ((rightsResult, rightsFormWidget),rightsFormEnctype) <- runFormPost userRightsForm
-    ((authResult, authFormWidget),authFormEnctype) <- runFormPost userAuthenticationForm
-    ((systemFunctionsResult, systemFunctionsWidget),systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm'
+    let assimilateForm' = renderAForm FormStandard $
+          areq (checkMap (first $ const MsgAssimilateUserNotFound) Right $ userField False Nothing) (fslI MsgUserAssimilateUser) Nothing
+        assimilateAction oldUserId = do
+          res <- try . runDB . setSerializable $ assimilateUser uid oldUserId
+          case res of
+            Left (err :: UserAssimilateException) ->
+              addMessageModal Error (i18n MsgAssimilateUserHaveError) $ Right
+                [whamlet|
+                  <div .shown>
+                    #{tshow err}
+                |]
+            Right warnings -> do
+              unless (null warnings) $
+                addMessageModal Warning (i18n MsgAssimilateUserHaveWarnings) $ Right
+                  [whamlet|
+                    $newline never
+                    <ul>
+                      $forall warning <- warnings
+                        <li .shown>
+                          #{tshow warning}
+                  |]
+              addMessageI Success MsgAssimilateUserSuccess
+              redirect $ AdminUserR uuid
+    ((rightsResult, rightsFormWidget), rightsFormEnctype) <- runFormPost . identifyForm FIDUserRights $ userRightsForm
+    ((authResult, authFormWidget), authFormEnctype) <- runFormPost . identifyForm FIDUserAuthentication $ userAuthenticationForm
+    ((systemFunctionsResult, systemFunctionsWidget), systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm'
+    ((assimilateFormResult, assimilateFormWidget), assimilateFormEnctype) <- runFormPost $ identifyForm FIDUserAssimilate assimilateForm'
    let rightsForm = wrapForm rightsFormWidget def
          { formAction = Just . SomeRoute $ AdminUserR uuid
          , formEncoding = rightsFormEnctype
@ -409,9 +444,14 @@ postAdminUserR uuid = do
          { formAction = Just . SomeRoute $ AdminUserR uuid
          , formEncoding = systemFunctionsEnctype
          }
+        assimilateForm = wrapForm' BtnUserAssimilate assimilateFormWidget def
+          { formAction = Just . SomeRoute $ AdminUserR uuid
+          , formEncoding = assimilateFormEnctype
+          }
    formResult rightsResult userRightsAction
    formResult authResult userAuthenticationAction
    formResult systemFunctionsResult userSystemFunctionsAction
+    formResult assimilateFormResult assimilateAction
    let heading =
          [whamlet|_{MsgAdminUserHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|]
    -- Delete Button needed in data-delete
@ -423,7 +463,7 @@ postAdminUserR uuid = do
          }
    userDataWidget <- runDB $ makeProfileData $ Entity uid user
    siteLayout heading $ do
-      let deleteWidget   = $(i18nWidgetFile "data-delete")
+      let _deleteWidget   = $(i18nWidgetFile "data-delete")
      $(widgetFile "adminUser")


--- a/src/Handler/Utils/Form.hs
+++ b/src/Handler/Utils/Form.hs
@ -48,7 +48,6 @@ import qualified Data.Vector as Vector

 import qualified Data.HashMap.Lazy as HashMap

-import Control.Monad.Writer.Class
 import Control.Monad.Error.Class (MonadError(..))

 import Data.Aeson (eitherDecodeStrict')
--- a/src/Handler/Utils/Form/MassInput.hs
+++ b/src/Handler/Utils/Form/MassInput.hs
@ -31,8 +31,6 @@ import Data.Map ((!))
 import qualified Data.Map as Map
 import qualified Data.Foldable as Fold

-import Control.Monad.Reader.Class (MonadReader(local))
-
 import Text.Hamlet (hamletFile)

 import Algebra.Lattice.Ordered (Ordered(..))
--- a/src/Handler/Utils/Table/Cells.hs
+++ b/src/Handler/Utils/Table/Cells.hs
@ -2,8 +2,6 @@ module Handler.Utils.Table.Cells where

 import Import hiding (link)

-import Control.Monad.Writer.Class (MonadWriter(..))
-
 import Text.Blaze (ToMarkup(..))

 import Handler.Utils.Table.Pagination
--- a/src/Handler/Utils/Users.hs
+++ b/src/Handler/Utils/Users.hs
@ -6,6 +6,8 @@ module Handler.Utils.Users
  , matchesName
  , GuessUserInfo(..)
  , guessUser
+  , UserAssimilateException(..), UserAssimilateExceptionReason(..)
+  , assimilateUser
  ) where

 import Import
@ -19,17 +21,23 @@ 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 qualified Database.Esqueleto 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
@ -172,3 +180,604 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> 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)
+  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 (return ()) $ 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 [ SentNotificationUser ==. oldUserId ] [ SentNotificationUser =. 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
+
+  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
--- a/src/Import/NoModel.hs
+++ b/src/Import/NoModel.hs
@ -88,17 +88,20 @@ import Control.Monad.Random.Class as Import (MonadRandom(..))
 import Control.Monad.Morph as Import
 import Control.Monad.Trans.Resource as Import (ReleaseKey)
 import Control.Monad.Trans.Reader as Import
-  ( reader, runReader, mapReader, withReader
+  ( runReader, mapReader, withReader
  , mapReaderT, withReaderT
  )
+import Control.Monad.Reader.Class as Import (MonadReader(..))
 import Control.Monad.Trans.State as Import
-  ( state, State, runState, mapState, withState
+  ( State, runState, mapState, withState
  , StateT(..), mapStateT, withStateT
  )
+import Control.Monad.State.Class as Import (MonadState(state))
 import Control.Monad.Trans.Writer.Lazy as Import
-  ( writer, Writer, runWriter, mapWriter, execWriter
+  ( Writer, runWriter, mapWriter, execWriter
  , WriterT(..), mapWriterT, execWriterT
  )
+import Control.Monad.Writer.Class as Import (MonadWriter(..))
 import Control.Monad.Trans.Except as Import
  ( except, Except, runExcept, mapExcept
  , ExceptT(..), runExceptT, mapExceptT, throwE
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@ -32,7 +32,6 @@ import Data.Map.Strict ((!))
 import Control.Monad.Trans.RWS.Lazy (RWST, mapRWST, evalRWST)
 import Control.Monad.Trans.State.Strict (StateT, evalStateT)
 import qualified Control.Monad.State.Class as State
-import Control.Monad.Writer.Class (MonadWriter(..))
 import Control.Monad.Trans.Cont (ContT(..), callCC)
 import Control.Monad.Random.Lazy (evalRandTIO, mapRandT)
 import Control.Monad.Logger
--- a/src/Jobs/Crontab.hs
+++ b/src/Jobs/Crontab.hs
@ -17,8 +17,6 @@ import Data.Time.Clock.POSIX

 import Handler.Utils.DateTime

-import Control.Monad.Writer.Class (MonadWriter(..))
-
 import qualified Data.Conduit.List as C

 import qualified Database.Esqueleto as E
--- a/src/Jobs/Queue.hs
+++ b/src/Jobs/Queue.hs
@ -13,8 +13,6 @@ import Import hiding ((<>))

 import Jobs.Types

-import Control.Monad.Writer.Class (MonadWriter(..))
-
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.List.NonEmpty as NonEmpty
--- a/src/Jobs/Types.hs
+++ b/src/Jobs/Types.hs
@ -1,8 +1,9 @@
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}

 module Jobs.Types
  ( Job(..), Notification(..)
+  , JobChildren
  , classifyJob
  , JobCtl(..)
  , classifyJobCtl
@ -42,6 +43,8 @@ import Cron (CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone)
 import System.Clock (getTime, Clock(Monotonic), TimeSpec)
 import GHC.Conc (unsafeIOToSTM)

+import Data.Generics.Product.Types (Children, ChGeneric)
+

 data Job
  = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
@ -144,6 +147,24 @@ deriveJSON defaultOptions
  , sumEncoding = TaggedObject "notification" "data"
  } ''Notification

+
+data JobChildren
+type instance Children JobChildren a = ChildrenJobChildren a
+type family ChildrenJobChildren a where
+  ChildrenJobChildren ByteString = '[]
+  ChildrenJobChildren Html = '[]
+  ChildrenJobChildren Day = '[]
+  ChildrenJobChildren DiffTime = '[]
+  ChildrenJobChildren (SelDateTimeFormat -> DateTimeFormat) = '[]
+  ChildrenJobChildren Natural = '[]
+  ChildrenJobChildren UUID = '[]
+  ChildrenJobChildren (Key a) = '[]
+  ChildrenJobChildren (CI a) = '[]
+  ChildrenJobChildren (Set a) = '[]
+
+  ChildrenJobChildren a = Children ChGeneric a
+  
+
 classifyJob :: Job -> String
 classifyJob job = unpack tag
  where
--- a/src/Model/Types/Sheet.hs
+++ b/src/Model/Types/Sheet.hs
@ -302,16 +302,12 @@ instance Monoid Load where

 data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
+  deriving anyclass (Universe, Finite, Hashable)

 deriveJSON defaultOptions
  { constructorTagModifier = fromJust . stripPrefix "Corrector"
  } ''CorrectorState

-instance Universe CorrectorState
-instance Finite CorrectorState
-
-instance Hashable CorrectorState
-
 nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)

 derivePersistField "CorrectorState"
--- a/src/Utils.hs
+++ b/src/Utils.hs
@ -810,7 +810,7 @@ and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool
 and2M ma mb = ifM ma mb (return False)
 or2M ma = ifM ma (return True)

-andM, orM :: (MonoFoldable mono, Element mono ~ (m Bool), Monad m) => mono -> m Bool
+andM, orM :: (MonoFoldable mono, Element mono ~ m Bool, Monad m) => mono -> m Bool
 andM = ofoldl' and2M (return True)
 orM = ofoldl' or2M (return False)

@ -875,9 +875,16 @@ diffTimeout timeoutLength timeoutRes act = fromMaybe timeoutRes <$> timeout time
      = let (MkFixed micro :: Micro) = realToFrac timeoutLength
         in fromInteger micro

+------------
+-- Writer --
+------------
+
 tellM :: (MonadTrans t, MonadWriter x (t m), Monad m) => m x -> t m ()
 tellM = tell <=< lift

+tellPoint :: (MonadWriter mono m, MonoPointed mono) => Element mono -> m ()
+tellPoint = tell . opoint
+
 -------------
 -- Conduit --
 -------------
--- a/src/Utils/Allocation.hs
+++ b/src/Utils/Allocation.hs
@ -16,7 +16,6 @@ import qualified Data.Array.MArray as MArr
 import System.Random (RandomGen)
 import Control.Monad.Trans.Random.Strict (evalRandT, RandT)
 import Control.Monad.Trans.State.Strict (StateT, modify', get, gets, evalStateT)
-import Control.Monad.Writer (tell)

 import Control.Monad.ST

--- a/src/Utils/Form.hs
+++ b/src/Utils/Form.hs
@ -223,7 +223,7 @@ data FormIdentifier
  | FIDUserDelete
  | FIDCommunication
  | FIDAssignSubmissions
-  | FIDUserAuthMode
+  | FIDUserAuthMode | FIDUserAssimilate | FIDUserRights | FIDUserAuthentication
  | FIDAllUsersAction
  | FIDLanguage
  | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID
--- a/templates/adminUser.hamlet
+++ b/templates/adminUser.hamlet
@ -11,7 +11,11 @@ $newline never
    _{MsgAdminUserAuthHeading}
  ^{authForm}
 <section>
-  <p>
-    _{MsgUserAccountDeleteWarning}
-  <p>
-    ^{modal "Benutzer löschen" (Right deleteWidget)}
+  <h3>
+    _{MsgAdminUserAssimilate}
+  ^{assimilateForm}
+$# <section>
+$#  <p>
+$#    _{MsgUserAccountDeleteWarning}
+$#  <p>
+$#    ^{modal "Benutzer löschen" (Right deleteWidget)}
--- a/templates/profileData.hamlet
+++ b/templates/profileData.hamlet
@ -5,6 +5,10 @@ $newline never
        _{MsgIdent}
      <dd .deflist__dd .email>
        #{userIdent}
+      <dt .deflist__dt>
+        _{MsgAuthMode}
+      <dd .deflist__dd>
+        _{userAuthentication}
      <dt .deflist__dt>
        _{MsgName}
      <dd .deflist__dd>
@ -18,19 +22,28 @@ $newline never
        _{MsgEMail}
      <dd .deflist__dd>
        #{mailtoHtml userEmail}
+      $if userEmail /= userDisplayEmail
+        <dt .deflist__dt>
+          _{MsgUserDisplayEmail}
+        <dd .deflist__dd .email>
+          #{userDisplayEmail}
      $if showAdminInfo
+        <dt .deflist__dt>
+          _{MsgUserCreated}
+        <dd .deflist__dd>
+          ^{formatTimeW SelFormatDateTime userCreated}
        <dt .deflist__dt>
          _{MsgLastLogin}
        <dd .deflist__dd>
-          $maybe llogin <- lastLogin
-            #{llogin}
+          $maybe llogin <- userLastAuthentication
+            ^{formatTimeW SelFormatDateTime llogin}
          $nothing
            _{MsgNever}
        <dt .deflist__dt>
          _{MsgProfileLastLdapSynchronisation}
        <dd .deflist__dd>
-          $maybe lsync <- lastLdapSync
-            #{lsync}
+          $maybe lsync <- userLastLdapSynchronisation
+            ^{formatTimeW SelFormatDateTime lsync}
          $nothing
            _{MsgNever}
        $maybe pKey <- userLdapPrimaryKey
@ -38,6 +51,13 @@ $newline never
            _{MsgProfileLdapPrimaryKey}
          <dd .deflist__dd .ldap-primary-key>
            #{pKey}
+        <dt .deflist__dt>
+          _{MsgTokensLastReset}
+        <dd .deflist__dd>
+          $maybe lastInvalidated <- userTokensIssuedAfter
+            ^{formatTimeW SelFormatDateTime lastInvalidated}
+          $nothing
+            _{MsgNever}
    $forall (function, schools) <- Map.toList functions
      <dt .deflist__dt>_{function}
      <dd .deflist__dd>