Merge branch 'master' into workflows

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)
 
 

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"

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

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

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

models/allocations.model

@@ -45,12 +45,14 @@ AllocationUser
     totalCourses        Natural          -- number of total allocated courses for this user must be <= than this number
     priority            AllocationPriority Maybe
     UniqueAllocationUser allocation user
+    deriving Eq Ord Show
 
 AllocationDeregister -- self-inflicted user-deregistrations from an allocated course
     user                UserId
     course              CourseId Maybe
     time                UTCTime
     reason              Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button)
+    deriving Eq Ord Show
 
 AllocationNotificationSetting
     user                UserId

models/courses.model

@@ -60,6 +60,7 @@ CourseParticipant                      -- course enrolement
     allocated    AllocationId Maybe    -- participant was centrally allocated
     state        CourseParticipantState
     UniqueParticipant user course
+    deriving Eq Ord Show
 -- Replace the last two by the following, once an audit log is available
 -- CourseUserNote                 -- lecturers of a specific course may share a text note on each enrolled student
 --     course       CourseId

models/exams.model

@@ -43,24 +43,28 @@ ExamRegistration
   occurrence ExamOccurrenceId Maybe
   time UTCTime default=now()
   UniqueExamRegistration exam user
+  deriving Eq Ord Show
 ExamPartResult
   examPart ExamPartId
   user UserId
   result ExamResultPoints
   lastChanged UTCTime default=now()
   UniqueExamPartResult examPart user
+  deriving Eq Ord Show
 ExamBonus
   exam ExamId
   user UserId
   bonus Points
   lastChanged UTCTime default=now()
   UniqueExamBonus exam user
+  deriving Eq Ord Show
 ExamResult
   exam ExamId
   user UserId
   result ExamResultPassedGrade
   lastChanged UTCTime default=now()
   UniqueExamResult exam user
+  deriving Eq Ord Show
 ExamCorrector
   exam ExamId
   user UserId

models/external-exams.model

@@ -13,6 +13,7 @@ ExternalExamResult
   time UTCTime
   lastChanged UTCTime
   UniqueExternalExamResult exam user
+  deriving Eq Ord Show
 ExternalExamStaff
   user UserId
   exam ExternalExamId

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

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

models/submissions.model

@@ -31,3 +31,4 @@ SubmissionGroupUser              -- Registered submission groups, just for check
     submissionGroup     SubmissionGroupId
     user                UserId
     UniqueSubmissionGroupUser submissionGroup user
+    deriving Eq Ord Show

models/tutorials.model

@@ -20,4 +20,5 @@ Tutor
 TutorialParticipant
     tutorial    TutorialId
     user        UserId
-    UniqueTutorialParticipant tutorial user
+    UniqueTutorialParticipant tutorial user
+    deriving Eq Ord Show

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "20.13.0",
+  "version": "21.0.3",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "20.13.0",
+  "version": "21.0.3",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 20.13.0
+version: 21.0.3
 
 dependencies:
   - base

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"

src/Audit/Types.hs

@@ -170,6 +170,11 @@ data Transaction
     , transactionUser         :: UserId
     }
 
+  | TransactionUserAssimilated
+    { transactionUser            :: UserId
+    , transactionAssimilatedUser :: UserId
+    }
+  
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 deriveJSON defaultOptions

src/Database/Esqueleto/Utils.hs

@@ -4,7 +4,7 @@
 module Database.Esqueleto.Utils
   ( true, false
   , justVal, justValList
-  , isJust
+  , isJust, alt
   , isInfixOf, hasInfix
   , strConcat, substring
   , or, and
@@ -30,6 +30,7 @@ module Database.Esqueleto.Utils
   , selectCountRows
   , selectMaybe
   , day, diffDays
+  , exprLift
   , module Database.Esqueleto.Utils.TH
   ) where
 
@@ -83,6 +84,9 @@ justValList = E.valList . map Just
 isJust :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value Bool)
 isJust = E.not_ . E.isNothing
 
