Merge branch 'master' into workflows

2020-11-05 12:19:18 +01:00 · 2020-11-05 12:19:18 +01:00 · 03fec7752b
commit 03fec7752b
parent 1e3873485e afb59f46f7
66 changed files with 1450 additions and 244 deletions
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@ -2,6 +2,59 @@

 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.

+### [21.0.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.2...v21.0.3) (2020-11-05)
+
+
+### Bug Fixes
+
+* **mails:** prevent emails being resent to due archiving errors ([8cf39dc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/8cf39dcbe68cefcc50691ae8a7194315d18420d6))
+
+### [21.0.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.1...v21.0.2) (2020-11-04)
+
+
+### Bug Fixes
+
+* build ([fa61b46](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fa61b46d308753354623df17241b5312f324321e))
+
+### [21.0.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v21.0.0...v21.0.1) (2020-11-04)
+
+
+### Bug Fixes
+
+* **mail:** better separation of sender/from/envelope-from ([0dbf4f8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0dbf4f8bde99431cafeec954dc164a73227154ad))
+
+## [21.0.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.14.0...v21.0.0) (2020-11-04)
+
+
+### ⚠ BREAKING CHANGES
+
+* **course:** AccessPredicates now take continuation
+
+### Features
+
+* **course:** warning if re-registration is not possible ([4451cee](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/4451ceedf7bde0da7f3bb4c0818b79d7c5df1cbd)), closes [#646](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/646)
+* **mail:** archive all sent mail & better verp ([1666081](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1666081fea0eec0bf5440a100db0e8cc69be8295))
+
+
+### Bug Fixes
+
+* **course:** don't delete applications when deregistering ([b666408](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b6664089f75dcb3b2c89dbd2941c064e8aa86404)), closes [#648](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/648)
+* **courses:** better defaults for application/registration ([1c2c8fe](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1c2c8fe3d99176e079d0473dd45039b44128c491))
+
+## [20.14.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.13.0...v20.14.0) (2020-11-02)
+
+
+### Features
+
+* **users:** assimilation ([ef51c6e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ef51c6e7c34effa691125e4313876d95feda96af))
+
+
+### Bug Fixes
+
+* **exam-users:** prevent exam results without registration via csv ([1c6ac4c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1c6ac4cb4a52ac7e69e615e0e3ff96432b173962))
+* work around conduit-bug releasing fh to early ([3ff2cf1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3ff2cf1fec1bf582fe1d5e1f6ee08dcc85d6bc00))
+* **exams:** error messages for foreign key constraint violations ([ca29a66](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ca29a66330a977a1f28bbdbe9a733aef10371427))
+
 ## [20.13.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.12.1...v20.13.0) (2020-10-20)


--- a/config/settings.yml
+++ b/config/settings.yml
@ -18,10 +18,11 @@ mail-from:
 mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
 mail-verp:
  separator:    "_env:VERP_SEPARATOR:+"
-  at-replacement: "_env:VERP_AT_REPLACEMENT:="
+  prefix:       "_env:VERP_PREFIX:bounce"
 mail-support:
  name:         "_env:MAILSUPPORT_NAME:"
  email:        "_env:MAILSUPPORT:uni2work@ifi.lmu.de"
+mail-retain-sent: 31470547

 job-workers:        "_env:JOB_WORKERS:10"
 job-flush-interval: "_env:JOB_FLUSH:30"
--- 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, .workflow-payload--text
  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
@ -212,7 +212,9 @@ CourseApplicationInstructionsTip: Wird den Studierenden angezeigt, wenn diese si
 CourseApplicationTemplate: Bewerbungsvorlagen
 CourseApplicationTemplateTip: Werden den Studierenden zum download angeboten, wenn diese sich für Ihre Veranstaltung bewerben bzw. bei dieser anmelden
 CourseApplicationsText: Text-Bewerbungen
-CourseApplicationsTextTip: Sollen die Studierenden Bewerbungen (ggf. zusätzlich zu abgegebenen Dateien) als unformatierten Text einreichen?
+CourseApplicationsTextTip: Sollen die Studierenden bei Ihrer Bewerbung bzw. Anmeldung (ggf. zusätzlich zu abgegebenen Dateien) auch unformatierten Text einreichen können?
+CourseApplicationsFiles: Bewerbungsdateien
+CourseApplicationsFilesTip: Sollen die Studierenden bei Ihrer Bewerbung bzw. Anmeldung (ggf. zusätzlich zu unformatiertem Text) auch Dateien abgeben können?
 CourseApplicationRatingsVisible: Feedback für Bewerbungen
 CourseApplicationRatingsVisibleTip: Sollen Bewertung und Kommentar der Bewerbungen den Studierenden nach Ende der Bewertungs-Phase angezeigt werden?
 CourseApplicationRequired: Bewerbungsverfahren
@ -225,6 +227,8 @@ CourseApplicationTemplateArchiveName tid@TermId ssh@SchoolId csh@CourseShorthand
 CourseApplication: Bewerbung
 CourseApplicationIsParticipant: Kursteilnehmer

+CourseApplicationInstructionsRecommended: Studierende können bei ihrer Anmeldung/Bewerbung nach aktuellen Einstellungen Texte bzw. Dateien abgeben. Es wurden jedoch keine Anweisungen zur Bewerbung oder Vorlage-Dateien hinterlegt. Sie sollten entweder keine Texte bzw. Dateien verlangen oder über Anweisungen bzw. Vorlagen klarstellen, was Sie von den Studierenden erwarten.
+
 CourseApplicationExists: Sie haben sich bereits für diesen Kurs beworben
 CourseApplicationInvalidAction: Angegebene Aktion kann nicht durchgeführt werden
 CourseApplicationCreated csh@CourseShorthand: Erfolgreich zu #{csh} beworben
@ -254,6 +258,8 @@ CourseRegistrationFilesNeedReupload: Dateien zur Anmeldung müssen neu hochgelad
 CourseApplicationDeleteToEdit: Um Ihre Bewerbung zu editieren müssen Sie sie zunächst zurückziehen und sich erneut bewerben.
 CourseRegistrationDeleteToEdit: Um Ihre Anmeldungsdaten zu editieren müssen Sie sich zunächst ab- und dann erneut anmelden.

+CourseDeregistrationNoReRegistration: Wenn Sie sich jetzt vom Kurs abmelden, können Sie sich nicht wieder selbstständig anmelden.
+
 CourseLoginToApply: Um sich zum Kurz zu bewerben müssen Sie sich zunächst in Uni2work anmelden
 CourseLoginToRegister: Um sich zum Kurs anzumelden müssen Sie zunächst in Uni2work anmelden

@ -787,6 +793,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"}

@ -2023,6 +2035,7 @@ ExamUsersResultsReset count@Int64: Prüfungsergebnis für #{show count} Teilnehm
 ExamUsersPartResultsSet count@Int64: Teilprüfungsergebnis für #{show count} Teilnehmer angepasst
 ExamUsersBonusSet count@Int64: Bonuspunkte für #{show count} Teilnehmer angepasst
 ExamUsersResultSet count@Int64: Prüfungsergebnis für #{show count} Teilnehmer angepasst
+ExamUsersExamDataRequiresRegistration: Wenn Prüfungsbezogene Daten (Teil-/Ergebnis, Termin/Raum, Bonus) gesetzt bzw. angepasst werden sollen, muss der jeweilige Teilnehmer zur Prüfung angemeldet sein bzw. werden.
 CourseUserTutorialsDeregistered count@Int64: Teilnehmer von #{show count} #{pluralDE count "Tutorium" "Tutorien"} abgemeldet
 CourseUserNoTutorialsDeregistered: Teilnehmer ist zu keinem der gewählten Tutorien angemeldet
 CourseUserExamsDeregistered count@Int64: Teilnehmer von #{show count} #{pluralDE count "Prüfung" "Prüfungen"} abgemeldet
@ -2348,6 +2361,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
@ -2455,6 +2470,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
@ -212,7 +212,9 @@ CourseApplicationInstructionsTip: Will be shown to students if they decide to ap
 CourseApplicationTemplate: Application template
 CourseApplicationTemplateTip: Students can download this template if they decide to apply for this course
 CourseApplicationsText: Text application
-CourseApplicationsTextTip: Should students submit a plaintext application (in addition to submitted files if applicable)?
+CourseApplicationsTextTip: Should students submit plaintext with their application/registration (in addition to submitted files if applicable)?
+CourseApplicationsFiles: Application files
+CourseApplicationsFilesTip: Should students submit files with their application/registration (in addition to plaintext if applicable)?
 CourseApplicationRatingsVisible: Feedback to applications
 CourseApplicationRatingsVisibleTip: Should students be allowed to view rating and comments on their application after the rating period?
 CourseApplicationRequired: Applications required
@ -225,6 +227,8 @@ CourseApplicationTemplateArchiveName tid ssh csh: #{foldCase (termToText (unTerm
 CourseApplication: Application
 CourseApplicationIsParticipant: Course participant

+CourseApplicationInstructionsRecommended: Students can, as per the current course settings, submit files and/or texts with their applications/registrations. There are, however, no instructions for application or template files. You should either not require files/texts or clarify through instructions or templates what is expected of the students.
+
 CourseApplicationExists: You already applied for this course
 CourseApplicationInvalidAction: Invalid action
 CourseApplicationCreated csh: Successfully applied for #{csh}
@ -254,6 +258,8 @@ CourseRegistrationFilesNeedReupload: Registration files need to be reuploaded ev
 CourseApplicationDeleteToEdit: You need to withdraw your application and reapply to edit your application.
 CourseRegistrationDeleteToEdit: You need to deregister and reregister to edit your registration.

+CourseDeregistrationNoReRegistration: If you deregister from the course now, you will not be able to re-register yourself.
+
 CourseLoginToApply: You need to login to Uni2work before you can apply for this course.
 CourseLoginToRegister: Your need to login to Uni2work before you can register for this course.

@ -772,6 +778,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"}

@ -1982,6 +1994,7 @@ ExamUsersResultsReset count: Successfully reset result for #{show count} #{plura
 ExamUsersPartResultsSet count: Successfully modified exam part result for #{show count} #{pluralEN count "participant" "participants"}
 ExamUsersBonusSet count: Successfully modified exam bonus for #{show count} #{pluralEN count "participant" "participants"}
 ExamUsersResultSet count: Sucessfully modified exam result for #{show count} #{pluralEN count "participant" "participants"}
+ExamUsersExamDataRequiresRegistration: If exam data (part-/result, occurrence/room, bonus) is to be modified/set, the relenvant participant needs to be registered for the exam.
 CourseUserTutorialsDeregistered count: Sucessfully deregistered participant from #{show count} #{pluralEN count "tutorial" "tutorials"}
 CourseUserNoTutorialsDeregistered: Participant is not registered for any of the selected tutorials
 CourseUserExamsDeregistered count: Successfully deregistered participant from #{show count} #{pluralEN count "exam" "exams"}
@ -2308,6 +2321,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
@ -2415,6 +2430,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/jobs.model
+++ b/models/jobs.model
@ -17,14 +17,6 @@ CronLastExec
    instance            InstanceId -- Which uni2work-instance did the work
    UniqueCronLastExec job

-
-SentNotification
-    content             Value
-    user                UserId
-    time                UTCTime
-    instance            InstanceId
-
-
 TokenBucket
    ident               TokenBucketIdent
    lastValue           Int64
--- a/models/mail.model
+++ b/models/mail.model
@ -0,0 +1,13 @@
+SentMail
+    sentAt       UTCTime
+    sentBy       InstanceId
+    objectId     MailObjectId Maybe
+    bounceSecret BounceSecret Maybe
+    recipient    UserId Maybe
+    headers      MailHeaders
+    contentRef   SentMailContentId
+
+SentMailContent
+    hash    MailContentReference
+    content MailContent
+    Primary hash
--- 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/package-lock.json
+++ b/package-lock.json
@ -1,6 +1,6 @@
 {
  "name": "uni2work",
-  "version": "20.13.0",
+  "version": "21.0.3",
  "lockfileVersion": 1,
  "requires": true,
  "dependencies": {
--- a/package.json
+++ b/package.json
@ -1,6 +1,6 @@
 {
  "name": "uni2work",
-  "version": "20.13.0",
+  "version": "21.0.3",
  "description": "",
  "keywords": [],
  "author": "",
--- a/package.yaml
+++ b/package.yaml
@ -1,5 +1,5 @@
 name:    uniworx
-version: 20.13.0
+version: 21.0.3

 dependencies:
  - base
--- a/src/Application.hs
+++ b/src/Application.hs
@ -183,7 +183,7 @@ makeFoundation appSettings'@AppSettings{..} = do
    -- logging function. To get out of this loop, we initially create a
    -- temporary foundation without a real connection pool, get a log function
    -- from there, and then create the real foundation.
-    let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache = UniWorX {..}
+    let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret = UniWorX {..}
        -- The UniWorX {..} syntax is an example of record wild cards. For more
        -- information, see:
        -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
@ -199,6 +199,7 @@ makeFoundation appSettings'@AppSettings{..} = do
          (error "ClusterID forced in tempFoundation")
          (error "memcached forced in tempFoundation")
          (error "MinioConn forced in tempFoundation")
+          (error "VerpSecret forced in tempFoundation")

    runAppLoggingT tempFoundation $ do
      $logInfoS "InstanceID" $ UUID.toText appInstanceID
@ -242,6 +243,7 @@ makeFoundation appSettings'@AppSettings{..} = do
      appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool
      appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool
      appClusterID <- clusterSetting (Proxy :: Proxy 'ClusterId) `runSqlPool` sqlPool
+      appVerpSecret <- clusterSetting (Proxy :: Proxy 'ClusterVerpSecret) `runSqlPool` sqlPool

      appMemcached <- for appMemcachedConf $ \memcachedConf -> do
        $logDebugS "setup" "Memcached"
@ -259,7 +261,7 @@ makeFoundation appSettings'@AppSettings{..} = do
          handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadCacheBucket Nothing
        return conn

-      let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache
+      let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appUploadCache appVerpSecret

      -- Return the foundation
      $logDebugS "setup" "Done"
--- 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
@ -46,7 +46,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)
@ -82,25 +81,27 @@ newtype InvalidAuthTag = InvalidAuthTag Text
 instance Exception InvalidAuthTag


+type AuthTagsEval m = AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
+  
 data AccessPredicate
  = APPure     (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
  | APHandler  (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult)
-  | APDB       (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)
+  | APDB       ((forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)

 class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where
-  evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
+  evalAccessPred :: AccessPredicate -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult

 instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where
-  evalAccessPred aPred aid r w = liftHandler $ case aPred of
+  evalAccessPred aPred cont aid r w = liftHandler $ case aPred of
    (APPure    p) -> runReader (p aid r w) <$> getMsgRenderer
    (APHandler p) -> p aid r w
-    (APDB      p) -> runDBRead $ p aid r w
+    (APDB      p) -> runDBRead $ p cont aid r w

 instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX) => MonadAP (ReaderT backend m) where
-  evalAccessPred aPred aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of
+  evalAccessPred aPred cont aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of
    (APPure    p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
    (APHandler p) -> lift $ p aid r w
-    (APDB      p) -> p aid r w
+    (APDB      p) -> p cont aid r w


 orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
@ -178,7 +179,9 @@ isDryRun = $cachedHere . liftHandler $ orM
          noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar

      dnf <- either throwM return $ routeAuthTags currentRoute
-      guardAuthResult <=< fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) mAuthId currentRoute isWrite
+      let eval :: forall m'. MonadAP m' => AuthTagsEval m'
+          eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite'
+       in guardAuthResult <=< fmap fst . runWriterT $ eval dnf mAuthId currentRoute isWrite

      return False

@ -230,6 +233,8 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
        noTokenAuth :: AuthDNF -> AuthDNF
        noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar

+        eval :: forall m'. MonadAP m' => AuthTagsEval m'
+        eval dnf' mAuthId'' route'' isWrite'' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId'' route'' isWrite''
      guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority

      forM_ bearerAuthority' $ \uid -> do
@ -238,12 +243,12 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val

        authorityVal <- do
          dnf <- either throwM return $ routeAuthTags route
-          fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth dnf) (Just uid) route isWrite
+          fmap fst . runWriterT $ eval (noTokenAuth dnf) (Just uid) route isWrite
        guardExceptT (is _Authorized authorityVal) authorityVal

      whenIsJust bearerAddAuth $ \addDNF -> do
        $logDebugS "validateToken" $ tshow addDNF
-        additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) (noTokenAuth addDNF) mAuthId route isWrite
+        additionalVal <- fmap fst . runWriterT $ eval (noTokenAuth addDNF) mAuthId route isWrite
        guardExceptT (is _Authorized additionalVal) additionalVal

      return Authorized
@ -295,7 +300,7 @@ maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do
 tagAccessPredicate :: BearerAuthSite UniWorX
                   => AuthTag -> AccessPredicate
 tagAccessPredicate AuthFree = trueAP
-tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthAdmin = APDB $ \_ mAuthId route _ -> case route of
  -- Courses: access only to school admins
  CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
@ -332,12 +337,12 @@ tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of
    adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
    guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
    return Authorized
-tagAccessPredicate AuthSystemExamOffice = APDB $ \mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
+tagAccessPredicate AuthSystemExamOffice = APDB $ \_ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
  authId <- maybeExceptT AuthenticationRequired $ return mAuthId
  isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False]
  guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice
  return Authorized
-tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthExamOffice = APDB $ \_ mAuthId route _ -> case route of
  CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasUsers <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
@ -375,7 +380,7 @@ tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of
    isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice]
    guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice)
    return Authorized
-tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthEvaluation = APDB $ \_ mAuthId route _ -> case route of
  ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
@ -391,7 +396,7 @@ tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of
    isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation]
    guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
    return Authorized
-tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthAllocationAdmin = APDB $ \_ mAuthId route _ -> case route of
  AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation
@ -407,9 +412,9 @@ tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route o
    isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation]
    guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
    return Authorized
-tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $
+tagAccessPredicate AuthToken = APDB $ \_ mAuthId route isWrite -> exceptT return return $
  lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe
-tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthNoEscalation = APDB $ \_ mAuthId route _ -> case route of
  AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
    myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
    uid <- decrypt cID
@ -430,7 +435,7 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
 #else
  return $ Unauthorized "Route under development"
 #endif
-tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthLecturer = APDB $ \_ mAuthId route _ -> case route of
  CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do
@ -469,7 +474,7 @@ tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] []
     return Authorized
-tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do
+tagAccessPredicate AuthCorrector = APDB $ \_ mAuthId route _ -> exceptT return return $ do
  authId <- maybeExceptT AuthenticationRequired $ return mAuthId
  resList <- $cachedHereBinary mAuthId . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
    E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
@ -497,7 +502,7 @@ tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return ret
    _ -> do
      guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
      return Authorized
-tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthExamCorrector = APDB $ \_ mAuthId route _ -> case route of
  CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
@ -522,7 +527,7 @@ tagAccessPredicate AuthExamCorrector = APDB $ \mAuthId route _ -> case route of
    guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector
    return Authorized
  r -> $unsupportedAuthPredicate AuthExamCorrector r
-tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return $ do
+tagAccessPredicate AuthTutor = APDB $ \_ mAuthId route _ -> exceptT return return $ do
  authId <- maybeExceptT AuthenticationRequired $ return mAuthId
  resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
    E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
@ -545,14 +550,14 @@ tagAccessPredicate AuthTutor = APDB $ \mAuthId route _ -> exceptT return return
    _ -> do
      guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
      return Authorized
-tagAccessPredicate AuthTutorControl = APDB $ \_ route _ -> case route of
+tagAccessPredicate AuthTutorControl = APDB $ \_ _ route _ -> case route of
  CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do
    Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
    guard tutorialTutorControlled
    return Authorized
  r -> $unsupportedAuthPredicate AuthTutorControl r
-tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthSubmissionGroup = APDB $ \_ mAuthId route _ -> case route of
  CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do
    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn
@ -577,7 +582,7 @@ tagAccessPredicate AuthSubmissionGroup = APDB $ \mAuthId route _ -> case route o

    return Authorized
  r -> $unsupportedAuthPredicate AuthSubmissionGroup r
-tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthTime = APDB $ \(runTACont -> cont) mAuthId route isWrite -> case route of
  CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
@ -677,9 +682,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
  CourseR tid ssh csh CRegisterR -> do
    now <- liftIO getCurrentTime
    mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh
-    registered <- case (mbc,mAuthId) of
-      (Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive]
-      _ -> return False
+    registered <- cont (predDNFSingleton $ PLVariable AuthCourseRegistered) mAuthId route isWrite
    case mbc of
      (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo}))
        | not registered
@ -759,7 +762,7 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
    return Authorized

  r -> $unsupportedAuthPredicate AuthTime r
-tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of
+tagAccessPredicate AuthStaffTime = APDB $ \_ _ route isWrite -> case route of
  CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
    course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
@ -784,16 +787,14 @@ tagAccessPredicate AuthStaffTime = APDB $ \_ route isWrite -> case route of
    return Authorized

  r -> $unsupportedAuthPredicate AuthStaffTime r
-tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthAllocationTime = APDB $ \(runTACont -> cont) mAuthId route isWrite -> case route of
  CourseR tid ssh csh CRegisterR -> do
    now <- liftIO getCurrentTime
    mba <- mbAllocation tid ssh csh
    case mba of
      Nothing -> return Authorized
-      Just (cid, Allocation{..}) -> do
-        registered <- case mAuthId of
-          Just uid -> $cachedHereBinary (uid, cid) $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
-          _        -> return False
+      Just (_, Allocation{..}) -> do
+        registered <- cont (predDNFSingleton $ PLVariable AuthCourseRegistered) mAuthId route isWrite
        if
          | not registered
          , NTop allocationRegisterByCourse >= NTop (Just now)
@ -830,7 +831,7 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
      cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
      Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid
      (cid,) <$> MaybeT (get allocationCourseAllocation)
-tagAccessPredicate AuthCourseTime = APDB $ \_mAuthId route _ -> case route of
+tagAccessPredicate AuthCourseTime = APDB $ \_ _mAuthId route _ -> case route of
  CourseR tid ssh csh _ -> exceptT return return $ do
    now <- liftIO getCurrentTime
    courseVisible <- $cachedHereBinary (tid, ssh, csh) . lift . E.selectExists . E.from $ \course -> do
@ -841,7 +842,7 @@ tagAccessPredicate AuthCourseTime = APDB $ \_mAuthId route _ -> case route of
    guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime)
    return Authorized
  r -> $unsupportedAuthPredicate AuthCourseTime r
-tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthCourseRegistered = APDB $ \_ mAuthId route _ -> case route of
  CourseR tid ssh csh _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
@ -854,7 +855,7 @@ tagAccessPredicate AuthCourseRegistered = APDB $ \mAuthId route _ -> case route
    guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
    return Authorized
  r -> $unsupportedAuthPredicate AuthCourseRegistered r
-tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthTutorialRegistered = APDB $ \_ mAuthId route _ -> case route of
  CTutorialR tid ssh csh tutn _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    isRegistered <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
@ -879,7 +880,7 @@ tagAccessPredicate AuthTutorialRegistered = APDB $ \mAuthId route _ -> case rout
    guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
    return Authorized
  r -> $unsupportedAuthPredicate AuthTutorialRegistered r
-tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ route _ -> case route of
+tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ _ route _ -> case route of
  CExamR tid ssh csh examn _ -> exceptT return return $ do
    isOccurrenceRegistration <- $cachedHereBinary (tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam) -> do
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
@ -891,7 +892,7 @@ tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ route _ -> case ro
    guardMExceptT isOccurrenceRegistration (unauthorizedI MsgUnauthorizedExamOccurrenceRegistration)
    return Authorized
  r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistration r
-tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \_ mAuthId route _ -> case route of
  CExamR tid ssh csh examn (ERegisterOccR occn) -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn, occn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration `E.InnerJoin` examOccurrence) -> do
@ -932,7 +933,7 @@ tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \mAuthId route _ -> cas
    guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
    return Authorized
  r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistered r
-tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthExamRegistered = APDB $ \_ mAuthId route _ -> case route of
  CExamR tid ssh csh examn _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
@ -973,7 +974,7 @@ tagAccessPredicate AuthExamRegistered = APDB $ \mAuthId route _ -> case route of
    guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredAnyExam
    return Authorized
  r -> $unsupportedAuthPredicate AuthExamRegistered r
-tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthExamResult = APDB $ \_ mAuthId route _ -> case route of
  CExamR tid ssh csh examn _ -> exceptT return return $ do
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    hasResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
@ -1026,14 +1027,14 @@ tagAccessPredicate AuthExamResult = APDB $ \mAuthId route _ -> case route of
    guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult)
    return Authorized
  r -> $unsupportedAuthPredicate AuthExamRegistered r
-tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthAllocationRegistered = APDB $ \_ mAuthId route _ -> case route of
  AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegistered) $ do
    uid <- hoistMaybe mAuthId
    aId <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getKeyBy $ TermSchoolAllocationShort tid ssh ash
    void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid
    return Authorized
  r -> $unsupportedAuthPredicate AuthAllocationRegistered r
-tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthParticipant = APDB $ \_ mAuthId route _ -> case route of
  CNewsR tid ssh csh cID _ -> maybeT (unauthorizedI MsgUnauthorizedParticipantSelf) $ do
    nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
    CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId
@ -1141,7 +1142,7 @@ tagAccessPredicate AuthParticipant = APDB $ \mAuthId route _ -> case route of
               E.&&. course E.^. CourseTerm      E.==. E.val tid
               E.&&. course E.^. CourseSchool    E.==. E.val ssh
               E.&&. course E.^. CourseShorthand E.==. E.val csh
-tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthApplicant = APDB $ \_ mAuthId route _ -> case route of
  CourseR tid ssh csh (CUserR cID) -> maybeT (unauthorizedI MsgUnauthorizedApplicant) $ do
    uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
    isApplicant <- isCourseApplicant tid ssh csh uid
@ -1162,7 +1163,7 @@ tagAccessPredicate AuthApplicant = APDB $ \mAuthId route _ -> case route of
           E.&&. course E.^. CourseTerm      E.==. E.val tid
           E.&&. course E.^. CourseSchool    E.==. E.val ssh
           E.&&. course E.^. CourseShorthand E.==. E.val csh
-tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
+tagAccessPredicate AuthCapacity = APDB $ \_ _ route _ -> case route of
  CExamR tid ssh csh examn (ERegisterOccR occn) -> maybeT (unauthorizedI MsgExamOccurrenceNoCapacity) $ do
    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    eid <- $cachedHereBinary (cid, examn) . MaybeT . getKeyBy $ UniqueExam cid examn
@ -1182,7 +1183,7 @@ tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
    guard $ NTop courseCapacity > NTop (Just registered)
    return Authorized
  r -> $unsupportedAuthPredicate AuthCapacity r
-tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthRegisterGroup = APDB $ \_ mAuthId route _ -> case route of
  CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do
    cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
    Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
@ -1198,7 +1199,7 @@ tagAccessPredicate AuthRegisterGroup = APDB $ \mAuthId route _ -> case route of
        guard $ not hasOther
        return Authorized
  r -> $unsupportedAuthPredicate AuthRegisterGroup r
-tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> do
+tagAccessPredicate AuthEmpty = APDB $ \_ mAuthId route _ -> do
  let wInstances rScope = maybeT (unauthorizedI MsgUnauthorizedWorkflowInstancesNotEmpty) $ do
        scope <- fromRouteWorkflowScope rScope
        
@ -1247,20 +1248,20 @@ tagAccessPredicate AuthEmpty = APDB $ \mAuthId route _ -> do
        E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
      return Authorized
    r -> $unsupportedAuthPredicate AuthEmpty r
-tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of
+tagAccessPredicate AuthMaterials = APDB $ \_ _ route _ -> case route of
  CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
    Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    guard courseMaterialFree
    return Authorized
  r -> $unsupportedAuthPredicate AuthMaterials r
-tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthOwner = APDB $ \_ mAuthId route _ -> case route of
  CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
    sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
    void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
    return Authorized
  r -> $unsupportedAuthPredicate AuthOwner r
-tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \_ mAuthId route _ -> case route of
  CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . exceptT return return $ do
    Entity shId Sheet{..} <- maybeTMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) $ do
      cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh
@ -1275,28 +1276,28 @@ tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \mAuthId route _ -> case
                    E.&&. E.not_ (E.isNothing $ psFile E.^. PersonalisedSheetFileContent) -- directories don't count
           return Authorized
  r -> $unsupportedAuthPredicate AuthPersonalisedSheetFiles r
-tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of
+tagAccessPredicate AuthRated = APDB $ \_ _ route _ -> case route of
  CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
    sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
    sub <- MaybeT $ get sid
    guard $ submissionRatingDone sub
    return Authorized
  r -> $unsupportedAuthPredicate AuthRated r
-tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of
+tagAccessPredicate AuthUserSubmissions = APDB $ \_ _ route _ -> case route of
  CSheetR tid ssh csh shn _ -> $cachedHereBinary (tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
    Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn
    guard $ is _Just submissionModeUser
    return Authorized
  r -> $unsupportedAuthPredicate AuthUserSubmissions r
-tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of
+tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ _ route _ -> case route of
  CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
    Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
    Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
    guard submissionModeCorrector
    return Authorized
  r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
-tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $ do
+tagAccessPredicate AuthSelf = APDB $ \_ mAuthId route _ -> exceptT return return $ do
  referencedUser' <- case route of
    AdminUserR cID -> return $ Left cID
    AdminUserDeleteR cID -> return $ Left cID
@ -1317,7 +1318,7 @@ tagAccessPredicate AuthSelf = APDB $ \mAuthId route _ -> exceptT return return $
      | uid == referencedUser -> return Authorized
    Nothing -> return AuthenticationRequired
    _other  -> unauthorizedI MsgUnauthorizedSelf
-tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do
+tagAccessPredicate AuthIsLDAP = APDB $ \_ _ route _ -> exceptT return return $ do
  referencedUser <- case route of
    AdminUserR cID -> return cID
    AdminUserDeleteR cID -> return cID
@ -1331,7 +1332,7 @@ tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do
    User{..} <- MaybeT $ get referencedUser'
    guard $ userAuthentication == AuthLDAP
  return Authorized
-tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ do
+tagAccessPredicate AuthIsPWHash = APDB $ \_ _ route _ -> exceptT return return $ do
  referencedUser <- case route of
    AdminUserR cID -> return cID
    AdminUserDeleteR cID -> return cID
@ -1345,7 +1346,7 @@ tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ d
    User{..} <- MaybeT $ get referencedUser'
    guard $ is _AuthPWHash userAuthentication
  return Authorized
-tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
+tagAccessPredicate AuthAuthentication = APDB $ \_ mAuthId route _ -> case route of
  MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
    smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
    SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId
@ -1359,7 +1360,7 @@ tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
    guard $ not systemMessageAuthenticatedOnly || isAuthenticated
    return Authorized
  r -> $unsupportedAuthPredicate AuthAuthentication r
-tagAccessPredicate AuthWorkflow = APDB $ \mAuthId route isWrite -> do
+tagAccessPredicate AuthWorkflow = APDB $ \_ mAuthId route isWrite -> do
  mr <- getMsgRenderer
  let orAR', _andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
      orAR' = shortCircuitM (is _Authorized) (orAR mr)
@ -1454,6 +1455,11 @@ tagAccessPredicate AuthWrite = APPure $ \_ _ isWrite -> do
  MsgRenderer mr <- ask
  return $ bool (Unauthorized $ mr MsgUnauthorized) Authorized isWrite

+runTACont :: forall m. MonadAP m
+          => (forall m'. MonadAP m' => AuthTagsEval m')
+          -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m Bool
+runTACont cont dnf mAuthId route isWrite = is _Authorized . fst <$> runWriterT (cont dnf mAuthId route isWrite)
+

 authTagSpecificity :: AuthTag -> AuthTag -> Ordering
 -- ^ Heuristic for which `AuthTag`s to evaluate first
@ -1495,9 +1501,9 @@ routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partiti
      | otherwise
        = Left $ InvalidAuthTag t

-evalAuthTags :: forall m. MonadAP m => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
+evalAuthTags :: forall ctx m. (Binary ctx, MonadAP m) => ctx -> AuthTagActive -> (forall m'. MonadAP m' => AuthTagsEval m') -> AuthTagsEval m
 -- ^ `tell`s disabled predicates, identified as pivots
-evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite
+evalAuthTags ctx AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite
  = do
      mr <- getMsgRenderer
      let
@ -1507,11 +1513,11 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnf
        authTagIsInactive = not . authTagIsActive

        evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult
-        evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite
+        evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (ctx, AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for5 memo (const evalAccessPred') ctx authTag mAuthId route isWrite
          where
            evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do
              $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
-              evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite'
+              evalAccessPred (tagAccessPredicate authTag') cont mAuthId' route' isWrite'

        evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult
        evalAuthLiteral PLVariable{..} = evalAuthTag plVar
@ -1547,14 +1553,16 @@ evalAccessWithFor assumptions mAuthId route isWrite = do
    | isSelf    -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
    | otherwise -> return . AuthTagActive $ const True
  dnf <- either throwM return $ routeAuthTags route
-  let dnf' = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) $ Just dnf
-  case dnf' of
-    Nothing -> return Authorized
-    Just dnf'' -> do
-      (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf'' mAuthId route isWrite
-      when isSelf $
-        tellSessionJson SessionInactiveAuthTags deactivated
-      return result
+  let adjDNF = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) . Just
+      evalAdj :: forall m'. MonadAP m' => AuthTagsEval m'
+      evalAdj (adjDNF -> dnf') mAuthId' route' isWrite' = case dnf' of
+        Nothing    -> return Authorized
+        Just dnf'' -> evalAuthTags ('evalAccessWithFor, assumptions) tagActive evalAdj dnf'' mAuthId' route' isWrite'
+   in do
+    (result, deactivated) <- runWriterT $ evalAdj dnf mAuthId route isWrite
+    when isSelf $
+      tellSessionJson SessionInactiveAuthTags deactivated
+    return result

 evalAccessFor :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
 evalAccessFor = evalAccessWithFor []
@ -1621,14 +1629,14 @@ evalWorkflowRoleFor' :: forall m backend.
                        , BearerAuthSite UniWorX
                        , BackendCompatible SqlReadBackend backend
                        )
-                     => AuthTagActive
+                     => (forall m'. MonadAP m' => AuthTagsEval m')
                     -> Maybe UserId
                     -> Maybe WorkflowWorkflowId
                     -> WorkflowRole UserId
                     -> Route UniWorX
                     -> Bool
                     -> WriterT (Set AuthTag) (ReaderT backend m) AuthResult
-evalWorkflowRoleFor' tagActive mAuthId mwwId wRole route isWrite = $cachedHereBinary (tagActive, mAuthId, mwwId, wRole, route, isWrite) $ case wRole of
+evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = case wRole of
  WorkflowRoleUser{..} -> lift . exceptT return return $ do
    uid <- maybeExceptT AuthenticationRequired $ return mAuthId
    unless (uid == workflowRoleUser) $
@ -1653,7 +1661,7 @@ evalWorkflowRoleFor' tagActive mAuthId mwwId wRole route isWrite = $cachedHereBi
    unless (uid `Set.member` uids) $ 
      throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch
    return Authorized
-  WorkflowRoleAuthorized{..} -> evalAuthTags tagActive workflowRoleAuthorized mAuthId route isWrite
+  WorkflowRoleAuthorized{..} -> eval workflowRoleAuthorized mAuthId route isWrite

 evalWorkflowRoleFor :: ( MonadHandler m
                       , HandlerSite m ~ UniWorX
@ -1671,7 +1679,10 @@ evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = do
  tagActive <- if
    | isSelf    -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
    | otherwise -> return . AuthTagActive $ const True
-  (result, deactivated) <- runWriterT $ evalWorkflowRoleFor' tagActive mAuthId mwwId wRole route isWrite
+  (result, deactivated) <-
+    let eval :: forall m'. MonadAP m' => AuthTagsEval m'
+        eval dnf' mAuthId' route' isWrite' = evalAuthTags 'evalWorkflowRoleFor tagActive eval dnf' mAuthId' route' isWrite'
+     in runWriterT $ evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite
  when isSelf $
    tellSessionJson SessionInactiveAuthTags deactivated
  return result
--- a/src/Foundation/Instances.hs
+++ b/src/Foundation/Instances.hs
@ -37,9 +37,18 @@ import Foundation.DB

 import Network.Wai.Parse (lbsBackEnd)

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

+import qualified Control.Monad.State.Class as State
+import qualified Crypto.Hash as Crypto
+import qualified Crypto.MAC.KMAC as Crypto
+
+import qualified Data.Binary as Binary
+
+import qualified Data.CaseInsensitive as CI
+
+import qualified Database.Esqueleto as E
+

 data instance ButtonClass UniWorX
  = BCIsButton
@ -178,23 +187,102 @@ instance YesodAuthPersist UniWorX where
    
 instance YesodMail UniWorX where
  defaultFromAddress = getsYesod $ view _appMailFrom
+  envelopeFromAddress = getsYesod $ view _appMailEnvelopeFrom
  mailObjectIdDomain = getsYesod $ view _appMailObjectDomain
-  mailVerp = getsYesod $ view _appMailVerp
  mailDateTZ = return appTZ
  mailSmtp act = do
    pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
    withResource pool act
-  mailT ctx mail = defMailT ctx $ do
-    void setMailObjectIdRandom
-    setDateCurrent
-    replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail)
+  mailT ctx mail = do
+    mailRecord <- newEmptyTMVarIO
+    mailProcess <- allocateLinkedAsync $ do
+      defMailT ctx $ do
+        void setMailObjectIdRandom
+        sentMailSentAt <- liftIO getCurrentTime
+        setDate sentMailSentAt
+        replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailSender . to renderAddress)

-    (mRes, smtpData) <- listen mail
-    unless (view _MailSmtpDataSet smtpData)
-      setMailSmtpData
+        (mRes, smtpData) <- listen mail

-    return mRes
+        sentMailObjectId <- getMailObjectId
+  
+        mContent <- State.get
+  
+        smtpData' <- if | smtpData ^. _MailSmtpDataSet -> return smtpData
+                        | otherwise -> getMailSmtpData
+        verpMode <- getsYesod $ view _appMailVerp
+        (smtpData'', sentMailBounceSecret) <- if
+          | Verp{..} <- verpMode
+          , [_] <- smtpData' ^.. _smtpRecipients . folded
+          , Just [l, d] <- previews (_smtpEnvelopeFrom . _Wrapped . _Just) (Text.splitOn "@") smtpData'
+            -> do
+              verpSecret <- getsYesod appVerpSecret
+              let bounceSecret = BounceSecret . Crypto.kmacGetDigest $ kmaclazy ("bounce" :: ByteString) verpSecret $ Binary.encode mContent
+                  verpAddr = l <> Text.singleton verpSeparator <> verpPrefix <> "." <> toPathPiece bounceSecret <> "@" <> d
+              return ( smtpData' <> mempty { smtpEnvelopeFrom = Last $ Just verpAddr }
+                     , Just bounceSecret
+                     )
+          | otherwise -> return (smtpData', Nothing)
+        tell smtpData''

+        sentMailSentBy <- getsYesod appInstanceID
+        let sentMailRecipient = Nothing -- Fill in later
+            sentMailHeaders = MailHeaders $ mconcat
+              [ renderAddressHeader "From" [mailFrom mContent]
+              , fromMaybe [] $ do
+                  toAddrs <- assertM' (not . null) $ mailTo mContent
+                  return $ renderAddressHeader "To" toAddrs
+              , fromMaybe [] $ do
+                  ccAddrs <- assertM' (not . null) $ mailCc mContent
+                  return $ renderAddressHeader "Cc" ccAddrs
+              , fromMaybe [] $ do
+                  bccAddrs <- assertM' (not . null) $ mailBcc mContent
+                  return $ renderAddressHeader "Bcc" bccAddrs
+              , mailHeaders mContent
+              ]
+              where
+                renderAddressHeader :: ByteString -> [Address] -> [(ByteString, Text)]
+                renderAddressHeader lbl = pure . (lbl, ) . Text.intercalate ", " . map renderAddress
+            sentMailContent = MailContent $ mailParts mContent
+            sentMailContentRef = SentMailContentKey . MailContentReference . Crypto.hashlazy $ Binary.encode sentMailContent
+
+        atomically $ putTMVar mailRecord
+          ( smtpData'' ^.. _smtpRecipients . folded
+          , sentMailContent
+          , SentMail{..}
+          )
+        atomically . guardM $ isEmptyTMVar mailRecord
+        return mRes
+
+    (smtpRecipients, sentMailContentContent, sentMail) <- atomically $ takeTMVar mailRecord
+    void . tryAny . liftHandler . runDB . setSerializable $ do -- Ignore exceptions that occur during logging
+      sentMailRecipient <- if
+        | [Address _ (CI.mk -> recipAddr)] <- smtpRecipients -> do
+            recipUsers <- E.select . E.from $ \user -> do
+              E.where_ $ user E.^. UserDisplayEmail E.==. E.val recipAddr
+                   E.||. user E.^. UserEmail        E.==. E.val recipAddr
+                   E.||. user E.^. UserIdent        E.==. E.val recipAddr
+              return user
+            let recipUserCompare = mconcat
+                  [ comparing $ Down . (== recipAddr) . userIdent . entityVal
+                  , comparing $ Down . (== recipAddr) . userEmail . entityVal
+                  , comparing $ Down . (== recipAddr) . userDisplayEmail . entityVal
+                  ]
+            return $ if
+              | ( bU : us ) <- sortBy recipUserCompare recipUsers
+              , maybe True (\u -> recipUserCompare bU u == LT) $ listToMaybe us
+                -> Just $ entityKey bU
+              | otherwise -> Nothing
+        | otherwise -> return Nothing
+
+      -- @insertUnique@ _does not_ work here
+      unlessM (exists [ SentMailContentHash ==. unSentMailContentKey (sentMailContentRef sentMail) ]) $
+        insert_ SentMailContent { sentMailContentHash = unSentMailContentKey $ sentMailContentRef sentMail
+                                , sentMailContentContent
+                                }
+      insert_ sentMail{ sentMailRecipient }
+      wait mailProcess -- Abort transaction if sending failed
+    wait mailProcess -- Rethrow exceptions for mailprocess; technically unnecessary due to linkage, doesn't hurt, though

 instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
  type MonadCryptoKey m = CryptoIDKey
--- a/src/Foundation/Routes.hs
+++ b/src/Foundation/Routes.hs
@ -43,6 +43,29 @@ deriving instance Generic GlobalWorkflowInstanceR
 deriving instance Generic GlobalWorkflowWorkflowR
 deriving instance Generic (Route UniWorX)

+instance Ord (Route Auth) where
+  compare = compare `on` renderRoute
+instance Ord (Route EmbeddedStatic) where
+  compare = compare `on` renderRoute
+
+deriving instance Ord CourseR
+deriving instance Ord SheetR
+deriving instance Ord SubmissionR
+deriving instance Ord MaterialR
+deriving instance Ord TutorialR
+deriving instance Ord ExamR
+deriving instance Ord EExamR
+deriving instance Ord CourseApplicationR
+deriving instance Ord AllocationR
+deriving instance Ord SchoolR
+deriving instance Ord ExamOfficeR
+deriving instance Ord CourseNewsR
+deriving instance Ord CourseEventR
+deriving instance Ord AdminWorkflowDefinitionR
+deriving instance Ord GlobalWorkflowInstanceR
+deriving instance Ord GlobalWorkflowWorkflowR
+deriving instance Ord (Route UniWorX)
+
 data RouteChildren
 type instance Children RouteChildren a = ChildrenRouteChildren a
 type family ChildrenRouteChildren a where
--- a/src/Foundation/Type.hs
+++ b/src/Foundation/Type.hs
@ -57,6 +57,7 @@ data UniWorX = UniWorX
    , appHealthReport     :: TVar (Set (UTCTime, HealthReport))
    , appMemcached        :: Maybe (AEAD.Key, Memcached.Connection)
    , appUploadCache      :: Maybe MinioConn
+    , appVerpSecret       :: VerpSecret
    }

 makeLenses_ ''UniWorX
--- 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
@ -18,9 +18,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))

 import qualified Data.Map as Map
--- a/src/Handler/Course/Application/List.hs
+++ b/src/Handler/Course/Application/List.hs
@ -402,6 +402,7 @@ postCApplicationsR tid ssh csh = do
            CourseApplicationsTableCsvSetRatingData{}  -> CourseApplicationsTableCsvSetRating
            CourseApplicationsTableCsvSetCommentData{} -> CourseApplicationsTableCsvSetComment
        , dbtCsvCoarsenActionClass = const DBCsvActionExisting
+        , dbtCsvValidateActions = return ()
        , dbtCsvExecuteActions = do
            C.mapM_ $ \case
              CourseApplicationsTableCsvSetVetoData{..} -> do
--- a/src/Handler/Course/Edit.hs
+++ b/src/Handler/Course/Edit.hs
@ -305,7 +305,7 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
      <*> aopt htmlField (fslI MsgCourseApplicationInstructions & setTooltip MsgCourseApplicationInstructionsTip) (cfAppInstructions <$> template)
      <*> aopt (multiFileField' . fromMaybe (return ()) $ cfAppInstructionFiles =<< template) (fslI MsgCourseApplicationTemplate & setTooltip MsgCourseApplicationTemplateTip) (cfAppInstructionFiles <$> template)
      <*> apopt checkBoxField (fslI MsgCourseApplicationsText & setTooltip MsgCourseApplicationsTextTip) (cfAppText <$> template)
-      <*> uploadModeForm (cfAppFiles <$> template)
+      <*> uploadModeForm (fslI MsgCourseApplicationsFiles & setTooltip MsgCourseApplicationsFilesTip) (fmap cfAppFiles template <|> pure NoUpload)
      <*> apopt checkBoxField (fslI MsgCourseApplicationRatingsVisible & setTooltip MsgCourseApplicationRatingsVisibleTip) (cfAppRatingsVisible <$> template)
      <*> aopt (natFieldI MsgCourseCapacity)  (fslI MsgCourseCapacity
            & setTooltip MsgCourseCapacityTip)                          (cfCapacity   <$> template)
@ -376,6 +376,10 @@ validateCourse = do
    $ length (CI.original cfShort) <= 10
  warnValidation MsgCourseNotAlwaysVisibleDuringRegistration
    $ NTop cfVisFrom <= NTop cfRegFrom && NTop cfRegTo <= NTop cfVisTo
+
+  warnValidation MsgCourseApplicationInstructionsRecommended
+    $  (is _Just cfAppInstructions || is _Just cfAppInstructionFiles)
+    || not (cfAppText || isn't _NoUpload cfAppFiles)
  

 getCourseNewR :: Handler Html -- call via toTextUrl
--- a/src/Handler/Course/Register.hs
+++ b/src/Handler/Course/Register.hs
@ -1,7 +1,7 @@
 module Handler.Course.Register
  ( ButtonCourseRegister(..)
  , CourseRegisterForm(..)
-  , courseRegisterForm
+  , courseRegisterForm, courseMayReRegister
  , getCRegisterR, postCRegisterR
  , deregisterParticipant
  ) where
@ -147,18 +147,29 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
        E.||. isCourseExamCorrector muid ata (course E.^. CourseId)
        )

+    mayReRegister <- liftHandler . runDB . courseMayReRegister $ Entity cid Course{..}
+
    when (is _Just $ registration >>= courseParticipantAllocated . entityVal) $
      wformMessage =<< messageIconI Warning IconExamRegisterFalse MsgCourseDeregistrationAllocationLog
    when (is _Just (registration >>= courseParticipantAllocated . entityVal) && courseDeregisterNoShow) $
      wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoShow
    when (isRegistered && not mayViewCourseAfterDeregistration) $
      wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationFromInvisibleCourse
+    unless mayReRegister $
+      wformMessage =<< messageIconI Warning IconEnrolFalse MsgCourseDeregistrationNoReRegistration

    return $ CourseRegisterForm
      <$  secretRes
      <*> appTextRes
      <*> appFilesRes

+courseMayReRegister :: Entity Course -> DB Bool
+courseMayReRegister (Entity cid Course{..}) = do
+  registrations <- count [ CourseParticipantState ==. CourseParticipantActive, CourseParticipantCourse ==. cid ]
+  let capacity = maybe True (>= registrations) courseCapacity
+  
+  wouldHaveWriteAccessTo [(AuthCapacity, capacity), (AuthCourseRegistered, False)] $ CourseR courseTerm courseSchool courseShorthand CRegisterR
+

 -- | Workaround for klicking register button without being logged in.
 -- After log in, the user sees a "get request not supported" error.
@ -273,7 +284,6 @@ deleteApplicationFiles appId = deleteWhere [ CourseApplicationFileApplication ==

 deregisterParticipant :: UserId -> CourseId -> DB ()
 deregisterParticipant uid cid = do
-  deleteApplications uid cid
  part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
  forM_ part $ \(Entity partId CourseParticipant{}) -> do
    update partId [CourseParticipantState =. CourseParticipantInactive False]
--- a/src/Handler/Course/Show.hs
+++ b/src/Handler/Course/Show.hs
@ -28,7 +28,7 @@ getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCShowR tid ssh csh = do
  mbAid <- maybeAuthId
  now <- liftIO getCurrentTime
-  (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen) <- runDB . maybeT notFound $ do
+  (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister) <- runDB . maybeT notFound $ do
    [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)]
       <- lift . E.select . E.from $
         \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
@ -106,7 +106,9 @@ getCShowR tid ssh csh = do
        return $ submissionGroup E.^. SubmissionGroupName
    let submissionGroup = guardOnM (hasSubmissionGroups && is _Just registration) submissionGroup'

-    return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen)
+    mayReRegister <- lift . courseMayReRegister $ Entity cid course
+
+    return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister)

  let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
  mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
--- a/src/Handler/Exam/Users.hs
+++ b/src/Handler/Exam/Users.hs
@ -43,6 +43,8 @@ import Control.Lens.Indexed ((<.), (.>))

 import Jobs.Queue

+import qualified Control.Monad.State.Class as State
+

 type ExamUserTableExpr = (              E.SqlExpr (Entity ExamRegistration)
                          `E.InnerJoin` E.SqlExpr (Entity User)
@ -613,8 +615,7 @@ postEUsersR tid ssh csh examn = do
                  -> error "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys"
                DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
                  (isPart, uid) <- lift $ guessUser' dbCsvNew
-                  unless isPart $ 
-                    yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupOccurrence dbCsvNew
+                  yieldM $ bool ExamUserCsvCourseRegisterData ExamUserCsvRegisterData isPart uid <$> lookupOccurrence dbCsvNew

                  iforMOf_ (ifolded <. _Just) (csvEUserExamPartResults dbCsvNew) $ \epNumber epRes ->
                    when (epNumber `elem` examPartNumbers) $
@ -706,6 +707,22 @@ postEUsersR tid ssh csh examn = do
                ExamUserCsvRegister       -> DBCsvActionNew
                ExamUserCsvDeregister     -> DBCsvActionMissing
                _other                    -> DBCsvActionExisting
+            , dbtCsvValidateActions = do
+                selectedActions <- State.get
+                availableActions <- ask
+                let missingExamDataUsers = flip filter examDataUsers $ \uid -> any (isRegisterAction uid) availableActions && none (isRegisterAction uid) selectedActions
+                      where
+                        examDataUsers = flip mapMaybe selectedActions $ \case
+                          ExamUserCsvSetResultData{..}        -> Just examUserCsvActUser
+                          ExamUserCsvSetBonusData{..}         -> Just examUserCsvActUser
+                          ExamUserCsvSetPartResultData{..}    -> Just examUserCsvActUser
+                          _other -> Nothing
+                        isRegisterAction uid = \case
+                          ExamUserCsvCourseRegisterData{..} -> uid == examUserCsvActUser
+                          ExamUserCsvRegisterData{..}       -> uid == examUserCsvActUser
+                          _other -> False
+                unless (null missingExamDataUsers) $
+                  tellMPoint $ messageI Error MsgExamUsersExamDataRequiresRegistration
            , dbtCsvExecuteActions = do
                C.mapM_ $ \case
                  ExamUserCsvCourseRegisterData{..} -> do
--- 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
@ -52,18 +52,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

@ -276,6 +274,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
@ -392,9 +403,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
@ -408,9 +443,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
@ -422,7 +462,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/ExternalExam/Users.hs
+++ b/src/Handler/Utils/ExternalExam/Users.hs
@ -446,6 +446,7 @@ makeExternalExamUsersTable mode (Entity eeId ExternalExam{..}) = do

              when (csvEUserExamResult /= dbCsvOld ^. resultResult . _entityVal . _externalExamResultResult) $
                yield $ ExternalExamUserCsvSetResultData (E.unValue dbCsvOldKey) csvEUserExamResult
+        , dbtCsvValidateActions = return ()
        , dbtCsvClassifyAction = \case
            ExternalExamUserCsvRegisterData{}   -> ExternalExamUserCsvRegister
            ExternalExamUserCsvSetTimeData{}    -> ExternalExamUserCsvSetTime
--- 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')
@ -586,8 +585,8 @@ studyFeaturesFieldFor mRestr isOptional oldFeatures mbuid = selectField $ do
          }


-uploadModeForm :: Maybe UploadMode -> AForm Handler UploadMode
-uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUploadMode <$> prev)
+uploadModeForm :: FieldSettings UniWorX -> Maybe UploadMode -> AForm Handler UploadMode
+uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
  where
    actions :: Map UploadModeDescr (AForm Handler UploadMode)
    actions = Map.fromList
@ -683,10 +682,10 @@ submissionModeForm prev = explainedMultiActionA actions opts (fslI MsgSheetSubmi
        , pure $ SubmissionMode True  Nothing
        )
      , ( SubmissionModeUser
-        , SubmissionMode False . Just <$> uploadModeForm (prev ^? _Just . _submissionModeUser . _Just)
+        , SubmissionMode False . Just <$> uploadModeForm (fslI MsgSheetUploadMode) (prev ^? _Just . _submissionModeUser . _Just)
        )
      , ( SubmissionModeBoth
-        , SubmissionMode True  . Just <$> uploadModeForm (prev ^? _Just . _submissionModeUser . _Just)
+        , SubmissionMode True  . Just <$> uploadModeForm (fslI MsgSheetUploadMode) (prev ^? _Just . _submissionModeUser . _Just)
        )
      ]

--- 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/Table/Pagination.hs
+++ b/src/Handler/Utils/Table/Pagination.hs
@ -69,7 +69,7 @@ import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)

 import qualified Network.Wai as Wai

-import Control.Monad.RWS (RWST(..), execRWS)
+import Control.Monad.RWS (RWST(..), execRWS, execRWST)
 import Control.Monad.State (evalStateT, execStateT)
 import Control.Monad.Trans.Maybe
 import Control.Monad.State.Class (modify)
@ -420,6 +420,9 @@ data DBCsvException k'
    { dbCsvExceptionRow :: NamedRecord
    , dbCsvException :: Text
    }
+  | DBCsvUnavailableActionRequested
+    { dbCsvActions :: Set Value
+    }
  deriving (Show, Typeable)

 makeLenses_ ''DBCsvException
@ -598,6 +601,7 @@ data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException
  ) => DBTCsvDecode
  { dbtCsvRowKey :: csv -> MaybeT DB k'
  , dbtCsvComputeActions :: DBCsvDiff r' csv k' -> ConduitT () csvAction DB ()
+  , dbtCsvValidateActions :: RWST (Set csvAction) [Message] [csvAction] DB ()
  , dbtCsvClassifyAction :: csvAction -> csvActionClass
  , dbtCsvCoarsenActionClass :: csvActionClass -> DBCsvActionMode
  , dbtCsvExecuteActions :: ConduitT csvAction Void (YesodJobDB UniWorX) route
@ -1177,6 +1181,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
                              <input id=#{theId} *{attrs} type=checkbox name=#{name} value=#{either id id val} :defaultChecked (dbtCsvClassifyAction act):checked>
                            |]
                        fieldView sJsonField (actionIdent act) (toPathPiece PostDBCsvImportAction) vAttrs (Right act) False
