feat(users): assimilation

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

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

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

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

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

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

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

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

models/tutorials.model

@@ -21,3 +21,4 @@ TutorialParticipant
     tutorial    TutorialId
     user        UserId
     UniqueTutorialParticipant tutorial user
+    deriving Eq Ord Show

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

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 ()))))
+ 

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)

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)
 
 

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)
 
 

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

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

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
+    let assimilateForm' = renderAForm FormStandard $
-    ((authResult, authFormWidget),authFormEnctype) <- runFormPost userAuthenticationForm
+          areq (checkMap (first $ const MsgAssimilateUserNotFound) Right $ userField False Nothing) (fslI MsgUserAssimilateUser) Nothing
-    ((systemFunctionsResult, systemFunctionsWidget),systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm'
+        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")
 
 

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')

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(..))

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

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

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

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

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

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

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

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"

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 --
 -------------

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
 

src/Utils/Form.hs

@@ -223,7 +223,7 @@ data FormIdentifier
   | FIDUserDelete
   | FIDCommunication
   | FIDAssignSubmissions
-  | FIDUserAuthMode
+  | FIDUserAuthMode | FIDUserAssimilate | FIDUserRights | FIDUserAuthentication
   | FIDAllUsersAction
   | FIDLanguage
   | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID

templates/adminUser.hamlet

@@ -11,7 +11,11 @@ $newline never
     _{MsgAdminUserAuthHeading}
   ^{authForm}
 <section>
-  <p>
+  <h3>
-    _{MsgUserAccountDeleteWarning}
+    _{MsgAdminUserAssimilate}
-  <p>
+  ^{assimilateForm}
-    ^{modal "Benutzer löschen" (Right deleteWidget)}
+$# <section>
+$#  <p>
+$#    _{MsgUserAccountDeleteWarning}
+$#  <p>
+$#    ^{modal "Benutzer löschen" (Right deleteWidget)}

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
+          $maybe llogin <- userLastAuthentication
-            #{llogin}
+            ^{formatTimeW SelFormatDateTime llogin}
           $nothing
             _{MsgNever}
         <dt .deflist__dt>
           _{MsgProfileLastLdapSynchronisation}
         <dd .deflist__dd>
-          $maybe lsync <- lastLdapSync
+          $maybe lsync <- userLastLdapSynchronisation
-            #{lsync}
+            ^{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>