+alt :: PersistField typ => E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value (Maybe typ)) -> E.SqlExpr (E.Value (Maybe typ))
+alt a b = E.case_ [(isJust a, a), (isJust b, b)] b
+
 infix 4 `isInfixOf`, `hasInfix`
 
 -- | Check if the first string is contained in the text derived from the second argument
@@ -388,3 +392,29 @@ infixl 6 `diffDays`
 diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int)
 -- ^ PostgreSQL is weird.
 diffDays a b = E.veryUnsafeCoerceSqlExprValue $ a E.-. b
+
+
+class ExprLift e a | e -> a where
+  exprLift :: a -> e
+
+instance PersistField a => ExprLift (E.SqlExpr (E.Value a)) a where
+  exprLift = E.val
+
+instance (PersistField a, PersistField b, Finite a) => ExprLift (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b)) (a -> b) where
+  exprLift f v = E.case_
+    [ E.when_ (v E.==. E.val v') E.then_ (E.val $ f v')
+    | v' <- universeF
+    ]
+    (E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ()))))
+  
+instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2) => ExprLift (E.SqlExpr (E.Value a1) -> E.SqlExpr (E.Value a2) -> E.SqlExpr (E.Value b)) (a1 -> a2 -> b) where
+  exprLift f v1 v2 = E.case_
+    [ E.when_ (       v1 E.==. E.val v1'
+                E.&&. v2 E.==. E.val v2'
+              )
+      E.then_ (E.val $ f v1' v2')
+    | v1' <- universeF
+    , v2' <- universeF
+    ]
+    (E.else_ $ E.else_ $ E.veryUnsafeCoerceSqlExprValue (E.nothing :: E.SqlExpr (E.Value (Maybe ()))))
+ 

src/Foundation/Authorization.hs

@@ -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
+    registered <- cont (predDNFSingleton $ PLVariable AuthCourseRegistered) mAuthId route isWrite
-      (Just (Entity cid _), Just uid) -> $cachedHereBinary (uid, cid) $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive]
-      _ -> return False
     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
+      Just (_, Allocation{..}) -> do
-        registered <- case mAuthId of
+        registered <- cont (predDNFSingleton $ PLVariable AuthCourseRegistered) mAuthId route isWrite
-          Just uid -> $cachedHereBinary (uid, cid) $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
-          _        -> return False
         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
+  let adjDNF = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) . Just
-  case dnf' of
+      evalAdj :: forall m'. MonadAP m' => AuthTagsEval m'
-    Nothing -> return Authorized
+      evalAdj (adjDNF -> dnf') mAuthId' route' isWrite' = case dnf' of
-    Just dnf'' -> do
+        Nothing    -> return Authorized
-      (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf'' mAuthId route isWrite
+        Just dnf'' -> evalAuthTags ('evalAccessWithFor, assumptions) tagActive evalAdj dnf'' mAuthId' route' isWrite'
-      when isSelf $
+   in do
-        tellSessionJson SessionInactiveAuthTags deactivated
+    (result, deactivated) <- runWriterT $ evalAdj dnf mAuthId route isWrite
-      return result
+    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

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
+  mailT ctx mail = do
-    void setMailObjectIdRandom
+    mailRecord <- newEmptyTMVarIO
-    setDateCurrent
+    mailProcess <- allocateLinkedAsync $ do
-    replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail)
+      defMailT ctx $ do
+        void setMailObjectIdRandom
+        sentMailSentAt <- liftIO getCurrentTime
+        setDate sentMailSentAt
+        replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailSender . to renderAddress)
 
-    (mRes, smtpData) <- listen mail
+        (mRes, smtpData) <- listen mail
-    unless (view _MailSmtpDataSet smtpData)
-      setMailSmtpData
 
-    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

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

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

src/Foundation/Yesod/Auth.hs

@@ -40,7 +40,6 @@ import qualified Data.Binary as Binary
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
 
-import Control.Monad.Writer.Class (MonadWriter(..))
 import Crypto.Hash.Conduit (sinkHash)
 
 

src/Foundation/Yesod/Middleware.hs

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

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

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

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]

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'

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 $ bool ExamUserCsvCourseRegisterData ExamUserCsvRegisterData isPart uid <$> lookupOccurrence dbCsvNew
-                    yieldM $ ExamUserCsvCourseRegisterData 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