+                      availableActs :: Widget
+                      availableActs = fieldView (secretJsonField :: Field Handler (Set csvAction)) "" (toPathPiece PostDBCsvImportAvailableActions) [] (Right . Set.unions $ Map.elems actionMap) False
                  (csvImportConfirmForm', csvImportConfirmEnctype) <- liftHandler . generateFormPost . withButtonForm' [BtnCsvImportConfirm, BtnCsvImportAbort] . identifyForm (FIDDBTableCsvImportConfirm dbtIdent) $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "csv-import-confirmation"))
                  let csvImportConfirmForm = wrapForm csvImportConfirmForm' FormSettings
                        { formMethod = POST
@ -1231,6 +1237,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
                         <section>
                           ^{csvReImport}
                       |]
+              other -> throwM other
          , Catch.Handler $ \(csvParseError :: CsvParseError)
              -> liftHandler $ sendResponseStatus badRequest400 =<< do
                   mr <- getMessageRender
@ -1389,18 +1396,29 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
      ]

  ((csvImportConfirmRes, _confirmView), _enctype) <- case dbtCsvDecode of
-    Just (DBTCsvDecode{dbtCsvExecuteActions} :: DBTCsvDecode r' k' csv) -> do
+    Just (DBTCsvDecode{dbtCsvExecuteActions, dbtCsvValidateActions} :: DBTCsvDecode r' k' csv) -> do
      lift . runFormPost . withButtonForm' [BtnCsvImportConfirm, BtnCsvImportAbort] . identifyForm (FIDDBTableCsvImportConfirm dbtIdent) $ \_csrf -> do
+        availableActs <- fromMaybe Set.empty <$> globalPostParamField PostDBCsvImportAvailableActions secretJsonField
        acts <- globalPostParamFields PostDBCsvImportAction secretJsonField
-        return . (, mempty) $ if
-          | null acts -> FormSuccess $ do
-              addMessageI Info MsgCsvImportAborted
-              redirect $ tblLink id
-          | otherwise -> FormSuccess $ do
-              finalDest <- runDBJobs' . runConduit $ C.sourceList acts .| dbtCsvExecuteActions
-              addMessageI Success . MsgCsvImportSuccessful $ length acts
-              E.transactionSave
-              redirect finalDest
+        return . (, mempty) . FormSuccess $ if
+          | unavailableActs <- filter (`Set.notMember` availableActs) acts
+          , not $ null unavailableActs -> do
+              throwM . DBCsvUnavailableActionRequested @k' . Set.fromList $ map toJSON unavailableActs
+          | otherwise -> do
+              (acts', validationMsgs) <- execRWST dbtCsvValidateActions availableActs acts
+              if | not $ null validationMsgs -> do
+                     mapM_ addMessage' validationMsgs
+                     E.transactionUndo
+                     redirect $ tblLink id
+                 | null acts' -> do
+                     addMessageI Info MsgCsvImportAborted
+                     redirect $ tblLink id
+                 | otherwise -> do
+                     finalDest <- runDBJobs' . runConduit $ C.sourceList acts' .| dbtCsvExecuteActions
+                     addMessageI Success . MsgCsvImportSuccessful $ length acts'
+                     E.transactionSave
+                     redirect finalDest
+              
    _other -> return ((FormMissing, mempty), mempty)
  formResult csvImportConfirmRes $ \case
    (_, BtnCsvImportAbort) -> do
--- 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 [ SentMailRecipient ==. Just oldUserId ] [ SentMailRecipient =. Just newUserId ]
+
+  updateWhere [ SheetEditUser ==. oldUserId] [ SheetEditUser =. newUserId ]
+
+  let getSheetPseudonyms = selectSource [ SheetPseudonymUser ==. oldUserId ] []
+      upsertSheetPseudonym (Entity oldSPId oldSP) = do
+        collision <- existsBy $ UniqueSheetPseudonymUser (sheetPseudonymSheet oldSP) newUserId
+        if
+          | collision -> delete oldSPId
+          | otherwise -> update oldSPId [ SheetPseudonymUser =. newUserId ]
+   in runConduit $ getSheetPseudonyms .| C.mapM_ upsertSheetPseudonym
+
+  let getSheetCorrectors = selectSource [ SheetCorrectorUser ==. oldUserId ] []
+      upsertSheetCorrector (Entity oldSCId oldSheetCorrector) = do
+        collision <- getBy $ UniqueSheetCorrector newUserId (sheetCorrectorSheet oldSheetCorrector)
+        case collision of
+          Nothing -> update oldSCId [ SheetCorrectorUser =. newUserId ]
+          Just (Entity newSCId newSheetCorrector) -> do
+            update newSCId
+              [ SheetCorrectorLoad =. (sheetCorrectorLoad oldSheetCorrector <> sheetCorrectorLoad newSheetCorrector)
+              , SheetCorrectorState =. (min `on` sheetCorrectorState) oldSheetCorrector newSheetCorrector
+              ]
+            delete oldSCId
+   in runConduit $ getSheetCorrectors .| C.mapM_ upsertSheetCorrector
+
+  do
+    collision <- E.selectMaybe . E.from $ \(personalisedSheetFileA `E.InnerJoin` personalisedSheetFileB) -> do
+      E.on $ personalisedSheetFileA E.^. PersonalisedSheetFileSheet E.==. personalisedSheetFileB E.^. PersonalisedSheetFileSheet
+       E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileType E.==. personalisedSheetFileB E.^. PersonalisedSheetFileType
+       E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileTitle E.==. personalisedSheetFileB E.^. PersonalisedSheetFileTitle
+       E.&&. personalisedSheetFileA E.^. PersonalisedSheetFileUser E.==. E.val oldUserId
+       E.&&. personalisedSheetFileB E.^. PersonalisedSheetFileUser E.==. E.val newUserId
+      E.where_ . E.not_ $ personalisedSheetFileA E.^. PersonalisedSheetFileContent `E.maybeEq` personalisedSheetFileB E.^. PersonalisedSheetFileContent
+      return (personalisedSheetFileA, personalisedSheetFileB)
+    whenIsJust collision $ \(oldPersonalisedSheetFile, newPersonalisedSheetFile)
+      -> tellError $ UserAssimilatePersonalisedSheetFileDifferentContent oldPersonalisedSheetFile newPersonalisedSheetFile
+  E.insertSelectWithConflict
+    UniquePersonalisedSheetFile
+    (E.from $ \personalisedSheetFile -> do
+        E.where_ $ personalisedSheetFile E.^. PersonalisedSheetFileUser E.==. E.val oldUserId
+        return $ PersonalisedSheetFile
+          E.<#  (personalisedSheetFile E.^. PersonalisedSheetFileSheet)
+          E.<&> E.val newUserId
+          E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileType)
+          E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileTitle)
+          E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileContent)
+          E.<&> (personalisedSheetFile E.^. PersonalisedSheetFileModified)
+    )
+    (\current excluded -> [ PersonalisedSheetFileModified E.=. E.max (current E.^. PersonalisedSheetFileModified) (excluded E.^. PersonalisedSheetFileModified) ])
+  deleteWhere [ PersonalisedSheetFileUser ==. oldUserId ]
+
+  E.insertSelectWithConflict
+    UniqueTutor
+    (E.from $ \tutor -> do
+        E.where_ $ tutor E.^. TutorUser E.==. E.val oldUserId
+        return $ Tutor
+          E.<#  (tutor E.^. TutorTutorial)
+          E.<&> E.val newUserId
+    )
+    (\_current _excluded -> [])
+
+  do
+    collision <- E.selectMaybe . E.from $ \((tutorialA `E.InnerJoin` tutorialParticipantA) `E.InnerJoin` (tutorialB `E.InnerJoin` tutorialParticipantB)) -> do
+      E.on $ tutorialParticipantB E.^. TutorialParticipantTutorial E.==. tutorialB E.^. TutorialId
+      E.on $ tutorialA E.^. TutorialCourse E.==. tutorialB E.^. TutorialCourse
+       E.&&. tutorialParticipantB E.^. TutorialParticipantUser E.==. E.val newUserId
+       E.&&. tutorialParticipantA E.^. TutorialParticipantUser E.==. E.val oldUserId
+      E.on $ tutorialParticipantA E.^. TutorialParticipantTutorial E.==. tutorialA E.^. TutorialId
+      E.where_ $ tutorialA E.^. TutorialId E.!=. tutorialB E.^. TutorialId
+           E.&&. tutorialA E.^. TutorialRegGroup E.==. tutorialB E.^. TutorialRegGroup
+      return (tutorialParticipantA, tutorialParticipantB)
+    whenIsJust collision $ \(tutorialUserA, tutorialUserB)
+      -> tellError $ UserAssimilateTutorialParticipantCollidingRegGroups tutorialUserA tutorialUserB
+  E.insertSelectWithConflict
+    UniqueTutorialParticipant
+    (E.from $ \tutorialParticipant -> do
+        E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val oldUserId
+        return $ TutorialParticipant
+          E.<#  (tutorialParticipant E.^. TutorialParticipantTutorial)
+          E.<&> E.val newUserId
+    )
+    (\_current _excluded -> [])
+  deleteWhere [ TutorialParticipantUser ==. oldUserId ]
+
+  E.insertSelectWithConflict
+    UniqueSystemMessageHidden
+    (E.from $ \systemMessageHidden -> do
+        E.where_ $ systemMessageHidden E.^. SystemMessageHiddenUser E.==. E.val oldUserId
+        return $ SystemMessageHidden
+          E.<#  (systemMessageHidden E.^. SystemMessageHiddenMessage)
+          E.<&> E.val newUserId
+          E.<&> (systemMessageHidden E.^. SystemMessageHiddenTime)
+    )
+    (\current excluded -> [ SystemMessageHiddenTime E.=. E.max (current E.^. SystemMessageHiddenTime) (excluded E.^. SystemMessageHiddenTime) ])
+  deleteWhere [ SystemMessageHiddenUser ==. oldUserId ]
+
+  let getStudyFeatures = selectSource [ StudyFeaturesUser ==. oldUserId ] []
+      upsertStudyFeatures (Entity oldSFId oldStudyFeatures) = do
+        collision <- getBy $ UniqueStudyFeatures newUserId (studyFeaturesDegree oldStudyFeatures) (studyFeaturesField oldStudyFeatures) (studyFeaturesType oldStudyFeatures) (studyFeaturesSemester oldStudyFeatures)
+        case collision of
+          Nothing -> update oldSFId [ StudyFeaturesUser =. newUserId ]
+          Just (Entity newSFId newStudyFeatures) -> do
+            update newSFId
+              [ StudyFeaturesSuperField =. ((<|>) `on` studyFeaturesSuperField) newStudyFeatures oldStudyFeatures
+              , StudyFeaturesFirstObserved =. (min `on` studyFeaturesFirstObserved) oldStudyFeatures newStudyFeatures
+              , StudyFeaturesLastObserved =. (max `on` studyFeaturesLastObserved) oldStudyFeatures newStudyFeatures
+              , StudyFeaturesValid =. ((||) `on` studyFeaturesValid) oldStudyFeatures newStudyFeatures
+              , StudyFeaturesRelevanceCached =. ((||) `on` studyFeaturesRelevanceCached) oldStudyFeatures newStudyFeatures
+              ]
+            E.insertSelectWithConflict
+              UniqueRelevantStudyFeatures
+              (E.from $ \relevantStudyFeatures -> do
+                  E.where_ $ relevantStudyFeatures E.^. RelevantStudyFeaturesStudyFeatures E.==. E.val oldSFId
+                  return $ RelevantStudyFeatures
+                    E.<#  (relevantStudyFeatures E.^. RelevantStudyFeaturesTerm)
+                    E.<&> E.val newSFId
+              )
+              (\_current _excluded -> [])
+            deleteWhere [ RelevantStudyFeaturesStudyFeatures ==. oldSFId ]
+            delete oldSFId
+   in runConduit $ getStudyFeatures .| C.mapM_ upsertStudyFeatures
+
+  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
@ -89,17 +89,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
@ -144,7 +147,7 @@ import Data.Time.Clock.Instances as Import ()
 import Data.Time.LocalTime.Instances as Import ()
 import Data.Time.Calendar.Instances as Import ()
 import Data.Time.Format.Instances as Import ()
-import Network.Mail.Mime.Instances as Import ()
+import Network.Mail.Mime.Instances as Import
 import Yesod.Core.Instances as Import ()
 import Data.Aeson.Types.Instances as Import ()
 import Database.Esqueleto.Instances as Import ()
--- 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
@ -61,6 +60,7 @@ import Jobs.Handler.PruneInvitations
 import Jobs.Handler.ChangeUserDisplayEmail
 import Jobs.Handler.Files
 import Jobs.Handler.PersonalisedSheetFiles
+import Jobs.Handler.PruneOldSentMails

 import Jobs.HealthReport

--- 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
@ -80,6 +78,16 @@ determineCrontab = execWriterT $ do
      , cronNotAfter  = Right CronNotScheduled
      }

+  oldestSentMail <- lift $ preview (_head . _entityVal . _sentMailSentAt) <$> selectList [] [Asc SentMailSentAt, LimitTo 1]
+  whenIsJust ((,) <$> appMailRetainSent <*> oldestSentMail) $ \(retain, oldest) -> tell $ HashMap.singleton
+    (JobCtlQueue JobPruneOldSentMails)
+    Cron
+      { cronInitial   = CronTimestamp . utcToLocalTime $ addUTCTime retain oldest
+      , cronRepeat    = CronRepeatOnChange
+      , cronRateLimit = retain / 2
+      , cronNotAfter  = Right CronNotScheduled
+      }
+

  whenIsJust (appInjectFiles <* appUploadCacheConf) $ \iInterval ->
    tell $ HashMap.singleton