src/Handler/Profile.hs

@@ -476,8 +476,6 @@ makeProfileData (Entity uid User{..}) = do
       examTable        = i18n MsgPersonalInfoExamAchievementsWip
       ownTutorialTable = i18n MsgPersonalInfoOwnTutorialsWip
       tutorialTable    = i18n MsgPersonalInfoTutorialsWip
-  lastLogin <- traverse (formatTime SelFormatDateTime) userLastAuthentication
-  lastLdapSync <- traverse (formatTime SelFormatDateTime) userLastLdapSynchronisation
 
   cID <- encrypt uid
   mCRoute <- getCurrentRoute

src/Handler/Users.hs

@@ -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
+    let assimilateForm' = renderAForm FormStandard $
-    ((authResult, authFormWidget),authFormEnctype) <- runFormPost userAuthenticationForm
+          areq (checkMap (first $ const MsgAssimilateUserNotFound) Right $ userField False Nothing) (fslI MsgUserAssimilateUser) Nothing
-    ((systemFunctionsResult, systemFunctionsWidget),systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm'
+        assimilateAction oldUserId = do
+          res <- try . runDB . setSerializable $ assimilateUser uid oldUserId
+          case res of
+            Left (err :: UserAssimilateException) ->
+              addMessageModal Error (i18n MsgAssimilateUserHaveError) $ Right
+                [whamlet|
+                  <div .shown>
+                    #{tshow err}
+                |]
+            Right warnings -> do
+              unless (null warnings) $
+                addMessageModal Warning (i18n MsgAssimilateUserHaveWarnings) $ Right
+                  [whamlet|
+                    $newline never
+                    <ul>
+                      $forall warning <- warnings
+                        <li .shown>
+                          #{tshow warning}
+                  |]
+              addMessageI Success MsgAssimilateUserSuccess
+              redirect $ AdminUserR uuid
+    ((rightsResult, rightsFormWidget), rightsFormEnctype) <- runFormPost . identifyForm FIDUserRights $ userRightsForm
+    ((authResult, authFormWidget), authFormEnctype) <- runFormPost . identifyForm FIDUserAuthentication $ userAuthenticationForm
+    ((systemFunctionsResult, systemFunctionsWidget), systemFunctionsEnctype) <- runFormPost . identifyForm FIDUserSystemFunctions $ renderAForm FormStandard systemFunctionsForm'
+    ((assimilateFormResult, assimilateFormWidget), assimilateFormEnctype) <- runFormPost $ identifyForm FIDUserAssimilate assimilateForm'
     let rightsForm = wrapForm rightsFormWidget def
           { formAction = Just . SomeRoute $ AdminUserR uuid
           , formEncoding = rightsFormEnctype
@@ -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")
 
 

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

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 :: FieldSettings UniWorX -> Maybe UploadMode -> AForm Handler UploadMode
-uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUploadMode <$> prev)
+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)
         )
       ]
 

src/Handler/Utils/Form/MassInput.hs

@@ -31,8 +31,6 @@ import Data.Map ((!))
 import qualified Data.Map as Map
 import qualified Data.Foldable as Fold
 
-import Control.Monad.Reader.Class (MonadReader(local))
-
 import Text.Hamlet (hamletFile)
 
 import Algebra.Lattice.Ordered (Ordered(..))

src/Handler/Utils/Table/Cells.hs

@@ -2,8 +2,6 @@ module Handler.Utils.Table.Cells where
 
 import Import hiding (link)
 