--- a/src/Jobs/Handler/PruneOldSentMails.hs
+++ b/src/Jobs/Handler/PruneOldSentMails.hs
@ -0,0 +1,21 @@
+module Jobs.Handler.PruneOldSentMails
+  ( dispatchJobPruneOldSentMails
+  ) where
+
+import Import
+
+import qualified Database.Esqueleto as E
+import Database.Persist.Sql (deleteWhereCount)
+
+
+dispatchJobPruneOldSentMails :: JobHandler UniWorX
+dispatchJobPruneOldSentMails = JobHandlerAtomic $ do
+  retain' <- getsYesod $ view _appMailRetainSent
+  whenIsJust retain' $ \retain -> do
+    now <- liftIO getCurrentTime
+    del <- deleteWhereCount [SentMailSentAt <. addUTCTime (-retain) now]
+    $logInfoS "JobPruneOldSentMails" [st|Deleted #{del} old sent mails|]
+  del <- E.deleteCount . E.from $ \sentMailContent ->
+    E.where_ . E.not_ . E.exists . E.from $ \sentMail ->
+      E.where_ $ sentMail E.^. SentMailContentRef E.==. sentMailContent E.^. SentMailContentId
+  $logInfoS "JobPruneOldSentMails" [st|Deleted #{del} old sent mail bodies|]
--- a/src/Jobs/Handler/SendNotification.hs
+++ b/src/Jobs/Handler/SendNotification.hs
@ -23,10 +23,5 @@ import Jobs.Handler.SendNotification.SubmissionEdited


 dispatchJobSendNotification :: UserId -> Notification -> JobHandler UniWorX
-dispatchJobSendNotification jRecipient jNotification = JobHandlerException $ do
+dispatchJobSendNotification jRecipient jNotification = JobHandlerException $
  $(dispatchTH ''Notification) jNotification jRecipient
-
-  instanceID' <- getsYesod $ view instanceID
-  now <- liftIO getCurrentTime
-
-  runDB . insert_ $ SentNotification (toJSON jNotification) jRecipient now instanceID'
--- a/src/Jobs/HealthReport.hs
+++ b/src/Jobs/HealthReport.hs
@ -63,6 +63,10 @@ dispatchHealthCheckMatchingClusterConfig
      ourSetting <- getsYesod $ fmap fst . appMemcached
      dbSetting <- clusterSetting @'ClusterMemcachedKey
      return $ maybe True ((== dbSetting) . Just) ourSetting
+    clusterSettingMatches ClusterVerpSecret = do
+      ourSetting <- getsYesod appVerpSecret
+      dbSetting <- clusterSetting @'ClusterVerpSecret
+      return $ Just ourSetting == dbSetting


    clusterSetting :: forall key.
--- 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 }
@ -93,6 +96,7 @@ data Job
  | JobPruneFallbackPersonalisedSheetFilesKeys
  | JobRechunkFiles
  | JobDetectMissingFiles
+  | JobPruneOldSentMails
  deriving (Eq, Ord, Show, Read, Generic, Typeable)
 data Notification
  = NotificationSubmissionRated { nSubmission :: SubmissionId }
@ -144,6 +148,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/Language/Haskell/TH/Instances.hs
+++ b/src/Language/Haskell/TH/Instances.hs
@ -7,6 +7,7 @@ module Language.Haskell.TH.Instances
 import ClassyPrelude

 import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
 import Language.Haskell.TH.Lift (deriveLift)
 import Data.Binary (Binary)

@ -15,6 +16,14 @@ instance Binary Loc
 deriveLift ''Loc


+instance Binary OccName
+instance Binary ModName
+instance Binary NameSpace
+instance Binary PkgName
+instance Binary NameFlavour
+instance Binary Name
+
+
 instance Semigroup (Q [Dec]) where
  (<>) = liftA2 (<>)

--- a/src/Mail.hs
+++ b/src/Mail.hs
@ -8,13 +8,12 @@ module Mail
    module Network.Mail.Mime
    -- * MailT
  , MailT, defMailT
-  , MailSmtpData(..)
+  , MailSmtpData(..), _smtpEnvelopeFrom, _smtpRecipients
  , _MailSmtpDataSet
  , MailContext(..)
  , MonadMail(..)
  , getMailMessageRender, getMailMsgRenderer
    -- * YesodMail
-  , VerpMode(..)
  , YesodMail(..)
  , MailException(..)
    -- * Monadically constructing Mail
@ -25,12 +24,13 @@ module Mail
  , MonadHeader(..)
  , MailHeader
  , MailObjectId
-  , replaceMailHeader, addMailHeader, removeMailHeader
+  , replaceMailHeader, addMailHeader, removeMailHeader, getMailHeaders, lookupMailHeader
  , replaceMailHeaderI, addMailHeaderI
  , setSubjectI
  , setMailObjectUUID, setMailObjectIdRandom, setMailObjectIdCrypto, setMailObjectIdPseudorandom
+  , getMailObjectId
  , setDate, setDateCurrent
-  , setMailSmtpData
+  , getMailSmtpData
  , _addressName, _addressEmail
  , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts
  , _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent
@ -50,7 +50,7 @@ import Settings.Mime
 import Data.Monoid (Last(..))
 import Control.Monad.Trans.RWS (RWST(..))
 import Control.Monad.Trans.State (StateT(..), execStateT, mapStateT)
-import Control.Monad.Trans.Writer (execWriter, Writer)
+import Control.Monad.Trans.Writer (execWriter, execWriterT, Writer)
 import Control.Monad.RWS.Class (MonadWriter(..), MonadState(..), modify)
 import Control.Monad.Fail
 import Control.Monad.Base
@ -62,16 +62,15 @@ import qualified Data.Sequence as Seq

 import qualified Data.Set as Set

-import qualified Data.Text as Text
-
 import qualified Data.Foldable as Foldable

+import qualified Data.Text as Text
 import qualified Data.Text.Lazy as LT
 import qualified Data.Text.Lazy.Builder as LTB
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.ByteString as BS

-import Utils (MsgRendererS(..), MonadSecretBox(..), maybeT, YamlValue)
+import Utils (MsgRendererS(..), MonadSecretBox(..), YamlValue)
 import Utils.Lens.TH

 import Control.Lens hiding (from)
@ -109,8 +108,6 @@ import Data.Universe.Instances.Reverse ()
 import Data.Universe.Instances.Reverse.JSON ()
 import Data.Universe.Instances.Reverse.Hashable ()

-import Control.Monad.Trans.Maybe (MaybeT(..))
-
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI

@ -123,6 +120,8 @@ import Crypto.Hash.Algorithms (SHAKE128)

 import Language.Haskell.TH (nameBase)

+import Network.Mail.Mime.Instances()
+

 makeLenses_ ''Address
 makeLenses_ ''Mail
@ -152,7 +151,7 @@ instance {-# OVERLAPPING #-} (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) =>

 data MailSmtpData = MailSmtpData
  { smtpEnvelopeFrom :: Last Text
-  , smtpRecipients :: Set Text
+  , smtpRecipients :: Set Address
  } deriving (Eq, Ord, Show, Read, Generic)

 instance Semigroup MailSmtpData where
@ -188,6 +187,8 @@ instance Default MailContext where

 makeLenses_ ''MailContext

+makeLenses_ ''MailSmtpData
+
 class (MonadHandler m, MonadState Mail m) => MonadMail m where
  askMailLanguages :: m Languages
  askMailDateTimeFormat :: SelDateTimeFormat -> m DateTimeFormat
@ -198,16 +199,6 @@ instance MonadHandler m => MonadMail (MailT m) where
  askMailDateTimeFormat = (view _mcDateTimeFormat ??)
  tellMailSmtpData = tell

-data VerpMode = VerpNone
-              | Verp { verpSeparator, verpAtReplacement :: Char }
-  deriving (Eq, Show, Read, Generic)
-
-deriveJSON defaultOptions
-  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  , sumEncoding = UntaggedValue
-  } ''VerpMode
-
 getMailMessageRender :: ( MonadMail m
                        , HandlerSite m ~ site
                        , RenderMessage site msg
@ -234,6 +225,8 @@ instance Exception MailException
 class Yesod site => YesodMail site where
  defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
  defaultFromAddress = Address Nothing . ("yesod@" <>) . pack <$> liftIO getHostName
+  envelopeFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Text
+  envelopeFromAddress = addressEmail <$> defaultFromAddress

  mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
  mailObjectIdDomain = pack <$> liftIO getHostName
@ -248,11 +241,6 @@ class Yesod site => YesodMail site where
              ) => (SMTPConnection -> m a) -> m a
  mailSmtp _ = throwM MailNotAvailable

-  mailVerp :: ( MonadHandler m
-              , HandlerSite m ~ site
-              ) => m VerpMode
-  mailVerp = return VerpNone
-
  mailT :: ( MonadHandler m
           , HandlerSite m ~ site
           , MonadUnliftIO m
@ -304,7 +292,7 @@ defMailT ls (MailT mailC) = do
    MailSmtpData{ smtpRecipients }
      | Set.null smtpRecipients -> throwM MailNoRecipientsSpecified
    MailSmtpData{ smtpEnvelopeFrom = Last (Just (unpack -> returnPath))
-                , smtpRecipients = (map unpack . toList -> recipients)
+                , smtpRecipients = (map (unpack . addressEmail) . toList -> recipients)
                } -> mailSmtp $ \conn -> do
      $logInfoS "Mail" $ "Submitting email: " <> tshow smtpData
      liftIO $ SMTP.sendMail
@ -434,15 +422,17 @@ partIsAttachment (repack -> fName) = modifyPart $ _partDisposition .= Attachment


 class MonadHandler m => MonadHeader m where
+  stateHeaders :: forall a. (Headers -> (a, Headers)) -> m a
  modifyHeaders :: (Headers -> Headers) -> m ()
+  modifyHeaders f = stateHeaders $ ((), ) . f
  objectIdHeader :: m MailHeader

 instance MonadHandler m => MonadHeader (MailT m) where
-  modifyHeaders f = MailT . modify $ over _mailHeaders f
+  stateHeaders = MailT . zoom _mailHeaders . state
  objectIdHeader = return "Message-ID"

 instance MonadHandler m => MonadHeader (StateT Part m) where
-  modifyHeaders f = _partHeaders %= f
+  stateHeaders = zoom _partHeaders . state
  objectIdHeader = return "Content-ID"


@ -459,6 +449,12 @@ addMailHeader header c = modifyHeaders $ \mailHeaders -> mailHeaders `snoc` (hea
 removeMailHeader :: MonadHeader m => MailHeader -> m ()
 removeMailHeader header = modifyHeaders $ \mailHeaders -> filter ((/= header) . fst) mailHeaders

+getMailHeaders :: MonadHeader m => MailHeader -> m [Text]
+getMailHeaders header = stateHeaders $ \hdrs -> (, hdrs) . map (view _2) $ filter (views _1 (== header)) hdrs
+
+lookupMailHeader :: MonadHeader m => MailHeader -> m (Maybe Text)
+lookupMailHeader = fmap listToMaybe . getMailHeaders
+

 replaceMailHeaderI :: ( RenderMessage site msg
                      , MonadMail m
@ -512,6 +508,11 @@ setMailObjectIdPseudorandom obj = do
    seed = KMAC.finalize . KMAC.updates (KMAC.initialize (BS.pack . encodeUtf8 $ nameBase 'setMailObjectIdPseudorandom) $ Saltine.encode sbKey) . LBS.toChunks $ Binary.encode obj
  setMailObjectUUID . fromMaybe (error "Could not convert hash to UUID") . UUID.fromByteString $ fromStrict (ByteArray.convert seed :: ByteString)

+getMailObjectId :: ( MonadHeader m, YesodMail (HandlerSite m) ) => m (Maybe MailObjectId)
+getMailObjectId = fmap (fmap stripBrackets) . lookupMailHeader =<< objectIdHeader
+  where stripBrackets val = fromMaybe val $
+          Text.stripSuffix ">" =<< Text.stripPrefix "<" val
+

 setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
 setDateCurrent = setDate =<< liftIO getCurrentTime
@ -539,27 +540,12 @@ setDate time = do
      ]


-setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m), MonadThrow m) => MailT m ()
-setMailSmtpData = do
-  Address _ from <- maybeT (throwM MailNoSenderSpecified) $ asum
-    [ MaybeT . preuses (_mailHeader "Sender") $ fromString . unpack
-    , use _mailFrom
-    ]
-  recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
+getMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m), MonadThrow m) => MailT m MailSmtpData
+getMailSmtpData = execWriterT $ do
+  from <- envelopeFromAddress
+  recps <- lift $ Set.fromList . concat <$> forM [_mailTo, _mailCc, _mailBcc] use

-  tell $ mempty { smtpRecipients = recps }
-
-  verpMode <- mailVerp
-  if
-    | Verp{..} <- verpMode
-    , [recp] <- Set.toList recps
-    -> let (user, domain) = Text.breakOn "@" from
-           verp = mconcat
-             [ user
-             , Text.singleton verpSeparator
-             , Text.replace "@" (Text.singleton verpAtReplacement) recp
-             , domain
-             ]
-        in tell $ mempty { smtpEnvelopeFrom = Last $ Just verp }
-    | otherwise
-    -> tell $ mempty { smtpEnvelopeFrom = Last $ Just from }
+  tell $ mempty
+    { smtpRecipients = recps
+    , smtpEnvelopeFrom = Last $ Just from 
+    }
--- a/src/Model/Migration.hs
+++ b/src/Model/Migration.hs
@ -176,6 +176,8 @@ migrateManual = do
    , ("submission_edit_submission",          "CREATE INDEX submission_edit_submission ON submission_edit (submission)"                  )
    , ("user_ldap_primary_key",               "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)"                        )
    , ("file_content_entry_chunk_hash",       "CREATE INDEX file_content_entry_chunk_hash ON \"file_content_entry\" (chunk_hash)"        )
+    , ("sent_mail_bounce_secret",             "CREATE INDEX sent_mail_bounce_secret ON \"sent_mail\" (bounce_secret) WHERE bounce_secret IS NOT NULL")
+    , ("sent_mail_recipient",                 "CREATE INDEX sent_mail_recipient ON \"sent_mail\" (recipient) WHERE recipient IS NOT NULL")
    ]
  where
    addIndex :: Text -> Sql -> Migration
--- a/src/Model/Types/Mail.hs
+++ b/src/Model/Types/Mail.hs
@ -1,5 +1,6 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}

 {-|
 Module: Model.Types.Mail
@ -17,6 +18,18 @@ import qualified Data.Aeson.Types as Aeson
 import qualified Data.HashSet as HashSet
 import qualified Data.HashMap.Strict as HashMap

+import Crypto.Hash (digestFromByteString, SHAKE128)
+import Database.Persist.Sql (PersistFieldSql)
+
+import Data.ByteArray (ByteArrayAccess)
+import qualified Data.ByteArray as BA
+
+import Web.HttpApiData (ToHttpApiData, FromHttpApiData)
+
+import Data.ByteString.Base32
+
+import qualified Data.CaseInsensitive as CI
+

 -- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
 --
@ -85,3 +98,32 @@ instance FromJSON NotificationSettings where
    return . NotificationSettings $ \n -> fromMaybe (notificationAllowed def n) $ HashMap.lookup n o'

 derivePersistFieldJSON ''NotificationSettings
+
+
+newtype BounceSecret = BounceSecret (Digest (SHAKE128 64))
+  deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
+  deriving newtype ( PersistField, PersistFieldSql
+                   , Hashable, NFData
+                   , ByteArrayAccess
+                   )
+
+instance PathPiece BounceSecret where
+  toPathPiece = CI.foldCase . encodeBase32Unpadded . BA.convert
+  fromPathPiece = fmap BounceSecret . digestFromByteString <=< either (const Nothing) Just . decodeBase32Unpadded . encodeUtf8
+
+newtype MailContent = MailContent [Alternatives]
+  deriving (Eq, Show, Generic, Typeable)
+  deriving newtype (ToJSON, FromJSON)
+  deriving anyclass (Binary)
+
+derivePersistFieldJSON ''MailContent
+
+newtype MailContentReference = MailContentReference (Digest SHA3_512)
+  deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable)
+  deriving newtype ( PersistField, PersistFieldSql
+                   , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON
+                   , Hashable, NFData
+                   , ByteArrayAccess
+                   )
+
+derivePersistFieldJSON ''MailHeaders
--- a/src/Model/Types/Security.hs
+++ b/src/Model/Types/Security.hs
@ -213,6 +213,16 @@ dnfAssumeValue var val
 predDNFFalse :: PredDNF a
 predDNFFalse = PredDNF Set.empty

+predDNFSingleton :: Ord a => PredLiteral a -> PredDNF a
+predDNFSingleton = PredDNF . Set.singleton . impureNonNull . Set.singleton
+
+predDNFAnd, predDNFOr :: Ord a => PredDNF a -> PredDNF a -> PredDNF a
+predDNFAnd (PredDNF a) (PredDNF b) = PredDNF . Set.fromList $ do
+  aConj <- Set.toList a
+  bConj <- Set.toList b
+  return . impureNonNull $ toNullable aConj `Set.union` toNullable bConj
+predDNFOr (PredDNF a) (PredDNF b) = PredDNF $ a <> b
+

 data UserGroupName
  = UserGroupMetrics
--- 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/Network/Mail/Mime/Instances.hs
+++ b/src/Network/Mail/Mime/Instances.hs
@ -1,20 +1,31 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}

 module Network.Mail.Mime.Instances