-import Control.Monad.Writer.Class (MonadWriter(..))
-
 import Text.Blaze (ToMarkup(..))
 
 import Handler.Utils.Table.Pagination

src/Handler/Utils/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
+        return . (, mempty) . FormSuccess $ if
-          | null acts -> FormSuccess $ do
+          | unavailableActs <- filter (`Set.notMember` availableActs) acts
-              addMessageI Info MsgCsvImportAborted
+          , not $ null unavailableActs -> do
-              redirect $ tblLink id
+              throwM . DBCsvUnavailableActionRequested @k' . Set.fromList $ map toJSON unavailableActs
-          | otherwise -> FormSuccess $ do
+          | otherwise -> do
-              finalDest <- runDBJobs' . runConduit $ C.sourceList acts .| dbtCsvExecuteActions
+              (acts', validationMsgs) <- execRWST dbtCsvValidateActions availableActs acts
-              addMessageI Success . MsgCsvImportSuccessful $ length acts
+              if | not $ null validationMsgs -> do
-              E.transactionSave
+                     mapM_ addMessage' validationMsgs
-              redirect finalDest
+                     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

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

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

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
 

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

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

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'

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.

src/Jobs/Queue.hs

@@ -13,8 +13,6 @@ import Import hiding ((<>))
 
 import Jobs.Types
 
-import Control.Monad.Writer.Class (MonadWriter(..))
-
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.List.NonEmpty as NonEmpty

src/Jobs/Types.hs

@@ -1,8 +1,9 @@
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
 
 module Jobs.Types
   ( Job(..), Notification(..)
+  , JobChildren
   , classifyJob
   , JobCtl(..)
   , classifyJobCtl
@@ -42,6 +43,8 @@ import Cron (CronNextMatch(..), _MatchAsap, _MatchAt, _MatchNone)
 import System.Clock (getTime, Clock(Monotonic), TimeSpec)
 import GHC.Conc (unsafeIOToSTM)
 
+import Data.Generics.Product.Types (Children, ChGeneric)
+
 
 data Job
   = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
@@ -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

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

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 ()
+getMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m), MonadThrow m) => MailT m MailSmtpData
-setMailSmtpData = do
+getMailSmtpData = execWriterT $ do
-  Address _ from <- maybeT (throwM MailNoSenderSpecified) $ asum
+  from <- envelopeFromAddress
-    [ MaybeT . preuses (_mailHeader "Sender") $ fromString . unpack
+  recps <- lift $ Set.fromList . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
-    , use _mailFrom
-    ]
-  recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
 
-  tell $ mempty { smtpRecipients = recps }
+  tell $ mempty
-
+    { smtpRecipients = recps
-  verpMode <- mailVerp
+    , smtpEnvelopeFrom = Last $ Just from 
-  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 }

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

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

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

src/Model/Types/Sheet.hs

@@ -302,16 +302,12 @@ instance Monoid Load where
 
 data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
+  deriving anyclass (Universe, Finite, Hashable)
 
 deriveJSON defaultOptions
   { constructorTagModifier = fromJust . stripPrefix "Corrector"
   } ''CorrectorState
 
-instance Universe CorrectorState
-instance Finite CorrectorState
-
-instance Hashable CorrectorState
-
 nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
 
 derivePersistField "CorrectorState"

src/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
+  parseJSON = Aeson.withObject "Address" $ \obj -> do
-    addressName <- assertM (not . null) <$> (obj .:? "name")
+    addressName <- assertM (not . null) <$> (obj Aeson..:? "name")
-    addressEmail <- obj .: "email"
+    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{..}

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"

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

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

src/Utils/Allocation.hs