-  (
+  ( MailHeaders(..)
  ) where

 import ClassyPrelude
 import Network.Mail.Mime

-import Data.Aeson
+import Data.Aeson (FromJSON(..), ToJSON(..))
+import qualified Data.Aeson as Aeson
 import Data.Aeson.TH

+import Control.Monad.Fail (MonadFail(..))
+
 import Utils.PathPiece

 import Utils (assertM)

 import qualified Data.Csv as Csv
+import Data.Binary (Binary)
+
+import qualified Data.ByteString.Base64 as Base64
+import qualified Data.ByteString as BS
+
+import Data.Text.Encoding (decodeUtf8')
+
+import Control.Lens


 deriving instance Read Address
@ -29,9 +40,9 @@ deriveToJSON defaultOptions
  } ''Address

 instance FromJSON Address where
-  parseJSON = withObject "Address" $ \obj -> do
-    addressName <- assertM (not . null) <$> (obj .:? "name")
-    addressEmail <- obj .: "email"
+  parseJSON = Aeson.withObject "Address" $ \obj -> do
+    addressName <- assertM (not . null) <$> (obj Aeson..:? "name")
+    addressEmail <- obj Aeson..: "email"
    return Address{..}


@ -43,3 +54,68 @@ instance Csv.ToNamedRecord Address where

 instance Csv.DefaultOrdered Address where
  headerOrder _ = Csv.header [ "name", "email" ]
+
+  
+newtype MailHeaders = MailHeaders Headers
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance ToJSON MailHeaders where
+  toJSON (MailHeaders hs) = toJSON $ over (traverse . _1) decodeUtf8 hs
+instance FromJSON MailHeaders where
+  parseJSON = fmap (MailHeaders . over (traverse . _1) encodeUtf8) . parseJSON
+
+deriving instance Generic Encoding
+deriving instance Generic Disposition
+deriving instance Generic PartContent
+deriving instance Generic Part
+deriving instance Generic Mail
+  
+instance Binary Encoding
+instance Binary Disposition
+instance Binary PartContent
+instance Binary Part
+instance Binary Address
+instance Binary Mail
+  
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece
+  } ''Encoding
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece . dropSuffix "Disposition"
+  } ''Disposition
+
+instance ToJSON PartContent where
+  toJSON (PartContent (toStrict -> content))
+    | BS.all (< 0x80) content
+    , Right content' <- decodeUtf8' content = Aeson.String content'
+  toJSON (PartContent content) = Aeson.object
+    [ "encoding" Aeson..= ("base64" :: String)
+    , "content" Aeson..= decodeUtf8 (Base64.encode $ toStrict content)
+    ]
+  toJSON (NestedParts ps) = toJSON ps
+instance FromJSON PartContent where
+  parseJSON (Aeson.String t) = return . PartContent . fromStrict $ encodeUtf8 t
+  parseJSON (Aeson.Object o) = do
+    encoding <- o Aeson..: "encoding"
+    content <- o Aeson..: "content"
+    if | encoding == "base64" -> either fail (return . PartContent . fromStrict) . Base64.decode $ encodeUtf8 content
+       | otherwise -> fail $ "Unknown encoding: “" <> encoding <> "”"
+  parseJSON v = NestedParts <$> parseJSON v
+
+instance ToJSON Part where
+  toJSON Part{..} = Aeson.object
+    [ "type" Aeson..= partType
+    , "encoding" Aeson..= partEncoding
+    , "disposition" Aeson..= partDisposition
+    , "headers" Aeson..= MailHeaders partHeaders
+    , "content" Aeson..= partContent
+    ]
+instance FromJSON Part where
+  parseJSON = Aeson.withObject "Part" $ \o -> do
+    partType <- o Aeson..: "type"
+    partEncoding <- o Aeson..: "encoding"
+    partDisposition <- o Aeson..: "disposition"
+    MailHeaders partHeaders <- o Aeson..: "headers"
+    partContent <- o Aeson..: "content"
+    return Part{..}
--- a/src/Settings.hs
+++ b/src/Settings.hs
@ -111,9 +111,12 @@ data AppSettings = AppSettings
    , appSessionTokenExpiration :: Maybe NominalDiffTime
    , appSessionTokenEncoding   :: JwtEncoding
    
-    , appMailFrom               :: Address
    , appMailObjectDomain       :: Text
    , appMailVerp               :: VerpMode
+    , appMailRetainSent         :: Maybe NominalDiffTime
+    , appMailEnvelopeFrom       :: Text
+    , appMailFrom
+    , appMailSender
    , appMailSupport            :: Address
    , appJobWorkers             :: Natural
    , appJobFlushInterval       :: Maybe NominalDiffTime
@ -301,6 +304,16 @@ data TokenBucketConf = TokenBucketConf
  , tokenBucketInitialValue :: Int64
  } deriving (Eq, Ord, Show, Generic, Typeable)

+data VerpMode = VerpNone
+              | Verp { verpPrefix :: Text, verpSeparator :: Char }
+  deriving (Eq, Show, Read, Generic)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , fieldLabelModifier = camelToPathPiece' 1
+  , sumEncoding = UntaggedValue
+  } ''VerpMode
+
 deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 2
  } ''TokenBucketConf
@ -449,9 +462,12 @@ instance FromJSON AppSettings where
        appIpFromHeader           <- o .: "ip-from-header"

        appMailFrom               <- o .: "mail-from"
+        appMailEnvelopeFrom       <- o .:? "mail-envelope-from" .!= addressEmail appMailFrom
+        appMailSender             <- o .:? "mail-sender" .!= appMailFrom
+        appMailSupport            <- o .: "mail-support"
        appMailObjectDomain       <- o .: "mail-object-domain"
        appMailVerp               <- fromMaybe VerpNone . join <$> (o .:? "mail-verp" <|> pure Nothing)
-        appMailSupport            <- o .: "mail-support"
+        appMailRetainSent         <- o .: "mail-retain-sent"

        appJobWorkers             <- o .:  "job-workers"
        appJobFlushInterval       <- o .:? "job-flush-interval"
--- a/src/Settings/Cluster.hs
+++ b/src/Settings/Cluster.hs
@ -3,6 +3,7 @@
 module Settings.Cluster
  ( ClusterSettingsKey(..)
  , ClusterSetting(..)
+  , VerpSecret(..)
  ) where

 import ClassyPrelude.Yesod
@ -36,6 +37,9 @@ import Control.Monad.Fail

 import Model.Types.TH.PathPiece

+import Data.ByteArray (ByteArray, ByteArrayAccess)
+import qualified Crypto.Random as Crypto
+

 data ClusterSettingsKey
  = ClusterCryptoIDKey
@ -44,6 +48,7 @@ data ClusterSettingsKey
  | ClusterJSONWebKeySet
  | ClusterId
  | ClusterMemcachedKey
+  | ClusterVerpSecret
  deriving (Eq, Ord, Enum, Bounded, Show, Read)

 instance Universe ClusterSettingsKey
@ -131,3 +136,19 @@ instance ClusterSetting 'ClusterMemcachedKey where
  type ClusterSettingValue 'ClusterMemcachedKey = AEAD.Key
  initClusterSetting _ = liftIO AEAD.newKey
  knownClusterSetting _ = ClusterMemcachedKey
+
+
+newtype VerpSecret = VerpSecret ByteString
+  deriving newtype (Eq, Ord, Monoid, Semigroup, ByteArray, ByteArrayAccess)
+
+instance ToJSON VerpSecret where
+  toJSON (VerpSecret vSecret) = Aeson.String . decodeUtf8 $ Base64.encode vSecret
+instance FromJSON VerpSecret where
+  parseJSON = Aeson.withText "VerpSecret" $ \t -> do
+    bytes <- either fail return . Base64.decode $ encodeUtf8 t
+    return $ VerpSecret bytes
+
+instance ClusterSetting 'ClusterVerpSecret where
+  type ClusterSettingValue 'ClusterVerpSecret = VerpSecret
+  initClusterSetting _ = liftIO $ Crypto.getRandomBytes 16
+  knownClusterSetting _ = ClusterVerpSecret
--- a/src/Utils.hs
+++ b/src/Utils.hs
@ -822,7 +822,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)

@ -887,9 +887,19 @@ 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
+  
+tellMPoint :: (MonadTrans t, MonadWriter mono (t m), Monad m, MonoPointed mono) => m (Element mono) -> t m ()
+tellMPoint = tellM . fmap opoint
+
 -------------
 -- Conduit --
 -------------
@ -1164,6 +1174,10 @@ setLastModified lastModified = do

    safeMethods = [ methodGet, methodHead, methodOptions ]

+-- | Adapter for memoization of five-argument function
+for5 :: (((k1, k2, k3, k4, k5) -> mv) -> (k1, k2, k3, k4, k5) -> mv) -> (k1 -> k2 -> k3 -> k4 -> k5 -> mv) -> k1 -> k2 -> k3 -> k4 -> k5 -> mv
+for5 m f a b c d e = m (\(a',b',c',d',e') -> f a' b' c' d' e') (a,b,c,d,e)
+
 --------------
 -- Lattices --
 --------------
--- 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
@ -224,7 +224,7 @@ data FormIdentifier
  | FIDUserDelete
  | FIDCommunication
  | FIDAssignSubmissions
-  | FIDUserAuthMode
+  | FIDUserAuthMode | FIDUserAssimilate | FIDUserRights | FIDUserAuthentication
  | FIDAllUsersAction
  | FIDLanguage
  | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID
--- a/src/Utils/Lens.hs
+++ b/src/Utils/Lens.hs
@ -260,6 +260,7 @@ makeLenses_ ''WorkflowGraphEdge
 makePrisms ''WorkflowGraphEdge

 makeWrapped ''Textarea
+makeLenses_ ''SentMail

 makePrisms ''AllocationPriority

--- a/src/Utils/Parameters.hs
+++ b/src/Utils/Parameters.hs
@ -57,7 +57,7 @@ data GlobalPostParam = PostFormIdentifier
                     | PostDeleteTarget
                     | PostMassInputShape
                     | PostBearer
-                     | PostDBCsvImportAction
+                     | PostDBCsvImportAction | PostDBCsvImportAvailableActions
                     | PostDBCsvReImport
                     | PostLoginDummy
                     | PostExamAutoOccurrencePrevious
--- 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/course.hamlet
+++ b/templates/course.hamlet
@ -225,13 +225,9 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
        $if registrationOpen
          $# regForm is defined through templates/widgets/registerForm
          ^{regForm}
-          $if isJust mApplication && courseApplicationsRequired course
-            <p>
+          $if (isJust mApplication && courseApplicationsRequired course) && mayReRegister
+            <p .explanation>
              _{MsgCourseApplicationDeleteToEdit}
-          $else
-            $if isJust registration
-              <p>
-                _{MsgCourseRegistrationDeleteToEdit}
  
  <dt .deflist__dt>
    _{MsgCourseMaterial}
--- a/templates/csv-import-confirmation.hamlet
+++ b/templates/csv-import-confirmation.hamlet
@ -1,5 +1,6 @@
 $newline never
 #{csrf}
+^{availableActs}
 <div .actions>
  $forall actionClass <- sortOn dbtCsvCoarsenActionClass (Map.keys actionMap)
    <div .action>
--- 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>
--- a/test/MailSpec.hs
+++ b/test/MailSpec.hs
@ -14,7 +14,7 @@ instance Arbitrary MailContext where
  arbitrary = genericArbitrary
  shrink = genericShrink

-instance Arbitrary VerpMode where
+instance Arbitrary Address where
  arbitrary = genericArbitrary
  shrink = genericShrink

@ -25,5 +25,3 @@ spec = do
      [ eqLaws, ordLaws, showReadLaws, monoidLaws ]
    lawsCheckHspec (Proxy @MailContext)
      [ eqLaws, ordLaws, showReadLaws, jsonLaws, hashableLaws ]
-    lawsCheckHspec (Proxy @VerpMode)
-      [ eqLaws, showReadLaws, jsonLaws ]
--- a/test/ModelSpec.hs
+++ b/test/ModelSpec.hs
@ -5,9 +5,10 @@ module ModelSpec where

 import TestImport

-import Settings (getTimeLocale')
+import Settings (getTimeLocale', VerpMode(..))

 import Model.TypesSpec ()
+import MailSpec ()

 import qualified Data.CaseInsensitive as CI
 import qualified Data.ByteString.Char8 as CBS
@ -170,6 +171,11 @@ instance {-# OVERLAPS #-} (HasCryptoID ns ct pt (ReaderT CryptoIDKey Catch), Arb
    where
      tmpKey = unsafePerformIO genKey

+instance Arbitrary VerpMode where
+  arbitrary = genericArbitrary
+  shrink = genericShrink
+
+
 spec :: Spec
 spec = do
  parallel $ do
@ -179,3 +185,5 @@ spec = do
      [ eqLaws ]
    lawsCheckHspec (Proxy @Term)
      [ eqLaws, jsonLaws ]
+    lawsCheckHspec (Proxy @VerpMode)
+      [ eqLaws, showReadLaws, jsonLaws ]