@@ -16,7 +16,6 @@ import qualified Data.Array.MArray as MArr
 import System.Random (RandomGen)
 import Control.Monad.Trans.Random.Strict (evalRandT, RandT)
 import Control.Monad.Trans.State.Strict (StateT, modify', get, gets, evalStateT)
-import Control.Monad.Writer (tell)
 
 import Control.Monad.ST
 

src/Utils/Form.hs

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

src/Utils/Lens.hs

@@ -260,6 +260,7 @@ makeLenses_ ''WorkflowGraphEdge
 makePrisms ''WorkflowGraphEdge
 
 makeWrapped ''Textarea
+makeLenses_ ''SentMail
 
 makePrisms ''AllocationPriority
 

src/Utils/Parameters.hs

@@ -57,7 +57,7 @@ data GlobalPostParam = PostFormIdentifier
                      | PostDeleteTarget
                      | PostMassInputShape
                      | PostBearer
-                     | PostDBCsvImportAction
+                     | PostDBCsvImportAction | PostDBCsvImportAvailableActions
                      | PostDBCsvReImport
                      | PostLoginDummy
                      | PostExamAutoOccurrencePrevious

templates/adminUser.hamlet

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

templates/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
+          $if (isJust mApplication && courseApplicationsRequired course) && mayReRegister
-            <p>
+            <p .explanation>
               _{MsgCourseApplicationDeleteToEdit}
-          $else
-            $if isJust registration
-              <p>
-                _{MsgCourseRegistrationDeleteToEdit}
   
   <dt .deflist__dt>
     _{MsgCourseMaterial}

templates/csv-import-confirmation.hamlet

@@ -1,5 +1,6 @@
 $newline never
 #{csrf}
+^{availableActs}
 <div .actions>
   $forall actionClass <- sortOn dbtCsvCoarsenActionClass (Map.keys actionMap)
     <div .action>

templates/profileData.hamlet

@@ -5,6 +5,10 @@ $newline never
         _{MsgIdent}
       <dd .deflist__dd .email>
         #{userIdent}
+      <dt .deflist__dt>
+        _{MsgAuthMode}
+      <dd .deflist__dd>
+        _{userAuthentication}
       <dt .deflist__dt>
         _{MsgName}
       <dd .deflist__dd>
@@ -18,19 +22,28 @@ $newline never
         _{MsgEMail}
       <dd .deflist__dd>
         #{mailtoHtml userEmail}
+      $if userEmail /= userDisplayEmail
+        <dt .deflist__dt>
+          _{MsgUserDisplayEmail}
+        <dd .deflist__dd .email>
+          #{userDisplayEmail}
       $if showAdminInfo
+        <dt .deflist__dt>
+          _{MsgUserCreated}
+        <dd .deflist__dd>
+          ^{formatTimeW SelFormatDateTime userCreated}
         <dt .deflist__dt>
           _{MsgLastLogin}
         <dd .deflist__dd>
-          $maybe llogin <- lastLogin
+          $maybe llogin <- userLastAuthentication
-            #{llogin}
+            ^{formatTimeW SelFormatDateTime llogin}
           $nothing
             _{MsgNever}
         <dt .deflist__dt>
           _{MsgProfileLastLdapSynchronisation}
         <dd .deflist__dd>
-          $maybe lsync <- lastLdapSync
+          $maybe lsync <- userLastLdapSynchronisation
-            #{lsync}
+            ^{formatTimeW SelFormatDateTime lsync}
           $nothing
             _{MsgNever}
         $maybe pKey <- userLdapPrimaryKey
@@ -38,6 +51,13 @@ $newline never
             _{MsgProfileLdapPrimaryKey}
           <dd .deflist__dd .ldap-primary-key>
             #{pKey}
+        <dt .deflist__dt>
+          _{MsgTokensLastReset}
+        <dd .deflist__dd>
+          $maybe lastInvalidated <- userTokensIssuedAfter
+            ^{formatTimeW SelFormatDateTime lastInvalidated}
+          $nothing
+            _{MsgNever}
     $forall (function, schools) <- Map.toList functions
       <dt .deflist__dt>_{function}
       <dd .deflist__dd>

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 ]

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 ]